Mercurial > hg > xemacs-beta
changeset 207:e45d5e7c476e r20-4b2
Import from CVS: tag r20-4b2
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 10:03:52 +0200 |
| parents | d3e9274cbc4e |
| children | f427b8ec4379 |
| files | CHANGES-beta ChangeLog Makefile.in PROBLEMS configure configure.in etc/Emacs.ad etc/GOATS etc/HELLO etc/NEWS etc/TUTORIAL etc/TUTORIAL.de etc/TUTORIAL.fr etc/TUTORIAL.hr etc/TUTORIAL.jp etc/TUTORIAL.kr etc/TUTORIAL.no etc/TUTORIAL.th etc/ajc.xpm.Z etc/ajcm.xpm.Z etc/baw.xpm.Z etc/bawm.xpm.Z etc/bw.xpm.Z etc/bwm.xpm.Z etc/cthomp.xpm.Z etc/cthompm.xpm.Z etc/custom/done-down.gif etc/custom/done-up.gif etc/custom/open-down.gif etc/custom/open-up.gif etc/custom/reset-down.gif etc/custom/reset-up.gif etc/custom/save-down.gif etc/custom/save-up.gif etc/custom/set-down.gif etc/custom/set-up.gif etc/dkindred.xpm.Z etc/dkindredm.xpm.Z etc/dmoore.xpm.Z etc/dmoorem.xpm.Z etc/dv.xpm.Z etc/dvm.xpm.Z etc/hniksic.xpm.Z etc/hniksicm.xpm.Z etc/jareth.xpm.Z etc/jarethm.xpm.Z etc/jens.xpm.Z etc/jensm.xpm.Z etc/jwz.xpm.Z etc/jwzm.xpm.Z etc/kazz.xpm.Z etc/kazzm.xpm.Z etc/kyle.xpm.Z etc/kylem.xpm.Z etc/larsi.xpm.Z etc/larsim.xpm.Z etc/mine/1_16_flat.gif etc/mine/1_16_flat_sel.gif etc/mine/2_16_flat.gif etc/mine/2_16_flat_sel.gif etc/mine/3_16_flat.gif etc/mine/3_16_flat_sel.gif etc/mine/4_16_flat.gif etc/mine/4_16_flat_sel.gif etc/mine/5_16_flat.gif etc/mine/5_16_flat_sel.gif etc/mine/6_16_flat.gif etc/mine/6_16_flat_sel.gif etc/mine/7_16_flat.gif etc/mine/7_16_flat_sel.gif etc/mine/8_16_flat.gif etc/mine/8_16_flat_sel.gif etc/mine/bomb_16_flat.gif etc/mine/bomb_trapped_16_flat.gif etc/mine/empty_16_down.gif etc/mine/empty_16_flat.gif etc/mine/empty_16_flat_sel.gif etc/mine/empty_16_up.gif etc/mine/empty_16_up_sel.gif etc/mine/explosion3.au etc/mine/flagged_16_up.gif etc/mine/flagged_16_up_sel.gif etc/mine/new_down.gif etc/mine/new_up.gif etc/mine/pad.xpm etc/mine/question_16_up.gif etc/mine/quit_down.gif etc/mine/quit_up.gif etc/mine/splash.xpm etc/mly.xpm.Z etc/mlym.xpm.Z etc/morioka.xpm.Z etc/moriokam.xpm.Z etc/mrb.xpm.Z etc/mrbm.xpm.Z etc/pez.xpm.Z etc/pezm.xpm.Z etc/photos/ajc.xpm.Z etc/photos/ajcm.xpm.Z etc/photos/baw.xpm.Z etc/photos/bawm.xpm.Z etc/photos/bw.xpm.Z etc/photos/bwm.xpm.Z etc/photos/cthomp.xpm.Z etc/photos/cthompm.xpm.Z etc/photos/dkindred.xpm.Z etc/photos/dkindredm.xpm.Z etc/photos/dmoore.xpm.Z etc/photos/dmoorem.xpm.Z etc/photos/dv.xpm.Z etc/photos/dvm.xpm.Z etc/photos/hniksic.xpm.Z etc/photos/hniksicm.xpm.Z etc/photos/jareth.xpm.Z etc/photos/jarethm.xpm.Z etc/photos/jens.xpm.Z etc/photos/jensm.xpm.Z etc/photos/jwz.xpm.Z etc/photos/jwzm.xpm.Z etc/photos/kazz.xpm.Z etc/photos/kazzm.xpm.Z etc/photos/kyle.xpm.Z etc/photos/kylem.xpm.Z etc/photos/larsi.xpm.Z etc/photos/larsim.xpm.Z etc/photos/mly.xpm.Z etc/photos/mlym.xpm.Z etc/photos/morioka.xpm.Z etc/photos/moriokam.xpm.Z etc/photos/mrb.xpm.Z etc/photos/mrbm.xpm.Z etc/photos/ograf.xpm.Z etc/photos/ografm.xpm.Z etc/photos/pez.xpm.Z etc/photos/pezm.xpm.Z etc/photos/piper.xpm.Z etc/photos/piperm.xpm.Z etc/photos/rickc.xpm.Z etc/photos/rickcm.xpm.Z etc/photos/slb.xpm.Z etc/photos/slbm.xpm.Z etc/photos/sperber.xpm.Z etc/photos/sperberm.xpm.Z etc/photos/stig.xpm.Z etc/photos/stigb.xpm.Z etc/photos/stigbm.xpm.Z etc/photos/stigm.xpm.Z etc/photos/thiessel.xpm.Z etc/photos/thiesselm.xpm.Z etc/photos/vin.xpm.Z etc/photos/vinm.xpm.Z etc/photos/vladimir.xpm.Z etc/photos/vladimirm.xpm.Z etc/photos/wing.xpm.Z etc/photos/wingm.xpm.Z etc/photos/wmperry.xpm.Z etc/photos/wmperrym.xpm.Z etc/piper.xpm.Z etc/piperm.xpm.Z etc/rickc.xpm.Z etc/rickcm.xpm.Z etc/sample.emacs etc/sgml/CATALOG etc/sgml/ECAT etc/sgml/ISO_8879=1986/entities/Added_Latin_1 etc/sgml/ISO_8879=1986/entities/Added_Latin_1_for_HTML etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Delimiters etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Ordinary etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Relations etc/sgml/ISO_8879=1986/entities/Diacritical_Marks etc/sgml/ISO_8879=1986/entities/General_Technical etc/sgml/ISO_8879=1986/entities/Greek_Symbols etc/sgml/ISO_8879=1986/entities/ISOamsa etc/sgml/ISO_8879=1986/entities/ISOamsb etc/sgml/ISO_8879=1986/entities/ISOamsc etc/sgml/ISO_8879=1986/entities/ISOamsn etc/sgml/ISO_8879=1986/entities/ISOamso etc/sgml/ISO_8879=1986/entities/ISOamsr etc/sgml/ISO_8879=1986/entities/ISObox etc/sgml/ISO_8879=1986/entities/ISOcyr1 etc/sgml/ISO_8879=1986/entities/ISOcyr2 etc/sgml/ISO_8879=1986/entities/ISOdia etc/sgml/ISO_8879=1986/entities/ISOgrk1 etc/sgml/ISO_8879=1986/entities/ISOgrk2 etc/sgml/ISO_8879=1986/entities/ISOgrk3 etc/sgml/ISO_8879=1986/entities/ISOgrk4 etc/sgml/ISO_8879=1986/entities/ISOlat1 etc/sgml/ISO_8879=1986/entities/ISOlat2 etc/sgml/ISO_8879=1986/entities/ISOnum etc/sgml/ISO_8879=1986/entities/ISOpub etc/sgml/ISO_8879=1986/entities/ISOtech etc/sgml/ISO_8879=1986/entities/Numeric_and_Special_Graphic etc/sgml/ISOlat1.sgml etc/sgml/README.cdtd etc/sgml/README.htmlpro etc/sgml/Wing.ISOlat1.sgml etc/sgml/cdtd/html etc/sgml/cdtd/html-2 etc/sgml/cdtd/html-3 etc/sgml/cdtd/html-3.2 etc/sgml/cdtd/html-3.2f etc/sgml/cdtd/html-hj etc/sgml/cdtd/html-mcom etc/sgml/cdtd/html-r etc/sgml/cdtd/iehtml etc/sgml/html-0.dtd etc/sgml/html-0s.dtd etc/sgml/html-1.dtd etc/sgml/html-1s.dtd etc/sgml/html-2.dtd etc/sgml/html-3.2.dtd etc/sgml/html-3.2f.dtd etc/sgml/html-3.dtd etc/sgml/html-3s.dtd etc/sgml/html-cougar.dtd etc/sgml/html-hj.dtd etc/sgml/html-hjs.dtd etc/sgml/html-icons.sgml etc/sgml/html-latin.sgml etc/sgml/html-math.sgml etc/sgml/html-mcom.dtd etc/sgml/html-mcoms.dtd etc/sgml/html-s.dtd etc/sgml/html.decl etc/sgml/html.dtd etc/sgml/htmlpro.dtd etc/sgml/ie30-s.dtd etc/sgml/ie30.dtd etc/sgml/ie3tables.dtd etc/sgml/iehtml-s.dtd etc/sgml/iehtml.dtd etc/sgml/ietables.dtd etc/sgml/iso88591.map etc/sgml/sinfo.dtd etc/sgml/webtechs.catalog etc/slb.xpm.Z etc/slbm.xpm.Z etc/sperber.xpm.Z etc/sperberm.xpm.Z etc/spook.lines etc/stig.xpm.Z etc/stigm.xpm.Z etc/thiessel.xpm.Z etc/thiesselm.xpm.Z etc/vin.xpm.Z etc/vinm.xpm.Z etc/viperCard.tex etc/vladimir.xpm.Z etc/vladimirm.xpm.Z etc/vm/audio_stamp-colorful.xpm etc/vm/audio_stamp-simple.xpm etc/vm/autofile-dn.xbm etc/vm/autofile-dn.xpm etc/vm/autofile-up.xbm etc/vm/autofile-up.xpm etc/vm/autofile-xx.xbm etc/vm/compose-dn.xbm etc/vm/compose-dn.xpm etc/vm/compose-up.xbm etc/vm/compose-up.xpm etc/vm/compose-xx.xbm etc/vm/delete-dn.xbm etc/vm/delete-dn.xpm etc/vm/delete-up.xbm etc/vm/delete-up.xpm etc/vm/delete-xx.xbm etc/vm/document-colorful.xpm etc/vm/document-simple.xpm etc/vm/file-dn.xbm etc/vm/file-dn.xpm etc/vm/file-up.xbm etc/vm/file-up.xpm etc/vm/file-xx.xbm etc/vm/film-colorful.xpm etc/vm/film-simple.xpm etc/vm/gear-colorful.xpm etc/vm/gear-simple.xpm etc/vm/getmail-dn.xbm etc/vm/getmail-dn.xpm etc/vm/getmail-up.xbm etc/vm/getmail-up.xpm etc/vm/getmail-xx.xbm etc/vm/help-dn.xbm etc/vm/help-dn.xpm etc/vm/help-up.xbm etc/vm/help-up.xpm etc/vm/help-xx.xbm etc/vm/message-colorful.xpm etc/vm/message-simple.xpm etc/vm/mime-colorful-dn.xpm etc/vm/mime-colorful-up.xpm etc/vm/mime-colorful-xx.xpm etc/vm/mime-dn.xbm etc/vm/mime-simple-dn.xpm etc/vm/mime-simple-up.xpm etc/vm/mime-simple-xx.xpm etc/vm/mime-up.xbm etc/vm/mime-xx.xbm etc/vm/mona_stamp-colorful.xpm etc/vm/mona_stamp-simple.xpm etc/vm/next-dn.xbm etc/vm/next-dn.xpm etc/vm/next-up.xbm etc/vm/next-up.xpm etc/vm/next-xx.xbm etc/vm/previous-dn.xbm etc/vm/previous-dn.xpm etc/vm/previous-up.xbm etc/vm/previous-up.xpm etc/vm/previous-xx.xbm etc/vm/print-dn.xbm etc/vm/print-dn.xpm etc/vm/print-up.xbm etc/vm/print-up.xpm etc/vm/print-xx.xbm etc/vm/quit-dn.xbm etc/vm/quit-dn.xpm etc/vm/quit-up.xbm etc/vm/quit-up.xpm etc/vm/quit-xx.xbm etc/vm/recover-dn.xbm etc/vm/recover-dn.xpm etc/vm/recover-up.xbm etc/vm/recover-up.xpm etc/vm/recover-xx.xbm etc/vm/reply-dn.xbm etc/vm/reply-dn.xpm etc/vm/reply-up.xbm etc/vm/reply-up.xpm etc/vm/reply-xx.xbm etc/vm/stuffed_box-colorful.xpm etc/vm/stuffed_box-simple.xpm etc/vm/undelete-dn.xbm etc/vm/undelete-dn.xpm etc/vm/undelete-up.xbm etc/vm/undelete-up.xpm etc/vm/undelete-xx.xbm etc/vm/visit-dn.xbm etc/vm/visit-dn.xpm etc/vm/visit-up.xbm etc/vm/visit-up.xpm etc/vm/visit-xx.xbm etc/wing.xpm.Z etc/wingm.xpm.Z etc/wmperry.xpm.Z etc/wmperrym.xpm.Z etc/xemacs-beta.xpm etc/yow.lines info/dir lib-src/ChangeLog lib-src/config.values.in lib-src/digest-doc.c lib-src/gnuslib.c lib-src/make-path.c lib-src/update-autoloads.sh lib-src/update-custom.sh lib-src/update-elc.sh lisp/ChangeLog lisp/calendar/appt.el lisp/calendar/auto-autoloads.el lisp/calendar/cal-dst.el lisp/calendar/cal-french.el lisp/calendar/cal-mayan.el lisp/calendar/cal-x.el lisp/calendar/cal-xemacs.el lisp/calendar/calendar.el lisp/calendar/custom-load.el lisp/calendar/diary-ins.el lisp/calendar/diary-lib.el lisp/calendar/holidays.el lisp/calendar/lunar.el lisp/calendar/solar.el lisp/cc-mode/custom-load.el lisp/cl/auto-autoloads.el lisp/cl/cl-macs.el lisp/comint/auto-autoloads.el lisp/comint/comint.el lisp/comint/custom-load.el lisp/comint/gdb.el lisp/custom/auto-autoloads.el lisp/custom/cus-dep.el lisp/custom/cus-edit.el lisp/custom/cus-face.el lisp/custom/cus-load.el lisp/custom/custom-load.el lisp/custom/wid-edit.el lisp/default.el lisp/edebug/custom-load.el lisp/ediff/Makefile lisp/ediff/README lisp/ediff/auto-autoloads.el lisp/ediff/custom-load.el lisp/ediff/ediff-diff.el lisp/ediff/ediff-help.el lisp/ediff/ediff-hook.el lisp/ediff/ediff-init.el lisp/ediff/ediff-merg.el lisp/ediff/ediff-mult.el lisp/ediff/ediff-ptch.el lisp/ediff/ediff-tbar.el lisp/ediff/ediff-util.el lisp/ediff/ediff-vers.el lisp/ediff/ediff-wind.el lisp/ediff/ediff.el lisp/efs/Makefile lisp/efs/README lisp/efs/auto-autoloads.el lisp/efs/custom-load.el lisp/efs/default-dir.el lisp/efs/dired-cmpr.el lisp/efs/dired-diff.el lisp/efs/dired-faces.el lisp/efs/dired-grep.el lisp/efs/dired-help.el lisp/efs/dired-mob.el lisp/efs/dired-mule.el lisp/efs/dired-oas.el lisp/efs/dired-rgxp.el lisp/efs/dired-sex.el lisp/efs/dired-shell.el lisp/efs/dired-uu.el lisp/efs/dired-vir.el lisp/efs/dired-xemacs.el lisp/efs/dired-xy.el lisp/efs/dired.el lisp/efs/efs-auto.el lisp/efs/efs-cms-knet.el lisp/efs/efs-cms.el lisp/efs/efs-coke.el lisp/efs/efs-cp-p.el lisp/efs/efs-cu.el lisp/efs/efs-defun.el lisp/efs/efs-dired-mule.el lisp/efs/efs-dired.el lisp/efs/efs-dl.el lisp/efs/efs-dos-distinct.el lisp/efs/efs-dump.el lisp/efs/efs-fnh.el lisp/efs/efs-guardian.el lisp/efs/efs-gwp.el lisp/efs/efs-hell.el lisp/efs/efs-ka9q.el lisp/efs/efs-kerberos.el lisp/efs/efs-mpe.el lisp/efs/efs-ms-unix.el lisp/efs/efs-mts.el lisp/efs/efs-mvs.el lisp/efs/efs-netrc.el lisp/efs/efs-netware.el lisp/efs/efs-nos-ve.el lisp/efs/efs-ovwrt.el lisp/efs/efs-pc.el lisp/efs/efs-plan9.el lisp/efs/efs-report.el lisp/efs/efs-ti-explorer.el lisp/efs/efs-ti-twenex.el lisp/efs/efs-tops-20.el lisp/efs/efs-vm.el lisp/efs/efs-vms.el lisp/efs/efs-vos.el lisp/efs/efs-x19.15.el lisp/efs/efs.el lisp/efs/fixup.el lisp/egg/egg-leim.el lisp/egg/egg.el lisp/emulators/crisp.el lisp/emulators/custom-load.el lisp/emulators/edt-mapper.el lisp/eterm/custom-load.el lisp/games/NeXTify.el lisp/games/auto-autoloads.el lisp/games/blackbox.el lisp/games/conx.el lisp/games/cookie1.el lisp/games/custom-load.el lisp/games/decipher.el lisp/games/dissociate.el lisp/games/doctor.el lisp/games/dunnet.el lisp/games/flame.el lisp/games/gomoku.el lisp/games/hanoi.el lisp/games/life.el lisp/games/mpuz.el lisp/games/spook.el lisp/games/studly.el lisp/games/tetris.el lisp/games/xmine.el lisp/games/yow.el lisp/hm--html-menus/ANNOUNCEMENT lisp/hm--html-menus/NEWS lisp/hm--html-menus/README lisp/hm--html-menus/adapt.el lisp/hm--html-menus/auto-autoloads.el lisp/hm--html-menus/command-description.html.tmpl lisp/hm--html-menus/custom-load.el lisp/hm--html-menus/frame.html.tmpl lisp/hm--html-menus/hm--date.el lisp/hm--html-menus/hm--html-configuration.el lisp/hm--html-menus/hm--html-drag-and-drop.el lisp/hm--html-menus/hm--html-indentation.el lisp/hm--html-menus/hm--html-keys.el lisp/hm--html-menus/hm--html-menu.el lisp/hm--html-menus/hm--html-mode.el lisp/hm--html-menus/hm--html-not-standard.el lisp/hm--html-menus/hm--html.el lisp/hm--html-menus/html-view.el lisp/hm--html-menus/internal-drag-and-drop.el lisp/hm--html-menus/templates.doc lisp/hm--html-menus/tmpl-minor-mode.el lisp/language/arabic-util.el lisp/language/arabic.el lisp/language/auto-autoloads.el lisp/language/china-util.el lisp/language/chinese.el lisp/language/cyril-util.el lisp/language/devanagari.el lisp/language/english.el lisp/language/ethio-util.el lisp/language/ethiopic.el lisp/language/european.el lisp/language/greek.el lisp/language/hebrew.el lisp/language/indian.el lisp/language/japan-util.el lisp/language/japanese.el lisp/language/korean.el lisp/language/lao-util.el lisp/language/lao.el lisp/language/thai-util.el lisp/language/thai.el lisp/language/tibet-util.el lisp/language/tibetan.el lisp/language/viet-chars.el lisp/language/viet-util.el lisp/language/vietnamese.el lisp/language/visual-mode.el lisp/leim/custom-load.el lisp/leim/leim-list.el lisp/leim/quail/cyrillic.el lisp/leim/quail/devanagari.el lisp/leim/quail/ethiopic.el lisp/leim/quail/japanese.el lisp/leim/quail/lao.el lisp/leim/quail/lrt.el lisp/leim/quail/tibetan.el lisp/mailcrypt/ANNOUNCE lisp/mailcrypt/ChangeLog lisp/mailcrypt/NEWS lisp/mailcrypt/ONEWS lisp/mailcrypt/README lisp/mailcrypt/auto-autoloads.el lisp/mailcrypt/mailcrypt.el lisp/mailcrypt/mc-pgp.el lisp/mailcrypt/mc-remail.el lisp/mailcrypt/mc-toplev.el lisp/mel/ChangeLog lisp/mel/auto-autoloads.el lisp/mel/mel-b.el lisp/mel/mel-g.el lisp/mel/mel-q.el lisp/mel/mel-u.el lisp/mel/mel.el lisp/modes/auto-autoloads.el lisp/modes/c-comment.el lisp/modes/cperl-mode.el lisp/modes/custom-load.el lisp/modes/enriched.el lisp/modes/lazy-shot.el lisp/modes/reftex.el lisp/mu/latex-math-symbol.el lisp/mu/mu-bbdb.el lisp/mu/mu-cite.el lisp/mule/auto-autoloads.el lisp/mule/canna-leim.el lisp/mule/canna.el lisp/mule/custom-load.el lisp/mule/hebrew-hooks.el lisp/mule/mule-cmds.el lisp/mule/mule-coding.el lisp/mule/mule-debug.el lisp/mule/mule-diag.el lisp/mule/mule-files.el lisp/mule/mule-help.el lisp/mule/mule-init.el lisp/mule/mule-misc.el lisp/mule/mule-process.el lisp/mule/mule-vietnamese.el lisp/mule/vietnamese-hooks-1.el lisp/mule/vietnamese-hooks-2.el lisp/packages/add-log.el lisp/packages/auto-autoloads.el lisp/packages/backup-dir.el lisp/packages/custom-load.el lisp/packages/etags.el lisp/packages/gnuserv.el lisp/packages/hyper-apropos.el lisp/packages/info.el lisp/packages/jka-compr.el lisp/packages/man.el lisp/pcl-cvs/pcl-cvs-xemacs.el lisp/pcl-cvs/pcl-cvs.el lisp/pcl-cvs/string.el lisp/prim/about.el lisp/prim/auto-autoloads.el lisp/prim/cmdloop.el lisp/prim/custom-load.el lisp/prim/dumped-lisp.el lisp/prim/faces.el lisp/prim/featurep.el lisp/prim/files.el lisp/prim/fill.el lisp/prim/find-func.el lisp/prim/frame.el lisp/prim/glyphs.el lisp/prim/help-nomule.el lisp/prim/help.el lisp/prim/keymap.el lisp/prim/minibuf.el lisp/prim/mouse.el lisp/prim/obsolete.el lisp/prim/packages.el lisp/prim/profile.el lisp/prim/simple.el lisp/prim/startup.el lisp/prim/subr.el lisp/psgml/ChangeLog lisp/psgml/README.psgml lisp/psgml/auto-autoloads.el lisp/psgml/custom-load.el lisp/psgml/iso-sgml.el lisp/psgml/psgml-api.el lisp/psgml/psgml-charent.el lisp/psgml/psgml-debug.el lisp/psgml/psgml-dtd.el lisp/psgml/psgml-edit.el lisp/psgml/psgml-fs.el lisp/psgml/psgml-html.el lisp/psgml/psgml-info.el lisp/psgml/psgml-other.el lisp/psgml/psgml-parse.el lisp/psgml/psgml-style.fs lisp/psgml/psgml-xemacs.el lisp/psgml/psgml.el lisp/psgml/tempo.el lisp/site-start.el lisp/tl/auto-autoloads.el lisp/tl/char-table.el lisp/tl/char-util.el lisp/tl/chartblxmas.el lisp/tl/cless.el lisp/tl/range.el lisp/tl/texi-util.el lisp/tl/tl-atype.el lisp/tl/tl-list.el lisp/tl/tl-misc.el lisp/tl/tl-num.el lisp/tl/tl-seq.el lisp/tl/tl-str.el lisp/tl/tu-comment.el lisp/tl/tu-replace.el lisp/tm/auto-autoloads.el lisp/tm/gnus-art-mime.el lisp/tm/gnus-charset.el lisp/tm/gnus-mime.el lisp/tm/gnus-sum-mime.el lisp/tm/message-mime.el lisp/tm/mime-setup.el lisp/tm/sc-setup.el lisp/tm/signature.el lisp/tm/tm-bbdb.el lisp/tm/tm-def.el lisp/tm/tm-edit-mc.el lisp/tm/tm-edit.el lisp/tm/tm-ew-d.el lisp/tm/tm-ew-e.el lisp/tm/tm-file.el lisp/tm/tm-ftp.el lisp/tm/tm-html.el lisp/tm/tm-image.el lisp/tm/tm-latex.el lisp/tm/tm-mail.el lisp/tm/tm-mh-e.el lisp/tm/tm-parse.el lisp/tm/tm-partial.el lisp/tm/tm-pgp.el lisp/tm/tm-play.el lisp/tm/tm-rmail.el lisp/tm/tm-setup.el lisp/tm/tm-tar.el lisp/tm/tm-text.el lisp/tm/tm-view.el lisp/tm/tm-vm.el lisp/tm/tmh-comp.el lisp/utils/auto-autoloads.el lisp/utils/browse-cltl2.el lisp/utils/build-report.el lisp/utils/crontab.el lisp/utils/custom-load.el lisp/utils/detached-minibuf.el lisp/utils/facemenu.el lisp/utils/find-gc.el lisp/utils/floating-toolbar.el lisp/utils/flow-ctrl.el lisp/utils/hide-copyleft.el lisp/utils/xemacs-build-report.el lisp/viper/Makefile lisp/viper/README lisp/viper/auto-autoloads.el lisp/viper/custom-load.el lisp/viper/viper-cmd.el lisp/viper/viper-ex.el lisp/viper/viper-init.el lisp/viper/viper-keym.el lisp/viper/viper-macs.el lisp/viper/viper-mous.el lisp/viper/viper-util.el lisp/viper/viper.el lisp/vm/Makefile lisp/vm/README lisp/vm/auto-autoloads.el lisp/vm/make-autoloads lisp/vm/tapestry.el lisp/vm/vm-byteopts.el lisp/vm/vm-delete.el lisp/vm/vm-digest.el lisp/vm/vm-easymenu.el lisp/vm/vm-edit.el lisp/vm/vm-folder.el lisp/vm/vm-license.el lisp/vm/vm-mark.el lisp/vm/vm-menu.el lisp/vm/vm-message.el lisp/vm/vm-mime.el lisp/vm/vm-minibuf.el lisp/vm/vm-misc.el lisp/vm/vm-motion.el lisp/vm/vm-mouse.el lisp/vm/vm-page.el lisp/vm/vm-pop.el lisp/vm/vm-reply.el lisp/vm/vm-save.el lisp/vm/vm-search18.el lisp/vm/vm-search19.el lisp/vm/vm-sort.el lisp/vm/vm-startup.el lisp/vm/vm-summary.el lisp/vm/vm-thread.el lisp/vm/vm-toolbar.el lisp/vm/vm-undo.el lisp/vm/vm-user.el lisp/vm/vm-vars.el lisp/vm/vm-version.el lisp/vm/vm-virtual.el lisp/vm/vm-window.el lisp/x11/custom-load.el lisp/x11/x-faces.el lisp/x11/x-menubar.el lwlib/xlwmenu.c lwlib/xlwmenu.h lwlib/xlwmenuP.h man/ChangeLog man/Makefile man/ediff.texi man/efs.texi man/hm--html-mode.texi man/lispref/commands.texi man/lispref/extents.texi man/mailcrypt.texi man/psgml-api.texi man/psgml.texi man/umlaute.texi man/viper.texi man/vm.texi man/vmcard.tex man/xemacs-faq.texi man/xemacs/custom.texi man/xemacs/major.texi man/xemacs/mule.texi man/xemacs/windows.texi man/xemacs/xemacs.texi src/ChangeLog src/Makefile.in.in src/README src/alloc.c src/buffer.c src/bytecode.c src/chartab.c src/config.h.in src/console-stream.c src/console-tty.c src/data.c src/database.c src/device-x.c src/elhash.c src/emacs.c src/emacsfns.h src/event-Xt.c src/events.c src/extents.c src/extents.h src/faces.c src/fns.c src/frame-x.c src/general.c src/glyphs-x.c src/gpmevent.c src/gpmevent.h src/input-method-motif.c src/input-method-xfs.c src/input-method-xlib.c src/lisp-disunion.h src/lisp-union.h src/lisp.h src/lread.c src/lrecord.h src/lstream.c src/m/ibmrs6000.h src/mule-canna.c src/mule-coding.c src/mule-wnnfns.c src/print.c src/process.c src/profile.c src/s/aix3-2.h src/s/aix4-1.h src/s/aix4.h src/s/irix5-0.h src/s/vms.h src/s/vms4-0.h src/s/vms4-2.h src/s/vms4-4.h src/s/vms5-5.h src/symbols.c src/systime.h src/toolbar.h src/unexaix.c src/vlimit.h version.sh |
| diffstat | 839 files changed, 20629 insertions(+), 212940 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGES-beta Mon Aug 13 10:02:48 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 10:03:52 2007 +0200 @@ -1,4 +1,70 @@ -*- indented-text -*- +to 20.4 beta2 "Alpine" +-- hm--html-mode has been packaged +-- viper has been packaged +-- ediff has been packaged +-- EFS has been packaged +-- Mailcrypt has been packaged +-- VM has been packaged +-- Mule updates, elimination of dead languages courtesy of MORIOKA Tomohiko +-- Phase one of graphics conversion to ImageMagic courtesy of William Perry +-- Miscellaneous menu hacking courtesy of Kyle Jones +-- Reorganization of Lisp type & type bits courtesy of Kyle Jones +-- reftex.el 3.7 courtesy of Carsten Dominik +-- Norwegian tutorial update courtesy of Stig Bjorlykkee +-- ediff & viper updates courtesy of Michael Kifer +-- Canna & Wnn integrated with LEIM courtesy of Stephen Turnbull +-- Berkeley DB 2.x support courtesy of Andreas Jaegar +-- tm has been packaged +-- calendar has been packaged +-- Build tweak: finder-inf is not aggressively rebuilt +-- New versions of TUTORIAL: +-- Croatian - Hrvoje Niksic +-- French - Didier Verna +-- German - Adrian Aichner +-- Norwegian - Stig Bjorlykke +-- Japanese, Korean, Thai - Imported from Emacs 20.1 +-- Disable puresize statistics unless --debug is in effect +-- about.el hacking +-- New command line options -no-packages, -vanilla +-- psgml has been packaged +-- Move lisp types into lrecords for portability courtesy of Kyle Jones +-- yow.el has been packaged +-- xmine.el has been packaged +-- tetris.el has been packaged +-- hanoi.el has been packaged +-- hide-copyleft.el has been packaged +-- flow-ctrl.el has been packaged +-- find-gc.el has been packaged +-- detached-minibuf.el has been packaged +-- crontab.el has been packaged +-- browse-cltl2.el has been packaged +-- studly.el has been packaged +-- spook.el has been packaged +-- mpuz.el has been packaged +-- life.el has been packaged +-- gomoku.el has been packaged +-- flame.el has been packaged +-- dunnet.el has been packaged +-- doctor.el has been packaged +-- dissociate.el has been packaged +-- decipher.el has been packaged +-- cookie1.el has been packaged +-- conx.el has been packaged +-- blackbox.el has been packaged +-- NeXTify.el has been packaged +-- Support for conses and vectors to be lrecords +-- autoloads found in User packages loaded at start up +-- reftex.el update courtesy of Carsten Dominik +-- crisp.el-1.21 courtesy of Gary Foster +-- lazy-shot.el update from Jan Vroonhof +-- XEmacs/BETA logo courtesy of Mark Borges & Didier Verna +-- Oliver Graf OffiX patches +-- Mule patches from MORIOKA Tomohiko +-- xemacs-build-report-1.33 courtesy of Adrian Aichner +-- Hrvoje Niksic updates +-- Miscellaneous bug fixes + to 20.4 beta1 "Century" -- Version fork, package work will be carried on in this branch -- Miscellaneous bug fixes
--- a/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,3 +1,137 @@ +1997-10-31 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.4-beta2 + +1997-10-30 SL Baur <steve@altair.xemacs.org> + + * configure.in (xetest): Eliminate tests for PNG, JPEG, + TIFF(broken) and replace with test for ImageMagick. + +1997-10-30 Kyle Jones <kyle_jones@wonderworks.com> + + * etc/Emacs.ad: Added *XlwMenu*highlightForeground entry. + Added *XlwMenu*titleForeground entry. + + * lwlib/xlwmenu.h: Added string macro declarations for + titleForeground and highlightForeground properties. + + * lwlib/xlwmenuP.h: Added struct fields for title and + highlight colors. + + * lwlib/xlwmenu.c: Added initialization and usage code + for the new titleForeground and highlightForeground + properties. + +1997-10-29 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * etc/HELLO: Add Czech. + + * etc/HELLO: Delete Amharic, Thai and Tigrigna. + +1997-10-28 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.3-beta94 is released. + +1997-10-28 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * configure.in: Correct last patch for berkdb. + +1997-10-28 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.3-beta93 is released. + +1997-10-27 Martin Buchholz <mrb@eng.sun.com> + + * lib-src/make-path.c: + * lib-src/digest-doc.c: + * lib-src/gnuslib.c: Always include config.h before system headers + * configure.in: Improve AIX configure support + - NON_GNU_CC defaults to `xlc' + - CFLAGS defaults to "-O3 -qstrict -qlibansi -qinfo -qro + -qmaxmem=20000" + - check for sin instead of sqrt in -lm to avoid xlc internal error + - Detect -li18n for use with Motif + - Move weird AIX static linking flags from s&m files to configure.in + - use #pragma instead of -ma flag to avoid compiler warnings + +1997-10-25 Kyle Jones <kyle_jones@wonderworks.com> + + * lwlib/xlwmenu.c: Use XtRDimension in place of + XmRHorizontalDimension in shadowThickness resource + declaration. + + * lwlib/xlwmenu.c (label_button_draw): Use the button_gc + color as the foreground for selected entries. + + * lwlib/xlwmenu.c (push_button_draw): Use the button_gc + color as the foreground for selected entries. + + * lwlib/xlwmenu.c (toggle_decoration_height): Force + height to be minimum of 2x the shadow thickness. + +1997-10-24 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * configure.in: Don't choke on Berkeley DB 2.x. + +1997-10-24 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.3-beta92 is released. + +1997-10-21 SL Baur <steve@altair.xemacs.org> + + * Makefile.in (lisp/utils/finder-inf.el): Don't force rebuild if + it already exists (use `make finder' to force rebuild). + +1997-10-18 SL Baur <steve@altair.xemacs.org> + + * XEmacs 20.3-beta91 is released. + +1997-10-16 Hrvoje Niksic <hniksic@srce.hr> + + * etc/NEWS: document changed package load semantics. + +1997-10-15 Olivier Galibert <olivier.galibert@mines.u-nancy.fr> + + * configure.in: Removed -Olimit=2000 from cc for IRIX. + +1997-10-12 Karl M. Hegbloom <karlheg@inetarena.com> + + * configure.in (null_string): Added AC_SUBST(infodir_user_defined) + and removed backquoted echo statement from the infopath report line. + +1997-10-15 Olivier Galibert <olivier.galibert@mines.u-nancy.fr> + + * configure.in: Added detection of the declaration of the timezone + variable in system files. Defines HAVE_TIMEZONE_DECL if yes. + + +1997-10-15 Olivier Galibert <olivier.galibert@mines.u-nancy.fr> + + * config.h.in: Add HAVE_TIMEZONE_DECL for detection of declaration + of the timezone variable in system headers. + + * systime.h: Use HAVE_TIMEZONE_DECL. + +1997-10-14 SL Baur <steve@altair.xemacs.org> + + * configure.in (all_widgets): Don't allow configuration of + --with-mule if Mule lisp hasn't been installed. + +1997-10-13 SL Baur <steve@altair.xemacs.org> + + * configure.in: Remove `site-lisp' from list of directories to + make symbolic links for. + + * XEmacs 20.3-beta90 is released. + +1997-10-12 Glynn Clements <glynn@sensei.co.uk> + + * info/dir: Cosmetic changes to info/dir + +1997-10-13 Hrvoje Niksic <hniksic@srce.hr> + + * etc/NEWS: Updates + 1997-10-12 SL Baur <steve@altair.xemacs.org> * XEmacs 20.4-beta1 is released. @@ -22,7 +156,7 @@ and lockdir * '' added a line to the report for infopath and lockdir - * NEWS: Draft entry for the info changes. + * etc/NEWS: Draft entry for the info changes. 1997-10-10 Karl M. Hegbloom <karlheg@inetarena.com>
--- a/Makefile.in Mon Aug 13 10:02:48 2007 +0200 +++ b/Makefile.in Mon Aug 13 10:03:52 2007 +0200 @@ -272,7 +272,7 @@ ${blddir}/src/xemacs -batch -q -no-site-file \ -l finder -f finder-compile-keywords ) -lisp/utils/finder-inf.el: FRC.lisp.utils.finder-inf.el +lisp/utils/finder-inf.el: @(cd lisp/utils; \ ${blddir}/src/xemacs -batch -q -no-site-file \ -l finder -f finder-compile-keywords )
--- a/PROBLEMS Mon Aug 13 10:02:48 2007 +0200 +++ b/PROBLEMS Mon Aug 13 10:03:52 2007 +0200 @@ -82,9 +82,6 @@ This error message has been observed with lesstif-0.75a. It does not appear to cause any harm. -### Does this happen in any of the more recent versions of -Lesstif/XEmacs? - ** Linking with -rpath on IRIX. Darrell Kindred <dkindred@cmu.edu> writes: @@ -106,7 +103,10 @@ or --site-runtime-libraries, you must use --use-gcc=no, or configure will fail. -### Is this valid in 20.3? +** On Irix 6.3, the SGI ld quits with segmentation fault when linking temacs + +This occurs if you use the SGI linker version 7.1. Installing the +patch SG0001872 fixes this problem. ** On Irix 5.x and 6.x, the dumped XEmacs (xemacs) core dumps when executed on another machine, or after newer SGI IRIX patches have been installed. @@ -170,8 +170,6 @@ remember the patch numbers. I think potential XEmacs builders on HP should be warned about this. -### Fixed in 20.3? - ** I don't have `xmkmf' and `imake' on my HP. You can get these standard X tools by anonymous FTP to hpcvaaz.cv.hp.com. @@ -191,8 +189,6 @@ Compiler fixes in Irix 6.0.1 should eliminate this problem. -### Fixed in 20.3? - ** Native cc on SCO OpenServer 5 is now OK. Icc may still throw you a curve. Here is what Robert Lipe <robertl@arnet.com> says: @@ -257,7 +253,8 @@ the emacstrs.sco is a suitable candidate for /usr/lib/keyboard/strings to take advantage of the keyboard map in emacskeys.sco. -### Is this valid in 20.3? +Note: Much of the above entry is probably not valid for XEmacs 20.3 +and later. ** Under some versions of OSF XEmacs runs fine if built without optimization but will crash randomly if built with optimization. @@ -829,7 +826,8 @@ delayed until mid-june ;-). I think this problem will be an FAQ soon after the release otherwise. -### Is this valid for 20.3? +Note: The above entry is probably not valid for XEmacs 20.3 and +later. ** When Emacs tries to ring the bell, you get an error like @@ -909,16 +907,12 @@ if it builds with the motif dialogs [boom!] you're a dead man. -### Does this apply to 20.3? - ** Beware of the default image & graphics library on Irix Richard Cognot <cognot@ensg.u-nancy.fr> writes: You *have* to compile your own jpeg lib. The one delivered with SGI systems is a C++ lib, which apparently XEmacs cannot cope with. -### Does this apply to 20.3? - ** Slow startup on Linux. People using systems based on the Linux kernel sometimes report that
--- a/configure Mon Aug 13 10:02:48 2007 +0200 +++ b/configure Mon Aug 13 10:03:52 2007 +0200 @@ -244,7 +244,6 @@ energize_version='' native_sound_lib='' use_assertions="yes" -with_gif="" with_toolbars="" with_tty="" use_union_type="no" @@ -309,7 +308,7 @@ --with-toolbars=no Don't compile with any toolbar support. --with-session=no Compile without realized leader window which will keep the WM_COMMAND property. Required for proper - session-management. (ON by default for testing) + session-management. --with-menubars=TYPE Use TYPE menubars (lucid, motif, or no). The Lucid widgets emulate Motif (mostly) but are faster. *WARNING* The Motif menubar is currently broken. @@ -331,13 +330,11 @@ --with-xface (*) Compile with support for X-Face mail header conversion. Requires the compface library. Get it from the XEmacs FTP site. ---with-jpeg (*) Compile with support for JPEG image conversion. - Requires libjpeg from the Independent JPEG Group. +--with-imagick (*) Compile with support for ImageMagick image conversion. + Requires ImageMagick from wizards.dupont.com and + libraries for whatever image types you wish to have + supported. Get it from the XEmacs FTP site. ---with-png (*) Compile with support for PNG image conversion. - Requires libpng. Get it from the XEmacs FTP site. ---with-tiff (*) Compile with support for TIFF image conversion - (not yet implemented). TTY options: @@ -533,12 +530,9 @@ with_cde | \ with_offix | \ with_gpm | \ - with_gif | \ with_xpm | \ with_xface | \ - with_jpeg | \ - with_png | \ - with_tiff | \ + with_imagick | \ with_session | \ with_xmu | \ with_quantify | \ @@ -874,7 +868,7 @@ esac echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:878: checking whether ln -s works" >&5 +echo "configure:872: checking whether ln -s works" >&5 rm -f conftestdata if ln -s X conftestdata 2>/dev/null @@ -892,7 +886,7 @@ fi -for dir in lisp etc man info site-lisp; do +for dir in lisp etc man info; do if test ! -d "$dir" ; then echo Making symbolic link to "$srcdir/$dir" ${LN_S} "$srcdir/$dir" "$dir" @@ -1051,7 +1045,7 @@ echo "checking "the configuration name"" 1>&6 -echo "configure:1055: checking "the configuration name"" >&5 +echo "configure:1049: checking "the configuration name"" >&5 internal_configuration=`echo $configuration | sed 's/-\(energize\|workshop\)//'` if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else exit $? @@ -1297,7 +1291,7 @@ m68*-sgi-iris3.6* | m68*-sgi-iris*) machine=irist opsys=iris3-6 ;; mips-sgi-irix3.* ) opsys=irix3-3 ;; mips-sgi-irix4.* ) opsys=irix4-0 ;; - mips-sgi-irix6* ) opsys=irix6-0 NON_GNU_CC="cc -Olimit 2000" ;; + mips-sgi-irix6* ) opsys=irix6-0 ;; mips-sgi-irix5.1* ) opsys=irix5-1 ;; mips-sgi-irix5.2* ) opsys=irix5-2 ;; mips-sgi-irix5.* ) opsys=irix5-3 ;; @@ -1451,6 +1445,8 @@ esac fi +case "$opsys" in aix*) NON_GNU_CC=xlc ;; esac + stack_trace_eye_catcher=`echo xemacs_${version}_${canonical} | sed 'y/.-/__/'` { test "$extra_verbose" = "yes" && cat << EOF Defining STACK_TRACE_EYE_CATCHER = $stack_trace_eye_catcher @@ -1505,7 +1501,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1509: checking for $ac_word" >&5 +echo "configure:1505: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1531,7 +1527,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1535: checking for $ac_word" >&5 +echo "configure:1531: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1576,7 +1572,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1580: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1576: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1588,11 +1584,11 @@ cross_compiling=no cat > conftest.$ac_ext <<EOF -#line 1592 "configure" +#line 1588 "configure" #include "confdefs.h" main(){return(0);} EOF -if { (eval echo configure:1596: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1592: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1612,19 +1608,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1616: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1612: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1621: checking whether we are using GNU C" >&5 +echo "configure:1617: checking whether we are using GNU C" >&5 cat > conftest.c <<EOF #ifdef __GNUC__ yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1628: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1624: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1638,7 +1634,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1642: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1638: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1667,7 +1663,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1671: checking for $ac_word" >&5 +echo "configure:1667: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1693,7 +1689,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1697: checking for $ac_word" >&5 +echo "configure:1693: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1738,7 +1734,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1742: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1738: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1750,11 +1746,11 @@ cross_compiling=no cat > conftest.$ac_ext <<EOF -#line 1754 "configure" +#line 1750 "configure" #include "confdefs.h" main(){return(0);} EOF -if { (eval echo configure:1758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1754: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1774,19 +1770,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1778: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1774: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1783: checking whether we are using GNU C" >&5 +echo "configure:1779: checking whether we are using GNU C" >&5 cat > conftest.c <<EOF #ifdef __GNUC__ yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1790: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1786: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1800,7 +1796,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1804: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1800: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1829,7 +1825,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1833: checking for $ac_word" >&5 +echo "configure:1829: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1855,7 +1851,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1859: checking for $ac_word" >&5 +echo "configure:1855: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1900,7 +1896,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1904: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1900: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1912,11 +1908,11 @@ cross_compiling=no cat > conftest.$ac_ext <<EOF -#line 1916 "configure" +#line 1912 "configure" #include "confdefs.h" main(){return(0);} EOF -if { (eval echo configure:1920: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1916: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1936,19 +1932,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1940: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1936: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1945: checking whether we are using GNU C" >&5 +echo "configure:1941: checking whether we are using GNU C" >&5 cat > conftest.c <<EOF #ifdef __GNUC__ yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1952: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1948: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1962,7 +1958,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1966: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1962: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1995,7 +1991,7 @@ test -n "$NON_GNU_CPP" -a "$GCC" != "yes" -a -z "$CPP" && CPP="$NON_GNU_CPP" echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:1999: checking how to run the C preprocessor" >&5 +echo "configure:1995: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -2008,13 +2004,13 @@ # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext <<EOF -#line 2012 "configure" +#line 2008 "configure" #include "confdefs.h" #include <assert.h> Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2018: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2014: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2025,13 +2021,13 @@ rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext <<EOF -#line 2029 "configure" +#line 2025 "configure" #include "confdefs.h" #include <assert.h> Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2035: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2031: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2054,9 +2050,9 @@ echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:2058: checking for AIX" >&5 -cat > conftest.$ac_ext <<EOF -#line 2060 "configure" +echo "configure:2054: checking for AIX" >&5 +cat > conftest.$ac_ext <<EOF +#line 2056 "configure" #include "confdefs.h" #ifdef _AIX yes @@ -2083,9 +2079,9 @@ echo $ac_n "checking whether we are using SunPro C""... $ac_c" 1>&6 -echo "configure:2087: checking whether we are using SunPro C" >&5 -cat > conftest.$ac_ext <<EOF -#line 2089 "configure" +echo "configure:2083: checking whether we are using SunPro C" >&5 +cat > conftest.$ac_ext <<EOF +#line 2085 "configure" #include "confdefs.h" int main() { @@ -2096,7 +2092,7 @@ ; return 0; } EOF -if { (eval echo configure:2100: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2096: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* __sunpro_c=yes else @@ -2322,16 +2318,17 @@ sol2 ) CFLAGS="-v -xO4" ;; sunos4* ) CFLAGS="-xO2";; esac + elif test "$CC" = "xlc"; then + CFLAGS="-O3 -qstrict -qnoansialias -qlibansi -qinfo -qro -qmaxmem=20000" else - CFLAGS="-O" # The only POSIX-approved flag - fi + CFLAGS="-O" ; fi fi if test "$GCC" = "yes"; then ld_switch_system_tmp="$ld_switch_system"; ld_switch_system="" for arg in $ld_switch_system_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) ld_switch_system="$ld_switch_system $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_switch_system="$ld_switch_system $arg" ;; -Xlinker* ) ;; * ) ld_switch_system="$ld_switch_system -Xlinker $arg" ;; esac @@ -2339,7 +2336,7 @@ ld_switch_machine_tmp="$ld_switch_machine"; ld_switch_machine="" for arg in $ld_switch_machine_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) ld_switch_machine="$ld_switch_machine $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_switch_machine="$ld_switch_machine $arg" ;; -Xlinker* ) ;; * ) ld_switch_machine="$ld_switch_machine -Xlinker $arg" ;; esac @@ -2347,7 +2344,7 @@ LDFLAGS_tmp="$LDFLAGS"; LDFLAGS="" for arg in $LDFLAGS_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) LDFLAGS="$LDFLAGS $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) LDFLAGS="$LDFLAGS $arg" ;; -Xlinker* ) ;; * ) LDFLAGS="$LDFLAGS -Xlinker $arg" ;; esac @@ -2355,7 +2352,7 @@ ld_call_shared_tmp="$ld_call_shared"; ld_call_shared="" for arg in $ld_call_shared_tmp; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) ld_call_shared="$ld_call_shared $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) ld_call_shared="$ld_call_shared $arg" ;; -Xlinker* ) ;; * ) ld_call_shared="$ld_call_shared -Xlinker $arg" ;; esac @@ -2373,7 +2370,7 @@ fi echo $ac_n "checking for dynodump""... $ac_c" 1>&6 -echo "configure:2377: checking for dynodump" >&5 +echo "configure:2374: checking for dynodump" >&5 if test "$unexec" != "unexsol2.o"; then echo "$ac_t""no" 1>&6 else @@ -2397,8 +2394,21 @@ fi - -test -n "$ld_text_start_addr" && start_flags="-T $ld_text_start_addr -e __start" +if test "$unexec" = "unexaix.o"; then + start_flags="-Wl,-bnso,-bnodelcsect" + test "$GCC" = "yes" && start_flags="-B/bin/ ${aixflags}" + for f in "/lib/syscalls.exp" "$srcdir/src/m/ibmrs6000.inp"; do + if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; fi + done + for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp"; do + if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; break; fi + done +elif test -n "$ld_text_start_addr"; then + start_flags="-T $ld_text_start_addr -e __start" +fi + + + if test "$ordinary_link" = "no" -a "$GCC" = "yes"; then test -z "$linker" && linker='$(CC) -nostdlib' @@ -2444,19 +2454,19 @@ if test "$add_runtime_path" = "yes"; then echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6 -echo "configure:2448: checking "for runtime libraries flag"" >&5 +echo "configure:2458: checking "for runtime libraries flag"" >&5 dash_r="" for try_dash_r in "-R" "-R " "-rpath "; do xe_check_libs="${try_dash_r}/no/such/file-or-directory" cat > conftest.$ac_ext <<EOF -#line 2453 "configure" +#line 2463 "configure" #include "confdefs.h" int main() { ; return 0; } EOF -if { (eval echo configure:2460: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2470: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* dash_r="$try_dash_r" else @@ -2554,7 +2564,7 @@ # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2558: checking for $ac_word" >&5 +echo "configure:2568: checking for $ac_word" >&5 if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. @@ -2607,7 +2617,7 @@ # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:2611: checking for a BSD compatible install" >&5 +echo "configure:2621: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" @@ -2658,7 +2668,7 @@ # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2662: checking for $ac_word" >&5 +echo "configure:2672: checking for $ac_word" >&5 if test -n "$YACC"; then ac_cv_prog_YACC="$YACC" # Let the user override the test. @@ -2689,15 +2699,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2693: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2696 "configure" +echo "configure:2703: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2706 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2701: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2711: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2730,15 +2740,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2734: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2737 "configure" +echo "configure:2744: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2747 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2742: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2752: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2771,15 +2781,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2775: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2778 "configure" +echo "configure:2785: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2788 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2783: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2793: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2809,10 +2819,10 @@ done echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:2813: checking for sys/wait.h that is POSIX.1 compatible" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2816 "configure" +echo "configure:2823: checking for sys/wait.h that is POSIX.1 compatible" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2826 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/wait.h> @@ -2828,7 +2838,7 @@ s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } EOF -if { (eval echo configure:2832: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2842: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_sys_wait_h=yes else @@ -2852,10 +2862,10 @@ fi echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:2856: checking for ANSI C header files" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2859 "configure" +echo "configure:2866: checking for ANSI C header files" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2869 "configure" #include "confdefs.h" #include <stdlib.h> #include <stdarg.h> @@ -2863,7 +2873,7 @@ #include <float.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2867: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2877: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2880,7 +2890,7 @@ if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext <<EOF -#line 2884 "configure" +#line 2894 "configure" #include "confdefs.h" #include <string.h> EOF @@ -2898,7 +2908,7 @@ if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext <<EOF -#line 2902 "configure" +#line 2912 "configure" #include "confdefs.h" #include <stdlib.h> EOF @@ -2916,7 +2926,7 @@ if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. cat > conftest.$ac_ext <<EOF -#line 2920 "configure" +#line 2930 "configure" #include "confdefs.h" #include <ctype.h> #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -2927,7 +2937,7 @@ exit (0); } EOF -if { (eval echo configure:2931: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:2941: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then : else @@ -2952,10 +2962,10 @@ fi echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:2956: checking whether time.h and sys/time.h may both be included" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2959 "configure" +echo "configure:2966: checking whether time.h and sys/time.h may both be included" >&5 + +cat > conftest.$ac_ext <<EOF +#line 2969 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/time.h> @@ -2964,7 +2974,7 @@ struct tm *tp; ; return 0; } EOF -if { (eval echo configure:2968: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2978: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -2988,10 +2998,10 @@ fi echo $ac_n "checking for sys_siglist declaration in signal.h or unistd.h""... $ac_c" 1>&6 -echo "configure:2992: checking for sys_siglist declaration in signal.h or unistd.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 2995 "configure" +echo "configure:3002: checking for sys_siglist declaration in signal.h or unistd.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3005 "configure" #include "confdefs.h" #include <sys/types.h> #include <signal.h> @@ -3003,7 +3013,7 @@ char *msg = *(sys_siglist + 1); ; return 0; } EOF -if { (eval echo configure:3007: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3017: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_decl_sys_siglist=yes else @@ -3028,9 +3038,9 @@ echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6 -echo "configure:3032: checking for struct utimbuf" >&5 -cat > conftest.$ac_ext <<EOF -#line 3034 "configure" +echo "configure:3042: checking for struct utimbuf" >&5 +cat > conftest.$ac_ext <<EOF +#line 3044 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME #include <sys/time.h> @@ -3049,7 +3059,7 @@ static struct utimbuf x; x.actime = x.modtime; ; return 0; } EOF -if { (eval echo configure:3053: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3063: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -3069,10 +3079,10 @@ rm -f conftest* echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:3073: checking return type of signal handlers" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3076 "configure" +echo "configure:3083: checking return type of signal handlers" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3086 "configure" #include "confdefs.h" #include <sys/types.h> #include <signal.h> @@ -3089,7 +3099,7 @@ int i; ; return 0; } EOF -if { (eval echo configure:3093: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3103: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -3111,10 +3121,10 @@ echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:3115: checking for size_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3118 "configure" +echo "configure:3125: checking for size_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3128 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3145,10 +3155,10 @@ fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:3149: checking for pid_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3152 "configure" +echo "configure:3159: checking for pid_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3162 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3179,10 +3189,10 @@ fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:3183: checking for uid_t in sys/types.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3186 "configure" +echo "configure:3193: checking for uid_t in sys/types.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3196 "configure" #include "confdefs.h" #include <sys/types.h> EOF @@ -3218,10 +3228,10 @@ fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:3222: checking for mode_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3225 "configure" +echo "configure:3232: checking for mode_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3235 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3252,10 +3262,10 @@ fi echo $ac_n "checking for off_t""... $ac_c" 1>&6 -echo "configure:3256: checking for off_t" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3259 "configure" +echo "configure:3266: checking for off_t" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3269 "configure" #include "confdefs.h" #include <sys/types.h> #if STDC_HEADERS @@ -3287,9 +3297,9 @@ echo $ac_n "checking for struct timeval""... $ac_c" 1>&6 -echo "configure:3291: checking for struct timeval" >&5 -cat > conftest.$ac_ext <<EOF -#line 3293 "configure" +echo "configure:3301: checking for struct timeval" >&5 +cat > conftest.$ac_ext <<EOF +#line 3303 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME #include <sys/time.h> @@ -3305,7 +3315,7 @@ static struct timeval x; x.tv_sec = x.tv_usec; ; return 0; } EOF -if { (eval echo configure:3309: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3319: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 HAVE_TIMEVAL=yes @@ -3327,10 +3337,10 @@ rm -f conftest* echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 -echo "configure:3331: checking whether struct tm is in sys/time.h or time.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3334 "configure" +echo "configure:3341: checking whether struct tm is in sys/time.h or time.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3344 "configure" #include "confdefs.h" #include <sys/types.h> #include <time.h> @@ -3338,7 +3348,7 @@ struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:3342: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3352: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -3362,10 +3372,10 @@ fi echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 -echo "configure:3366: checking for tm_zone in struct tm" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3369 "configure" +echo "configure:3376: checking for tm_zone in struct tm" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3379 "configure" #include "confdefs.h" #include <sys/types.h> #include <$ac_cv_struct_tm> @@ -3373,7 +3383,7 @@ struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:3377: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3387: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -3396,10 +3406,10 @@ else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:3400: checking for tzname" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3403 "configure" +echo "configure:3410: checking for tzname" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3413 "configure" #include "confdefs.h" #include <time.h> #ifndef tzname /* For SGI. */ @@ -3409,7 +3419,7 @@ atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:3413: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3423: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -3435,10 +3445,10 @@ echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:3439: checking for working const" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3442 "configure" +echo "configure:3449: checking for working const" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3452 "configure" #include "confdefs.h" int main() { @@ -3487,7 +3497,7 @@ ; return 0; } EOF -if { (eval echo configure:3491: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3501: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3512,7 +3522,7 @@ echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:3516: checking whether ${MAKE-make} sets \${MAKE}" >&5 +echo "configure:3526: checking whether ${MAKE-make} sets \${MAKE}" >&5 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` cat > conftestmake <<\EOF @@ -3537,12 +3547,12 @@ echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:3541: checking whether byte ordering is bigendian" >&5 +echo "configure:3551: checking whether byte ordering is bigendian" >&5 ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext <<EOF -#line 3546 "configure" +#line 3556 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/param.h> @@ -3553,11 +3563,11 @@ #endif ; return 0; } EOF -if { (eval echo configure:3557: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3567: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext <<EOF -#line 3561 "configure" +#line 3571 "configure" #include "confdefs.h" #include <sys/types.h> #include <sys/param.h> @@ -3568,7 +3578,7 @@ #endif ; return 0; } EOF -if { (eval echo configure:3572: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3582: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -3585,7 +3595,7 @@ rm -f conftest* if test $ac_cv_c_bigendian = unknown; then cat > conftest.$ac_ext <<EOF -#line 3589 "configure" +#line 3599 "configure" #include "confdefs.h" main () { /* Are we little or big endian? From Harbison&Steele. */ @@ -3598,7 +3608,7 @@ exit (u.c[sizeof (long) - 1] == 1); } EOF -if { (eval echo configure:3602: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_bigendian=no else @@ -3624,10 +3634,10 @@ echo $ac_n "checking size of short""... $ac_c" 1>&6 -echo "configure:3628: checking size of short" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3631 "configure" +echo "configure:3638: checking size of short" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3641 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3638,7 +3648,7 @@ exit(0); } EOF -if { (eval echo configure:3642: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3652: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_short=`cat conftestval` else @@ -3665,10 +3675,10 @@ exit 1 fi echo $ac_n "checking size of int""... $ac_c" 1>&6 -echo "configure:3669: checking size of int" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3672 "configure" +echo "configure:3679: checking size of int" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3682 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3679,7 +3689,7 @@ exit(0); } EOF -if { (eval echo configure:3683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3693: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_int=`cat conftestval` else @@ -3700,10 +3710,10 @@ echo $ac_n "checking size of long""... $ac_c" 1>&6 -echo "configure:3704: checking size of long" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3707 "configure" +echo "configure:3714: checking size of long" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3717 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3714,7 +3724,7 @@ exit(0); } EOF -if { (eval echo configure:3718: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3728: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long=`cat conftestval` else @@ -3735,10 +3745,10 @@ echo $ac_n "checking size of long long""... $ac_c" 1>&6 -echo "configure:3739: checking size of long long" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3742 "configure" +echo "configure:3749: checking size of long long" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3752 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3749,7 +3759,7 @@ exit(0); } EOF -if { (eval echo configure:3753: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long_long=`cat conftestval` else @@ -3770,10 +3780,10 @@ echo $ac_n "checking size of void *""... $ac_c" 1>&6 -echo "configure:3774: checking size of void *" >&5 - -cat > conftest.$ac_ext <<EOF -#line 3777 "configure" +echo "configure:3784: checking size of void *" >&5 + +cat > conftest.$ac_ext <<EOF +#line 3787 "configure" #include "confdefs.h" #include <stdio.h> main() @@ -3784,7 +3794,7 @@ exit(0); } EOF -if { (eval echo configure:3788: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_void_p=`cat conftestval` else @@ -3806,7 +3816,7 @@ echo $ac_n "checking for long file names""... $ac_c" 1>&6 -echo "configure:3810: checking for long file names" >&5 +echo "configure:3820: checking for long file names" >&5 ac_cv_sys_long_file_names=yes # Test for long file names in all the places we know might matter: @@ -3852,24 +3862,24 @@ -echo $ac_n "checking for sqrt in -lm""... $ac_c" 1>&6 -echo "configure:3857: checking for sqrt in -lm" >&5 -ac_lib_var=`echo m'_'sqrt | sed 'y%./+-%__p_%'` +echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 +echo "configure:3867: checking for sin in -lm" >&5 +ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` xe_check_libs=" -lm " cat > conftest.$ac_ext <<EOF -#line 3862 "configure" +#line 3872 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ -char sqrt(); +char sin(); int main() { -sqrt() +sin() ; return 0; } EOF -if { (eval echo configure:3873: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3883: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3911,7 +3921,7 @@ echo "checking type of mail spool file locking" 1>&6 -echo "configure:3915: checking type of mail spool file locking" >&5 +echo "configure:3925: checking type of mail spool file locking" >&5 test -z "$mail_locking" -a "$mail_use_flock" = "yes" && mail_locking=flock test -z "$mail_locking" -a "$mail_use_lockf" = "yes" && mail_locking=lockf if test "$mail_locking" = "lockf"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -3935,12 +3945,12 @@ echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6 -echo "configure:3939: checking for kstat_open in -lkstat" >&5 +echo "configure:3949: checking for kstat_open in -lkstat" >&5 ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lkstat " cat > conftest.$ac_ext <<EOF -#line 3944 "configure" +#line 3954 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -3951,7 +3961,7 @@ kstat_open() ; return 0; } EOF -if { (eval echo configure:3955: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3965: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3985,12 +3995,12 @@ echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6 -echo "configure:3989: checking for kvm_read in -lkvm" >&5 +echo "configure:3999: checking for kvm_read in -lkvm" >&5 ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'` xe_check_libs=" -lkvm " cat > conftest.$ac_ext <<EOF -#line 3994 "configure" +#line 4004 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4001,7 +4011,7 @@ kvm_read() ; return 0; } EOF -if { (eval echo configure:4005: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4015: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4035,12 +4045,12 @@ echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6 -echo "configure:4039: checking for cma_open in -lpthreads" >&5 +echo "configure:4049: checking for cma_open in -lpthreads" >&5 ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lpthreads " cat > conftest.$ac_ext <<EOF -#line 4044 "configure" +#line 4054 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4051,7 +4061,7 @@ cma_open() ; return 0; } EOF -if { (eval echo configure:4055: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4065: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4087,7 +4097,7 @@ fi echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6 -echo "configure:4091: checking whether the -xildoff compiler flag is required" >&5 +echo "configure:4101: checking whether the -xildoff compiler flag is required" >&5 if ${CC-cc} '-###' -xildon no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then if ${CC-cc} '-###' -xildoff no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then echo "$ac_t""no" 1>&6; @@ -4098,7 +4108,7 @@ if test "$opsys" = "sol2" && test "$OS_RELEASE" -ge 56; then echo $ac_n "checking for \"-z ignore\" linker flag""... $ac_c" 1>&6 -echo "configure:4102: checking for \"-z ignore\" linker flag" >&5 +echo "configure:4112: checking for \"-z ignore\" linker flag" >&5 case "`ld -h 2>&1`" in *-z\ ignore\|record* ) echo "$ac_t""yes" 1>&6 ld_switch_site="-z ignore $ld_switch_site" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-z ignore\" to \$ld_switch_site"; fi ;; @@ -4108,7 +4118,7 @@ echo "checking "for specified window system"" 1>&6 -echo "configure:4112: checking "for specified window system"" >&5 +echo "configure:4122: checking "for specified window system"" >&5 if test "$with_x11" != "no"; then test "$x_includes $x_libraries" != "NONE NONE" && \ @@ -4138,7 +4148,7 @@ # Uses ac_ vars as temps to allow command line to override cache and checks. # --without-x overrides everything else, but does not touch the cache. echo $ac_n "checking for X""... $ac_c" 1>&6 -echo "configure:4142: checking for X" >&5 +echo "configure:4152: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -4198,12 +4208,12 @@ # First, try using that file with no special directory specified. cat > conftest.$ac_ext <<EOF -#line 4202 "configure" +#line 4212 "configure" #include "confdefs.h" #include <$x_direct_test_include> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4207: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:4217: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4272,14 +4282,14 @@ ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <<EOF -#line 4276 "configure" +#line 4286 "configure" #include "confdefs.h" int main() { ${x_direct_test_function}() ; return 0; } EOF -if { (eval echo configure:4283: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4293: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* LIBS="$ac_save_LIBS" # We can link X programs with no special library path. @@ -4388,17 +4398,17 @@ case "`(uname -sr) 2>/dev/null`" in "SunOS 5"*) echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6 -echo "configure:4392: checking whether -R must be followed by a space" >&5 +echo "configure:4402: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <<EOF -#line 4395 "configure" +#line 4405 "configure" #include "confdefs.h" int main() { ; return 0; } EOF -if { (eval echo configure:4402: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4412: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -4414,14 +4424,14 @@ else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <<EOF -#line 4418 "configure" +#line 4428 "configure" #include "confdefs.h" int main() { ; return 0; } EOF -if { (eval echo configure:4425: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4435: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -4457,12 +4467,12 @@ else echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:4461: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:4471: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet " cat > conftest.$ac_ext <<EOF -#line 4466 "configure" +#line 4476 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4473,7 +4483,7 @@ dnet_ntoa() ; return 0; } EOF -if { (eval echo configure:4477: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4487: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4497,12 +4507,12 @@ if test $ac_cv_lib_dnet_dnet_ntoa = no; then echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6 -echo "configure:4501: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:4511: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet_stub " cat > conftest.$ac_ext <<EOF -#line 4506 "configure" +#line 4516 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4513,7 +4523,7 @@ dnet_ntoa() ; return 0; } EOF -if { (eval echo configure:4517: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4527: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4542,10 +4552,10 @@ # The nsl library prevents programs from opening the X display # on Irix 5.2, according to dickey@clark.net. echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 -echo "configure:4546: checking for gethostbyname" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4549 "configure" +echo "configure:4556: checking for gethostbyname" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4559 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char gethostbyname(); below. */ @@ -4568,7 +4578,7 @@ ; return 0; } EOF -if { (eval echo configure:4572: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4582: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -4589,12 +4599,12 @@ if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:4593: checking for gethostbyname in -lnsl" >&5 +echo "configure:4603: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` xe_check_libs=" -lnsl " cat > conftest.$ac_ext <<EOF -#line 4598 "configure" +#line 4608 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4605,7 +4615,7 @@ gethostbyname() ; return 0; } EOF -if { (eval echo configure:4609: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4619: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4635,10 +4645,10 @@ # -lsocket must be given before -lnsl if both are needed. # We assume that if connect needs -lnsl, so does gethostbyname. echo $ac_n "checking for connect""... $ac_c" 1>&6 -echo "configure:4639: checking for connect" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4642 "configure" +echo "configure:4649: checking for connect" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4652 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char connect(); below. */ @@ -4661,7 +4671,7 @@ ; return 0; } EOF -if { (eval echo configure:4665: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -4684,12 +4694,12 @@ xe_msg_checking="for connect in -lsocket" test -n "$X_EXTRA_LIBS" && xe_msg_checking="$xe_msg_checking using extra libs $X_EXTRA_LIBS" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:4688: checking "$xe_msg_checking"" >&5 +echo "configure:4698: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocket $X_EXTRA_LIBS" cat > conftest.$ac_ext <<EOF -#line 4693 "configure" +#line 4703 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4700,7 +4710,7 @@ connect() ; return 0; } EOF -if { (eval echo configure:4704: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4714: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4724,10 +4734,10 @@ # gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX. echo $ac_n "checking for remove""... $ac_c" 1>&6 -echo "configure:4728: checking for remove" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4731 "configure" +echo "configure:4738: checking for remove" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4741 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char remove(); below. */ @@ -4750,7 +4760,7 @@ ; return 0; } EOF -if { (eval echo configure:4754: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4764: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -4771,12 +4781,12 @@ if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:4775: checking for remove in -lposix" >&5 +echo "configure:4785: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` xe_check_libs=" -lposix " cat > conftest.$ac_ext <<EOF -#line 4780 "configure" +#line 4790 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4787,7 +4797,7 @@ remove() ; return 0; } EOF -if { (eval echo configure:4791: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4801: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4811,10 +4821,10 @@ # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay. echo $ac_n "checking for shmat""... $ac_c" 1>&6 -echo "configure:4815: checking for shmat" >&5 - -cat > conftest.$ac_ext <<EOF -#line 4818 "configure" +echo "configure:4825: checking for shmat" >&5 + +cat > conftest.$ac_ext <<EOF +#line 4828 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char shmat(); below. */ @@ -4837,7 +4847,7 @@ ; return 0; } EOF -if { (eval echo configure:4841: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4851: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -4858,12 +4868,12 @@ if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:4862: checking for shmat in -lipc" >&5 +echo "configure:4872: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` xe_check_libs=" -lipc " cat > conftest.$ac_ext <<EOF -#line 4867 "configure" +#line 4877 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4874,7 +4884,7 @@ shmat() ; return 0; } EOF -if { (eval echo configure:4878: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4888: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4908,12 +4918,12 @@ # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:4912: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:4922: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` xe_check_libs=" -lICE " cat > conftest.$ac_ext <<EOF -#line 4917 "configure" +#line 4927 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -4924,7 +4934,7 @@ IceConnectionNumber() ; return 0; } EOF -if { (eval echo configure:4928: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4938: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5057,7 +5067,7 @@ fi echo "checking for X defines extracted by xmkmf" 1>&6 -echo "configure:5061: checking for X defines extracted by xmkmf" >&5 +echo "configure:5071: checking for X defines extracted by xmkmf" >&5 rm -fr conftestdir if mkdir conftestdir; then cd conftestdir @@ -5089,15 +5099,15 @@ ac_safe=`echo "X11/Intrinsic.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Intrinsic.h""... $ac_c" 1>&6 -echo "configure:5093: checking for X11/Intrinsic.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5096 "configure" +echo "configure:5103: checking for X11/Intrinsic.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5106 "configure" #include "confdefs.h" #include <X11/Intrinsic.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5101: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5111: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5121,12 +5131,12 @@ echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6 -echo "configure:5125: checking for XOpenDisplay in -lX11" >&5 +echo "configure:5135: checking for XOpenDisplay in -lX11" >&5 ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <<EOF -#line 5130 "configure" +#line 5140 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5137,7 +5147,7 @@ XOpenDisplay() ; return 0; } EOF -if { (eval echo configure:5141: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5151: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5162,12 +5172,12 @@ xe_msg_checking="for XGetFontProperty in -lX11" test -n "-b i486-linuxaout" && xe_msg_checking="$xe_msg_checking using extra libs -b i486-linuxaout" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5166: checking "$xe_msg_checking"" >&5 +echo "configure:5176: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 -b i486-linuxaout" cat > conftest.$ac_ext <<EOF -#line 5171 "configure" +#line 5181 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5178,7 +5188,7 @@ XGetFontProperty() ; return 0; } EOF -if { (eval echo configure:5182: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5192: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5205,12 +5215,12 @@ echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6 -echo "configure:5209: checking for XShapeSelectInput in -lXext" >&5 +echo "configure:5219: checking for XShapeSelectInput in -lXext" >&5 ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'` xe_check_libs=" -lXext " cat > conftest.$ac_ext <<EOF -#line 5214 "configure" +#line 5224 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5221,7 +5231,7 @@ XShapeSelectInput() ; return 0; } EOF -if { (eval echo configure:5225: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5235: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5244,12 +5254,12 @@ echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6 -echo "configure:5248: checking for XtOpenDisplay in -lXt" >&5 +echo "configure:5258: checking for XtOpenDisplay in -lXt" >&5 ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lXt " cat > conftest.$ac_ext <<EOF -#line 5253 "configure" +#line 5263 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5260,7 +5270,7 @@ XtOpenDisplay() ; return 0; } EOF -if { (eval echo configure:5264: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5274: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5283,14 +5293,14 @@ echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6 -echo "configure:5287: checking the version of X11 being used" >&5 +echo "configure:5297: checking the version of X11 being used" >&5 cat > conftest.$ac_ext <<EOF -#line 5289 "configure" +#line 5299 "configure" #include "confdefs.h" #include <X11/Intrinsic.h> main(int c, char* v[]) { return c>1 ? XlibSpecificationRelease : 0; } EOF -if { (eval echo configure:5294: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5304: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; x11_release=$? else @@ -5314,15 +5324,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:5318: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5321 "configure" +echo "configure:5328: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5331 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5326: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5336: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5353,7 +5363,7 @@ echo $ac_n "checking for XFree86""... $ac_c" 1>&6 -echo "configure:5357: checking for XFree86" >&5 +echo "configure:5367: checking for XFree86" >&5 if test -d "/usr/X386/include" -o \ -f "/etc/XF86Config" -o \ -f "/etc/X11/XF86Config" -o \ @@ -5373,12 +5383,12 @@ test -z "$with_xmu" && { echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6 -echo "configure:5377: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 +echo "configure:5387: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'` xe_check_libs=" -lXmu " cat > conftest.$ac_ext <<EOF -#line 5382 "configure" +#line 5392 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5389,7 +5399,7 @@ XmuReadBitmapDataFromFile() ; return 0; } EOF -if { (eval echo configure:5393: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5403: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5428,19 +5438,19 @@ echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6 -echo "configure:5432: checking for main in -lXbsd" >&5 +echo "configure:5442: checking for main in -lXbsd" >&5 ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lXbsd " cat > conftest.$ac_ext <<EOF -#line 5437 "configure" +#line 5447 "configure" #include "confdefs.h" int main() { main() ; return 0; } EOF -if { (eval echo configure:5444: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5454: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5470,7 +5480,7 @@ fi for feature in tooltalk cde offix session \ menubars scrollbars toolbars dialogs xim xmu \ - tiff png jpeg gif xface xpm + imagick xface xpm do if eval "test -n \"\$with_${feature}\" -a \"\$with_${feature}\" != no" ; then echo "configure: warning: --with-$feature ignored: Not valid without X support" 1>&2 @@ -5494,7 +5504,7 @@ esac echo "checking for session-management option" 1>&6 -echo "configure:5498: checking for session-management option" >&5; +echo "configure:5508: checking for session-management option" >&5; if test "$with_session" != "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SESSION @@ -5509,15 +5519,15 @@ test -z "$with_xauth" && test "$window_system" = "none" && with_xauth=no test -z "$with_xauth" && { ac_safe=`echo "X11/Xauth.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xauth.h""... $ac_c" 1>&6 -echo "configure:5513: checking for X11/Xauth.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5516 "configure" +echo "configure:5523: checking for X11/Xauth.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5526 "configure" #include "confdefs.h" #include <X11/Xauth.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5521: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5531: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5540,12 +5550,12 @@ } test -z "$with_xauth" && { echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6 -echo "configure:5544: checking for XauGetAuthByAddr in -lXau" >&5 +echo "configure:5554: checking for XauGetAuthByAddr in -lXau" >&5 ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'` xe_check_libs=" -lXau " cat > conftest.$ac_ext <<EOF -#line 5549 "configure" +#line 5559 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5556,7 +5566,7 @@ XauGetAuthByAddr() ; return 0; } EOF -if { (eval echo configure:5560: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5570: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5596,76 +5606,7 @@ OFFIX_O="" -test -z "$with_offix" && { ac_safe=`echo "OffiX/DragAndDrop.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for OffiX/DragAndDrop.h""... $ac_c" 1>&6 -echo "configure:5602: checking for OffiX/DragAndDrop.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5605 "configure" -#include "confdefs.h" -#include <OffiX/DragAndDrop.h> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5610: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_offix=no -fi - } -test -z "$with_offix" && { -echo $ac_n "checking for DndInitialize in -lDnd""... $ac_c" 1>&6 -echo "configure:5633: checking for DndInitialize in -lDnd" >&5 -ac_lib_var=`echo Dnd'_'DndInitialize | sed 'y%./+-%__p_%'` - -xe_check_libs=" -lDnd " -cat > conftest.$ac_ext <<EOF -#line 5638 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char DndInitialize(); - -int main() { -DndInitialize() -; return 0; } -EOF -if { (eval echo configure:5649: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_offix=no -fi - - } +test "$window_system" != "x11" && with_offix=no test -z "$with_offix" && with_offix=yes if test "$with_offix" = "yes"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -5685,15 +5626,15 @@ for dir in "" "Tt/" "desktop/" ; do ac_safe=`echo "${dir}tt_c.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}tt_c.h""... $ac_c" 1>&6 -echo "configure:5689: checking for ${dir}tt_c.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5692 "configure" +echo "configure:5630: checking for ${dir}tt_c.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5633 "configure" #include "confdefs.h" #include <${dir}tt_c.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5697: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5638: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5722,12 +5663,12 @@ xe_msg_checking="for tt_message_create in -ltt" test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5726: checking "$xe_msg_checking"" >&5 +echo "configure:5667: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'` xe_check_libs=" -ltt $extra_libs" cat > conftest.$ac_ext <<EOF -#line 5731 "configure" +#line 5672 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5738,7 +5679,7 @@ tt_message_create() ; return 0; } EOF -if { (eval echo configure:5742: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5787,15 +5728,15 @@ test -z "$with_cde" && { ac_safe=`echo "Dt/Dt.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Dt/Dt.h""... $ac_c" 1>&6 -echo "configure:5791: checking for Dt/Dt.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5794 "configure" +echo "configure:5732: checking for Dt/Dt.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5735 "configure" #include "confdefs.h" #include <Dt/Dt.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5799: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5740: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5818,12 +5759,12 @@ } test -z "$with_cde" && { echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6 -echo "configure:5822: checking for DtDndDragStart in -lDtSvc" >&5 +echo "configure:5763: checking for DtDndDragStart in -lDtSvc" >&5 ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'` xe_check_libs=" -lDtSvc " cat > conftest.$ac_ext <<EOF -#line 5827 "configure" +#line 5768 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -5834,7 +5775,7 @@ DtDndDragStart() ; return 0; } EOF -if { (eval echo configure:5838: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5779: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5881,19 +5822,19 @@ echo $ac_n "checking for main in -lenergize""... $ac_c" 1>&6 -echo "configure:5885: checking for main in -lenergize" >&5 +echo "configure:5826: checking for main in -lenergize" >&5 ac_lib_var=`echo energize'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lenergize " cat > conftest.$ac_ext <<EOF -#line 5890 "configure" +#line 5831 "configure" #include "confdefs.h" int main() { main() ; return 0; } EOF -if { (eval echo configure:5897: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5838: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5925,19 +5866,19 @@ if test -z "$energize_version"; then echo $ac_n "checking for main in -lconn""... $ac_c" 1>&6 -echo "configure:5929: checking for main in -lconn" >&5 +echo "configure:5870: checking for main in -lconn" >&5 ac_lib_var=`echo conn'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lconn " cat > conftest.$ac_ext <<EOF -#line 5934 "configure" +#line 5875 "configure" #include "confdefs.h" int main() { main() ; return 0; } EOF -if { (eval echo configure:5941: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5882: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5970,15 +5911,15 @@ fi ac_safe=`echo "editorconn.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for editorconn.h""... $ac_c" 1>&6 -echo "configure:5974: checking for editorconn.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 5977 "configure" +echo "configure:5915: checking for editorconn.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 5918 "configure" #include "confdefs.h" #include <editorconn.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5982: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5923: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6022,27 +5963,12 @@ if test "$with_x11" = "yes"; then echo "checking for X11 graphics libraries" 1>&6 -echo "configure:6026: checking for X11 graphics libraries" >&5 - test -z "$with_gif" && with_gif=yes; - if test "$with_gif" = "yes"; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_GIF -EOF -cat >> confdefs.h <<\EOF -#define HAVE_GIF 1 -EOF -} - - extra_objs="$extra_objs dgif_lib.o gif_err.o gifalloc.o" && if test "$extra_verbose" = "yes"; then - echo " xemacs will be linked with \"dgif_lib.o gif_err.o gifalloc.o\"" - fi - fi - +echo "configure:5967: checking for X11 graphics libraries" >&5 echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6 -echo "configure:6043: checking for Xpm - no older than 3.4f" >&5 +echo "configure:5969: checking for Xpm - no older than 3.4f" >&5 xe_check_libs=-lXpm test -z "$with_xpm" && { cat > conftest.$ac_ext <<EOF -#line 6046 "configure" +#line 5972 "configure" #include "confdefs.h" #include <X11/xpm.h> int main(int c, char **v) { @@ -6052,7 +5978,7 @@ 0 ; } EOF -if { (eval echo configure:6056: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5982: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; xpm_status=$?; if test "$xpm_status" = "0"; then with_xpm=yes; else with_xpm=no; fi; @@ -6090,15 +6016,15 @@ test -z "$with_xface" && { ac_safe=`echo "compface.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for compface.h""... $ac_c" 1>&6 -echo "configure:6094: checking for compface.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6097 "configure" +echo "configure:6020: checking for compface.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6023 "configure" #include "confdefs.h" #include <compface.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6102: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6028: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6121,12 +6047,12 @@ } test -z "$with_xface" && { echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6 -echo "configure:6125: checking for UnGenFace in -lcompface" >&5 +echo "configure:6051: checking for UnGenFace in -lcompface" >&5 ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'` xe_check_libs=" -lcompface " cat > conftest.$ac_ext <<EOF -#line 6130 "configure" +#line 6056 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6137,7 +6063,7 @@ UnGenFace() ; return 0; } EOF -if { (eval echo configure:6141: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6067: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6171,100 +6097,17 @@ libs_x="-lcompface $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lcompface\" to \$libs_x"; fi fi - test -z "$with_jpeg" && { ac_safe=`echo "jpeglib.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for jpeglib.h""... $ac_c" 1>&6 -echo "configure:6177: checking for jpeglib.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6180 "configure" -#include "confdefs.h" -#include <jpeglib.h> + test -z "$with_imagick" && { ac_safe=`echo "magick.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for magick.h""... $ac_c" 1>&6 +echo "configure:6103: checking for magick.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6106 "configure" +#include "confdefs.h" +#include <magick.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6185: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_jpeg=no -fi - } - test -z "$with_jpeg" && { -echo $ac_n "checking for jpeg_destroy_decompress in -ljpeg""... $ac_c" 1>&6 -echo "configure:6208: checking for jpeg_destroy_decompress in -ljpeg" >&5 -ac_lib_var=`echo jpeg'_'jpeg_destroy_decompress | sed 'y%./+-%__p_%'` - -xe_check_libs=" -ljpeg " -cat > conftest.$ac_ext <<EOF -#line 6213 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char jpeg_destroy_decompress(); - -int main() { -jpeg_destroy_decompress() -; return 0; } -EOF -if { (eval echo configure:6224: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_jpeg=no -fi - - } - test -z "$with_jpeg" && with_jpeg=yes - if test "$with_jpeg" = "yes"; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_JPEG -EOF -cat >> confdefs.h <<\EOF -#define HAVE_JPEG 1 -EOF -} - - libs_x="-ljpeg $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-ljpeg\" to \$libs_x"; fi - fi - - test -z "$with_png" && { ac_safe=`echo "png.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for png.h""... $ac_c" 1>&6 -echo "configure:6260: checking for png.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6263 "configure" -#include "confdefs.h" -#include <png.h> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6268: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6111: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6282,78 +6125,28 @@ : else echo "$ac_t""no" 1>&6 -with_png=no +with_imagick=no fi } - test -z "$with_png" && { echo $ac_n "checking for pow""... $ac_c" 1>&6 -echo "configure:6290: checking for pow" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6293 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char pow(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char pow(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_pow) || defined (__stub___pow) -choke me -#else -pow(); -#endif - -; return 0; } -EOF -if { (eval echo configure:6316: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_pow=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_pow=no" -fi -rm -f conftest* - -if eval "test \"`echo '$ac_cv_func_'pow`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -with_png=no -fi - } - if test "$with_png" != "no"; then - for extra_libs in "" "-lz" "-lgz"; do - -xe_msg_checking="for png_read_image in -lpng" -test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" -echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6341: checking "$xe_msg_checking"" >&5 -ac_lib_var=`echo png'_'png_read_image | sed 'y%./+-%__p_%'` - -xe_check_libs=" -lpng $extra_libs" -cat > conftest.$ac_ext <<EOF -#line 6346 "configure" + test -z "$with_imagick" && { +echo $ac_n "checking for MogrifyImage in -lMagick""... $ac_c" 1>&6 +echo "configure:6134: checking for MogrifyImage in -lMagick" >&5 +ac_lib_var=`echo Magick'_'MogrifyImage | sed 'y%./+-%__p_%'` + +xe_check_libs=" -lMagick " +cat > conftest.$ac_ext <<EOF +#line 6139 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ -char png_read_image(); +char MogrifyImage(); int main() { -png_read_image() +MogrifyImage() ; return 0; } EOF -if { (eval echo configure:6357: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6150: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6367,94 +6160,34 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then echo "$ac_t""yes" 1>&6 - png_libs="-lpng $extra_libs" with_png=yes; break -else - echo "$ac_t""no" 1>&6 -: -fi - - - done - fi - test -z "$with_png" && with_png=no - if test "$with_png" = "yes"; then + : +else + echo "$ac_t""no" 1>&6 +with_imagick=no +fi + + } + test -z "$with_imagick" && with_imagick=yes + if test "$with_imagick" = "yes"; then { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_PNG -EOF -cat >> confdefs.h <<\EOF -#define HAVE_PNG 1 -EOF -} - - libs_x="$png_libs $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"$png_libs\" to \$libs_x"; fi - fi - - if test "$with_tiff" != no; then - for extra_libs in "" "-lz" "-lgz"; do - -xe_msg_checking="for TIFFReadScanline in -ltiff" -test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" -echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6399: checking "$xe_msg_checking"" >&5 -ac_lib_var=`echo tiff'_'TIFFReadScanline | sed 'y%./+-%__p_%'` - -xe_check_libs=" -ltiff $extra_libs" -cat > conftest.$ac_ext <<EOF -#line 6404 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char TIFFReadScanline(); - -int main() { -TIFFReadScanline() -; return 0; } -EOF -if { (eval echo configure:6415: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - tiff_libs="-ltiff $extra_libs" with_tiff=yes; break -else - echo "$ac_t""no" 1>&6 -: -fi - - - done - fi - test -z "$with_tiff" && with_tiff=no - if test "$with_tiff" = "yes"; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining HAVE_TIFF -EOF -cat >> confdefs.h <<\EOF -#define HAVE_TIFF 1 -EOF -} - - libs_x="$tiff_libs $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"$tiff_libs\" to \$libs_x"; fi + Defining HAVE_IMAGEMAGICK +EOF +cat >> confdefs.h <<\EOF +#define HAVE_IMAGEMAGICK 1 +EOF +} + + libs_x="-lMagick $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lMagick\" to \$libs_x"; fi fi echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6 -echo "configure:6453: checking for XawScrollbarSetThumb in -lXaw" >&5 +echo "configure:6186: checking for XawScrollbarSetThumb in -lXaw" >&5 ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'` xe_check_libs=" -lXaw " cat > conftest.$ac_ext <<EOF -#line 6458 "configure" +#line 6191 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6465,7 +6198,7 @@ XawScrollbarSetThumb() ; return 0; } EOF -if { (eval echo configure:6469: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6202: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6489,15 +6222,15 @@ if test "$have_xaw" = "yes"; then ac_safe=`echo "X11/Xaw/Reports.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xaw/Reports.h""... $ac_c" 1>&6 -echo "configure:6493: checking for X11/Xaw/Reports.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6496 "configure" +echo "configure:6226: checking for X11/Xaw/Reports.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6229 "configure" #include "confdefs.h" #include <X11/Xaw/Reports.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6501: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6234: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6523,15 +6256,15 @@ ac_safe=`echo "Xm/Xm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Xm/Xm.h""... $ac_c" 1>&6 -echo "configure:6527: checking for Xm/Xm.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6530 "configure" +echo "configure:6260: checking for Xm/Xm.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6263 "configure" #include "confdefs.h" #include <Xm/Xm.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6535: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6268: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6548,12 +6281,12 @@ echo "$ac_t""yes" 1>&6 echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6 -echo "configure:6552: checking for XmStringFree in -lXm" >&5 +echo "configure:6285: checking for XmStringFree in -lXm" >&5 ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <<EOF -#line 6557 "configure" +#line 6290 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6564,7 +6297,7 @@ XmStringFree() ; return 0; } EOF -if { (eval echo configure:6568: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6301: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6811,9 +6544,16 @@ test -z "$with_mule" && with_mule=no +if test "$with_mule" = "yes" && test ! -d "$srcdir/lisp/mule"; then + echo "Attempt to Build with Mule without Mule/Lisp" + echo "Please install the XEmacs/Mule tarball or" + echo "rerun configure with --with-mule=no" + exit 1 +fi + if test "$with_mule" = "yes" ; then echo "checking for Mule-related features" 1>&6 -echo "configure:6817: checking for Mule-related features" >&5 +echo "configure:6557: checking for Mule-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining MULE EOF @@ -6830,15 +6570,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:6834: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <<EOF -#line 6837 "configure" +echo "configure:6574: checking for $ac_hdr" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6577 "configure" #include "confdefs.h" #include <$ac_hdr> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6842: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6582: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6869,12 +6609,12 @@ echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6 -echo "configure:6873: checking for strerror in -lintl" >&5 +echo "configure:6613: checking for strerror in -lintl" >&5 ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'` xe_check_libs=" -lintl " cat > conftest.$ac_ext <<EOF -#line 6878 "configure" +#line 6618 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6885,7 +6625,7 @@ strerror() ; return 0; } EOF -if { (eval echo configure:6889: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6629: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6918,19 +6658,19 @@ echo "checking for Mule input methods" 1>&6 -echo "configure:6922: checking for Mule input methods" >&5 +echo "configure:6662: checking for Mule input methods" >&5 test -z "$with_xim" -a "$opsys" != "sol2" && with_xim=no case "$with_xim" in "" | "yes" ) echo "checking for XIM" 1>&6 -echo "configure:6926: checking for XIM" >&5 +echo "configure:6666: checking for XIM" >&5 echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6 -echo "configure:6929: checking for XmImMbLookupString in -lXm" >&5 +echo "configure:6669: checking for XmImMbLookupString in -lXm" >&5 ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <<EOF -#line 6934 "configure" +#line 6674 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -6941,7 +6681,7 @@ XmImMbLookupString() ; return 0; } EOF -if { (eval echo configure:6945: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6685: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7004,15 +6744,15 @@ fi else case "$with_xfs" in "yes" ) echo "checking for XFontSet" 1>&6 -echo "configure:7008: checking for XFontSet" >&5 +echo "configure:6748: checking for XFontSet" >&5 echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6 -echo "configure:7011: checking for XmbDrawString in -lX11" >&5 +echo "configure:6751: checking for XmbDrawString in -lX11" >&5 ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <<EOF -#line 7016 "configure" +#line 6756 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7023,7 +6763,7 @@ XmbDrawString() ; return 0; } EOF -if { (eval echo configure:7027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6767: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7062,15 +6802,15 @@ test "$with_wnn6" = "yes" && with_wnn=yes # wnn6 implies wnn support test -z "$with_wnn" && { ac_safe=`echo "wnn/jllib.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for wnn/jllib.h""... $ac_c" 1>&6 -echo "configure:7066: checking for wnn/jllib.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7069 "configure" +echo "configure:6806: checking for wnn/jllib.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6809 "configure" #include "confdefs.h" #include <wnn/jllib.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7074: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6814: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7095,10 +6835,10 @@ for ac_func in crypt do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7099: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7102 "configure" +echo "configure:6839: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 6842 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7121,7 +6861,7 @@ ; return 0; } EOF -if { (eval echo configure:7125: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6865: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7150,12 +6890,12 @@ test "$ac_cv_func_crypt" != "yes" && { echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6 -echo "configure:7154: checking for crypt in -lcrypt" >&5 +echo "configure:6894: checking for crypt in -lcrypt" >&5 ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'` xe_check_libs=" -lcrypt " cat > conftest.$ac_ext <<EOF -#line 7159 "configure" +#line 6899 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7166,7 +6906,7 @@ crypt() ; return 0; } EOF -if { (eval echo configure:7170: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6910: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7200,12 +6940,12 @@ fi test -z "$with_wnn" && { echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6 -echo "configure:7204: checking for jl_dic_list_e in -lwnn" >&5 +echo "configure:6944: checking for jl_dic_list_e in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <<EOF -#line 7209 "configure" +#line 6949 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7216,7 +6956,7 @@ jl_dic_list_e() ; return 0; } EOF -if { (eval echo configure:7220: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6960: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7253,12 +6993,12 @@ fi echo $ac_n "checking for jl_fi_dic_list in -lwnn""... $ac_c" 1>&6 -echo "configure:7257: checking for jl_fi_dic_list in -lwnn" >&5 +echo "configure:6997: checking for jl_fi_dic_list in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <<EOF -#line 7262 "configure" +#line 7002 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7269,7 +7009,7 @@ jl_fi_dic_list() ; return 0; } EOF -if { (eval echo configure:7273: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7013: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7301,15 +7041,15 @@ test -z "$with_canna" && { ac_safe=`echo "canna/RK.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for canna/RK.h""... $ac_c" 1>&6 -echo "configure:7305: checking for canna/RK.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7308 "configure" +echo "configure:7045: checking for canna/RK.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7048 "configure" #include "confdefs.h" #include <canna/RK.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7313: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7053: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7332,12 +7072,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6 -echo "configure:7336: checking for RkBgnBun in -lRKC" >&5 +echo "configure:7076: checking for RkBgnBun in -lRKC" >&5 ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'` xe_check_libs=" -lRKC " cat > conftest.$ac_ext <<EOF -#line 7341 "configure" +#line 7081 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7348,7 +7088,7 @@ RkBgnBun() ; return 0; } EOF -if { (eval echo configure:7352: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7092: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7371,12 +7111,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6 -echo "configure:7375: checking for jrKanjiControl in -lcanna" >&5 +echo "configure:7115: checking for jrKanjiControl in -lcanna" >&5 ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'` xe_check_libs=" -lcanna " cat > conftest.$ac_ext <<EOF -#line 7380 "configure" +#line 7120 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -7387,7 +7127,7 @@ jrKanjiControl() ; return 0; } EOF -if { (eval echo configure:7391: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7131: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7434,6 +7174,44 @@ if test "$need_motif" = "yes" ; then libs_x="-lXm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXm\" to \$libs_x"; fi + +echo $ac_n "checking for layout_object_getvalue in -li18n""... $ac_c" 1>&6 +echo "configure:7180: checking for layout_object_getvalue in -li18n" >&5 +ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'` + +xe_check_libs=" -li18n " +cat > conftest.$ac_ext <<EOF +#line 7185 "configure" +#include "confdefs.h" +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char layout_object_getvalue(); + +int main() { +layout_object_getvalue() +; return 0; } +EOF +if { (eval echo configure:7196: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + libs_x="-li18n $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-li18n\" to \$libs_x"; fi +else + echo "$ac_t""no" 1>&6 +fi + + if test "$add_runtime_path" = "yes" -a -n "$dash_r"; then ld_switch_site=`echo '' $ld_switch_site | sed -e 's:^ ::' -e "s/$dash_r[^ ]*//g"` @@ -7487,10 +7265,10 @@ for ac_func in acosh asinh atanh cbrt closedir dup2 eaccess fmod fpathconf frexp ftime gethostname getpagesize gettimeofday getcwd getwd logb lrand48 matherr mkdir mktime perror poll random rename res_init rint rmdir select setitimer setpgid setlocale setsid sigblock sighold sigprocmask strcasecmp strerror tzset ulimit usleep utimes waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7491: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7494 "configure" +echo "configure:7269: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7272 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7513,7 +7291,7 @@ ; return 0; } EOF -if { (eval echo configure:7517: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7295: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7550,10 +7328,10 @@ for ac_func in realpath do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7554: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7557 "configure" +echo "configure:7332: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7335 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7576,7 +7354,7 @@ ; return 0; } EOF -if { (eval echo configure:7580: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7358: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7609,16 +7387,16 @@ esac echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6 -echo "configure:7613: checking whether netdb declares h_errno" >&5 -cat > conftest.$ac_ext <<EOF -#line 7615 "configure" +echo "configure:7391: checking whether netdb declares h_errno" >&5 +cat > conftest.$ac_ext <<EOF +#line 7393 "configure" #include "confdefs.h" #include <netdb.h> int main() { return h_errno; ; return 0; } EOF -if { (eval echo configure:7622: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7400: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -7638,16 +7416,16 @@ rm -f conftest* echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6 -echo "configure:7642: checking for sigsetjmp" >&5 -cat > conftest.$ac_ext <<EOF -#line 7644 "configure" +echo "configure:7420: checking for sigsetjmp" >&5 +cat > conftest.$ac_ext <<EOF +#line 7422 "configure" #include "confdefs.h" #include <setjmp.h> int main() { sigjmp_buf bar; sigsetjmp (bar, 0); ; return 0; } EOF -if { (eval echo configure:7651: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7429: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -7667,11 +7445,11 @@ rm -f conftest* echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6 -echo "configure:7671: checking whether localtime caches TZ" >&5 +echo "configure:7449: checking whether localtime caches TZ" >&5 if test "$ac_cv_func_tzset" = "yes"; then cat > conftest.$ac_ext <<EOF -#line 7675 "configure" +#line 7453 "configure" #include "confdefs.h" #include <time.h> #if STDC_HEADERS @@ -7706,7 +7484,7 @@ exit (0); } EOF -if { (eval echo configure:7710: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7488: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then emacs_cv_localtime_cache=no else @@ -7735,9 +7513,9 @@ if test "$HAVE_TIMEVAL" = "yes"; then echo $ac_n "checking whether gettimeofday cannot accept two arguments""... $ac_c" 1>&6 -echo "configure:7739: checking whether gettimeofday cannot accept two arguments" >&5 -cat > conftest.$ac_ext <<EOF -#line 7741 "configure" +echo "configure:7517: checking whether gettimeofday cannot accept two arguments" >&5 +cat > conftest.$ac_ext <<EOF +#line 7519 "configure" #include "confdefs.h" #ifdef TIME_WITH_SYS_TIME @@ -7759,7 +7537,7 @@ ; return 0; } EOF -if { (eval echo configure:7763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7541: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""no" 1>&6 else @@ -7779,21 +7557,64 @@ rm -f conftest* fi +echo $ac_n "checking whether the timezone variable is already declared""... $ac_c" 1>&6 +echo "configure:7562: checking whether the timezone variable is already declared" >&5 +cat > conftest.$ac_ext <<EOF +#line 7564 "configure" +#include "confdefs.h" + +#ifdef TIME_WITH_SYS_TIME +#include <sys/time.h> +#include <time.h> +#else +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#else +#include <time.h> +#endif +#endif + +int main() { + + timezone = 0; + +; return 0; } +EOF +if { (eval echo configure:7584: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + echo "$ac_t""yes" 1>&6 + { test "$extra_verbose" = "yes" && cat << \EOF + Defining HAVE_TIMEZONE_DECL +EOF +cat >> confdefs.h <<\EOF +#define HAVE_TIMEZONE_DECL 1 +EOF +} + +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + echo $ac_n "checking for inline""... $ac_c" 1>&6 -echo "configure:7785: checking for inline" >&5 +echo "configure:7606: checking for inline" >&5 ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat > conftest.$ac_ext <<EOF -#line 7790 "configure" +#line 7611 "configure" #include "confdefs.h" int main() { } $ac_kw foo() { ; return 0; } EOF -if { (eval echo configure:7797: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7618: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_inline=$ac_kw; break else @@ -7843,17 +7664,17 @@ # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! echo $ac_n "checking for working alloca.h""... $ac_c" 1>&6 -echo "configure:7847: checking for working alloca.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7850 "configure" +echo "configure:7668: checking for working alloca.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7671 "configure" #include "confdefs.h" #include <alloca.h> int main() { char *p = alloca(2 * sizeof(int)); ; return 0; } EOF -if { (eval echo configure:7857: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7678: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_header_alloca_h=yes else @@ -7877,10 +7698,10 @@ fi echo $ac_n "checking for alloca""... $ac_c" 1>&6 -echo "configure:7881: checking for alloca" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7884 "configure" +echo "configure:7702: checking for alloca" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7705 "configure" #include "confdefs.h" #ifdef __GNUC__ @@ -7903,7 +7724,7 @@ char *p = (char *) alloca(1); ; return 0; } EOF -if { (eval echo configure:7907: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7728: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_func_alloca_works=yes else @@ -7942,10 +7763,10 @@ echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6 -echo "configure:7946: checking whether alloca needs Cray hooks" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7949 "configure" +echo "configure:7767: checking whether alloca needs Cray hooks" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7770 "configure" #include "confdefs.h" #if defined(CRAY) && ! defined(CRAY2) webecray @@ -7969,10 +7790,10 @@ if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7973: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 7976 "configure" +echo "configure:7794: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7797 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -7995,7 +7816,7 @@ ; return 0; } EOF -if { (eval echo configure:7999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7820: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8025,10 +7846,10 @@ fi echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6 -echo "configure:8029: checking stack direction for C alloca" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8032 "configure" +echo "configure:7850: checking stack direction for C alloca" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7853 "configure" #include "confdefs.h" find_stack_direction () { @@ -8047,7 +7868,7 @@ exit (find_stack_direction() < 0); } EOF -if { (eval echo configure:8051: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7872: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_stack_direction=1 else @@ -8075,15 +7896,15 @@ ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for vfork.h""... $ac_c" 1>&6 -echo "configure:8079: checking for vfork.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8082 "configure" +echo "configure:7900: checking for vfork.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7903 "configure" #include "confdefs.h" #include <vfork.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8087: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7908: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8111,10 +7932,10 @@ fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:8115: checking for working vfork" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8118 "configure" +echo "configure:7936: checking for working vfork" >&5 + +cat > conftest.$ac_ext <<EOF +#line 7939 "configure" #include "confdefs.h" /* Thanks to Paul Eggert for this test. */ #include <stdio.h> @@ -8209,7 +8030,7 @@ } } EOF -if { (eval echo configure:8213: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8034: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_vfork_works=yes else @@ -8234,10 +8055,10 @@ echo $ac_n "checking for working strcoll""... $ac_c" 1>&6 -echo "configure:8238: checking for working strcoll" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8241 "configure" +echo "configure:8059: checking for working strcoll" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8062 "configure" #include "confdefs.h" #include <string.h> main () @@ -8247,7 +8068,7 @@ strcoll ("123", "456") >= 0); } EOF -if { (eval echo configure:8251: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_strcoll_works=yes else @@ -8274,10 +8095,10 @@ for ac_func in getpgrp do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8278: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8281 "configure" +echo "configure:8099: checking for $ac_func" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8102 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func(); below. */ @@ -8300,7 +8121,7 @@ ; return 0; } EOF -if { (eval echo configure:8304: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8125: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8328,10 +8149,10 @@ done echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6 -echo "configure:8332: checking whether getpgrp takes no argument" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8335 "configure" +echo "configure:8153: checking whether getpgrp takes no argument" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8156 "configure" #include "confdefs.h" /* @@ -8386,7 +8207,7 @@ } EOF -if { (eval echo configure:8390: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8211: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_getpgrp_void=yes else @@ -8412,10 +8233,10 @@ echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:8416: checking for working mmap" >&5 +echo "configure:8237: checking for working mmap" >&5 case "$opsys" in ultrix* ) have_mmap=no ;; *) cat > conftest.$ac_ext <<EOF -#line 8419 "configure" +#line 8240 "configure" #include "confdefs.h" #include <stdio.h> #include <unistd.h> @@ -8448,7 +8269,7 @@ return 1; } EOF -if { (eval echo configure:8452: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8273: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then have_mmap=yes else @@ -8482,15 +8303,15 @@ ac_safe=`echo "termios.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termios.h""... $ac_c" 1>&6 -echo "configure:8486: checking for termios.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8489 "configure" +echo "configure:8307: checking for termios.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8310 "configure" #include "confdefs.h" #include <termios.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8494: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8315: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8533,15 +8354,15 @@ echo "$ac_t""no" 1>&6 ac_safe=`echo "termio.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termio.h""... $ac_c" 1>&6 -echo "configure:8537: checking for termio.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8540 "configure" +echo "configure:8358: checking for termio.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8361 "configure" #include "confdefs.h" #include <termio.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8545: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8366: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8573,10 +8394,10 @@ echo $ac_n "checking for socket""... $ac_c" 1>&6 -echo "configure:8577: checking for socket" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8580 "configure" +echo "configure:8398: checking for socket" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8401 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char socket(); below. */ @@ -8599,7 +8420,7 @@ ; return 0; } EOF -if { (eval echo configure:8603: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8424: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_socket=yes" else @@ -8614,15 +8435,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "netinet/in.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for netinet/in.h""... $ac_c" 1>&6 -echo "configure:8618: checking for netinet/in.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8621 "configure" +echo "configure:8439: checking for netinet/in.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8442 "configure" #include "confdefs.h" #include <netinet/in.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8626: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8447: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8639,15 +8460,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "arpa/inet.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for arpa/inet.h""... $ac_c" 1>&6 -echo "configure:8643: checking for arpa/inet.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8646 "configure" +echo "configure:8464: checking for arpa/inet.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8467 "configure" #include "confdefs.h" #include <arpa/inet.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8651: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8472: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8672,9 +8493,9 @@ } echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6 -echo "configure:8676: checking "for sun_len member in struct sockaddr_un"" >&5 +echo "configure:8497: checking "for sun_len member in struct sockaddr_un"" >&5 cat > conftest.$ac_ext <<EOF -#line 8678 "configure" +#line 8499 "configure" #include "confdefs.h" #include <sys/types.h> @@ -8685,7 +8506,7 @@ static struct sockaddr_un x; x.sun_len = 1; ; return 0; } EOF -if { (eval echo configure:8689: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8510: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SOCKADDR_SUN_LEN @@ -8716,10 +8537,10 @@ echo $ac_n "checking for msgget""... $ac_c" 1>&6 -echo "configure:8720: checking for msgget" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8723 "configure" +echo "configure:8541: checking for msgget" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8544 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char msgget(); below. */ @@ -8742,7 +8563,7 @@ ; return 0; } EOF -if { (eval echo configure:8746: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8567: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_msgget=yes" else @@ -8757,15 +8578,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/ipc.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/ipc.h""... $ac_c" 1>&6 -echo "configure:8761: checking for sys/ipc.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8764 "configure" +echo "configure:8582: checking for sys/ipc.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8585 "configure" #include "confdefs.h" #include <sys/ipc.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8769: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8590: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8782,15 +8603,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/msg.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/msg.h""... $ac_c" 1>&6 -echo "configure:8786: checking for sys/msg.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8789 "configure" +echo "configure:8607: checking for sys/msg.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8610 "configure" #include "confdefs.h" #include <sys/msg.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8794: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8615: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8828,15 +8649,15 @@ ac_safe=`echo "dirent.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for dirent.h""... $ac_c" 1>&6 -echo "configure:8832: checking for dirent.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8835 "configure" +echo "configure:8653: checking for dirent.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8656 "configure" #include "confdefs.h" #include <dirent.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8840: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8661: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8863,15 +8684,15 @@ echo "$ac_t""no" 1>&6 ac_safe=`echo "sys/dir.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/dir.h""... $ac_c" 1>&6 -echo "configure:8867: checking for sys/dir.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8870 "configure" +echo "configure:8688: checking for sys/dir.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8691 "configure" #include "confdefs.h" #include <sys/dir.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8875: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8696: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8904,15 +8725,15 @@ ac_safe=`echo "nlist.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for nlist.h""... $ac_c" 1>&6 -echo "configure:8908: checking for nlist.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8911 "configure" +echo "configure:8729: checking for nlist.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8732 "configure" #include "confdefs.h" #include <nlist.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8916: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8737: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8940,20 +8761,9 @@ fi -for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp" ; do - if test -r $f; then { test "$extra_verbose" = "yes" && cat << EOF - Defining AIX_SMT_EXP = "-bI:$f" -EOF -cat >> confdefs.h <<EOF -#define AIX_SMT_EXP "-bI:$f" -EOF -} - break; fi -done - echo "checking "for sound support"" 1>&6 -echo "configure:8957: checking "for sound support"" >&5 +echo "configure:8767: checking "for sound support"" >&5 case "$with_sound" in native | both ) with_native_sound=yes;; nas | no ) with_native_sound=no;; @@ -8964,15 +8774,15 @@ if test -n "$native_sound_lib"; then ac_safe=`echo "multimedia/audio_device.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for multimedia/audio_device.h""... $ac_c" 1>&6 -echo "configure:8968: checking for multimedia/audio_device.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 8971 "configure" +echo "configure:8778: checking for multimedia/audio_device.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8781 "configure" #include "confdefs.h" #include <multimedia/audio_device.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8976: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8786: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9020,12 +8830,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6 -echo "configure:9024: checking for ALopenport in -laudio" >&5 +echo "configure:8834: checking for ALopenport in -laudio" >&5 ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'` xe_check_libs=" -laudio " cat > conftest.$ac_ext <<EOF -#line 9029 "configure" +#line 8839 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9036,7 +8846,7 @@ ALopenport() ; return 0; } EOF -if { (eval echo configure:9040: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8850: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9067,12 +8877,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6 -echo "configure:9071: checking for AOpenAudio in -lAlib" >&5 +echo "configure:8881: checking for AOpenAudio in -lAlib" >&5 ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'` xe_check_libs=" -lAlib " cat > conftest.$ac_ext <<EOF -#line 9076 "configure" +#line 8886 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9083,7 +8893,7 @@ AOpenAudio() ; return 0; } EOF -if { (eval echo configure:9087: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8897: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9121,15 +8931,15 @@ for dir in "machine" "sys" "linux"; do ac_safe=`echo "${dir}/soundcard.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}/soundcard.h""... $ac_c" 1>&6 -echo "configure:9125: checking for ${dir}/soundcard.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9128 "configure" +echo "configure:8935: checking for ${dir}/soundcard.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 8938 "configure" #include "confdefs.h" #include <${dir}/soundcard.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9133: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8943: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9199,7 +9009,7 @@ fi libs_x="-laudio $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-laudio\" to \$libs_x"; fi cat > conftest.$ac_ext <<EOF -#line 9203 "configure" +#line 9013 "configure" #include "confdefs.h" #include <audio/Xtutil.h> EOF @@ -9226,7 +9036,7 @@ if test "$with_tty" = "yes" ; then echo "checking for TTY-related features" 1>&6 -echo "configure:9230: checking for TTY-related features" >&5 +echo "configure:9040: checking for TTY-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_TTY EOF @@ -9242,12 +9052,12 @@ if test -z "$with_ncurses"; then echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6 -echo "configure:9246: checking for tgetent in -lncurses" >&5 +echo "configure:9056: checking for tgetent in -lncurses" >&5 ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lncurses " cat > conftest.$ac_ext <<EOF -#line 9251 "configure" +#line 9061 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9258,7 +9068,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9262: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9291,15 +9101,15 @@ ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:9295: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9298 "configure" +echo "configure:9105: checking for ncurses/curses.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9108 "configure" #include "confdefs.h" #include <ncurses/curses.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9303: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9113: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9321,15 +9131,15 @@ ac_safe=`echo "ncurses/term.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/term.h""... $ac_c" 1>&6 -echo "configure:9325: checking for ncurses/term.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9328 "configure" +echo "configure:9135: checking for ncurses/term.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9138 "configure" #include "confdefs.h" #include <ncurses/term.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9333: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9143: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9359,15 +9169,15 @@ c_switch_site="$c_switch_site -I/usr/include/ncurses" ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:9363: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9366 "configure" +echo "configure:9173: checking for ncurses/curses.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9176 "configure" #include "confdefs.h" #include <ncurses/curses.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9371: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9181: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9402,12 +9212,12 @@ for lib in curses termlib termcap; do echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6 -echo "configure:9406: checking for tgetent in -l$lib" >&5 +echo "configure:9216: checking for tgetent in -l$lib" >&5 ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -l$lib " cat > conftest.$ac_ext <<EOF -#line 9411 "configure" +#line 9221 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9418,7 +9228,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9422: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9449,12 +9259,12 @@ else echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6 -echo "configure:9453: checking for tgetent in -lcurses" >&5 +echo "configure:9263: checking for tgetent in -lcurses" >&5 ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lcurses " cat > conftest.$ac_ext <<EOF -#line 9458 "configure" +#line 9268 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9465,7 +9275,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9469: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9279: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9483,12 +9293,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6 -echo "configure:9487: checking for tgetent in -ltermcap" >&5 +echo "configure:9297: checking for tgetent in -ltermcap" >&5 ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -ltermcap " cat > conftest.$ac_ext <<EOF -#line 9492 "configure" +#line 9302 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9499,7 +9309,7 @@ tgetent() ; return 0; } EOF -if { (eval echo configure:9503: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9313: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9547,15 +9357,15 @@ test -z "$with_gpm" && { ac_safe=`echo "gpm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for gpm.h""... $ac_c" 1>&6 -echo "configure:9551: checking for gpm.h" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9554 "configure" +echo "configure:9361: checking for gpm.h" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9364 "configure" #include "confdefs.h" #include <gpm.h> EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9559: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9369: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9578,12 +9388,12 @@ } test -z "$with_gpm" && { echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6 -echo "configure:9582: checking for Gpm_Open in -lgpm" >&5 +echo "configure:9392: checking for Gpm_Open in -lgpm" >&5 ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgpm " cat > conftest.$ac_ext <<EOF -#line 9587 "configure" +#line 9397 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9594,7 +9404,7 @@ Gpm_Open() ; return 0; } EOF -if { (eval echo configure:9598: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9643,17 +9453,17 @@ echo "checking for database support" 1>&6 -echo "configure:9647: checking for database support" >&5 +echo "configure:9457: checking for database support" >&5 if test "$with_database_gnudbm" != "no"; then echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6 -echo "configure:9652: checking for dbm_open in -lgdbm" >&5 +echo "configure:9462: checking for dbm_open in -lgdbm" >&5 ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdbm " cat > conftest.$ac_ext <<EOF -#line 9657 "configure" +#line 9467 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9664,7 +9474,7 @@ dbm_open() ; return 0; } EOF -if { (eval echo configure:9668: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9478: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9686,10 +9496,10 @@ if test "$with_database_gnudbm" != "yes"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9690: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9693 "configure" +echo "configure:9500: checking for dbm_open" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9503 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char dbm_open(); below. */ @@ -9712,7 +9522,7 @@ ; return 0; } EOF -if { (eval echo configure:9716: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9526: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9748,10 +9558,10 @@ if test "$with_database_dbm" != "no"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9752: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9755 "configure" +echo "configure:9562: checking for dbm_open" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9565 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char dbm_open(); below. */ @@ -9774,7 +9584,7 @@ ; return 0; } EOF -if { (eval echo configure:9778: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9588: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9795,12 +9605,12 @@ if test "$need_libdbm" != "no"; then echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6 -echo "configure:9799: checking for dbm_open in -ldbm" >&5 +echo "configure:9609: checking for dbm_open in -ldbm" >&5 ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -ldbm " cat > conftest.$ac_ext <<EOF -#line 9804 "configure" +#line 9614 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9811,7 +9621,7 @@ dbm_open() ; return 0; } EOF -if { (eval echo configure:9815: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9625: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9848,10 +9658,10 @@ if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for dbopen""... $ac_c" 1>&6 -echo "configure:9852: checking for dbopen" >&5 - -cat > conftest.$ac_ext <<EOF -#line 9855 "configure" +echo "configure:9662: checking for dbopen" >&5 + +cat > conftest.$ac_ext <<EOF +#line 9665 "configure" #include "confdefs.h" /* System header to define __stub macros and hopefully few prototypes, which can conflict with char dbopen(); below. */ @@ -9874,7 +9684,7 @@ ; return 0; } EOF -if { (eval echo configure:9878: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9688: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbopen=yes" else @@ -9895,12 +9705,12 @@ if test "$need_libdb" != "no"; then echo $ac_n "checking for dbopen in -ldb""... $ac_c" 1>&6 -echo "configure:9899: checking for dbopen in -ldb" >&5 +echo "configure:9709: checking for dbopen in -ldb" >&5 ac_lib_var=`echo db'_'dbopen | sed 'y%./+-%__p_%'` xe_check_libs=" -ldb " cat > conftest.$ac_ext <<EOF -#line 9904 "configure" +#line 9714 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -9911,7 +9721,7 @@ dbopen() ; return 0; } EOF -if { (eval echo configure:9915: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9725: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9935,7 +9745,7 @@ if test "$with_database_berkdb" = "yes"; then for path in "db/db.h" "db.h"; do cat > conftest.$ac_ext <<EOF -#line 9939 "configure" +#line 9749 "configure" #include "confdefs.h" #ifdef HAVE_INTTYPES_H #define __BIT_TYPES_DEFINED__ @@ -9948,17 +9758,12 @@ #endif #endif #include <$path> -#ifdef DB_VERSION_MAJOR -#if DB_VERSION_MAJOR > 1 -choke me; -#endif -#endif int main() { ; return 0; } EOF -if { (eval echo configure:9962: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:9767: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* db_h_path="$path"; break else @@ -10010,12 +9815,12 @@ if test "$with_socks" = "yes"; then echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6 -echo "configure:10014: checking for SOCKSinit in -lsocks" >&5 +echo "configure:9819: checking for SOCKSinit in -lsocks" >&5 ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocks " cat > conftest.$ac_ext <<EOF -#line 10019 "configure" +#line 9824 "configure" #include "confdefs.h" /* Override any gcc2 internal prototype to avoid an error. */ /* We use char because int might match the return type of a gcc2 @@ -10026,7 +9831,7 @@ SOCKSinit() ; return 0; } EOF -if { (eval echo configure:10030: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9835: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10234,6 +10039,7 @@ + RECURSIVE_MAKE="\$(MAKE) \$(MFLAGS) CC='\$(CC)' CFLAGS='\$(CFLAGS)' LDFLAGS='\$(LDFLAGS)' CPPFLAGS='\$(CPPFLAGS)'" @@ -10256,6 +10062,11 @@ } + +T="" +for W in $ac_configure_args; do if test -z "$T"; then T="$W"; else T="$T $W"; fi; done +ac_configure_args="$T" + { test "$extra_verbose" = "yes" && cat << EOF Defining EMACS_CONFIGURATION = "$canonical" EOF @@ -10265,10 +10076,10 @@ } { test "$extra_verbose" = "yes" && cat << EOF - Defining EMACS_CONFIG_OPTIONS = "${ac_configure_args}" + Defining EMACS_CONFIG_OPTIONS = "$ac_configure_args" EOF cat >> confdefs.h <<EOF -#define EMACS_CONFIG_OPTIONS "${ac_configure_args}" +#define EMACS_CONFIG_OPTIONS "$ac_configure_args" EOF } @@ -10517,7 +10328,6 @@ echo " No Xmu; substituting equivalent routines." fi -test "$with_gif" = yes && echo " Compiling in support for GIF image conversion." if test "$with_xpm" = yes; then echo " Compiling in support for XPM images." elif test "$with_x11" = yes; then @@ -10528,9 +10338,7 @@ echo " --------------------------------------------------------------------" fi test "$with_xface" = yes && echo " Compiling in support for X-Face message headers." -test "$with_jpeg" = yes && echo " Compiling in support for JPEG image conversion." -test "$with_png" = yes && echo " Compiling in support for PNG image conversion." -test "$with_tiff" = yes && echo " Compiling in support for TIFF image conversion (not implemented)." +test "$with_imagick" = yes && echo " Compiling in support for ImageMagick image conversion." case "$with_sound" in nas ) echo " Compiling in network sound (NAS) support." ;; @@ -10589,7 +10397,7 @@ test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" echo " The \`Info-default-directory-list' will be initialized from:" -echo " INFOPATH=\"`echo $infopath`\"" +echo " INFOPATH=\"$infopath\"" test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$debug" = yes && echo " Compiling in extra code for debugging." test "$memory_usage_stats" = yes && echo " Compiling in code for checking XEmacs memory usage." @@ -10705,9 +10513,9 @@ s%@blddir@%$blddir%g s%@CC@%$CC%g s%@CPP@%$CPP%g +s%@start_flags@%$start_flags%g s%@ld_switch_shared@%$ld_switch_shared%g s%@start_files@%$start_files%g -s%@start_flags@%$start_flags%g s%@ld@%$ld%g s%@lib_gcc@%$lib_gcc%g s%@RANLIB@%$RANLIB%g @@ -10735,6 +10543,7 @@ s%@statedir@%$statedir%g s%@infodir_user_defined@%$infodir_user_defined%g s%@infopath@%$infopath%g +s%@infopath_user_defined@%$infopath_user_defined%g s%@lispdir@%$lispdir%g s%@lispdir_user_defined@%$lispdir_user_defined%g s%@sitelispdir@%$sitelispdir%g
--- a/configure.in Mon Aug 13 10:02:48 2007 +0200 +++ b/configure.in Mon Aug 13 10:03:52 2007 +0200 @@ -1,4 +1,4 @@ -dnl Define our own header notice with own copyrights +dnl Define our own header notice with own copyright define([AC_INIT_NOTICE], [#### Configuration script for XEmacs. Largely divergent from FSF. #### Guess values for system-dependent variables and create Makefiles. @@ -358,7 +358,6 @@ dnl core file went\". At least we should get some useful output ... use_assertions="yes" dnl the following is set to yes or no later. -with_gif="" dnl the following is set to yes or no later. with_toolbars="" with_tty="" @@ -425,7 +424,7 @@ --with-toolbars=no Don't compile with any toolbar support. --with-session=no Compile without realized leader window which will keep the WM_COMMAND property. Required for proper - session-management. (ON by default for testing) + session-management. --with-menubars=TYPE Use TYPE menubars (lucid, motif, or no). The Lucid widgets emulate Motif (mostly) but are faster. *WARNING* The Motif menubar is currently broken. @@ -447,13 +446,11 @@ --with-xface (*) Compile with support for X-Face mail header conversion. Requires the compface library. Get it from the XEmacs FTP site. ---with-jpeg (*) Compile with support for JPEG image conversion. - Requires libjpeg from the Independent JPEG Group. +--with-imagick (*) Compile with support for ImageMagick image conversion. + Requires ImageMagick from wizards.dupont.com and + libraries for whatever image types you wish to have + supported. Get it from the XEmacs FTP site. ---with-png (*) Compile with support for PNG image conversion. - Requires libpng. Get it from the XEmacs FTP site. ---with-tiff (*) Compile with support for TIFF image conversion - (not yet implemented). TTY options: @@ -680,12 +677,9 @@ with_cde | \ with_offix | \ with_gpm | \ - with_gif | \ with_xpm | \ with_xface | \ - with_jpeg | \ - with_png | \ - with_tiff | \ + with_imagick | \ with_session | \ with_xmu | \ with_quantify | \ @@ -1046,7 +1040,7 @@ dnl have stuck the source on a read-only partition. Instead we dnl create it as an actual directory later on if it does not already dnl exist. -for dir in lisp etc man info site-lisp; do +for dir in lisp etc man info; do if test ! -d "$dir" ; then echo Making symbolic link to "$srcdir/$dir" ${LN_S} "$srcdir/$dir" "$dir" @@ -1467,7 +1461,7 @@ dnl Iris 4D mips-sgi-irix3.* ) opsys=irix3-3 ;; mips-sgi-irix4.* ) opsys=irix4-0 ;; - mips-sgi-irix6* ) opsys=irix6-0 NON_GNU_CC="cc -Olimit 2000" ;; + mips-sgi-irix6* ) opsys=irix6-0 ;; mips-sgi-irix5.1* ) opsys=irix5-1 ;; mips-sgi-irix5.2* ) opsys=irix5-2 ;; mips-sgi-irix5.* ) opsys=irix5-3 ;; @@ -1647,6 +1641,9 @@ esac fi +dnl Use xlc by default on AIX +case "$opsys" in aix*) NON_GNU_CC=xlc ;; esac + stack_trace_eye_catcher=`echo xemacs_${version}_${canonical} | sed 'y/.-/__/'` AC_DEFINE_UNQUOTED(STACK_TRACE_EYE_CATCHER, $stack_trace_eye_catcher) @@ -1884,8 +1881,10 @@ sol2 ) CFLAGS="-v -xO4" ;; sunos4* ) CFLAGS="-xO2";; esac + elif test "$CC" = "xlc"; then + CFLAGS="-O3 -qstrict -qnoansialias -qlibansi -qinfo -qro -qmaxmem=20000" else - CFLAGS="-O" # The only POSIX-approved flag + CFLAGS="-O" ;dnl The only POSIX-approved flag fi fi @@ -1895,7 +1894,7 @@ [[$1_tmp]="$[$1]"; [$1]="" for arg in $[$1_tmp]; do case "$arg" in - -L* | -l* | -R* | -u* | -Wl* | -f* ) [$1]="$[$1] $arg" ;; + -L* | -l* | -R* | -u* | -Wl* | -f* | -B*) [$1]="$[$1] $arg" ;; -Xlinker* ) ;; * ) [$1]="$[$1] -Xlinker $arg" ;; esac @@ -1930,10 +1929,25 @@ fi dnl Feed s&m crud to src/Makefile + +if test "$unexec" = "unexaix.o"; then +dnl AIX needs various hacks to make static linking work. +dnl This can go away if we ever figure out how to get dynamic linking on AIX. + start_flags="-Wl,-bnso,-bnodelcsect" + test "$GCC" = "yes" && start_flags="-B/bin/ ${aixflags}" + for f in "/lib/syscalls.exp" "$srcdir/src/m/ibmrs6000.inp"; do + if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; fi + done + for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp"; do + if test -r "$f"; then start_flags="${start_flags},-bI:${f}"; break; fi + done +elif test -n "$ld_text_start_addr"; then + start_flags="-T $ld_text_start_addr -e __start" +fi +AC_SUBST(start_flags) + AC_SUBST(ld_switch_shared) AC_SUBST(start_files) -test -n "$ld_text_start_addr" && start_flags="-T $ld_text_start_addr -e __start" -AC_SUBST(start_flags) if test "$ordinary_link" = "no" -a "$GCC" = "yes"; then test -z "$linker" && linker='$(CC) -nostdlib' test -z "$lib_gcc" && lib_gcc='`$(CC) -print-libgcc-file-name`' @@ -2190,7 +2204,7 @@ AC_SYS_LONG_FILE_NAMES dnl -lm is required by LISP_FLOAT_TYPE, among other things -AC_CHECK_LIB(m, sqrt) +AC_CHECK_LIB(m, sin) dnl Floating operation support is now unconditional AC_DEFINE(LISP_FLOAT_TYPE) @@ -2421,7 +2435,7 @@ fi for feature in tooltalk cde offix session \ menubars scrollbars toolbars dialogs xim xmu \ - tiff png jpeg gif xface xpm + imagick xface xpm do if eval "test -n \"\$with_${feature}\" -a \"\$with_${feature}\" != no" ; then AC_MSG_WARN([--with-$feature ignored: Not valid without X support]) @@ -2463,10 +2477,10 @@ fi AC_SUBST(libs_xauth) -dnl Autodetect OffiX +dnl Always compile OffiX except --without-offix is given or no +dnl x11 support is compiled in OFFIX_O="" -test -z "$with_offix" && { AC_CHECK_HEADER(OffiX/DragAndDrop.h, , with_offix=no) } -test -z "$with_offix" && { AC_CHECK_LIB(Dnd, DndInitialize, [:] , with_offix=no) } +test "$window_system" != "x11" && with_offix=no test -z "$with_offix" && with_offix=yes if test "$with_offix" = "yes"; then AC_DEFINE(HAVE_OFFIX_DND) @@ -2537,13 +2551,6 @@ if test "$with_x11" = "yes"; then AC_CHECKING(for X11 graphics libraries) - dnl Built-in GIF support defaults to yes - test -z "$with_gif" && with_gif=yes; - if test "$with_gif" = "yes"; then - AC_DEFINE(HAVE_GIF) - XE_ADD_OBJS(dgif_lib.o gif_err.o gifalloc.o) - fi - dnl Autodetect Xpm AC_MSG_CHECKING(for Xpm - no older than 3.4f) xe_check_libs=-lXpm @@ -2583,41 +2590,13 @@ XE_PREPEND(-lcompface, libs_x) fi - dnl autodetect JPEG - test -z "$with_jpeg" && { AC_CHECK_HEADER(jpeglib.h, ,with_jpeg=no) } - test -z "$with_jpeg" && { AC_CHECK_LIB(jpeg, jpeg_destroy_decompress,[:],with_jpeg=no) } - test -z "$with_jpeg" && with_jpeg=yes - if test "$with_jpeg" = "yes"; then - AC_DEFINE(HAVE_JPEG) - XE_PREPEND(-ljpeg, libs_x) - fi - - dnl autodetect PNG - test -z "$with_png" && { AC_CHECK_HEADER(png.h, , with_png=no) } - test -z "$with_png" && { AC_CHECK_FUNC(pow, , with_png=no) } - if test "$with_png" != "no"; then - for extra_libs in "" "-lz" "-lgz"; do - AC_CHECK_LIB(png, png_read_image, - png_libs="-lpng $extra_libs" with_png=yes; break,[:],$extra_libs) - done - fi - test -z "$with_png" && with_png=no - if test "$with_png" = "yes"; then - AC_DEFINE(HAVE_PNG) - XE_PREPEND($png_libs, libs_x) - fi - - dnl autodetect TIFF - if test "$with_tiff" != no; then - for extra_libs in "" "-lz" "-lgz"; do - AC_CHECK_LIB(tiff, TIFFReadScanline, - tiff_libs="-ltiff $extra_libs" with_tiff=yes; break, [:], $extra_libs) - done - fi - test -z "$with_tiff" && with_tiff=no - if test "$with_tiff" = "yes"; then - AC_DEFINE(HAVE_TIFF) - XE_PREPEND($tiff_libs, libs_x) + dnl autodetect ImageMagick + test -z "$with_imagick" && { AC_CHECK_HEADER(magick.h, ,with_imagick=no) } + test -z "$with_imagick" && { AC_CHECK_LIB(Magick, MogrifyImage,[:],with_imagick=no) } + test -z "$with_imagick" && with_imagick=yes + if test "$with_imagick" = "yes"; then + AC_DEFINE(HAVE_IMAGEMAGICK) + XE_PREPEND(-lMagick, libs_x) fi dnl Autodetect -lXaw @@ -2714,6 +2693,13 @@ test -z "$with_mule" && with_mule=no +if test "$with_mule" = "yes" && test ! -d "$srcdir/lisp/mule"; then + echo "Attempt to Build with Mule without Mule/Lisp" + echo "Please install the XEmacs/Mule tarball or" + echo "rerun configure with --with-mule=no" + exit 1 +fi + if test "$with_mule" = "yes" ; then AC_CHECKING(for Mule-related features) AC_DEFINE(MULE) @@ -2799,6 +2785,8 @@ dnl At this point, we know whether we need the motif lib or not. if test "$need_motif" = "yes" ; then XE_PREPEND(-lXm, libs_x) + dnl AIX needs the following library for use with Motif + AC_CHECK_LIB(i18n, layout_object_getvalue, [XE_PREPEND(-li18n, libs_x)]) XE_COMPUTE_RUNPATH() fi @@ -2902,6 +2890,27 @@ AC_DEFINE(GETTIMEOFDAY_ONE_ARGUMENT)]) fi +AC_MSG_CHECKING(whether the timezone variable is already declared) +AC_TRY_LINK([ +#ifdef TIME_WITH_SYS_TIME +#include <sys/time.h> +#include <time.h> +#else +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#else +#include <time.h> +#endif +#endif + ], + [ + timezone = 0; +], + [AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_TIMEZONE_DECL)], + [AC_MSG_RESULT(no)]) + + AC_C_INLINE if test "$ac_cv_c_inline" != "no"; then @@ -3013,11 +3022,6 @@ dnl Check for nlist.h AC_CHECK_HEADER(nlist.h, AC_DEFINE(NLIST_STRUCT), ) -dnl AIX export list -for f in "/usr/lpp/X11/bin/smt.exp" "/usr/bin/X11/smt.exp" ; do - if test -r $f; then AC_DEFINE_UNQUOTED(AIX_SMT_EXP, "-bI:$f") break; fi -done - dnl Check for sound of various sorts. dnl Autodetect native sound @@ -3251,11 +3255,6 @@ #endif #endif #include <$path> -#ifdef DB_VERSION_MAJOR -#if DB_VERSION_MAJOR > 1 -choke me; -#endif -#endif ],[], db_h_path="$path"; break) done test -z "$db_h_path" && with_database_berkdb=no @@ -3382,6 +3381,7 @@ AC_SUBST(infodir) AC_SUBST(infodir_user_defined) AC_SUBST(infopath) +AC_SUBST(infopath_user_defined) AC_SUBST(lispdir) AC_SUBST(lispdir_user_defined) AC_SUBST(sitelispdir) @@ -3431,8 +3431,9 @@ package_path=`echo $package_path | sed 'y/ /:/'` AC_DEFINE_UNQUOTED(PACKAGE_PATH, "$package_path") +XE_SPACE(ac_configure_args, $ac_configure_args) AC_DEFINE_UNQUOTED(EMACS_CONFIGURATION, "$canonical") -AC_DEFINE_UNQUOTED(EMACS_CONFIG_OPTIONS, "${ac_configure_args}") +AC_DEFINE_UNQUOTED(EMACS_CONFIG_OPTIONS, "$ac_configure_args") AC_DEFINE_UNQUOTED(config_machfile, "$machfile") AC_DEFINE_UNQUOTED(config_opsysfile, "$opsysfile") @@ -3522,7 +3523,6 @@ echo " No Xmu; substituting equivalent routines." fi -test "$with_gif" = yes && echo " Compiling in support for GIF image conversion." if test "$with_xpm" = yes; then echo " Compiling in support for XPM images." elif test "$with_x11" = yes; then @@ -3533,9 +3533,7 @@ echo " --------------------------------------------------------------------" fi test "$with_xface" = yes && echo " Compiling in support for X-Face message headers." -test "$with_jpeg" = yes && echo " Compiling in support for JPEG image conversion." -test "$with_png" = yes && echo " Compiling in support for PNG image conversion." -test "$with_tiff" = yes && echo " Compiling in support for TIFF image conversion (not implemented)." +test "$with_imagick" = yes && echo " Compiling in support for ImageMagick image conversion." case "$with_sound" in nas ) echo " Compiling in network sound (NAS) support." ;; @@ -3594,7 +3592,7 @@ test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" echo " The \`Info-default-directory-list' will be initialized from:" -echo " INFOPATH=\"`echo $infopath`\"" +echo " INFOPATH=\"$infopath\"" test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$debug" = yes && echo " Compiling in extra code for debugging." test "$memory_usage_stats" = yes && echo " Compiling in code for checking XEmacs memory usage."
--- a/etc/Emacs.ad Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/Emacs.ad Mon Aug 13 10:03:52 2007 +0200 @@ -51,6 +51,8 @@ ! This is for buttons in the menubar. ! Yellow would be better, but that would map to white on monochrome. *menubar*buttonForeground: Blue +*XlwMenu*highlightForeground: Red +*XlwMenu*titleForeground: Maroon *XlwMenu*selectColor: ForestGreen *XmToggleButton*selectColor: ForestGreen
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/GOATS Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,18 @@ +Reference: http://www.ansi.okstate.edu/breeds/heading.htm + + Goats: (Capra hircus) + + [INLINE] The goat, along with sheep, were among the earliest + domesticated animals. Goat remains have been found at + archaeological sites in western Asia, such as Jericho, Choga, Mami, + Djeitun and Cayonu, which allows domestication of the goats to be + dated at between 6000 and 7000 B.C. + + [INLINE] However, unlike sheep, their ancestry is fairly clear. The + major contributor of modern goats is the Bezoar goat which is + distributed from the mountains of Asia Minor across the Middle East + to Sind. + Unlike sheep, goats easily revert to feral or wild condition given + a chance. In fact, the only domestic species which will return to a + wild state as rapidly as a goat is the domestic cat. + ________________________________________
--- a/etc/HELLO Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/HELLO Mon Aug 13 10:03:52 2007 +0200 @@ -2,9 +2,9 @@ Please correct this incomplete list and add more! --------------------------------------------------------- -Amharic ($(3"c!<!N"^(B) $(3!A!,!>(B Arabic [2](38R(47d(3T!JSa(4W(3W[0](B Croatian Zdravo +Czech (,Bh(Besky) Dobr,B}(B den Danish (Dansk) Hej, Goddag English Hello Esperanto Saluton @@ -24,9 +24,6 @@ Russian (,L@caaZXY(B) ,L7T`PRabRcYbU(B! Spanish (Espa,Aq(Bol) ,A!(BHola! Swedish (Svenska) Hej, Goddag -Thai (,T@RIRd7B(B) ,TJ0GQ1J04U1$0CQ1:(B, ,TJ0GQ1J04U10$h1P(B -Tigrigna ($(3"8#r!N"^(B) $(3!Q!,!<"8(B -Turkish (T,A|(Brk,Ag(Be) Merhaba Vietnamese (Ti,1*(Bng Vi,1.(Bt) Ch,1`(Bo b,1U(Bn Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B, $BqV$(DiQ(B
--- a/etc/NEWS Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/NEWS Mon Aug 13 10:03:52 2007 +0200 @@ -139,6 +139,26 @@ creating a new frame with `C-x 5 2' also raises and selects that frame. The behavior of window system frames is unchanged. +** Package starting changes. + +State of Emacs should never be changed with loading a package. The +following XEmacs packages that used to break this have been changed. + +*** Loading `paren' no longer enables paren-blinking. Use +`paren-set-mode' explicitly, or customize `paren-mode'. + +*** Loading `uniquify' no longer enables uniquify. Set +`uniquify-buffer-name-style' to a legal value. + +*** Loading `time' no longer enables display time. Invoke +`display-time' explicitly. + +*** Loading `jka-compr' no longer enables on-the-fly compression. Use +`toggle-auto-compression' instead. + +*** Loading `id-select' no longer enables its behaviour. Use +`id-select-install' instead. + ** Zmacs region is not deactivated when an error is signaled. The behavior of the zmacs region can now be controlled in the event of @@ -146,74 +166,15 @@ set to nil to revert to the old behaviour. As before, typing C-g deactivates the region. -** Info "dir" functionality merged from Emacs-19.34 - - ------------------ DRAFT ------------------ - -At the time it is dumped, XEmacs will initialize the value of -`Info-default-directory-list' from the value of the environment -variable INFOPATH, which it inherits from the Makefile. The Makefile -gets the value from `configure'. - - #### BETA Note: if the package startup stuff moves or changes, this - next paragraph may need fixing. - -At runtime, the XEmacs startup code will loop through that list and -collect all of the directories in it that satisfy `file-directory-p', -and then appends any site package info directories found... ?? How do -you want this worded? XXXXX !!!! (bright red bold DRAFT) - -When you start the info reader, `Info-directory-list' is initialized -from either the environment variable "INFOPATH", if it exists, or -`Info-default-directory-list'. The first directory in this list must -contain a "dir" file like the one supplied with XEmacs. Note that if -an INFOPATH variable is used, that only the directories in that path -will be searched; no package info paths will be appended, as `Info- -default-directory-list' will be ignored in that case. - -All of the directories on `Info-directory-list' will be searched for -"dir" files, which may be full fledged Info files containing subnodes -as well as menus. They are merged to become one Info directory, with -menus in like-named subnodes being coalesced from the several "dir" -files. - - BETA Note: I have not tested this very thouroughly. Does anyone out - there actually have a dir file with real `info' subnodes in it? I - will create one and try it as I learn how. - karlheg - -"localdir" files are looked for also, secondary to "dir"'s. A localdir -file should look like a section of the Info directory menu: - - | - |* Gnus:: The all seeing all knowing News and Mail - | interface for XEmacs. - |* Calc:: HP-48 alike Calculator that can do algebra - | - -The info reader will insert its contents into the main Info directory -either at the end of the (dir)Top node, beginning at and replacing a -line that looks like: - - | - |* Locals: - | - - BETA-Note: Coming soon... - - ... or, below a line that contains the exact text: - - | - |Locally installed XEmacs Packages - | - - ... by default. (This text is configurable--- see: - `M-x customize-variable Info-localdir-heading-regexp' - -The `Info-localdir-heading-regexp' may be underlined with *'s, ='s, or --'s, like any Info topic header. When `Info-fontify' is non-nil, the -underlineing characters will be elided and the topic heading itself -will be given a face, according to `Info-title-face-alist'. - +** Multiple Info `dir' functionality has been merged with GNU Emacs +19.34. + +XEmacs will now correctly merge all the `dir' files in +`Info-directory-list' (initialized from either `INFOPATH' +env. variable or `Info-default-directory-list'.) These files may be +full-fledged info files containing subnodes or menus. Previously +supported `localdir' files are looked for also, secondary to `dir's. +See the manual for details. ** Abbreviations can now contain non-word characters. @@ -230,8 +191,14 @@ current buffer and deletes the selected window. It asks for confirmation first. +** `ESC ESC ESC' (keyboard-escape-quit) will now correctly abort +recursive edits (as documented.) + ** arc-mode has a new function called `archive-quit' bound to q, which quits archive mode in the same fashion dired-quit works. + +** A `tetris' clone is now available within XEmacs, written by Glynn +Clements. Try it out with `M-x tetris'. ** The feature to teach the key bindings of extended commands now prints the message after the command finishes. After some time, the @@ -247,6 +214,15 @@ background pixmap, which means that background pixmaps no longer clash with zmacs-regions, or clickable buttons. +** Regexps can now contain additional Perl-like constructs. + +** Modifiers can be added to a keystroke by preceding it with a `C-x @ +<x>' sequence where <x> is one of letters `S', `c', `m', `a', `h', `s' +corresponding to shift, control, meta, alt, hyper, and super modifiers, +respectively. It is possible to add several modifiers by repeating this +sequence. This feature is especially useful on text terminals where it +allows one to enter keystrokes like, e.g., `M-home'. + ** Customize changes. *** Customize has undergone a massive speedup, and should now operate @@ -254,7 +230,7 @@ gripe. *** Many more packages have been modified to use the facility, so -almost all of XEmacs options can be examined through the Customize +almost all of XEmacs options can now be examined through the Customize groups. *** There is a new `browser' mode of traversing customizations, in @@ -278,23 +254,6 @@ In .emacs: Use (turn-on-pending-delete) not (load "pending-del") -** Package starting changes. - -*** Loading `paren' no longer enables paren-blinking. Use -`paren-set-mode' explicitly, or customize `paren-mode'. - -*** Loading `uniquify' no longer enables uniquify. Set -`uniquify-buffer-name-style' to a legal value. - -*** Loading `time' no longer enables display time. Invoke -`display-time' explicitly. - -*** Loading `jka-compr' no longer enables on-the-fly compression. Use -`toggle-auto-compression' instead. - -*** Loading `id-select' no longer enables its behaviour. Use -`id-select-install' instead. - ** XEmacs can now save the minibuffer histories from various minibuffers. To use this feature, add the line: @@ -313,6 +272,10 @@ Or `M-x customize RET add-log RET'. +** In ChangeLog mode, you can now press `C-c C-c' to save the file +and restore old window configuration, or `C-c C-k' to abandon the +changes. + ** The key `C-x m' no longer runs the `mail' command directly. Instead, it runs the command `compose-mail', which invokes the mail composition mechanism you have selected with the variable @@ -346,10 +309,10 @@ flexibility and features. *** Many new options and variables are now customizable. Try -`M-x customize-group RET gnuserv RET'. - -*** The `gnuattach' and `gnudoit' programs have been abandoned in -favor of `gnuclient', which now accepts the standard `-nw', +`M-x customize RET gnuserv RET'. + +*** The functionality of `gnuattach' and `gnudoit' programs is +provided by `gnuclient', which now accepts the standard `-nw', `-display', `-eval' and `-f' options. ** Etags changes. @@ -408,6 +371,71 @@ places one blank between a word end and an opening '(', and puts one space between a comma and the beginning of a word. +** New demand based locking implementation + +A faster, but experimental replacement for lazy-lock (called lazy-shot) is +provided. Like lazy-lock it provides demand based and idle time +font-lock-ing. However the lazy-lock versions that came with previous +versions slowed down XEmacs (possibly quite a lot). Lazy-shot solves +this problem by relying on new support from the C code part of XEmacs. +The support however is experimental and will cause some flashing as +parts of the buffer are colored. This likely to change in the future +as the C support is completed. + +The current lazy-shot implementation is mostly interface compatible +with lazy-lock v2.06 (the version shipped with XEmacs is v1.x). + +*** To enable: + 1. Despite the flashing, lazy-shot was deemed such an improvement by + the majority of beta testers that it is now the standard method + provided by the options menu. Alternatively add + + (add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) + + to '.emacs'. + 2. If you were using lazy-lock before, just replace all occurrences of + "lazy-lock" by "lazy-shot" in your '.emacs' file. + +*** To disable: + +If prefer to use lazy-lock in stead of lazy-shot, put + + (remove-hook 'font-lock-mode-hook 'turn-on-lazy-shot) + (add-hook 'font-lock-mode-hook 'turn-on-lazy-lock) + +at the END of `.emacs'. + +** RefTeX mode + +RefTeX mode is a new minor mode with special support for \label{}, \ref{} +and \cite{} macros in LaTeX documents. RefTeX distinguishes labels of +different environments (equation, figure, ...) and has full support for +multifile documents. To use it, select a buffer with a LaTeX document and +turn the mode on with M-x reftex-mode. Here are the main user commands: + +C-c ( reftex-label + Creates a label semi-automatically. RefTeX is context sensitive and + knows which kind of label is needed. + +C-c ) reftex-reference + Offers in a menu all labels in the document, along with context of the + label definition. The selected label is referenced as \ref{LABEL}. + +C-c [ reftex-citation + Prompts for a regular expression and displays a list of matching BibTeX + database entries. The selected entry is cited with a \cite{KEY} macro. + +C-c & reftex-view-crossref + Views the cross reference of a \ref{} or \cite{} command near point. + +C-c = reftex-toc + Shows a table of contents of the (multifile) document. From there you + can quickly jump to every section. + +Under X, RefTeX installs a "Ref" menu in the menu bar, with additional +commands. Full documentation and customization examples are in the file +reftex.el. You can use the finder to view this information: +C-h p --> tex --> reftex.el * Lisp and internal changes in XEmacs 20.3 @@ -420,6 +448,10 @@ was set up as the terminal's erase character at the time Emacs was started. +** It is now possible to attach the menubar accelerator keys to menu +entries. Look at the Lispref under Menus->Menu Accelerators for +details. + ** `insert-file-contents' can now read from a special file, as long as the arguments VISIT and REPLACE are nil. @@ -436,6 +468,12 @@ change properties of an extent at once, and is analogous to `set-frame-properties'. +** If a format field width is specified as `*', the field width is +now assumed to have been specified as an argument (as in C.) + + (format "%*s" 10 "abc") + => " abc" + ** The new macro `with-current-buffer' lets you evaluate an expression conveniently with a different current buffer. It looks like this: @@ -471,11 +509,56 @@ This makes it possible for a Lisp program to open a file whose name begins with ~. +** The regexp matcher has been extended to recognize the following +constructs, borrowed from Perl: + +*** Additional quantifiers. + +In addition to `*', `+' and `?', XEmacs now recognizes the following +quantifiers: + + \{n\} Match exactly n times + \{n,\} Match at least n times + \{n,m\} Match at least n but not more than m times + +*** Non-greedy quantifiers. + +Any of the standard quantifiers (`*', `+' and others) can now be +followed by an optional `?', which will make them become "non-greedy", +i.e. they will match as little text as possible. Note that the +meanings don't change, just the "gravity." + +*** Shy groups. + +The \(?: ... \) groups things like \( ... \), but doesn't record the +context for backreferences or future use. This is useful when you +need a lot of groups for the sake of priorities, but actually want to +record only one or two. + ** The new function `regexp-opt' returns an efficient regexp to match a string. The arguments are STRINGS and (optionally) PAREN. This function can be used where regexp matching or searching is intensively used and speed is important, e.g., in Font Lock mode. +** The featurep syntax has been extended to resemble the Common Lisp +one, as suggested by Erik Naggum. + +*** The `xemacs' feature is defined in XEmacs by default. + +*** The expression `#+fexp form' is equivalent to +(when (featurep fexp) form), only it is evaluated at read-time. Also, +`#-fexp form' is equivalent to (unless (featurep fexp) form). + +*** In addition to symbols, a FEXP can also be a number, or a logical +operator. Here are some examples: + ;; evaluates to non-nil on XEmacs: + (featurep 'xemacs) + ;; evaluates to non-nil on XEmacs 20.3 or later: + (featurep '(and xemacs 20.03)) + ;; evaluates to non-nil either on Emacs, or on XEmacs built without + ;; X support: + (featurep '(or emacs (and xemacs (not x)))) + * Changes in XEmacs 20.2
--- a/etc/TUTORIAL Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/TUTORIAL Mon Aug 13 10:03:52 2007 +0200 @@ -313,11 +313,11 @@ top of the screen." So C-u 0 C-l means "redraw the screen, putting the current line at the top.") ->> Type Control-h k Control-f. +>> Type Control-x 2 See how this window shrinks, while a new one appears - to display documentation on the Control-f command. + to display contents of this buffer. ->> Type C-x 1 and see the documentation listing window disappear. +>> Type C-x 1 and see the new window disappear. * INSERTING AND DELETING @@ -762,10 +762,10 @@ area contains the bottom line of the screen. -* MODE LINE +* MODELINE ----------- -The line immediately above the echo area it is called the "mode line". +The line immediately above the echo area it is called the "modeline". The mode line says something like this: --**-XEmacs: TUTORIAL (Fundamental)--L670--58%---------------- @@ -820,7 +820,7 @@ >> Use C-u C-v once or more to bring this line near the top of screen. >> Type C-h m, to see how Text mode differs from Fundamental mode. ->> Type C-x 1 to remove the documentation from the screen. +>> Type q to remove the documentation from the screen. Major modes are called major because there are also minor modes. Minor modes are alternatives not to the major modes, just minor @@ -879,7 +879,7 @@ When you type C-s you'll notice that the string "I-search" appears as a prompt in the echo area. This tells you that Emacs is in what is called an incremental search waiting for you to type the thing that -you want to search for. <RET> terminates a search. +you want to search for. <Return> terminates a search. >> Now type C-s to start a search. SLOWLY, one letter at a time, type the word 'cursor', pausing after you type each @@ -890,10 +890,11 @@ >> Type <RET> to terminate the search. Did you see what happened? Emacs, in an incremental search, tries to -go to the occurrence of the string that you've typed out so far. To -go to the next occurrence of 'cursor' just type C-s again. If no such -occurrence exists Emacs beeps and tells you the search is currently -"failing", C-g would also terminate the search. +go to the occurrence of the string that you've typed out so far, +highlighting it for your convenience. To go to the next occurrence of +'cursor' just type C-s again. If no such occurrence exists Emacs +beeps and tells you the search is currently "failing", C-g would also +terminate the search. NOTE: On some systems, typing C-s will freeze the screen and you will see no further output from Emacs. This indicates that an operating @@ -1049,9 +1050,7 @@ This displays the documentation of the function, as well as its name, in an Emacs window. When you are finished reading the -output, type C-x 1 to get rid of the help text. You do not have -to do this right away. You can do some editing while referring -to the help text, and then type C-x 1. +output, type q to get rid of the help text. Here are some other useful C-h options: @@ -1062,21 +1061,16 @@ This prints all the information Emacs has about the function which implements the C-p command. - C-h a Command Apropos. Type in a keyword and Emacs will list - all the commands whose names contain that keyword. - These commands can all be invoked with Meta-x. - For some commands, Command Apropos will also list a one - or two character sequence which runs the same command. - ->> Type C-h a file<Return>. + C-h a Hyper Apropos. Type in a keyword and Emacs will list + all the functions and variables whose names contain + that keyword. The commands that can be invoked with + Meta-x, an asterisk will be displayed to the left. -This displays in another window a list of all M-x commands with "file" -in their names. You will see character-commands like C-x C-f listed -beside the corresponding command names such as find-file. +>> Type C-h a newline<Return>. ->> Type C-M-v to scroll the help window. Do this a few times. - ->> Type C-x 1 to delete the help window. +This displays a list of all functions and variables with "newline" in +their names. Press <Return> or click the middle mouse button to find +out more about a function or variable. Type `q' to exit hyper-apropos. * CONCLUSION @@ -1095,7 +1089,8 @@ This tutorial descends from a long line of Emacs tutorials starting with the one written by Stuart Cracraft for the original Emacs. -Ben Wing updated the tutorial for X Windows. +Ben Wing updated the tutorial for X Windows. Martin Buchholz and +Hrvoje Niksic added more corrections for XEmacs. This version of the tutorial, like GNU Emacs, is copyrighted, and comes with permission to distribute copies on certain conditions:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.de Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1150 @@ +Copyright (c) 1985, 1996 Free Software Foundation, Inc. See end for conditions. + +Du betrachtest das Emacs Tutorial. +Dies sind die einführenden Übungen für Emacs. + +Emacs-Befehle verwenden generell entweder die CONTROL- (manchmal mit +CTRL oder CTL beschriftet, auf deutschen Tastaturen auch oft mit STRG) +oder die META-Taste. Auf manchen Tastaturen ist die META-Taste mit +ALT, EDIT oder sonstwie (z.B. ist auf einer Sun Tastatur die +Raute-Taste links vom SPACE Balken die META-Taste) beschriftet. Statt +jedesmal META oder CONTROL auszuschreiben, wenn wir wollen daß Du die +Taste drückst, verwenden wir folgende Abkürzungen: + +C-<chr> bedeutet: Halte die CONTROL-Taste während der Betätigung der + <chr>-Taste gedrückt. Also bedeutet C-f: Halte die CONTROL + Taste, während Du den Buchstaben f drückst. +M-<chr> bedeutet: Halte die META-Taste während der Betätigung der + <chr>-Taste gedrückt. Falls es keine META-Taste gibt, tippe + zuerst ESC (die ESCAPE-Taste) und danach die <chr>-Taste. + +Wichtig: Tippe C-x C-c, um die Emacs-Sitzung zu beenden (zwei +Zeichen). Die ">>" am linken Seitenrand deuten auf Anweisungen, die +Du probieren solltest. so z.B: +<<Blank lines inserted here by startup of help-with-tutorial>> +>> Tippe nun C-v (Betrachte nächste Seite) um die nächste Seite zu + betrachten. (Also, halte die CONTROL-Taste gedrückt während + Du v tippst.) + Von jetzt an tu das bitte jeweils nachdem Du eine Seite + vollständig gelesen hast. + +Bitte beachte die Überlappung von zwei Zeilen wenn Du vorwärts +blätterst; dies erlaubt es, den Text fließend weiter zu lesen. + +Zuerst solltest Du wissen, wie man sich im Text von Stelle zu Stelle +bewegt. Du weißt bereits, wie man sich mit C-v eine Seite +weiterbewegt. Um eine Seite zurück zu gehen, tippe M-v (halte die +META-Taste gedrückt und tippe v oder tippe <ESC>v wenn Deine Tastatur +keine META-, EDIT- oder ALT-Taste besitzt). + +>> Versuche ein paar Mal M-v und C-v zu tippen. + + +* ZUSAMMENFASSUNG +----------------- + +Die folgenden Befehle sind nützlich um Text seitenweise zu betrachten: + + C-v Eine Seite vorwärts blättern + M-v Eine Seite zurück blättern + C-l Bewegt den Bildschirminhalt um den Textzeiger in die + Bildmitte und baut den Bildschirm neu auf. + (Dies ist CONTROL-<klein L>, nicht CONTROL-1.) + +>> Finde den Textzeiger und merke Dir den Text der ihm nahe ist. + Nun tippe C-l. + Finde den Textzeiger abermals und achte darauf daß er sich, + relativ zum Text, nicht bewegt hat. + + +* EINFACHE TEXTZEIGER-STEUERUNG +------------------------------- + +Das Bewegen von Bildschirminhalt zum nächsten ist nützlich, aber wie +bewegt man sich an eine bestimmte Stelle im Text? + +Dazu gibt es mehrere Möglichkeiten. Die einfachste ist die Befehle +C-p, C-b, C-f und C-n zu verwenden. Jeder dieser Befehle bewegt den +Textzeiger um eine Zeile bzw. Spalte in eine bestimmte Richtung. +Hier ist eine Tabelle welche die Bewegungsrichtung der vier Befehle +zeigt: + + Vorherige Zeile, C-p + : + : + Rückwärts, C-b .... Jetzige Textzeiger-Position .... Vorwärts, C-f + : + : + Nächste Zeile, C-n + +>> Bewege den Textzeiger mittels C-n oder C-p auf die mittlere Zeile + der obigen Tabelle. Dann zentriere das Diagramm mittels C-l im + Bildschirmfenster. + +Auf Englisch kann man sich diese Befehle leicht einprägen: P für +previous, N für next, B für backward und F für forward. Dies sind die +einfachen Befehle zur Bewegung des Textzeigers. Da Du sie ständig +benutzen wirst, solltest Du sie jetzt erlernen. + +>> Verwende einige C-n's um den Textzeiger auf diese Zeile zu + bringen. + +>> Bewege Dich mit C-f's in die Zeile und dann hinauf mit C-p's. + Beobachte das Verhalten von C-p, wenn Du Dich mitten in einer Zeile + befindest. + +Jede Textzeile endet mit einem Newline-Zeichen, welches sie von der +nächsten trennt. Auch die letzte Zeile in Deiner Datei sollte ein +Newline am Ende besitzen (obschon Emacs dieses nicht benötigt). + +>> Versuche C-b am Beginn einer Zeile. Es sollte Dich zum Ende der + vorigen Zeile bringen. Dies deshalb, weil es Dich über das + Newline-Zeichen zurückbewegt. + +C-f kann sich, wie C-b, über ein Newline hinwegbewegen. + +>> Tippe einige C-b's um ein Gefühl für die Position des Textzeigers + zu bekommen. Dann verwende C-f um ans Ende der Zeile zu gelangen. + Nun versuche ein weiteres C-f um in die nächste Zeile zu gelangen. + +Wenn Du Dich am Anfang oder Ende aus dem Bildschirm bewegst, schiebt +sich der Text ins Blickfeld. Diesen Vorgang nennt man rollen oder +"scrolling". Er erlaubt Emacs den Textzeiger an die gewünschte +Stelle zu bringen, ohne ihn aus dem Bildschirmfenster zu bewegen. + +>> Versuche den Textzeiger mittels C-n aus dem Blickfeld zu bewegen + und beobachte was geschieht. + +Wenn Dir die zeichenweise Fortbewegung zu langsam ist, kannst Du +Dich Wort für Wort bewegen. M-f (META-f) geht ein Wort weiter und M-b +geht eins zurück. + +>> Tippe ein paar M-f's und M-b's. + +Wenn Du mitten in einem Wort bist, bringt Dich M-f an sein Ende. +Wenn Du auf Leerzeichen zwischen Worten stehst, bewegt Dich M-f zum +Ende des folgenden Wortes. M-b bewegt sich sinngemäß zurück. + +>> Versuche M-f und M-b einige Male, abgewechselt von C-f's und C-b's + so daß Du das Verhalten von M-f und M-b an verschiedenen Stellen + innerhalb und zwischen Wörtern beobachten kannst. + +Achte auf die Verwandtschaft von C-f und C-b auf der einen Seite und +M-f und M-b auf der anderen. Sehr oft werden META-Befehle für +Operationen mit Einheiten einer Sprache verwendet (Worte, Sätze, +Absätze), während CONTROL-Befehle unverändert mit den einfachen +Einheiten (Buchstaben, Zeilen, etc.) arbeiten. + +Diese Parallele ist auf Zeilen und Sätze anwendbar: C-a und C-e gehen +zum Anfang und Ende einer Zeile, M-a und M-e zum Anfang bzw. Ende +eines Satzes. + +>> Versuche ein paar C-a's und dann ein paar C-e's. + Versuche ein paar M-a's und dann ein paar M-e's. + +Schau wie mehrere C-a's nichts bewirken, mehrere M-a's sich aber Satz +für Satz weiterbewegen. Obwohl sich ihr Verhalten unterscheidet, +erscheint es natürlich. + +Die Stelle des Textzeigers im Text wird auch "Punkt" genannt. Der +Textzeiger auf dem Bildschirm zeigt an welchem Punkt im Text sich +dieser befindet. + +Hier ist eine Zusammenfassung der einfachen Befehle zur Bewegung des +Textzeigers, inklusive der Befehle zur wort- und satzweisen Bewegung: + + C-f Gehe ein Zeichen weiter + C-b Gehe ein Zeichen zurück + + M-f Gehe ein Wort weiter + M-b Gehe ein Wort zurück + + C-n Gehe zur nächsten Zeile + C-p Gehe zur vorherigen Zeile + + C-a Gehe an den Anfang der Zeile + C-e Gehe an das Ende der Zeile + + M-a Gehe zurück zum Anfang des Satzes + M-e Gehe weiter zum Ende des Satzes + +>> Übe jetzt alle diese Befehle einige Male. + Es sind die am häufigsten benutzten. + +Zwei weitere wichtige Befehle zur Bewegung im Text sind M-< (META +kleiner), welcher an den Anfang des gesamten Texts springt, und M-> +(META größer), welcher an das Textende hüpft. + +Auf einigen deutschen Tastaturen ist ">" über "<", Du mußt also +möglicherweise die Shift-Taste drücken, um ein > zu tippen. Auf +solchen Tastaturen mußt Du auch für M-> die Shift-Taste drücken; ohne +Shift-Taste würdest Du sonst M-< tippen. + +>> Versuche jetzt M-< um an den Beginn dieser einführenden Übungen zu + gelangen. + Dann verwende C-v wiederholt um hierher zurück zu kommen. + +>> Versuche jetzt M-> um ans Ende der Übungen zu springen. + Benutzte M-v widerholt um hierher zurück zu gelangen. + +Du kannst den Textzeiger auch mit den Pfeil-Tasten bewegen, falls +Deine Tastatur solche besitzt. Wir empfehlen das Erlernen von C-b, +C-f, C-n und C-p aus drei Gründen. Erstens funktionieren sie auf allen +Tastaturen. Zweitens wirst Du herausfinden, wenn Du einige Übung mit +Emacs bekommst, daß es schneller ist die CTRL-Tasten zu drücken als +die Pfeil-Tasten (weil Du Deine Hände nicht aus dem normalen +Fingersatz bringen mußt). Drittens: Hast Du die Versendung der CTRL +Befehle erst zu Deiner Gewohnheit gemacht, wird es ein Leichtes +weitere Bewegungs-Befehle zu erlernen. + +Die meisten Emacs-Befehle akzeptieren ein numerisches Argument; +meistens dient dieses als Wiederholzähler. Dieses Argument übergibt +man mit C-u, gefolgt von einer Zahl, bevor man den jeweiligen Befehl +eingibt. Steht Dir eine META- (oder EDIT- oder ALT)-Taste zur +Verfügung, so kannst Du dieses Argument auch wie folgt eingeben: Tippe +die Ziffern während Du die META-Taste gedrückt hältst. Wir empfehlen +das Erlernen der C-u Methode, da sie überall funktioniert. + + +z.B., C-u 8 C-f bewegt den Textzeiger um acht Zeichen weiter. + +>> Versuche C-n und C-p mit numerischem Argument um den Textzeiger + mit nur einem Befehl nahe an diese Zeile heranzubringen. + +Die meisten Befehle verwenden ein Argument als Wiederholzähler. Einige +ausgenommene Befehle verwenden es anders. C-v und M-v sind unter den +Ausnahmen. Mit Argument rollen sie den Text um eben soviele Zeilen, +anstelle von Bildschirmseiten. z.B. C-u 4 C-v rollt den +Bildschirminhalt um 4 Zeilen. + +>> Versuche C-u 8 C-v nun aus. + +Dies sollte den Bildschirminhalt um acht Zeilen nach oben gerollt +haben. Wenn Du ihn wieder zurückrollen willst, kannst Du M-v ein +entsprechendes Argument geben. + +Verwendest Du das X Window System, so befindet sich wahrscheinlich ein +rechteckiger Balken, Scrollbar oder Rollbalken genannt, rechts neben +dem Emacs-Fenster. Du kannst den Text auch durch Manipulieren dieses +Rollbalkens mit der Maus rollen. + +>> Versuche die mittlere Maustaste in der hervorgehobenen Fläche + innerhalb des Rollbalkens zu drücken. Dies sollte den Text mehr + oder weniger rollen, je nachdem wie hoch oder tief der Mauszeiger + auf dem Rollbalken positioniert ist. + +>> Bewege den Mauszeiger im Rollbalken etwa drei Zeilen unter das + obere Ende und drücke die linke Maus-Taste einige Male. + +* TEXTZEIGER STEUERUNG MIT EINEM X-TERMINAL +------------------------------------------- + +An einem X-Terminal wirst Du es wahrscheinlich einfacher finden die +Tasten des Tastenfeldes zur Textzeiger Steuerung zu gebrauchen. Die +Links, Rechts, Auf und Ab Pfeil Tasten steuern in die erwartete +Richtung; sie funktionieren exakt wie C-b, C-f, C-p und C-n, sind aber +leichter zu tippen und zu merken. Du kannst auch C-Links und C-Rechts +verwenden um wortweise zu springen. C-Auf und C-Ab bewegen den +Textzeiger blockweise (z.B. Absätze, wenn Du Text bearbeitest). +Die Tasten HOME (oder BEGIN, POS1) und END (oder ENDE) bringen Dich +zum Anfang oder Ende einer Zeile und C-HOME bzw. C-END bringen Dich +zum Anfang oder Ende der Datei. Hat Deine Tastatur PgUp (oder BILD +AUF) und PgDn (oder BILD AB) kannst Du diese wie M-v und C-v zum +seitenweisen Rollen verwenden. + +All diese Befehle nehmen numerische Argumente wie weiter oben +beschrieben. Du kannst diese Argumente mittels einer Abkürzung +eingeben: Drücke einfache die CONTROL- oder META-Taste während Du die +Ziffern tippst. z.B. um 12 Worte nach rechts zu gehen, tippe C-1 C-2 +C-Rechts. Beachte, daß dies ganz einfach, ohne Loslassen der +CONTROL-Taste, getippt werden kann. + +* WENN EMACS HÄNGT +------------------ + +Wenn Emacs auf Deine Befehle nicht mehr reagiert, kannst Du den +Befehle risikolos mit C-g unterbrechen. Mit C-g kann man Befehle +abbrechen, die zu lange dauern. + +Du kannst mit C-g auch ein numerisches Argument oder einen teilweise +eingegebenen Befehl, den Du nicht mehr ausführen willst, verwerfen. + +>> Tippe C-u 100 für ein numerisches Argument von 100, dann tippe + C-g. Nun tippe C-f. Es wird nur eine Bewegung um ein Zeichen + ausgeführt, da Du das Argument mit C-g verworfen hast. + +Hast Du fälschlich ein <ESC> getippt, kannst Du es mit C-g loswerden. + + +* GESPERRTE BEFEHLE +------------------- + +Einige Emacs-Befehle sind "gesperrt", damit sie von Anfängern nicht +versehentlich benutzt werden können. + +Wenn Du einen der gesperrten Befehle tippst, zeigt Emacs die +Befehlsdokumentation und fragt um Bestätigung, daß der Befehl +tatsächlich ausgeführt werden soll. + +Wenn Du den Befehl wirklich probieren willst, tippe Space als Antwort +auf die Frage. Normalerweise, wenn Du den gesperrten Befehl nicht +ausführen willst, beantwortest Du die Frage mit "n". + +>> Tippe `C-x n p' (ein gesperrter Befehl), dann beantworte die Frage + mit n. + + +* FENSTER +--------- + +Emacs unterstützt mehrere Fenster, jedes mit unterschiedlichem Text. +Beachte, daß sich der Begriff "Fenster" in Emacs nicht auf +verschiedene, überlappende Fenster im Fenstersystem bezieht, sondern +auf verschiedene Teil-Fenster innerhalb eines X Fensters. (Emacs +unterstützt auch mehrere X-Fenster, oder "Rahmen" ("frames") in +Emacs-Terminologie. Dies wird später beschrieben.) + + C-x 1 Ein Fenster (d.h., Beende alle anderen Fenster). + +Dies ist CONTROL-x gefolgt von der Ziffer 1. C-x 1 erweitert das +Fenster mit dem Textzeiger, so daß es das ganze Emacs-Fenster +einnimmt. Alle anderen Fenster werden beendet. + +>> Bewege den Textzeiger auf diese Zeile und tippe C-u 0 C-l. + +(Denke daran, daß C-l den Bildschirminhalt neu aufbaut. Das +numerische Argument bedeutet: "Baue den Bildschirminhalt neu auf und +bewege die aktuelle Zeile ebensoviele Zeilen vom oberen +Bildschirmrand." C-u 0 C-l bedeutet also "Bau den Bildschirm, mit der +aktuellen Zeile ganz oben, neu auf.") + +>> Tippe CONTROL-x 2 + Beachte wie das Fenster schrumpft, während ein neues mit Teilen + derselben Datei erscheint. + +>> Tippe C-x 1 und sehe das neue Fenster verschwinden. + + +* EINFÜGEN UND LÖSCHEN +---------------------- + +Willst Du Text einfügen, so tippe ihn. Sichtbare Zeichen, wie A, +7, *, etc., werden von Emacs als Text betrachtet und unmittelbar +eingefügt. Tippe <Return> (die Rücklauf-Taste) um ein Newline +einzufügen. + +Mit <Delete> kannst Du das zuletzt getippte Zeichen löschen. +<Delete> ist eine Taste die möglicherweise mit "Del" oder "Entf" +beschriftet ist. In einigen Fällen dient die Backspace (Rückschritt) +Taste als <Delete>, jedoch nicht immer! + +Allgemeiner ausgedrückt löscht <Delete> das Zeichen unmittelbar vor +dem Textzeiger. + +>> Tu dies nun -- tippe einige Buchstaben, lösche sie dann durch + mehrmaliges Tippen von <Delete>. Kein Grund zur Sorge diese Datei + zu verändern. Es ist Deine persönliche Kopie der "Einführenden + Übungen für Emacs". + +Wird eine Zeile zu lang für eine Bildschirm-Zeile, so wird die Zeile +auf der nächsten Bildschirm-Zeile fortgesetzt. Ein umgekehrter +Schrägstrich ("\") am rechten Rand zeigt an, daß die Zeile fortgesetzt +wird. + +>> Füge Text ein bis Du den rechten Rand erreichst und tippe weiter. + Du wirst bemerken, wie die Fortsetzungszeile erscheint. + +>> Verwende <Delete>s bis die Zeile wieder auf eine Bildschirmzeile + paßt. Die Fortsetzungszeile verschwindet. + +Ein Newline-Zeichen kann wie jedes andere gelöscht werden. Das +Löschen des Newline-Zeichens fügt die umgebenden Zeilen zusammen. +Ist die entstehende Zeile zu lang für den Bildschirm, erscheint +wieder eine Fortsetzungszeile. + +>> Geh an den Anfang einer Zeile und tippe <Delete>. Dies fügt die + Zeile an die vorhergehende an. + +>> Tippe <Return> um den Newline-Zeichen wieder einzufügen. + +Denke daran, daß die meisten Emacs-Befehle mittels eines Arguments +wiederholt werden können; Ein Textzeichen wird mittels Argument +mehrfach eingefügt. + +>> Versuch's einfach -- Tippe C-u 8 * um ******** einzufügen. + +Du hast jetzt die einfachsten Befehle zum Einfügen und Korrigieren von +Text gelernt. Du kannst auch ganze Worte oder Zeilen löschen. Hier +ist eine Zusammenfassung der Lösch-Befehle: + + <Delete> Lösche das Zeichen vor dem Textzeiger + C-d Lösche das Zeichen nach dem Textzeiger + + M-<Delete> Lösche das Wort vor dem Textzeiger + M-d Lösche das Wort nach dem Textzeiger + + C-k Lösche vom Textzeiger bis ans Zeilenende + M-k Lösche vom Textzeiger bis ans Satzende + +Beachte daß <Delete> und C-d gegenüber M-<Delete> und M-d die +Verwandtschaft von C-f und M-f fortsetzen (<Delete> ist zwar keine +CONTROL-Taste, aber das kümmert uns nicht). C-k und M-k verhalten +sich zueinander wie C-e und M-e zu Zeilen und Sätzen. + +Wenn Du mehr als ein Zeichen auf einmal löschst, speichert sie +Emacs, damit Du sie wieder abrufen kannst. Den gelöschten Text +zurückzuholen nennt man "yanking". Du kannst den gelöschten Text an +der selben oder an einer anderen Textstelle zurückholen. Der Text +kann mehrere Male zurückgeholt geholt werden um Mehrfachkopien +anzulegen. Der Zurückhol-Befehl ist C-y. + +Beachte daß der Unterschied zwischen Entfernen ("Killing") und Löschen +("Deleting") darin besteht, daß gelöschte Teile zurückgeholt werden +können, während dies für entfernte Teile nicht möglich ist. Allgemein +speichern Befehle die viel Text löschen diesen auch, während Befehle, +die nur einzelne Zeichen oder Leerzeilen entfernen, diese nicht +speichern. + +>> Gehe zum Beginn einer nicht leeren Zeile. + Dann lösche den gesamten Text der Zeile mit C-k. +>> Tippe C-k ein zweites Mal. Du wirst sehen, daß dies das folgende + Newline-Zeichen löscht. + +Beachte, daß ein einzelnes C-k den Inhalt einer Zeile löscht, ein +zweites die Zeile selbst, so daß sich nachfolgende Zeilen nach oben +bewegen. Ein numerisches Argument wird von C-k besonders behandelt: +Es löscht ebensoviele Zeilen mitsamt Inhalt. Dies ist keine einfache +Wiederholung. C-u 2 C-k löscht zwei Zeilen und deren Inhalt; zwei +aufeinanderfolgende C-k würden dies nicht tun. + +Um den zuletzt gelöschten Text beim Textzeiger zurückzuholen, tippe +C-y. + +>> Versuch's; Tippe C-y um den Text zurückzuholen. + +Denke so über C-y als ob Du etwas zurückholst, das man Dir genommen +hat. Beachte, daß bei aufeinanderfolgenden C-k's der gelöschte Text in +einem Stück gespeichert wird, so daß ein C-y alle Zeilen zurück bringt. + +>> Tu's jetzt, tippe C-k mehrere Male. + +Nun das Zurückholen des gelöschten Texts: + +>> Tippe C-y. Dann gehe einige Zeilen nach unten und tippe wieder C-y. + Jetzt siehst Du, wie man Text kopiert. + +Was machst Du, wenn Du Text zum Zurückholen hast, dann aber etwas +anderes löscht? C-y würde das zuletzt Gelöschte zurückbringen. Aber +der zuvor gelöschte Text ist nicht verloren. Du kannst Ihn mit M-y +zurückholen. Nachdem Du C-y getippt hast, kannst Du mit M-y den +zurückgeholten Text durch früher gelöschten Text ersetzten. Tippst Du +M-y wieder und wieder, holst Du früher und früher Gelöschtes zurück. +Hast Du den gewünschten Text erreicht, brauchst Du nichts weiter zu +tun um diesen zu behalten. Fahre mit mit Deiner Arbeit fort und laß +den zurückgeholten Text wo er ist. + +Verwendest Du M-y oft genug, kehrst Du an den Anfang zurück (der +letzte Löschvorgang). + +>> Lösche eine Zeile, bewege Dich im Text, lösche eine weitere Zeile. + Dann tippe C-y um die zuletzt gelöschte Zeile zurückzuholen. + Darauf verwende M-y und die zuerst gelöschte Zeile ersetzt den + zuvor zurückgeholten Text. Verwende weitere M-y's und sieh was + passiert. Fahre fort bis die zweite Zeile wiederkehrt und versuche + noch einige M-y's. + Wenn Du willst, kannst Du M-y positive und negative Argumente + geben. + + +* RÜCKGÄNGIG MACHEN +------------------- + +Veränderst Du Text und entscheidest Du dann, daß dies ein Fehler war, +kannst Du die Änderungen mit C-x u rückgängig machen. + +Üblicherweise macht C-x u die Änderungen des letzten Befehls +rückgängig; wenn Du C-x u mehrmals wiederholst, wird jeweils ein +weiterer Befehl rückgängig gemacht. + +Aber es gibt zwei Ausnahmen: Befehle, die keinen Text verändern, +zählen nicht (dies schließt Befehle zum Bewegen und Rollen des +Textzeigers ein) und selbsteinfügende Befehle werden üblicherweise in +Zwanziger-Gruppen behandelt. (Dies dient dazu, die Anzahl der C-x u's +zu reduzieren die Du tippen mußt um eingetippten Text rückgängig zu +machen.) + +>> Lösche diese Zeile mit C-k, dann tippe C-x u und sie sollte + wiedererscheinen. + +C-_ ist ein alternativer rückgängig (undo) Befehl; er funktioniert wie +C-x u, ist aber einfacher zu Wiederholen. Der Nachteil ist, daß C-_ +auf einigen Tastaturen nicht direkt getippt werden kann. Deshalb gibt +es C-x u. Auf einigen Tastaturen kann man C-_ als C-\ tippen. + +Ein numerisches Argument für C-_ oder C-x u dient als Wiederholwert. + + +* DATEIEN +--------- + +Um an einem Text bleibende Änderungen vorzunehmen, mußt Du ihn in +einer Datei speichern. Sonst gehen Deine Änderungen mit dem Beenden +von Emacs verloren. Du legst Deine Arbeit in einer Datei ab, indem Du +eine Datei "findest". (Man nennt dies auch das "Besuchen" +("visiting") einer Datei.) + +Das Finden einer Datei bedeutet, daß Du ihren Inhalt mit Emacs +betrachtest. In vielfacher Hinsicht ist es, als würdest Du die Datei +selbst bearbeiten. Jedoch sind Deine Änderungen nicht permanent bis +Du die Datei sicherst. Damit kannst Du verhindern halb-fertige +Dateien auf dem System abzulegen, wenn Du dies nicht willst. Sogar +beim Abspeichern hinterläßt Emacs die Originaldatei unter verändertem +Namen falls Du später entscheiden solltest, daß die Änderungen ein +Fehler waren. + +Nahe dem unteren Ende des Bildschirms siehst Du eine Zeile die mit +Bindestrichen beginnt und endet und den Text "Emacs: TUTORIAL" +enthält. Dieser Teil des Bildschirms zeigt immer den Namen der +besuchten Datei. Zur Zeit besuchst Du eine Datei namens "TUTORIAL", +welche Deine persönliche Kopie des Emacs Tutorials ist. Was immer für +eine Datei Du findest, ihr Name wird immer an dieser Stelle +erscheinen. + +Die Befehle zum Finden und Sichern von Dateien sind anders als die +bisher erlernten, da sie jeweils aus zwei Zeichen bestehen. Beide +beginnen mit dem Zeichen CONTROL-x. Es gibt eine ganze Reihe von +Befehlen, die mit CONTROL-x beginnen; viele haben mit Dateien, Buffern +und verwandten Dingen zu tun. Diese Befehle sind zwei, drei oder vier +Zeichen lang. + +Bei Befehlen zum Finden einer Datei mußt Du außerdem den Dateinamen +angeben. Wir sagen: "Der Befehl liest ein Argument vom Terminal." (In +diesem Fall ist das Argument der Dateiname). Nachdem Du folgenden +Befehl tippst + + C-x C-f Finde eine Datei + +bittet Dich Emacs, einen Dateinamen einzugeben. Der Dateiname den Du +tippst erscheint am unteren Ende des Emacs-Fensters. Diese unterste +Zeile wird Minibuffer genannt, wenn sie für diese Art Eingabe +verwendet wird. Du kannst die üblichen Emacs-Befehle zum +Bearbeiten des Dateinamens verwenden. + +Während Du den Dateinamen eingibst (oder bei jeder anderen +Minibuffer-Eingabe) kannst Du den Befehl mit C-g abbrechen. + +>> Tippe C-x C-f, dann tippe C-g. Dies beendet den Minibuffer und + bricht den C-x C-f Befehl ab, der den Minibuffer benutzte. Du wirst + also keine Datei finden. + +Wenn Du mit dem Bearbeiten des Dateinamens fertig bist, tippe <Return> +um die Eingabe zu beenden. Der C-x C-f Befehl beginnt seine Arbeit +und findet die Datei Deiner Wahl. Der Minibuffer verschwindet, wenn +der C-x C-f Befehl beendet ist. + +Nach kurzer Zeit erscheint der Inhalt der Datei auf dem Bildschirm und +Du kannst diesen bearbeiten. Wenn Du Deine Änderungen sichern willst, +tippe den Befehl + + C-x C-s Sichere die Datei + +Das kopiert den Text von Emacs in die Datei. Geschieht dies das erste +Mal so benennt Emacs die Originaldatei um, so daß sie nicht verloren +geht. Der neue Name entsteht durch Anhängen von "~" am Ende des +Originalnamens. + +Ist der Sicherungsvorgang beendet, gibt Emacs den Namen der Datei an. +Du solltest recht oft sichern, damit Du nicht viel Arbeit verlierst, +sollte das System abstürzen. + +>> Tippe C-x C-s um Deine Kopie des tutorials zu sichern. + Dies sollte "Wrote ...TUTORIAL" am Fuß des Bildschirms ausgeben. + +ACHTUNG: Auf manchen Systemen wird C-x C-s den Bildschirm anhalten und +Du wirst keine weitere Ausgabe von Emacs sehen. Dies bedeutet, daß +auf Deinem System eine Betriebssystemeigenschaft ("feature") namens +Flußsteuerung ("flow control") das C-s abfängt und nicht an Emacs +weitergibt. Tippe C-q, um den Effekt aufzuheben, so daß der Bildschirm +wieder reagiert. Schau dann unter "Spontaneous Entry to Incremental +Search" im Emacs Manual nach, um Hilfe im Umgang mit diesem "Vorzug" +("feature") zu bekommen. + +Du kannst eine existierende Datei finden, um sie zu betrachten. Du +kannst aber auch eine Datei "finden", die es noch nicht gibt. So +erstellt man eine neue Datei mit Emacs: finde die Datei, welche +anfänglich leer ist, dann tippe den Text für die Datei ein. Wenn Du +danach sicherst, wird Emacs die Datei tatsächlich anlegen und Deinen +eingetippten Text darin ablegen. Von da an arbeitest Du an einer +existierenden Datei. + + +* BUFFER +-------- + +Findest Du eine weitere Datei mit C-x C-f, bleibt die erste in Emacs +erhalten. Du kannst zu dieser mit C-x C-f zurückschalten. Auf diese +Art kannst Du eine erhebliche Anzahl von Dateien in Emacs verfügbar +haben. + +>> Erstelle eine Datei namens "foo" durch Eintippen von C-x C-f foo + <Return>. + Dann füge etwas Text ein, bearbeite ihn und sichere die Datei "foo" + mit C-x C-s. + Schließlich tippe C-x C-f TUTORIAL <Return> um zum Tutorial zurück + zu gelangen. + +Emacs hält den Text jeder Datei in einem Objekt namens "buffer". Das +Finden einer Datei legt in Emacs einen neuen Buffer an. Um eine Liste +aller Buffer in Deiner Emacs-Sitzung zu erhalten tippst Du + + C-x C-b Liste alle Buffer + +>> Probiere C-x C-b jetzt aus. + +Beachte, daß jeder Buffer einen Namen hat. Wenn der Buffer einer Datei +zugeordnet ist, wird auch der Dateiname angezeigt. Einige Buffer haben +keine Entsprechung im Dateisystem. So hat z.B. der Buffer namens +"*Buffer List*" keine zugeordnete Datei. Dieser Buffer enthält die +Liste der Buffer, die mit C-x C-b erstellt wurde. JEDER Text in Emacs +ist Teil irgendeines Buffers. + +>> Tippe C-x 1 um die Bufferliste loszuwerden. + +Wenn Du Änderungen in einer Datei vornimmst, dann eine andere findest, +so wird der Inhalt der ersten nicht gesichert. Die Änderungen bleiben +innerhalb von Emacs im zugeordneten Buffer erhalten. Das Bearbeiten +einer weiteren Datei hat keinen Einfluß auf den Buffer der ersten. +Dies ist sehr nützlich, man braucht aber auch eine angenehme +Möglichkeit, den Buffer der ersten Datei zu sichern. Es wäre lästig, +müßte man mit C-x C-f zur ersten Datei zurückgehen, um diese dann mit +C-x C-s zu sichern. Darum haben wir + + C-x s Sichere mehrere Buffer + +C-x s befragt Dich zu jedem Buffer, der ungesicherte Änderungen +enthält. Für jeden einzelnen wirst Du gefragt ob Du Ihn sichern +willst. + +>> Füge eine Text-Zeile ein, dann tippe C-x s. + Du wirst gefragt, ob Du den Buffer namens TUTORIAL speichern + willst. + +* VERWENDUNG DES MENÜS +---------------------- + +An einem X-Terminal wirst Du eine Menüleiste am oberen Ende des Emacs +Fensters bemerken. Mit der Menüleiste kannst Du die allgemeinsten +Emacs-Befehle, wie "Finde Datei" ("find file"), erreichen. Du wirst +dies anfänglich einfacher finden, da Du dir die notwendigen +Tastenkombinationen der Befehle nicht merken mußt. Bist Du einmal +mit Emacs vertraut, wird es ein Leichtes sein die Kommandos zu +benutzen, da jeder Menüeintrag, der einer Tastenkombination +entspricht, diese auch anzeigt. + +Beachte, daß es viele Menüeinträge ohne entsprechende Tastensequenz +gibt. So listet z.B. das Buffers-Menü die verfügbaren Buffer in +letzt-benutzter Reihenfolge. Du kannst zu jedem Buffer über den +Eintrag im Buffers-Menü gelangen. + +* VERWENDUNG DER MAUS +--------------------- + +Unter X Windows hat Emacs volle Maus-Unterstützung. Der Textzeiger +kann durch Drücken der linken Maustaste an der gewünschten Stelle des +Mauszeigers dorthin gesetzt werden. Text kann durch Ziehen des +Mauszeigers bei gedrückter linker Maustaste selektiert werden. +(Oder man klickt die linke Maustaste an der einen Stelle im Text und +verwendet SHIFT-Klick an der anderen um den dazwischenliegenden Text +zu selektieren.) + +Um selektierten Text zu löschen kannst Du C-w benutzen, oder den +Menüeintrag "Cut" im Edit-Menü verwenden. Beachte, daß diese +Methoden nicht gleichbedeutend sind: C-w sichert den Text nur +innerhalb von Emacs (ähnlich wie oben unter C-k beschrieben), während +Cut den Text auch im X Clipboard ablegt, von wo ihn andere Programme +abholen können. + +Verwende "Paste" im Edit-Menü um Text vom X Clipboard zurückzuholen. + +Die mittlere Maustaste wird häufig verwendet um sichtbare Objekte auf +dem Bildschirm auszuwählen. Wenn Du z.B. "Info" (die Online Emacs +Dokumentation) mit C-h i oder über das Help-Menü aufrufst, kannst Du +einer hervorgehobenen Verknüpfung durch Klicken der mittleren +Maustaste folgen. Ganz ähnlich, wenn Du einen Dateinamen eingibst +(z.B. wenn von "Find File" gefragt) und TAB tippst um die möglichen +Vervollständigungen zu erhalten, kannst Du mit der mittleren Maus die +gewünschte Vervollständigung wählen. + +Die rechte Maustaste zeigt ein Popup-Menü. Der Inhalt des Menüs +variiert abhängig vom gewählten Modus und zeigt für gewöhnlich einige +häufig benutzte Befehle, die so einfacher benutzt werden können. + +>> Drücke jetzt die rechte Maustaste. + +Du mußt die Taste gedrückt halten, damit das Menü nicht gleich wieder +verschwindet. + +* ERWEITERUNG DES BEFEHLSSATZES +------------------------------- + +Es gibt viel mehr Emacs-Befehle als man auf allen CONTROL- und +META-Zeichen unterbringen könnte. Emacs löst dieses Problem mit dem X +(eXtend) Befehl. Davon gibt es zwei Ausführungen: + + C-x Zeichenerweiterung eXtend. Gefolgt von einer + Tastaturkombination. + M-x Namenserweiterung eXtend. Gefolgt von einer + ausgeschriebenen Befehlsbezeichnung. + +Diese Befehle sind zwar im Allgemeinen nützlich, werden aber seltener +verwendet als die bereits erlernten Befehle. Zwei von ihnen hast Du +bereits kennengelernt: Die Befehle C-x C-f zum Finden und C-x C-s +zum Sichern von Dateien. Ein anderes Beispiel ist der Befehl zum Beenden +einer Emacs-Sitzung -- dieser Befehl ist C-x C-c. (Habe keine Angst, +ungesicherte Änderungen zu verlieren; C-x C-c bietet die Möglichkeit zum +Sichern einer jeden geänderten Datei bevor Emacs beendet wird.) + +Mit C-z kann man Emacs vorübergehend verlassen -- so daß Du später zur +gleichen Sitzung zurückkehren kannst. + +Auf Systemen, die dies unterstützen sendet C-z Emacs "in den +Hintergrund"; man kehrt zur Shell zurück, ohne daß der Emacs-Prozeß +beendet wird. In den gebräuchlichsten Shells kann man zu Emacs mit +`fg' oder `%emacs' zurückkehren. + +Auf Systemen, die dieses Aussetzen von Emacs nicht unterstützen, +startet C-z eine s.g. Sub-Shell von der aus Du Programme starten und +danach zu Emacs zurückkehren kannst; Emacs wird in diesem Fall nicht +wirklich verlassen. Der Shell-Befehl `exit' ist in diesem Fall der +üblichste um zu Emacs zurückzukehren. + +C-x C-c verwendet man unmittelbar bevor man das System verlassen will. +Es ist auch die richtige Methode um einen Emacs zu verlassen der für +E-mail-Programme, oder andere Erweiterungen, die das Aussetzen von +Emacs nicht korrekt handhaben können, benutzt wird. Normalerweise +ist es besser Emacs mit C-z auszusetzen statt ihn zu beenden, wenn +man das System nicht verlassen will,. + +Es gibt viele C-x-Befehle. Hier ist eine Liste der bereits erlernten: + + C-x C-f Finde Datei. + C-x C-s Sichere Datei. + C-x C-b Liste alle Buffer. + C-x C-c Beende Emacs. + C-x u Rückgängig machen (Undo). + +Namenserweiterte Befehle (eXtended commands) sind solche, die weniger +häufig oder nur in einem bestimmten Modus verwendet werden. Ein +Beispiel ist der Befehl replace-string, der einen Text durch einen +anderen ersetzt. Wenn Du M-x tippst, zeigt dies Emacs am unteren Ende +des Emacs-Fensters mit M-x an und Du solltest den Namen des Befehls +eintippen; in diesem Fall "replace-string". Tippe einfach +"repl s<TAB>" und Emacs wird den Namen vervollständigen. Beende den +Befehlsnamen mit <Return>. + +Der replace-string Befehl braucht zwei Argumente -- den zu ersetzenden +Text und den Ersatz-Text. Jedes Argument muß mit <Return> beendet +werden. + +>> Gehe zur Leerzeile zwei Zeilen unter dieser. + Dann tippe M-x repl s<Return>veraendert<Return>geaendert<Return>. + + Beachte wie diese Zeile sich veraendert hat: Du hast das Wort + v-e-r-a-e-n-d-e-r-t mit "geaendert" ersetzt wo immer es nach der + anfänglichen Textzeiger Position auftrat. + + +* AUTOMATISCHE SICHERUNG +------------------------ + +Wenn Du Änderungen in einer Datei vornimmst, diese aber noch nicht +gesichert hast, so können diese bei einem Computerabsturz verloren +gehen. Um Dich davor zu schützen, schreibt Emacs regelmäßig eine +Autosave-Datei für jede Datei, die Du bearbeitest. Autosave-Dateien +beginnen und enden mit "#"; wenn Deine Datei z.B. "hello.c" heißt, so +heißt die auto-save Datei "#hello.c#". Sicherst Du die Datei, so +löscht Emacs die entsprechende auto-save Datei. + +Nach einem Computerabsturz kannst Du die automatisch +gesicherten Änderungen nach dem normalen Finden der Datei (Deiner +Datei, nicht der Autosave-Datei) durch Eintippen von M-x +recover-file<return> zurückholen. Wenn Du nach der Bestätigung +gefragt wirst, tippst Du yes<return> um die Änderungen in der +Autosave-Datei wiederherzustellen. + + +* ECHO BEREICH +-------------- + +Wenn Emacs bemerkt, daß Du Befehle langsam tippst, werden Dir diese am +Fuß des Emacs-Fensters in der s.g. "echo area" angezeigt. Die echo +area nimmt die unterste Zeile im Emacs-Fenster ein. + + +* MODUSZEILE +------------ + +Die Zeile über der echo area wird "mode line" genannt. Die Moduszeile +zeigt etwa folgendes: + +--**-XEmacs: TUTORIAL (Fundamental)--L670--58%---------------- + +Diese Zeile gibt nützliche Information über den Zustand von Emacs und +dem Text, den Du bearbeitest. + +Du kennst bereits die Bedeutung des Dateinamens -- es ist die Datei, +die Du gefunden hast. -NN%-- zeigt Deine Position im Text; dies +bedeutet daß NN Prozent des Texts oberhalb des sichtbaren Bereiches +liegen. Bist Du am Beginn, so erscheint --Top-- anstelle von --00%--. +Bist Du am Ende des Texts, so erscheint --Bot--. Ist der gesamte Text +sichtbar, so erscheint --All--. + +Die Sterne nahe dem Beginn der Moduszeile bedeuten, daß der Text +verändert wurde. Unmittelbar nach dem Besuchen oder Sichern einer +Datei, zeigt dieser Bereich keine Sterne, sondern Bindestriche. + +Der Teil der Moduszeile innerhalb der Klammern gibt Auskunft über die +Bearbeitungs-Modi, die Du derzeit verwendest. Der Ausgangsmodus ist +Fundamental -- der, den Du jetzt gerade benutzt. Er ist ein Beispiel +für einen Hauptmodus ("major mode"). + +Emacs besitzt viele verschiedene Hauptmodi. Einige von ihnen sind zum +Bearbeiten von verschiedenen Computersprachen und/oder Textformaten, +wie z.B. Lisp-Modus, Text-Modus, etc., gedacht. Es ist immer nur ein +Hauptmodus aktiv und sein Name kann dort gefunden werden, wo jetzt +"Fundamental" steht. + +Jeder Hauptmodus ändert das Verhalten einiger Befehle. So gibt es +z.B. Befehle zum Erstellen von Kommentaren in Programmen und da diese +in jeder Programmiersprache unterschiedlich aussehen, muß jeder +Hauptmodus diese Kommentare entsprechend vorbereiten. Jeder +Hauptmodus trägt den Namen eines entsprechenden Erweiterungsbefehls, so +kann man ihn wählen. So ist z.B. M-x fundamental-mode der Befehl, um +in den Fundamental-Modus zu schalten. + +Wenn Du deutschen Text bearbeitest, wie in diesem Fall, solltest Du +wahrscheinlich den Text-Modus verwenden. + +>> Tippe M-x text-mode<Return>. + +Keine Sorge, keiner der bis jetzt erlernten Befehle ändert Emacs +grundlegend. Du kannst aber beobachten, daß M-f und M-b Gänsefüßchen +jetzt als Teil von Worten betrachten. Zuvor, im Fundamental-Modus, +haben M-f und M-b diese als Wort-Separatoren betrachtet. + +Hauptmodi machen im Allgemeinen kleine Änderungen wie diese: die +meisten Befehle erfüllen den selben Zweck, aber sie funktionieren +etwas anders. + +Um Dokumentation über den aktuellen Hauptmodus zu bekommen, kannst Du +immer C-h m verwenden. + +>> Verwende C-u C-v ein- oder mehrmals um diese Zeile ans obere Ende + des Emacs-Fensters zu bekommen. +>> Tippe C-h m um den Unterschied zwischen Text- und Fundamental-Modus + zu sehen. +>> Tippe C-x 1 um die Dokumentation wieder verschwinden zu lassen. + +Hauptmodi heißen so, weil es auch Untermodi gibt. Untermodi sind keine +Alternativen zu Hauptmodi, sondern bewirken kleine Veränderungen +derselben. Jeder Untermodus kann für sich allein, unabhängig von +allen Haupt- und Untermodi, ein und ausgeschaltet werden. Du kannst +also jederzeit keinen, einen, oder beliebig viele Untermodi verwenden. + +Ein sehr nützlicher Untermodus, speziell für deutschen Text, ist der +Automatische-Zeilenumbruch-Modus (auto fill). Ist dieser Modus aktiv, +bricht Emacs überlange Zeilen automatisch zwischen zwei Worten um. + +Du kannst den Modus mit M-x auto-fill-mode<Return> einschalten. Ist +der Modus aktiv, kannst Du ihn mit M-x auto-fill-mode<Return> wieder +ausschalten. Wir sagen der Befehl "toggelt" den Modus. + +>> Tippe jetzt M-x auto-fill-mode<Return>. Dann füge "asdf " + wiederholt ein, bis die Zeile, zu lang geworden, umgebrochen + wird. Du mußt die Leerzeichen einfügen, weil Auto Fill Zeilen nur an + diesen Zeichen umbricht. + +Die Umbruchspalte steht üblicherweise bei 70 Zeichen, aber Du kannst +dies mit dem C-x f Befehl ändern. Die gewünschte Umbruchspalte wird +als numerisches Argument übergeben. + +>> Tippe C-x f mit einem Argument von 20. (C-u 2 0 C-x f). + Danach tippe etwas Text, um zu sehen wie Emacs die Zeilen jetzt bis + Spalte 20 füllt. Dann setze den Zeilenumbruch zurück auf 70. + +Machst Du Änderungen mitten im Absatz, so wird der automatische Umbruch +diesen nicht für Dich auffüllen. Um den Absatz aufzufüllen, tippe M-q +(META-q) während der Textzeiger in diesem Absatz steht. + +>> Bewege den Textzeiger in den vorherigen Absatz und tippe M-q. + + +* SUCHEN +-------- + +Emacs kann nach Zeichenketten ("Strings", dies sind Gruppen von +zusammenhängenden Buchstaben oder Worten) entweder vorwärts oder +rückwärts durch den Text suchen. Suchen nach einem String ist ein +Befehl, der den Textzeiger bewegt; er bewegt den Textzeiger zur +nächsten Stelle an der ein bestimmter String vorkommt. + +Der Emacs Suchbefehl unterscheidet sich von denen der meisten anderen +Editoren, da er "inkrementell" ist. Dies bedeutet, daß das Suchen +während der Eingabe des Such-Strings passiert. + +Der Befehl um eine Suche auszulösen ist C-s für vorwärtiges und C-r +für rückwärtiges Suchen. ABER WARTE! Versuche die Befehle noch nicht. + +Wenn Du C-s tippt, wirst Du den String "I-search" in der echo area +bemerken. Dies bedeutet, daß Emacs im inkrementellen Suchmodus auf +Deine Eingabe wartet. <RET> bricht die Suche ab. + +>> Nun tippe C-s um die Suche einzuleiten. LANGSAM, Buchstabe für + Buchstabe, tippe das Wort 'Textzeiger', mit Pausen dazwischen, + damit Du beobachten kannst, was mit dem Textzeiger basiert. + Du hast jetzt einmal nach "Textzeiger" gesucht. +>> Tippe erneut C-s, um nach dem nächsten Vorkommen von "Textzeiger" + zu suchen. +>> Nun tippe <Delete> viermal und schau wie sich der Textzeiger + bewegt. +>> Tippe <RET> zum Abbrechen der Suche. + +Hast Du gesehen was passiert? Emacs, in der inkrementellen Suche, +versucht zu dem String zu springen, den Du bisher getippt hast. Um +zum nächsten Auftreten von "Textzeiger" zu gelangen, tippst Du einfach +wieder C-s. Gibt es kein weiteres Vorkommen, so piepst Emacs und +zeigt die Suche als fehlgeschlagen an. C-g bricht die Suche auch ab. + +ACHTUNG: Auf manchen Systemen wird C-s den Bildschirm anhalten und Du +wirst keine weitere Ausgabe von Emacs sehen. Dies bedeutet, daß auf +Deinem System eine Betriebssystemeigenschaft ("feature") namens +Flußsteuerung ("flow control") das C-s abfängt und nicht an Emacs +weitergibt. Tippe C-q, um den Effekt aufzuheben, so daß der Bildschirm +wieder reagiert. Schau dann unter "Spontaneous Entry to Incremental +Search" im Emacs Manual nach, um Hilfe im Umgang mit diesem "Vorzug" +("feature") zu bekommen. + +Wenn Du in der Mitte einer inkrementellen Suche <Delete> tippst, wirst +Du bemerken, wie der letzte Such-Buchstabe entfernt wird und die Suche +an die letzte Stelle der Suche zurück springt. Nehmen wir z.B. an, Du +hast "T" getippt, um nach dem ersten Auftreten von "T" zu suchen. Wenn +Du jetzt "e" tippst, springt der Textzeiger zum ersten Auftreten von +"Te". Tippe nun <Delete>. Dies entfernt das "e" von Such-String und +der Textzeiger springt zurück zum ersten Vorkommen von "T". + +Wenn Du mitten in einer Suche ein CONTROL- oder META-Zeichen tippst +(mit wenigen Ausnahmen -- Buchstaben mit Sonderbedeutung bei der +Suche, so wie C-s und C-r), wird die Suche abgebrochen. + +C-s startet eine Suche NACH der aktuellen Textzeiger Position. Willst +Du etwas früher im Text finden, tippe stattdessen C-r. All das was +wir über C-s gesagt haben gilt auch für C-r, nur daß die Suchrichtung +umgedreht wird. + + +* MEHRERE FENSTER +----------------- + +Einer der netten Vorzüge von Emacs ist es, daß Du mehr als jeweils ein +Fenster am Bildschirm darstellen kannst. + +>> Bewege den Textzeiger auf diese Zeile und tippe C-u 0 C-l. + +>> Nun tippe C-x 2, was das Emacs-Fenster zweiteilen wird. + Beide Fenster zeigen dieses Tutorial. Der Textzeiger bleibt im + oberen Fenster. + +>> Tippe C-M-v um beide Fenster zu rollen. + (Hast Du keine echte META-Taste, tippe Esc C-v.) + +>> Tippe C-x o ("o" für "other" oder anderes) um den Textzeiger ins + andere (untere) Fenster zu bewegen. +>> Verwende C-v und M-v im unteren Fenster um dieses zu rollen. + Lies diese Anweisungen im oberen Fenster weiter. + +>> Tippe C-x o um wieder zurück ins obere Fenster zu gelangen. + Der Textzeiger im oberen Fenster ist noch immer wo er vorher war. + +Du kannst weiterhin mit C-x o zwischen den Fenstern umschalten. Jedes +Fenster hat seine eigene Textzeiger-Position, aber nur ein Fenster +zeigt diese auch an. Alle üblichen Bearbeitungs-Befehle beziehen sich +auf das Fenster mit dem Textzeiger. Wir nennen es das "selektierte +Fenster". + +Der Befehl C-M-v ist sehr hilfreich wenn Du in einem Fenster Text +bearbeitest und das andere als Referenz verwendest. Du kannst den +Textzeiger immer im oberen Fenster lassen, und Dich mit C-M-v durch +das andere Fenster bewegen. + +C-M-v ist ein Beispiel für einen CONTROL-META-Zeichen. Wenn Du eine +echte META-Taste hast, kannst Du sowohl CTRL als auch META gedrückt +halten, während Du v tippst. Es kommt nicht darauf an ob CTRL oder +META zuerst gedrückt wird, weil beide dazu dienen um den gedrückten +Buchstaben zu verändern. + +Hast Du keine echte META-Taste und Du verwendest stattdessen ESC, ist +die Reihenfolge nicht egal: zuerst tippst Du ESC, gefolgt von CTRL-v; +CTRL-ESC v wird nicht funktionieren. Dies ist so weil ESC ein +eigenständiges Zeichen ist und keine Modifikations-Taste. + +>> Tippe C-x 1 (im oberen Fenster) um das untere Fenster loszuwerden. + +(Hättest Du C-x 1 im unteren Fenster getippt, wäre das obere Fenster +verschwunden. Merke Dir den Befehl mit "Behalte nur ein Fenster -- +das aktuelle Fenster.") + +Du mußt nicht denselben Buffer in beiden Fenstern anzeigen. Wenn Du +C-x C-f zum Finden einer Datei in einem Fenster verwendest, verändert +sich das andere Fenster nicht. Du kannst in jedem Fenster unabhängig +eine Datei finden. + +Hier ist eine andere Möglichkeit zwei Fenster zum Anzeigen +verschiedener Dinge zu nutzen: + +>> Tippe C-x 4 C-f gefolgt vom Namen einer Deiner Dateien. + Beende mit <Return>. Schau wie die angegebene Datei im unteren + Fenster erscheint. Auch der Textzeiger folgt dorthin. + +>> Tippe C-x o um ins obere Fenster zurückzukehren und beende das + untere Fenster mit C-x 1. + + +* REKURSIVE BEARBEITUNGSEBENEN +------------------------------ + +Manchmal wirst Du in sogenannte rekursive Bearbeitungsebenen +gelangen. Dies wird durch eckige Klammern in der Moduszeile angezeigt, +welche den Namen des Hauptmodus umgeben. Du könntest +z.B. [(Fundamental)] anstelle von (Fundamental) sehen. + +Um aus der rekursiven Bearbeitungsebene zu gelangen, tippst Du ESC +ESC ESC. Dies ist ein allgemeiner Ausstiegs- oder "get out"-Befehl. +Du kannst ihn auch verwenden, um unnötige Fenster loszuwerden und um +aus dem Minibuffer zu gelangen. + +>> Tippe M-x um in den Minibuffer zu gelangen; dann ESC ESC ESC um + auszusteigen. + +Du kannst nicht mit C-g aus einer rekursiven Bearbeitungs-Ebene +gelangen. Dies deshalb, weil C-g zum Beenden von Befehlen und +Argumenten INNERHALB von rekursiven Bearbeitungs-Ebenen dient. + + +* WEITERFÜHRENDE HILFE +---------------------- + +In diesen einführenden Übungen haben wir versucht, gerade genug +Information zu liefern, damit Du beginnen kannst mit Emacs zu +arbeiten. Emacs ist so umfangreich, daß es unmöglich wäre, alles +hier zu erklären. Allerdings solltest Du versuchen, mehr über Emacs zu +lernen, da er so viele nützliche Vorzüge besitzt. Emacs bietet +Befehle zum Lesen der Emacs-Befehlsdokumentation. Diese Hilfe- oder +"help" Befehle beginnen alle mit dem Buchstaben CONTROL-h, den wir auch +das "Hilfe-Zeichen" nennen. + +Um die Hilfeeinrichtungen zu verwenden, tippe C-h, gefolgt von einem +Buchstaben der angibt, welche Art von Hilfe Du willst. Wenn Du Dich +WIRKLICH "verirrst", tippe C-h ? und Emacs wird Dir mitteilen, welche +Art von Hilfe zur Verfügung steht. Hast Du C-h getippt, willst aber +keine Hilfe mehr, dann tippe einfach C-g zum Abbrechen des Befehls. + +(Einige Administratoren verändern die Bedeutung von C-h. Sie sollten +dies wirklich nicht tun, beschwere Dich also beim System +Administrator. In der Zwischenzeit, wenn C-h keine Mitteilung +bezüglich Hilfe am Fuß des Emacs-Fensters anzeigt, versuche M-x help +RET zu tippen.) + +Die einfachste Hilfe-Einrichtung ist C-h c. Tippe C-h, ein c und +einen Befehls-Buchstaben oder eine Sequenz davon und Emacs gibt Dir +eine ganz kurze Beschreibung des Befehls. + +>> Tippe C-h c C-p. + Die Mitteilung sollte etwa wie folgt aussehen + + C-p runs the command previous-line + +Dies teils Dir den "Namen der Funktion" mit. Funktions-Namen werden +hauptsächlich zum Spezialisieren und Erweitern von Emacs verwendet. +Aber da die Funktions-Namen etwas darüber aussagen was der Befehl tut, +können Sie auch als sehr kurze Dokumentation dienen -- genug um Dich +an Befehle zu erinnern die Du bereits gelernt hast. + +Zeichenerweiterte Befehle so wie C-x C-s und (wenn Du keine META- oder +EDIT- oder ALT-Taste hast) <ESC>v sind nach C-h c auch erlaubt. + +Um mehr Hilfe zu einem Befehl zu bekommen verwende C-h k anstelle von +C-h c. + +>> Tippe C-h k C-p. + +Dies zeigt die Dokumentation der Funktion, als auch ihren Namen, in +einem eigenen Emacs-Fenster. Wenn Du mit dem Lesen fertig bist, tippe +C-x 1 um den Hilfetext loszuwerden. Du mußt dies nicht gleich tun. +Du kannst etwas bearbeiten, das sich auf den Hilfetext bezieht und +dann C-x 1 tippen. + +Hier sind einige andere nützliche C-h Möglichkeiten: + + C-h f Beschreibe eine Funktion. Du tippst den Namen der + Funktion + +>> Versuche C-h f previous-line<Return>. + Dies gibt Dir all die Information die Emacs zu der Funktion hat, welche + C-p implementiert. + + C-h a Befehls-Apropos. Tippe ein Schlüsselwort und Emacs listet + alle Befehle die es enthalten. + Diese Befehle können alle mit M-x aufgerufen werden. + Für einige Befehle listet das Befehls-Apropos eine + Buchstaben-Sequenz, die den Befehl ausführt. + +>> Tippe C-h a file<Return>. + +Dies zeigt in einem anderen Fenster eine Liste aller M-x Befehle die +"file" in ihrem Namen haben. Du wirst Buchstaben-Sequenzen wie C-x +C-f mit dem entsprechenden Befehl, wie etwa find-file, aufgelistet +sehen. + +>> Tippe C-M-v um das Hilfe Fenster zu rollen. Mache dies ein paar mal. + +>> Tippe C-x 1 um das Fenster loszuwerden. + + +* ZUM SCHLUß +------------ + +Merke Dir, daß Du Emacs mit C-x C-c endgültig beendest. Um vorübergehend +in eine Shell auszusteigen, so daß Du später zurückkehren kannst, +verwende C-z. (Unter X ikonifiziert dies den aktuellen Emacs-Rahmen.) + +Dieses Tutorial sollte für Anfänger verständlich sein, hast Du etwas +Unklares gefunden, schiebe die Schuld nicht auf Dich - beschwere Dich! + + +ANFERTIGEN VON KOPIEN +--------------------- + +This tutorial descends from a long line of Emacs tutorials +starting with the one written by Stuart Cracraft for the original Emacs. +Ben Wing updated the tutorial for X Windows. + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1985, 1996 Free Software Foundation + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are more complex, but in the +same spirit. Please read the file COPYING and then do give copies of +GNU Emacs to your friends. Help stamp out software obstructionism +("ownership") by using, writing, and sharing free software!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.fr Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1085 @@ +Copyright (c) 1997, Didier Verna <verna@inf.enst.fr>. +Se reporter à la fin du document pour les conditions. + +Vous lisez actuellement la version française du tutoriel d'Emacs. + +Cette version a été produite à partir de la version anglaise, qui est +Copyright (c) 1985, 1996 Free Software Foundation, Inc. + + + + Bienvenue dans le tutoriel d'Emacs en Français !! + + +La plupart des commandes d'Emacs utilisent la touche <Control> +(également notée <Ctrl> ou <Ctl>), ou la touche <Meta>. Sur certains +claviers, la touche <Meta> s'appelle <Alt>, <Edit> ou autre chose (sur +les claviers des stations Sun par exemple, il s'agit de la touche à +gauche de la barre espace, celle avec un petit losange). Si vous ne +disposez pas de la touche <Meta>, il est possible d'utiliser la touche +<Esc> à la place. Afin de décrire les combinaisons de touches +disponibles dans Emacs, les conventions suivantes sont utilisées: + + C-<chr> signifie maintenir la touche <Control> enfoncée tout en tapant + le caractère <chr>. Ainsi, C-f signifie «maintenir la touche + <Control> enfoncée, et taper 'f'». + M-<chr> signifie maintenir la touche <Meta> enfoncée tout en tapant le + caractère <chr>. Si la touche <Meta> n'est pas disponible, + tapez d'abord <Esc>, relâchez la, puis tapez <chr>. + +NOTE IMPORTANTE: pour quitter Emacs, tapez C-x C-c (deux caractères). + +Quand vous trouvez les caractères >> au début d'une ligne, cette ligne +vous donne des directives pour essayer une commande. Par exemple, +<<Blank lines inserted here by startup of help-with-tutorial>> +>> Maintenant, tapez C-v («view next screen») pour passer à l'écran + suivant. (Faites le vraiment! Maintenez la touche <Control> + enfoncée et tapez 'v'). À partir de maintenant, refaites la même + chose quand vous avez fini de lire tout l'écran. + +Remarquez que quand vous changez d'écran, les deux dernières lignes de +l'écran précédent sont conservées, ceci afin de conserver un minimum +de continuité dans la lecture. + +Une des premières choses à savoir dans Emacs est comment se déplacer +dans un texte. Vous savez déjà comment changer d'écran avec C-v. Pour +revenir d'un écran en arrière, tapez M-v (maintenez la touche <Meta> +enfoncée tout en appuyant sur 'v', ou encore tapez <Esc>-v si vous ne +disposez pas de <Meta>, <Edit> ou <Alt>). + +>> Essayez de taper M-v puis C-v un certain nombre de fois. + + +* RÉSUMÉ +-------- + +Les commandes suivantes sont utiles pour voir des écrans entiers: + + C-v Passer à l'écran suivant + M-v Revenir à l'écran précédent + C-l Effacer l'écran et tout retracer, en mettant la ligne + où se trouve le curseur au centre (C'est bien la + touche 'L', pas la touche 'un' + +>> Trouvez le curseur et rappelez vous bien du texte qui l'entoure. + Tapez C-l + Trouvez le curseur à nouveau, et remarquez qu'il s'agit bien du + même texte autour de lui. + + +* MOUVEMENTS DE BASE DU CURSEUR +------------------------------- + +Passer d'un écran à l'autre, c'est bien ... mais comment faire pour se +déplacer dans le texte d'un seul écran? + +Il existe plusieurs manières de faire. La plus simple est d'utiliser +les commandes C-p, C-b, C-f et C-n. Chacune de ces commandes déplace +le curseur d'une ligne ou d'une colonne dans une direction donnée, +comme illustré sur le diagramme suivant: + + + Ligne précédente, C-p + : + : + En arrière, C-b .... Position courante .... En avant, C-f + : + : + Ligne suivante, C-n + +>> Déplacez le curseur au centre de ce diagramme en utilisant C-n ou + C-p, puis placez le au centre de l'écran avec C-l. + + +Pour vous rappeler ces commandes, pensez à leur signification en +anglais (et oui, pas en français ...): F pour Forward, B pour +Backward, N pour Next, P pour Previous. Retenez bien ces commandes, +car vous vous en servirez très souvent. + +>> Amenez le curseur sur cette ligne avec quelques C-n. + +>> Déplacez vous sur la ligne avec des C-f, puis vers le haut avec des + C-p. Remarquez ce que fait C-p quand le curseur est au milieu de la + ligne. + +Chaque ligne de texte se termine avec un caractère nommé Newline, qui +sert à séparer les lignes entre elles. La dernière ligne du fichier +est censée avoir un tel caractère à la fin (bien qu'Emacs n'ait pas +particulièrement besoin de sa présence). + +>> Placez vous au début d'une ligne, et tapez C-b. Cela devrait vous + placer à la fin de la ligne précédente. En fait, on a juste reculé + d'un caractère, à travers le caractère Newline. + +C-f vous déplace à travers Newline, exactement comme C-b. + +>> Faites encore quelques C-b, pour bien sentir comment se déplace le + curseur, puis des C-f pour retourner à la fin de la ligne, et pour + finir encore un C-f pour aller au début de la ligne suivante. + +Si vous vous déplacez en dehors de l'écran, le texte se déplace de +manière à ce que la position du curseur redevienne visible. Cette +opération est appelée «scrolling». + +>> Déplacez le curseur jusqu'en bas de l'écran, et remarquez ce qu'il + se passe. + +Si vous trouvez que le déplacement caractère par caractère est trop +lent, vous pouvez vous déplacer mot par mot. M-f et M-b vous déplacent +respectivement d'un mot en avant et en arrière. + +>> Tapez quelques M-f et M-b. + +Si vous êtes au milieu d'un mot, M-f vous déplace à la fin du mot. +Si vous êtes entre deux mots, M-f vous déplace à la fin du mot +suivant. M-b produit le même comportement, en sens inverse. + +>> Mélangez quelques M-f et M-b avec quelques C-f et C-b pour bien +noter les différences de comportement suivant l'endroit où vous êtes. + +Remarquez le parallèle qui existe entre C-f et C-b d'un côté, et M-f +et M-b de l'autre. Très souvent, les commandes Meta agissent sur des +unités de langage (mots, phrases, paragraphes etc.) tandis que les +commandes Control agissent sur des unités plus primaires (caractères, +lignes etc.). + +Ce parallèle existe encore entre les lignes et les phrases: C-a et C-e +vous positionnent au début ou à la fin d'une ligne, tandis que M-a et +M-e vous déplacent au début ou à la fin d'une phrase. + +>> Tapez quelques C-a et quelques C-e. + Puis tapez quelques M-a et quelques M-e. + +Remarquez que plusieurs C-a ne font rien, mais que plusieurs M-a +n'arrêtent pas de vous faire remonter de phrase en phrase. + +La position du curseur sur dans le texte est aussi appelée le +«point». En d'autres termes, le curseur à l'écran se trouve où le +point est dans le texte. + +Voici un résumé des commandes simples de déplacement, y compris celles +relatives aux mots et aux phrases: + + C-f En avant d'un caractère + C-b En arrière d'un caractère + + M-f En avant d'un mot + M-b En arrière d'un mot + + C-n Ligne suivante + C-p Ligne précédente + + C-a Début de ligne + C-e Fin de ligne + + M-a Début de phrase + M-e Fin de phrase + +>> Entraînez vous un peu à la pratique de ces commandes. Elles sont + très souvent utilisées. + +Deux autres commandes importantes pour le déplacement sont M-< +(Meta-Inférieur) et M-> (Meta-Supérieur). Elles vous déplacent +respectivement au début et à la fin de tout le texte. + +Sur la plupart des terminaux, '<' se trouve au dessus de la +virgule. Il faut donc utiliser la touche <Shift> pour l'obtenir, sans +quoi vous obtiendrez M-'virgule'. + +>> Tapez M-< pour retourner au début du texte. + Puis tapez plusieurs C-v pour revenir ici. + +>> Tapez M-> pour aller à la fin du texte. + Puis tapez plusieurs M-v pour revenir ici. + +Vous pouvez aussi déplacer le curseur avec les flèches, si votre +clavier en possède. Il est cependant préférable d'utiliser C-b C-f C-n +et C-p pour trois raisons: premièrement, ces commandes fonctionnent +sur tous les terminaux. Deuxièmement, quand vous vous serez habitué à +Emacs, vous découvrirez que ces touches sont plus rapides car vous +n'avez pas besoin de déplacer vos mains loin des lettres du +clavier. Enfin, quand vous aurez l'habitude d'utiliser la touche +<Control>, vous apprendrez plus facilement d'autres commandes de +déplacement plus complexes. + +La plupart des commandes d'Emacs acceptent un argument numérique, qui +sert souvent comme compteur de répétition. Pour donner un tel argument +à une fonction, tapez C-u puis les chiffres, et enfin entrez la +commande. Si vous disposez de la touche <Meta> (ou <Edit> ou <Alt>), vous +pouvez aussi tapez directement les chiffres tout en maintenant la +touche <Meta> enfoncée. Il est préférable d'apprendre la méthode C-u car +elle fonctionne sur tous les terminaux. + +Par exemple, C-u 8 C-f vous déplace de huit caractères en avant. + +>> Essayez d'utiliser C-n avec un argument numérique pour vous + déplacer d'un seul coup sur une autre ligne. + +Certaines commandes n'interprètent pas leur argument numérique comme +un compteur de répétition. C'est le cas de C-v et M-v qui déplacent le +texte d'autant de lignes plutôt que d'écrans entiers. Par exemple, C-u +4 C-v déroulera l'écran de 4 lignes. + +>> Essayez C-u 8 C-v. + +Cela a du déplacer l'écran de 8 lignes. Pour faire la manoeuvre +inverse, donnez le même argument a M-v. + +Si vous travaillez sous X Window, il y a sans doute une scrollbar sur +le côté droit de la fenêtre d'Emacs. Vous pouvez aussi vous en servir +avec la souris pour déplacer le texte. + +>> Essayer de cliquer avec le deuxième bouton au dessus du bouton de + la scrollbar. Cela devrait dérouler le texte jusqu'à une position + déterminée par l'endroit où vous avez cliqué. + +>> Cliquez maintenant avec le premier bouton à quelques lignes du + sommet dans la scrollbar. + + +* CONTRôLE DU CURSEUR AVEC UN TERMINAL X +---------------------------------------- + +Si vous travaillez sur un terminal X, vous trouverez surement plus +facile d'utiliser les flèches du pavé numérique pour déplacer le +curseur. Les quatre flèches fonctionnent exactement comme C-f C-b C-n +et C-p mais sont plus faciles à retenir. Vous pouvez aussi les +combiner avec la touche <Control> pour vous déplacer par bloc (par +exemple par paragraphe dans un texte). Si votre pavé numérique dispose +de touches <Home> (ou <Begin>) et <End>, elles vous déplaceront +respectivement en début et en fin de ligne. Combinées avec la touche +<Control>, elles vous déplaceront respectivement en début et en fin de +fichier. Si enfin votre pavé numérique dispose des touches <PgUp> et +<PgDn>, celles-ci vous déplaceront d'écran en écran comme C-v et M-v. + +Toutes ces commandes acceptent des arguments numériques comme décrit +précédemment. + + +* QUAND EMACS EST BLOQUÉ +------------------------ + +Si jamais Emacs ne répond plus à vos ordres, vous pouvez l'arrêter en +toute sécurité en tapant C-g. C-g peut aussi être utilisé pour stopper +une commande qui met trop de temps à s'exécuter. + +C-g sert également à annuler un argument numérique, ou une commande +que vous ne voulez plus mener à terme. + +>> Tapez C-u 1 0 0 pour produire un argument numérique de 100, puis + tapez C-g. + Maintenant, tapez C-f. Le curseur doit finalement ne bouger que + d'un seul caractère, puisque vous avez annulé l'argument. + +Si vous avez tapé un <Esc> par erreur, vous pourrez toujours l'annuler +avec C-g. + + +* COMMANDES DÉSACTIVÉES +----------------------- + +Quelques commandes sont «désactivées» pour empêcher les nouveaux +utilisateurs de les appeler par accident. + +Si vous tapez une de ces commandes, Emacs ouvrira un message vous +disant quelle était cette commande, et vous demandant si vous voulez +vraiment poursuivre son exécution. + +Si vous souhaitez effectivement l'essayer, appuyez sur la barre +espace. Sinon, répondez à la question en tapant 'n'. + +>> Tapez `C-x n p' (commande désactivée), puis répondez par 'n'. + + +* FENÊTRES +---------- + +Emacs peut afficher plusieurs fenêtres, chacune avec un texte +différent. Le terme «fenêtre» signifie ici une zone particulière dans +la fenêtre d'Emacs; il ne s'agit pas de fenêtres pouvant se superposer +dans votre système de multifenétrage. Emacs peut aussi ouvrir +plusieurs fenêtres X (appelées «frames» en jargon Emacsien), mais ceci +est décrit ultérieurement. + +Pour l'instant, mieux vaut ne pas trop s'occuper de plusieurs fenêtres +simultanées, sauf peut-être pour savoir les éliminer toutes sauf +une. Ceci est effectué par la commande C-x 1 ('un', pas 'L'). Cette +commande tue toutes les fenêtres sauf celle dans laquelle vous vous +trouvez, et s'arrange pour que la fenêtre restante occupe toute la place. + +>> Amenez le curseur ici, puis tapez C-u 0 C-l. + +(Rappelez vous que C-l recentre le curseur au milieu de la +fenêtre. Avec un argument numérique, elle place la ligne courante à +autant de lignes du sommet de la fenêtre. Avec 0 comme argument, on +réaffiche donc le texte, en plaçant la ligne courante en haut.) + +>> Tapez Control-x 2 + Notez que cette fenêtre diminue (de moitié), et qu'une nouvelle + fenêtre apparaît (avec le même texte). + +>> Tapez C-x 1 pour faire à nouveau disparaître la deuxième fenêtre. + + +* INSÉRER ET EFFACER +-------------------- + +Pour insérer du texte, il suffit de le taper. Tous les caractères que +vous pouvez voir à l'écran (A, %, - etc.) sont considérés comme du +texte et sont insérés. Pour insérer le caractère Newline, tapez +<Return> (retour chariot). + +Vous pouvez effacer le dernier caractère que vous avez tapé avec la +touche <Delete> parfois nommée «Del». La touche <Backspace> peut +quelques fois être utilisée de la même manière, mais pas tout le +temps! + +Plus généralement, <Delete> efface le caractère situé juste avant le +curseur. + +>> Maintenant, tapez quelques caractères, puis effacez-les avec + <Delete>. Ne vous inquiétez pas pour le contenu de ce tutoriel, ce + que vous avez à l'écran n'est que votre copie personnelle du + fichier, pas le fichier d'origine. + +Si une ligne de texte devient trop grande, elle se poursuit sur une +seconde ligne. Un «Backslash» ('\') situé tout à fait à droite de la +ligne indique que celle-ci continue sur la ligne suivante. + +>> Insérez des caractères jusqu'à ce que la ligne devienne trop + grande, et notez l'apparition du '\'. + +>> Utilisez <Delete> pour effacer des caractères jusqu'à ce que la + ligne reprenne une taille raisonnable. Vous remarquerez que le '\' + disparaît. + +Le caractère Newline s'efface exactement comme les autres. L'effacer +revient à ne faire qu'une seule ligne à partir de deux. Si cette +nouvelle ligne est trop grande, le '\' apparaîtra a nouveau. + +>> Déplacez le curseur au début d'une ligne et tapez <Delete>. Le +caractère Newline sera effacé et cette ligne sera ajoutée à la ligne +précédente. + +>> Tapez <Return> pour réinsérer le Newline que vous avez effacé. + +Rappelez-vous bien que la plupart des commandes acceptent un argument +numérique, y compris l'insertion de caractères: + +>> Tapez C-u 8 *, vous obtiendrez "********". + +Vous connaissez maintenant les commandes de base pour insérer du texte +et corriger des erreurs. Toujours grâce aux touches <Control> et +<Meta>, vous pouvez aussi effacer du texte par mot ou par ligne: + + <Delete> efface le caractère juste avant le curseur + C-d efface le caractère juste après le curseur + + M-<Delete> supprime le mot juste avant le curseur + M-d supprime le mot juste après le curseur + + C-k supprime tout du curseur jusqu'à la fin de ligne + M-k supprime tout du curseur jusqu'à la fin de phrase + + +Quand vous supprimez plus d'un caractère à la fois, Emacs sauvegarde le +texte pour vous donner la possibilité de le réintroduire. L'opération +de réintroduction s'appelle le «yanking». Vous pouvez réintroduire le +texte à la même place ou ailleurs. Vous pouvez même le réintroduire +plusieurs fois, pourquoi pas à des endroits différents. La commande de +«yanking» est C-y. + +Notez bien la différence entre «effacer» et «supprimer». Un texte +«supprimé» est sauvegardé, tandis qu'un caractère «effacé» ne l'est +pas. De même, les commandes effaçant juste des blancs ou des lignes +vides ne sauvegardent rien. + +>> Placez le curseur au début d'une ligne non vide. + Tapez C-k pour supprimer le texte sur cette ligne. +>> Tapez C-k une deuxième fois. Vous remarquerez que cette fois-ci, la + ligne elle-même est supprimée (le caractère Newline). + +C-k traite son argument numérique de manière spéciale: il supprime +autant de lignes Y COMPRIS LE CARACTÈRE NEWLINE. Taper C-k deux fois +de suite ne produirait pas le même résultat. + +>> Pour récupérer le texte dernièrement supprimé, tapez C-y. Celui-ci + sera placé où se trouve le curseur. + +Notez également que si vous faites plusieurs C-k à la suite, tout les +morceaux supprimés seront concaténés, et un seul C-y suffira à tout +ramener. + +>> Faites-le. C-k plusieurs fois, puis C-y. + +>> Déplacez le curseur à un autre endroit puis tapez à nouveau C-y. + Voilà comment on copie du texte! + +C-y restaure le dernier morceau de texte à avoir été supprimé, mais +les suppressions précédentes ne sont pas perdues pour autant. Après +avoir tapé C-y, la commande M-y remplace le texte restauré par l'avant +dernière suppression. Tapez à nouveau M-y et vous obtiendrez +l'avant-avant dernière suppression et ainsi de suite. Quand vous avez +récupéré le texte que vous cherchiez, rien de plus à faire: continuez +simplement votre édition. + +Si vous tapez M-y assez longtemps, vous retomberez sur la suppression +la plus récente. + +>> Supprimez une ligne, déplacez vous et supprimez-en une autre. + Tapez C-y pour récupérer la dernière ligne. + Puis tapez M-y, ce qui restaurera la première ligne supprimée. + Tapez encore M-y pour voir ce qu'il se passe, et continuez jusqu'à + récupérer à nouveau la deuxième ligne. + Si ça vous amuse, donnez des arguments positifs et négatifs à M-y. + + +* ANNULATION +------------ + +Si vous changez du texte, et que finalement vous décidez que ce +n'était pas une bonne idée, vous pouvez annuler les changements grâce +à la commande C-x u. + +C-x u annule les changements produits par la dernière commande. Taper +C-x u plusieurs fois annule de plus en plus de commandes précédentes. + +Il existe cependant quelques exceptions: les commandes qui ne changent +pas le texte ne comptent pas (par exemple les commandes de +déplacement). Les commandes qui insèrent juste un caractère sont +souvent regroupées jusqu'à une vingtaine, ceci pour réduire le nombre +de C-x u à taper ensuite. + +>> Supprimez cette ligne avec C-k, puis tapez C-x u. Elle devrait + revenir ... + +Une alternative à C-x u est C-_. C-x u existe car c'est plus facile à +taper sur certains claviers. Sur d'autres vous pouvez également +obtenir C-_ en tapant C-/. + +Enfin, la commande d'annulation accepte les argument numériques. + + +* FICHIERS +---------- + +Pour sauver votre texte, vous avez besoin de le mettre dans un +fichier, sans quoi il disparaîtra quand vous quitterez Emacs. On dit +«trouver» un fichier («finding»), ou encore «visiter» un fichier +(«visiting»), ou bien «ouvrir». + +Visiter un fichier revient à voir son contenu dans Emacs. Si vous +modifiez le texte du fichier dans Emacs, ces changements ne deviennent +pas permanent, sauf si vous «sauvez» le fichier. Cela permet de ne pas +avoir des fichiers à moitié modifiés sur votre système, à moins que +vous ne le souhaitiez vraiment. D'autre part, quand Emacs «sauve» un +fichier, il commence par copier l'ancienne version sous un nouveau nom +afin que vous puissiez toujours revenir en arrière. + +Regardez en bas de la fenêtre d'Emacs. Vous trouverez une ligne +contenant des tirets '-', et la chaîne de caractères +«Emacs: TUTORIAL.FRANCAIS». Cela vous donne le nom du fichier que vous +êtes en train de visiter. En ce moment, vous visitez le fichier +«TUTORIAL.FRANCAIS» qui correspond au Tutoriel d'Emacs, version +française. Ceci est votre copie personnelle du fichier. Pour chaque +fichier que vous visitez, son nom apparaît exactement à cet endroit. + +La plupart des commandes relatives aux fichiers sont des commandes à +deux caractères, commençant par C-x. Il y a toute une série de +commandes commençant par C-x, beaucoup concernant les fichiers et les +buffers, et longues de 2 caractères ou plus. + +Une autre chose importante pour visiter un fichier est que vous devez +spécifier le nom du fichier à visiter. On dit que cette commande «lis +un argument depuis le terminal». Dans le cas présent, l'argument est +le nom du fichier. Après avoir tapé la commande + +C-x C-f («find») + +Emacs vous demande son nom. Le nom que vous tapez apparaît tout en bas +de la fenêtre. Quand cette ligne sert à entrer des données de cette +manière, on l'appelle «minibuffer». Les commandes d'édition ordinaires +peuvent être utilisées pour éditer le nom du fichier. + +Pendant que vous êtes en train de taper le nom du fichier, vous pouvez +annuler la commande grâce à C-g. + +>> Tapez C-x C-f puis C-g. Cela annule le minibuffer ainsi que la + commande C-x C-f. Vous n'allez finalement pas visiter de fichier. + +Quand le nom du fichier est correct, tapez <Return>. La commande +prendra alors effet et ira chercher le fichier. Après avoir terminé la +saisie du nom, le minibuffer disparaît. + +Au bout d'un petit moment, le contenu du fichier apparaît et vous +pouvez commencer votre édition. Quand vous êtes satisfait des +changements apportés au texte, tapez + +C-x C-s («save») + +Cette commande copie le texte contenu dans Emacs vers le fichier +lui-même. La première fois que vous le faites, Emacs sauvegarde la +version initiale du fichier sous un autre nom, en ajoutant un '~' à la +fin du nom. + +Quand la sauvegarde est terminée, Emacs affiche le nom du fichier dans +lequel on vient d'écrire. Il est fortement conseillé de sauver assez +souvent les fichiers pour éviter de tout perdre en cas de crash +système (non pas qu'Emacs ne puisse jamais crasher lui-même ...). + +>> Tapez C-x C-s pour sauver votre copie du tutoriel. + Vous devriez voir apparaître «Wrote ...TUTORIAL.FRANCAIS" tout en bas + de la fenêtre. + +NOTE: Sur certains systèmes, C-x C-s bloque l'écran et Emacs ne dit +plus rien. Cela signifie qu'une «fonctionnalité» système que l'on +appelle le «flow control» intercepte le C-s et l'empêche de parvenir à +Emacs. Pour débloquer la situation, tapez C-q. Reportez-vous dans ce +cas à la section «Spontaneous Entry to Incremental Search» du manuel +d'Emacs pour plus d'information sur cette ... «particularité». + +Vous pouvez visiter des fichiers existant, mais aussi des fichiers qui +n'existent pas. C'est en fait comme cela que l'on crée un nouveau +fichier dans Emacs. Initialement, le fichier sera inexistant, et la +première fois que vous demanderez à Emacs de le sauver, il créera +effectivement le fichier correspondant. + + +* BUFFERS +--------- + +Si vous ouvrez un nouveau fichier avec C-x C-f, le précédent reste +dans Emacs. Pour retravailler dessus, retapez simplement C-x C-f. De +cette manière, vous pouvez avoir un nombre important de fichiers +ouverts dans Emacs. + +>> Créez un fichier nommé «foo» en tapant C-x C-f foo<Return>. + Insérez un peu de texte puis sauvez-le en tapant C-x C-s. + Enfin, tapez C-x C-f TUTORIAL.FRANCAIS<Return> pour revenir ici. + +Emacs conserve le contenu de chaque fichier dans un objet appelé +«buffer». Visiter un fichier revient à créer un nouveau buffer et y +placer le contenu du fichier. Pour obtenir la liste des buffers qui +existent actuellement dans votre session Emacs, tapez la commande +suivante: + +>> Tapez C-x C-b pour obtenir la liste des buffers. + +Remarquez que chaque buffer a un nom, et qu'il peut aussi avoir un nom +de fichier dans le cas où un fichier lui est associé. Il extsite des +buffers non attachés à des fichiers, par exemple, le buffer nommé +«*Buffer List*». C'est le buffer qui a été créé par la commande C-x +C-b. Par contre, TOUT texte que vous pouvez voir dans Emacs appartient +à un buffer. + +>> Tapez C-x 1 pour faire disparaître le buffer contenant la liste des + buffers. + +Quand vous éditez un fichier, puis que vous en ouvrez un autre, le +fichier précédent n'a pas été sauvé. Tous les changements effectués +sont conservés dans le buffer associé au fichier, mais l'ouverture +et l'édition d'un nouveau fichier n'ont aucun effet sur le +premier. Vous constatez donc qu'il serait ennuyeux d'avoir à revenir +au premier fichier pour le sauver avec C-x C-s. Pour éviter ce +désagrément, il existe une autre commande: + + C-x s (Sauver certains buffers) + +C-x s vous demandera, pour chaque buffer contenant des modifications +non sauvegardées, si vous désirez le sauver ou non. + +>> Insérez une ligne de texte, puis tapez C-x s + Emacs vous demandera si vous désirez sauver le buffer nommé + TUTORIAL.FRANCAIS. + Répondez «oui» à la question en tapant 'y'. + + +* UTILISATION DES MENU +---------------------- + +Si vous travaillez sur un terminal X, vous avez déjà remarqué une +barre de menu en haut de la fenêtre d'Emacs. Cette barre de menu vous +permet d'accéder à la plupart des commandes d'Emacs comme celles +permettant d'ouvrir ou de sauver un fichier. L'utilisation de la barre +de menu vous semblera plus facile au début, puis quand vous serez +habitué à Emacs, il vous sera facile d'utiliser les commandes au +clavier, car chaque commande figurant dans un menu affiche également +son équivalent clavier sur le bouton. + +Remarquez qu'il existe des boutons n'ayant aucun équivalent +clavier. Par exemple, le menu «Buffers» donne la liste de tous les +buffers par ordre de plus récente utilisation. Vous pouvez passer d'un +buffer à l'autre en les sélectionnant par leur nom dans ce menu. + + +* UTILISATION DE LA SOURIS +-------------------------- + +Quand vous travaillez sous X, Emacs utilise pleinement la souris. Vous +pouvez vous positionner dans le texte en cliquant avec le bouton de +gauche à l'endroit souhaité, vous pouvez sélectionner du texte en +déplaçant la souris avec le bouton de gauche enfoncé, ou bien en +cliquant le bouton de gauche au début de la portion à sélectionner, +puis en Shift-cliquant à l'autre bout. + +Pour supprimer un morceau de texte, utilisez C-w ou le bouton «Cut» du +menu «Edit». Notez bien que ces deux commandes ne sont pas +équivalentes: C-w ne fait que supprimer le texte en le sauvegardant de +manière interne (comme C-k), mais «Cut» sauvegarde en plus le texte +dans le clipboard de X Window, où il pourra être accédé par d'autres +applications. + +Pour récupérer du texte en provenance d'autres applications, utilisez +«Paste» du menu «Edit». + +Le bouton du milieu sert principalement à choisir des objets visibles +dans les fenêtres d'Emacs. Par exemple, si vous entrez dans «Info» (le +système de documentation en ligne) en tapant C-h i ou en utilisant le +menu «Help», vous pourrez suivre un lien surligné en cliquant dessus +avec le bouton du milieu. De la même manière, si vous commencez à +taper un nom de fichier après avoir fait C-x C-f, et que vous appuyez +sur <Tab> en cours de route, Emacs vous ouvrira une fenêtre avec +toutes les complétions possibles, et vous pourrez en sélectionner une +grâce au bouton du milieu. + +Le bouton droit fait apparaître un menu. Le contenu de ce menu varie +en fonction du mode dans lequel vous vous trouvez, et contient en +général quelques commandes fréquemment utilisées. + +>> Cliquez avec le bouton de droite pour voir le menu en question. + +Si vous relâchez le bouton, le menu disparaît. + + +* EXTENSION DE L'ENSEMBLE DES COMMANDES +--------------------------------------- + +Il existe bien plus de commandes dans Emacs que l'on ne pourrait en +associer aux touches <Control> et <Meta>. Pour remédier à cela, Emacs +utilise la commande X (eXtension) qui se présente sous deux aspects: + + C-x Extension par caractère (suivit d'un caractère). + M-x Extension par nom (suivit d'un nom de commande). + +Ces commandes, bien que très utiles, sont utilisées moins souvent que +celles que vous avez déjà apprises. Vous en connaissez déjà deux: les +commandes relatives aux fichiers (C-x C-f et C-x C-s). Un autre +exemple est la commande pour quitter définitivement Emacs, C-x C-c (ne +vous inquiétez pas des éventuels changements qui seraient perdus, C-x +C-c vous propose de sauver ces changements avant de tuer Emacs). + +C-z est la commande qui vous permet de quitter Emacs «temporairement», +pour que vous puissiez y revenir plus tard. + +Sur les systèmes le permettant, C-z «suspend» Emacs, ce qui signifie +que l'on retourne au shell sans tuer Emacs. Dans la plupart des cas, +vous pouvez revenir à Emacs en tapant 'fg' ou '%emacs'. + +Sur les systèmes ne permettant pas la suspension de processus, cette +commande créé un sous-shell qui continue à exécuter Emacs, vous +donnant ainsi la possibilité de faire tourner d'autres programmes et +revenir à Emacs plus tard. Dans ce cas, la commande shell 'exit' est +la manière habituelle de retourner au sous-shell d'Emacs. + +Vous utiliserez C-x C-c quand le moment sera venu de vous déloguer ou +d'éteindre la machine. C'est aussi la bonne manière de sortir d'Emacs +si celui-ci a été lancé depuis un maileur ou tout autre utilitaire, +ceux-ci ne sachant pas forcément comment gérer les suspensions. Dans +des circonstances où vous ne vous déloguez pas, mieux vaut suspendre +par C-z au lieu de sortir véritablement d'Emacs. + +Il existe de nombreuses commandes sous C-x. Voici celles que vous avez +apprises jusque là: + + C-x C-f Visiter un fichier (Find File). + C-x C-s Sauver un fichier (Save File). + C-x C-b Lister les buffers (List buffers). + C-x C-c Quitter Emacs (Quit Emacs). + C-x u Annuler Opération (Undo). + +Les commandes étendues par nom sont des commandes utilisées très peu +souvent, ou disponibles seulement sous certains modes. Par exemple, la +commande «replace-string» substitue globalement une chaîne de +caractères par une autre. Si vous tapez M-x, Emacs vous affichera M-x +en bas de la fenêtre et vous pourrez alors taper le nom d'une +commande, ici replace-string. Tapez simplement 'repl <Espace> s <Tab>' +et Emacs complétera le nom pour vous. Terminez le nom avec <Return> + +La commande replace-string requiert deux arguments: la chaîne à +remplacer et la chaîne de remplacement. Terminez chacune de ces +chaînes par <Return>. + +>> Déplacez le curseur sur la ligne blanche en dessous de ce + paragraphe, puis tapez + M-x repls<Return>Remarquez<Return>Notez<Return>. + + Remarquez comme cette ligne a changé: le mot R-e-m-a-r-q-u-e-z a + été remplacé par N-o-t-e-z partout où il est apparu après le + curseur. + + +* SAUVEGARDE AUTOMATIQUE +------------------------ + +Si votre système crashe alors que certaines modifications n'étaient +pas sauvées, vous perdez des donnés. Pour remédier à ce problème, +Emacs sauvegarde périodiquement tous vous fichiers, et cela de manière +automatique. Ce fichier de sauvegarde est appelé «auto save». Son nom +commence et se termine par un '#'. Par exemple, un fichier auto save +de 'hello.c' a pour nom '#hello.c#'. Quand vous sauvez le fichier de +manière normale, le fichier auto save est effacé. + +Si votre ordinateur crashe, vous pouvez restaurer la sauvegarde en +ouvrant le fichier normalement (le VRAI fichier, pas l'auto save), +puis en tapant M-x recover-file<Return>. Répondez 'yes<Return>' à la +question. + + +* ZONE D'ÉCHO +------------- + +Quand Emacs constate que vous tapez lentement, il vous montre ce que +vous avez tapez en bas de la fenêtre, dans la zone d'écho («echo +area»). Cette zone contient la dernière ligne de la fenêtre d'Emacs. + + +* LIGNE DE MODE +--------------- + +La ligne juste au dessus de la zone d'écho s'appelle ligne de mode +(«modeline»). Elle dit actuellement quelque chose comme ça: + +--**-XEmacs: TUTORIAL.FRANCAIS (Fundamental)--L752--67%--------- + +Cette ligne fournit des renseignements utiles sur le status d'Emacs et +le texte que vous éditez. + +Vous connaissez déjà la signification du nom de fichier: c'est celui +que vous êtes en train d'éditer. -xx%- indique le pourcentage de texte +situé au dessus du curseur. Si vous pouvez voir le début du fichier à +l'écran, --Top-- sera indiqué au lieu de --00%--. Si le bas du fichier +est visible, il y aura --Bot-- à la place. Si votre texte est tout +entier contenu dans la fenêtre, vous verrez --All--. + +Les étoiles '*' au début signifient que vous avez fait des changements +au texte. Quand vous ouvrez le fichier, ou après l'avoir sauvé, il n'y +aura plus d'étoiles, mais juste des tirets. + +La partie entre parenthèses vous indique dans quel mode d'édition vous +vous trouvez. Le défaut (que vous utilisez en ce moment) est le mode +«Fundamental». C'est un exemple de Mode Majeur («major mode»). + +Il existe de nombreux modes majeurs. Certains sont faits pour éditer +différents langages, différentes sortes de texte, du Lisp, du C etc. +Il ne peut y avoir qu'un mode majeur actif à la fois, et son nom se +trouve sur la ligne de mode (là ou vous voyez «Fundamental» en ce +moment). + +Chaque mode fait certaines commandes se comporter différemment. Par +exemple, la commande pour créer des commentaires dans un programme +tient compte des différents caractères de commentaire des +langages. Chaque mode majeur est le nom d'une commande étendue. Par +exemple la commande M-x fundamental-mode vous place en mode +fondamental. + +Si vous voulez éditer du texte en français, vous devriez plutôt +choisir le mode Text. + +>> Tapez M-x text-mode<Return> + +Pas d'inquiétude: les commandes que vous avez apprises jusqu'ici ne +sont pas radicalement différentes d'un mode à l'autre. Mais vous +pouvez constater par exemple que M-b et M-f traitent les apostrophes +comme faisant partie des mots. Auparavant, ces caractères étaient +considérés comme des séparateurs de mots. En général, les modes +majeurs ne changent que très peu le comportement des commandes +habituelles. + +Pour voir la documentation du mode majeur courant, tapez C-h m. + +>> Utilisez C-u C-v pour amener cette ligne vers le haut de l'écran. +>> Tapez C-h m, pour voir les différences entre les mode Fundamental + et Text. +>> Tapez 'q' pour faire disparaître la documentation. + +Les modes majeurs sont appelés «majeurs» parce qu'il y en a aussi des +«mineurs». Les modes mineurs n'altèrent que partiellement le +comportement de tel ou tel mode majeur. Ils peuvent être activés ou +désactivés indépendamment du mode majeur courant. Vous pouvez en +utiliser autant que possible en même temps. + +Un mode mineur très utile pour éditer du texte est le mode +«Auto Fill». Quand ce mode est activé, Emacs coupe lui-même les lignes +si vous tapez du texte trop long pour être contenu sur une seule. + +Pour activer ce mode, tapez M-x auto-fill-mode<Return>. Cette commande +sert à le désactiver ou à l'activer selon son status actuel; elle +intervertit son état d'activation. + +>> Tapez M-x auto-fill-mode<Return>. Insérez maintenant une quantité + de «aslidfhw» jusqu'à voir que votre ligne se divise + automatiquement en deux, à un endroit où il y avait un espace. + +La marge est en général à 70 caractères, mais vous pouvez la changer +grâce à la commande C-x f. Donner la marge requise comme argument +numérique. + +>> Tapez C-x f avec un argument de 20 (C-u 2 0 C-x f). + Tapez du texte jusqu'à ce que la ligne soit coupée, puis replacez + la marge à 70. + +Si vous faites des changements au milieu d'un paragraphe, le mode Auto +Fill ne recoupera pas les lignes tout seul. Pour réajuster les lignes +d'un tel paragraphe, tapez M-q avec le curseur n'importe où dans le +paragraphe. + +>> Déplacez le curseur dans le paragraphe précédent, et tapez M-q. + + +* RECHERCHE +----------- + +Emacs est capable de rechercher des chaînes de caractères aussi bien +en avant qu'en arrière dans un texte. Ces commandes sont en fait des +commandes de déplacement du curseur. Elles déplacent le curseur au +prochain (ou précédent) endroit ou la chaîne apparaît. + +La commande de recherche d'Emacs est un peu différente de celle des +autres éditeurs de texte dans la mesure où elle est incrémentale: la +recherche intervient au fur et à mesure que vous tapez la chaîne à +rechercher. + +Pour démarrer une recherche, tapez C-s (en avant) ou C-r (en +arrière). MAIS PAS TOUT DE SUITE !! Attendez un peu pour tester ... + +Après avoir tapé C-s, vous constaterez que la chaîne «I-search» +apparaît comme prompt dans la zone d'écho. Cela vous indique qu'Emacs +est en mode de recherche incrémentale, et qu'il attend que vous +entriez la chaîne à rechercher. <Return> termine la chaîne. + +>> Tapez C-s, et entrez LENTEMENT, une lettre à la fois, le mot + «curseur», en regardant bien ce qu'il se produit. + À ce stade, vous avez cherché le mot «curseur» une fois. +>> Tapez C-s à nouveau, pour chercher la prochaine occurrence du mot. +>> Maintenant, tapez <Delete> quatre fois et regardez comment le + curseur se déplace. +>> Tapez <Return> pour terminer la recherche. + +En mode incrémental, Emacs recherche ce que vous avez tapé jusqu'ici, +en surlignant les occurrences trouvées. Si aucune (nouvelle) occurrence +n'existe, C-s produira un «bip», et la zone d'écho affichera +«failing». C-g terminerait aussi bien la recherche. + +NOTE: Sur certains systèmes, C-x C-s bloque l'écran et Emacs ne dit +plus rien. Cela signifie qu'une «fonctionnalité» système que l'on +appelle le «flow control» intercepte le C-s et l'empêche de parvenir à +Emacs. Pour débloquer la situation, tapez C-q. Reportez-vous dans ce +cas à la section «Spontaneous Entry to Incremental Search» du manuel +d'Emacs pour plus d'information sur cette ... «particularité». + +Si vous êtes au milieu d'une recherche incrémentale et que vous tapez +<Delete>, vous constaterez que le dernier caractère de la chaîne est +effacé, et que Emacs retourne à l'occurrence précédente. Si d'autre +part vous tapez un caractère <Control> ou <Meta> (mises à part +quelques exceptions comme les caractères spéciaux pour la recherche, +C-s et C-r), la recherche sera terminée. + +Rappelez vous que si C-s cherche une chaîne APRÈS le curseur, C-r la +recherche AVANT. Tout ce que nous venons de dire sur C-s s'applique à +C-r. + + +* FENÊTRES MULTIPLES +-------------------- + +Un des avantages d'Emacs est que vous pouvez afficher plusieurs +fenêtres à la fois sur l'écran. + +>> Déplacez le curseur sur cette ligne, et tapez C-u 0 C-l ('L' pas '1') + +>> Maintenant tapez C-x 2 pour obtenir deux fenêtres. + Les deux fenêtres affichent le tutoriel. Le curseur reste en haut. + +>> Tapez C-M-v (ou <Esc> C-v) pour dérouler la fenêtre du bas. + +>> Tapez C-x o (o pour ôtre ...) pour placer le curseur dans la + fenêtre du bas. +>> Utilisez C-v et M-v pour dérouler la fenêtre. + Continuez de lire dans celle du haut. + +>> Tapez C-x o pour retourner dans la fenêtre du haut. + Le curseur est exactement à la même place que quand vous aviez + quitté cette fenêtre. + +Vous pouvez continuer d'utiliser C-x o pour passer d'une fenêtre à +l'autre. Chaque fenêtre a sa propre position du curseur, mais une +seule fenêtre a la fois contient réellement le curseur. Toutes les +commandes ordinaires d'édition prennent effet dans la fenêtre qui +contient le curseur. On dit que cette fenêtre est «sélectionnée». + +La commande C-M-v est très utile quand vous éditez un texte dans une +fenêtre et que vous vous servez d'une autre en guise de +référence. Vous pouvez avancer dans l'autre grâce à C-M-v. + +C-M-v (ou <Esc> C-v si vous n'avez pas de touche <Meta>) est un +exemple de Control-Méta caractère. L'ordre dans lequel les touches +<Control> et <Meta> sont enfoncées n'a pas d'importance. Ce sont juste +des modificateurs. Par contre, <Esc> n'est pas un modificateur, donc +vous êtes obligés de taper d'abord <Esc>, et C-v ensuite. + +>> Tapez C-x 1 dans la fenêtre du haut pour éliminer celle du bas. + +C-x 1 élimine en fait toutes les fenêtres non sélectionnées. + +Les fenêtres peuvent bien entendu contenir des buffers différents. Si +vous utilisez C-x C-f pour ouvrir un fichier dans l'une des fenêtres, +l'autre ne change pas. Elles sont totalement indépendantes. + +Voici une autre manière d'ouvrir un fichier dans l'autre fenêtre: + +>> Tapez C-x 4 C-f suivit du nom d'un fichier, puis <Return>. + Vous verrez le fichier apparaître dans l'autre fenêtre. Le curseur + ira également dans cette fenêtre. + +>> Tapez C-x o pour remonter à la fenêtre du haut, puis C-x 1 pour + éliminer celle du bas. + + +* NIVEAUX D'ÉDITION RÉCURSIFS +----------------------------- + +De temps en temps, vous vous trouverez dans ce qu'on appelle des +niveaux d'édition récursifs. Ceci est indiqué dans la ligne de mode +par des crochets autour des parenthèses qui englobent le nom du mode +majeur. Par exemple, vous pouvez voir [(Fundamental)] au lieu de +(Fundamental). + +Pour sortir d'un niveau récursif d'édition, tapez <Esc> <Esc> +<Esc>. C'est un «siège éjectable» à usage multiple. Vous pouvez aussi +l'utiliser pour sortir du minibuffer ou éliminer des fenêtres +superflues. + +>> Tapez M-x pour vous rendre dans le minibuffer, puis tapez + <Esc> <Esc> <Esc> pour en sortir. + +Il n'est pas possible d'utiliser C-g pour sortir d'un niveau récursif +d'édition. La raison en est que C-g sert à annuler des commandes au +sein même d'un niveau récursif d'édition. + + +* POUR OBTENIR PLUS D'AIDE +-------------------------- + +Dans ce tutoriel, nous avons essayé de vous fournir assez de +connaissance pour commencer à utiliser Emacs. Emacs est tellement +riche en possibilités qu'il serait impossible de tout dire +ici. Cependant, vous souhaiterez surement à un moment ou un autre +avoir plus de renseignements sur ses énormes possibilités. Emacs +comprend entre autres des commandes d'aide sur sa propre +utilisation. Toutes ces commandes d'aide commencent par le préfixe +C-h, le «caractère d'aide». + +Typiquement, vous tapez C-h, puis un caractère indiquant quelle aide +vous souhaitez obtenir. Si vous êtes VRAIMENT perdu, tapez C-h ? et +Emacs vous indiquera quelles sortes d'aide il peut vous fournir. Si +vous ne désirez finalement pas d'aide après avoir tapé C-h, tapez +simplement C-g. + +(Quelques sites redéfinissent la commande C-h. Cela ne devrait vraiment +pas être fait, donc allez vous plaindre à votre administrateur système. +Si C-h ne marche pas, tapez M-x help<Return>.) + +L'aide de base est C-h c. Tapez C-h c puis une commande (même une +séquence comme C-x f), et Emacs vous donnera une brève description de +la commande en question. + +>> Tapez C-h c C-p. + Le message doit ressembler à quelque chose comme + + C-p runs the command previous-line + +Cela vous donne le «nom de la fonction». Les noms de fonctions sont +principalement utilisés pour customiser Emacs, mais comme en général +ils sont choisi de manière à indiquer ce que fait la commande, ils +peuvent servir de courte documentation (au moins pour vous rappeler +les commandes que vous avez déjà apprises). + +Pour de plus amples informations sur les commandes, utilisez C-h k au +lieu de C-h c. + +>> Tapez C-h k C-p. + +Ceci affiche la documentation sur la fonction, ainsi que son nom dans +une autre fenêtre. Quand vous avez fini de lire, tapez 'q' pour +éliminer la fenêtre d'aide. + +Voici d'autres aides utiles: + + C-h f Décrire une fonction. Vous donnez son nom. + +>> Tapez C-h f previous-line<Return>. + Cela vous donne toute l'information dont Emacs dispose sur la + fonction appelée par la commande C-p. + + C-h a Hyper Apropos. Tapez un mot-clé et Emacs vous + affichera toutes les fonctions ou variables contenant + ce mot-clé. Les commandes que vous pouvez appeler + grâce à M-x ont un astérisque à gauche de leur nom. + +>> Tapez C-h a newline<Return>. + +Tapez <Return> pour effacer l'à-propos, ou cliquez avec le bouton du +milieu sur un nom pour obtenir l'aide sur cette fonction ou variable. + + +* CONCLUSION +------------ + +Rappelez-vous bien, pour quitter définitivement Emacs, tapez C-x +C-c. Pour quitter temporairement (et pour pouvoir revenir), tapez C-z +(sous X Windows, C-z iconifie la fenêtre). + +Ce tutoriel est fait pour être compréhensible par tout nouvel +utilisateur. Donc si quelque chose n'est pas clair, n'hésitez pas à +vous plaindre !! + +Si vous avez plus particulièrement des remarques à faire sur la +version française, vous pouvez aussi me contacter directement +(Didier Verna <verna@inf.enst.fr>). + + +COPIES / DISTRIBUTION +--------------------- + +Un peu d'histoire ... + +* Le premier tutoriel pour l'Emacs d'origine fut écrit par Stuart + Cracraft. +* Ben Wing l'a mis à jour pour X Windows. +* Martin Buchholz et Hrvoje Niksic y ont apporté des corrections pour + XEmacs. +* J'en (Didier Verna) ai fait une version française un beau jour de 1997. + +Cette version du tutoriel, tout comme Emacs, est copyrightée, et vous +est fournie avec la permission d'en distribuer des copies sous +certaines conditions (je laisse la notice du copyright en anglais): + +Copyright (c) 1997, Didier Verna. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +Les conditions pour copier Emacs lui-même sont plus complexes, mais +dans le même état d'esprit. Vous êtes conviés à lire le fichier +COPYING et à distribuer Emacs à vos amis. Aidez-nous à tuer +l'obstructionnisme logiciel en utilisant, écrivant et partageant du +logiciel libre! +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.hr Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1128 @@ +Copyright (c) 1985, 1996 Free Software Foundation, Inc. Uvjeti +kopiranja na kraju. + +Ovo su osnovne upute za Emacs. + +Opæenito, Emacsove naredbe sadr¾e tipku CONTROL (ponekad oznaèenu CTRL +ili CTL) ili tipku META. Na nekim tipkovnicama tipka META je oznaèena +kao ALT ili EDIT, ili ne¹to treæe (na primjer, na Sunovim tipkovnicama +karo znak lijevo od razmaknice je META). Ako nemate tipku META, +umjesto nje mo¾ete koristiti ESC. Da ne pi¹emo META ili CONTROL svaki +put kad mislimo na prefiksnu tipku, koristit æemo sljedeæe skraæenice: + + C-<znak> znaèi dr¾eæi tipku CONTROL, stisnite znak <znak>. Tako bi + C-f bilo: Dr¾eæi tipku CONTROL, napi¹ite f. + M-<znak> znaèi dr¾eæi tipku META, pritisnite <znak>. Ako nema tipke + META, pritisnite <ESC>, otpustite ga, i napi¹ite znak + <znak>. + +Napomena: za izlazak iz Emacsa, utipkajte C-x C-c. (Dva znaka.) +Znakovi ">>" na lijevom rubu naznaèuju uputstva da poku¹ate koristiti +neku naredbu. Na primjer: +<<Blank lines inserted here by startup of help-with-tutorial>> +>> Sad utipkajte C-v za pomak na sljedeæi ekran. + (samo naprijed, uèinite to tako da dr¾ite tipku control i + pritisnite 'v'). Od sad, ovo trebate napraviti kad god zavr¹ite + sa èitanjem stranice teksta. + +Uoèite dva reda koja se preklapaju kad se pomaknete s ekrana na ekran; +preklapanje osigurava kontinuitet koji vam olak¹ava èitanje teksta. + +Prva stvar koju trebate znati jest kako se micati s mjesta na mjesto u +tekstu. Veæ znate kako se pomaknuti ekran naprijed, pomoæu C-v. Da +biste se pomakli ekran natrag, pritisnite M-v (dr¾ite tipku META i +pritisnite v, ili upi¹ite <ESC>v ako nemate tipke META, EDIT ili ALT). + +>> Poku¹ajte tipkati M-v, zatim C-v, nekoliko puta. + + +* SA®ETAK +--------- + +Sljedeæe naredbe su korisne za pregledavanje stranica teksta: + + C-v Pomièe stranicu naprijed + M-v Pomièe stranicu natrag + C-l Bri¹e ekran, i ponovno iscrtava sve, stavljajuæi tekst + pokraj kursora u sredinu. + (to je control-L, a ne control-1.) + +>> Naðite kursor, i pogledajte tekst pokraj njega. + Sada stisnite C-l. + Opet naðite kursor, i uoèite da se pokraj kursora nalazi isti + tekst. + + +* OSNOVE KONTROLE KURSORA +------------------------- + +Pomaci s ekrana na ekran su korisni, ali kako se pomaknuti na pojedino +mjesto u tekstu na ekranu? + +To mo¾ete uèiniti na nekoliko naèina. Najosnovniji naèin je +upotrijebiti naredbe C-p, C-b, C-f i C-n. Svaka od ovih naredbi +pomièe kursor jedan redak ili stupac u pojedinom smjeru. Evo tablice +koja pokazuje ove èetiri naredbe i smjerove u kojem pomièu. + + Prethodni red, C-p + (eng. previous line) + : + : + Natrag, C-b .... Trenutni polo¾aj kursora .... Naprijed, C-f + (eng. backward) : (eng. forward) + : + Sljedeæi red, C-n + (eng. next line) + +>> Pomaknite kursor do retka u sredini tablice koristeæi C-n i C-p. + Tada stisnite C-l da vidite cijelu tablicu u sredi¹tu ekrana. + +Ove su naredbe temeljene na engleskim mnemonicima: P za previous, N za +next, B za backward i F za forward. Ovo su osnovne naredbe za +pomicanje kursora, i s vremenom æete ih SVE koristiti, pa bi bilo vrlo +korisno da ih sada nauèite. + +>> Stisnite C-n nekoliko puta, tako da dovedete kursor do ovog retka. + +>> Pomaknite se na red s C-f-ovima, i onda gore do C-p-ova. + Uoèite ¹to C-p radi kad je kursor na sredini reda. + +Svaki red teksta zavr¹ava znakom Newline (novi red), èime ga se odvaja +od sljedeæeg reda. Zadnji red u datoteci bi trebao imati Newline na +kraju (ali Emacs to ne zahtijeva). + +>> Poku¹ajte stisnuti C-b na poèetku reda. Trebalo bi vas pomaknuti + na kraj prethodnog reda. To se dogaða zato ¹to ste se pomakli + unatrag, preko znaka Newline. + +C-f se mièe preko Newline-a, ba¹ kao i C-b. + +>> Pritisnite jo¹ nekoliko puta C-b, da steknete osjeæaj za kursor. + Tad sti¹æite C-f dok se ne vratite na kraj reda. + Zatim se jo¹ jednim C-f-om pomaknite na poèetak sljedeæeg reda. + +Kad se pomaknete preko gornjeg ili donjeg ruba ekrana, tekst iza ruba +se pomakne na ekran. Ovo se naziva "pomak" (eng. scrolling). Njime +Emacs mo¾e pomaknuti kursor na neko mjesto u tekstu bez uklanjanja +kursora s ekrana. + +>> Poku¹ajte pomaknuti kursor s donjeg ruba sa C-n, i pogledajte ¹to + se dogaða. + +Ako je micanje po znakovima presporo, mo¾ete se micati po rijeèima. +M-f (Meta-f) mièe rijeè naprijed, a M-b mièe rijeè natrag. + +>> Pritisnite nekoliko puta M-f i M-b. + +Kad se nalazite u sredini rijeèi, M-f pomièe na kraj rijeèi. Kad se +nalazite u praznom prostoru izmeðu rijeèi, M-f pomièe na kraj sljedeæe +rijeèi. M-b se pona¹a na isti naèin, ali u suprotnom smjeru. + +>> Pritisnite M-f i M-b nekoliko puta, izmije¹ano s C-f i C-b, tako da + mo¾ete promotriti kako se M-f i M-b pona¹aju na razlièitim mjestima + unutar i izmeðu rijeèi. + +Uoèite paralelu izmeðu C-f i C-b na jednoj strani, i M-f i M-b na +drugoj. Meta znakovi se èesto koriste za operacije vezane uz jedinice +definirane jezikom (rijeèi, reèenice, paragrafi), dok Control znakovi +rade na osnovnim jedinicama, neovisno o onome ¹to editirate (znakovi, +redovi, itd.) + +Analogija vrijedi i izmeðu redova i reèenica: C-a i C-e pomièu na +poèetak, odnosno na kraj reda, dok M-a i M-e pomièu na poèetak, odnosno +kraj reèenice. + +>> Isku¹ajte C-a nekoliko puta, potom C-e nekoliko puta. +>> Iskupajte M-a nekoliko puta, potom M-e nekoliko puta. + +Uoèite kako ponovljeni C-a ne rade ni¹ta, dok ponovljeni M-a +nastavljaju micati po reèenicama. Iako ovo nije sasvim analogno, +svaka se naredba doima prirodnom. + +Polo¾aj kursora u tekstu se takoðer naziva "toèka" (eng. point). +Drugaèije reèeno, kursor pokazuje na ekranu gdje se point nalazi u +tekstu. + +Evo sa¾etka jednostavnih operacija za micanje kursora, ukljuèujuæi i +naredbe za pomicanje preko rijeèi i reèenica: + + C-f Znak naprijed + C-b Znak natrag + + M-f Rijeè naprijed + M-b Rijeè natrag + + C-n Sljedeæi red + C-p Prethodni red + + C-a Poèetak reda + C-e Kraj reda + + M-a Poèetak reèenice + M-e Kraj reèenice + +>> Isku¹ajte sve ove naredbe jo¹ nekoliko puta, za vje¾bu. + To su najèe¹æe rabljene naredbe. + +Dvije druge va¾ne naredbe za pomicanje kursora su M-< (Meta Manje), +koja pomièe na poèetak cijelog teksta, i M-> (Meta Veæe), koja pomièe +na kraj cijelog teksta. + +Na veæini terminala, "<" je iznad zareza, tako da morate koristiti +tipku shift da biste ga utipkali. Na tim terminalima morate koristiti +tipku shift i da biste utipkali M-<; bez shifta, pisali biste M-zarez. + +>> Sada isku¹ajte M-<, da biste se pomaknuli na poèetak uputa. + Potom upotrijebite C-v nekoliko puta da se vratite ovamo. + +>> Sada isku¹ajte M->, pomaknuv¹i se na kraj uputa. + Potom upotrijebite M-v nekoliko puta da se vratite ovamo. + +Ako va¹ terminal ima kursorske tipke, mo¾ete kursor pomicati njima. +Preporuèujemo da nauèite C-b, C-f, C-n i C-p iz tri razloga. Prvo, +rade na svim vrstama terminala. Drugo, kad steknete rutinu kori¹tenja +Emacsa, primijetit æete da je tipkanje ovih CTRL znakova br¾e od +uporabe kursorskih tipki (jer ne morate odmicati prste od polo¾aja za +tipkanje). Treæe, jednom kad se naviknete koristiti CTRL znakovne +naredbe, lako æete nauèiti koristiti druge napredne naredbe za micanje +kursora. + +Veæina Emacsovih naredbi prihvaæa numerièki argument; za veæinu njih +ovo slu¾i kao brojaè ponavljanja. Brojaè ponavljanja zadajete tako da +utipkate C-u i potom znamenke prije nego ¹to utipkate naredbu. Ako +imate tipku META (ili EDIT ili ALT), postoji jo¹ jedan alternativan +naèin uno¹enja numerièkog argumenta: tipkajte znamenke dr¾eæi svo vrijeme +tipku META. Preporuèujemo uèenje metode pomoæu C-u, jer radi na svim +terminalima. + +Primjerice, C-u 8 C-f pomièe osam znakova naprijed. + +>> Poku¹ajte koristiti C-n ili C-p s numerièkim argumentom, tako da + pomaknete kursor na liniju blisku ovoj samo jednom naredbom. + +Veæina naredbi koristi numerièki argument kao brojaè ponavljanja. +Neke ga naredbe, izunimno, koriste drugaèije. C-v i M-v su meðu +iznimkama. Kad im se proslijedi argument, one pomaknu ekran gore ili +dolje, za toliko redova, a ne stranica. Na primjer, C-u 4 C-v pomièe +ekran za èetiri reda. + +>> Sada poku¹ajte upisati C-u 8 C-v. + +Ovo je trebalo pomaknuti ekran za 8 redova. Ako ga hoæete pomaknuti +natrag, mo¾ete dati isti argument M-v. + +Ako koristite X Window sistem, vjerojatno se na desnoj strani Emacsova +prozora nalazi pravokutno podruèje nazvano "vrpca za pomicanje" +(eng. scroll-bar). Mo¾ete pomicati tekst mi¹em povlaèeæi klizaè +unutar vrpce. + +>> Poku¹ajte pritisnuti srednju tipku mi¹a na vrh klizaèa unutar + scroll-bara. Ovo bi trebalo pomaknuti tekst do polo¾aja odreðenog + visinom toèke pritiska. + +>> Pomaknite mi¹a na toèku scroll-bara otprilike tri reda od vrha, i +pritisnite lijevu tipku mi¹a nekoliko puta. + + +* KONTROLA KURSORA NA X TERMINALU +--------------------------------- + +Ako imate X terminal, vjerojatno æe vam biti lak¹e koristiti tipke +kursorskog bloka. Lijeva, desna, gornja i donja strelica pomièu u +oèekivanom smjeru; one funkcioniraju jednako kao i C-b, C-f, C-p i +C-n, ali ih je lak¹e tipkati i zapamtiti. Takoðer mo¾ete koristiti +C-lijevo i C-desno za pomake po rijeèima, a C-gore i C-dolje za pomake +po blokovima (npr. paragrafima, ako editirate tekst). Ako imate tipke +oznaèene s HOME (ili BEGIN) i END, one æe vas pomaknuti na poèetak +odnosno kraj reda, a C-home i C-end æe vas pomaknuti na poèetak +odnosno kraj datoteke. Ako va¹a tipkovnica ima tipke PgUp i PgDn, +mo¾ete ih koristiti za pomicanje gore i dolje po stranicama, kao M-v i +C-v. + +Sve ove naredbe mogu primiti numerièke argumente, kao ¹to je gore +opisano. Mo¾ete taj argument unijeti kraæim putem: samo dr¾ite tipku +CONTROL ili META, i upi¹ite broj. Na primjer, za pomak 12 rijeèi +desno, tipkajte C-1 C-2 C-desno. Uoèite da je ovo jako lako utipkati, +jer ne morate otpu¹tati tipku CONTROL izmeðu pritisaka tipki. + + +* KAD EMACS BLOKIRA +------------------- + +Ako Emacs prestane odgovarati na va¹e naredbe, mo¾ete ga zaustaviti +utipkav¹i C-g. Mo¾ete koristiti C-g da zaustavite naredbu koja predugo +traje. + +Takoðer s C-g mo¾ete odbaciti numerièki argument, ili poèetak naredbe +koju ne ¾elite zavr¹iti. + +>> Upi¹ite C-u 100 da napravite numerièki argument 100, zatim stisnite C-g. + Sad upi¹ite C-f. Pomaknut æe se samo za jedan znak, jer ste + argument odbacili s C-g. + +Ako gre¹kom stisnete <ESC>, mo¾ete ga se rije¹iti s C-g. + + +* ONEMOGUÆENE NAREDBE +--------------------- + +Neke Emacsove naredbe su "onemoguæene", tako da ih poèetnici ne mogu +pokrenuti gre¹kom. + +Ako utipkate jednu od onemoguæenih naredbi, Emacs æe vas porukom +obavijestiti koju ste naredbu poku¹ali pokrenuti, i pitati vas ¾elite +li je ipak izvr¹iti. + +Ako je zaista ¾elite isprobati, pritisnite razmaknicu kao odgovor na +pitanje. Inaèe, ako ne ¾elite izvr¹iti onemoguæenu naredbu, +odgovorite na pitanje s "n". + +>> Pritisnite `C-x n p' (¹to je onemoguæena naredba), + zatim na pitanje odgovorite s "n". + + +* PROZORI +--------- + +Emacs mo¾e imati nekoliko prozora, svaki s vlastitim tekstom. Uoèite +da se pojam "prozora" kako ga koristi Emacs ne odnosi na odvojene +preklapajuæe prozore windowing sustava, veæ na razdvojene dijelove +unutar jednog X prozora. (Emacs takoðer mo¾e prikazati vi¹e X +prozora, odnosno "okvira", u Emacsovoj terminologiji. To je opisano +kasnije.) + +Za sada je bolje ne ulaziti u tehnike kori¹tenja vi¹e prozora. Ono +¹to trebate znati jest kako se rije¹iti dodatnih prozora koji se mogu +javiti za prikaz pomoæi, ili kao izlaz nekih naredbi. +Jednostavno: + + C-x 1 Jedan prozor (tj. ubij sve druge prozore) + +To je Control-x praæen znamenkom 1. C-x 1 pro¹iruje prozor u kojem je +kursor, tako da on zauzme cijeli ekran. Pobri¹e, takoðer, i ostale +prozore. + +>> Pomaknite kursor na ovu liniju i upi¹ite C-u 0 C-l. + +(Sjetite se da C-l ponovno iscrtava ekran. Ako ovoj naredbi date +numerièki argument, on znaèi "iscrtaj ekran i smjesti trenutni red +toliko linija od vrha ekrana." Tako C-u 0 C-l znaèi "iscrtaj ekran, i +stavi trenutni red na vrh.") + +>> Pritisnite Control-x 2 + Uoèite kako se ovaj prozor smanjuje, dok se novi pojavljuje + prikazujuæi sadr¾aj ovog spremnika (buffera). + +>> Upi¹ite C-x 1 i gledajte kako novi prozor nestaje. + + +* UMETANJE I BRISANJE +--------------------- + +®elite li umetnuti tekst, samo ga utipkajte. Znakove koje vidite, kao +¹to su A, 7, *, itd. Emacs shvaæa kao tekst i umeæe trenutno. +Pritisnite <Return> (znak za novi red) da umetnete znak Newline. + +Zadnji znak koji ste umetnuli mo¾ete izbrisati pritisnuv¹i <Delete>. +<Delete> je tipka na tipkovnici koja mo¾e biti oznaèena kao "Del". U +nekim sluèajevima, tipka "Backspace" slu¾i kao <Delete>, ali ne +uvijek! + +Opæenitije, <Delete> bri¹e znak neposredno ispred trenutnog polo¾aja +kursora. + +>> Uèinite sljedeæe: utipkajte nekoliko znakova, zatim ih izbri¹ite + stisnuv¹i <Delete> nekoliko puta. Ne brinite o promjeni ove + datoteke; neæete izmijeniti glavnu verziju uputa. Ovo je va¹a + osobna kopija. + +Kad red teksta postane prevelik za jedan red na ekranu, red se +"nastavlja" na drugi ekranski red. Obrnuta kosa crta ("\") na desnom +rubu ukazuje na red koji je nastavljen. + +>> Upisujte tekst dok ne doðete do desnog ruba, i nastavite pisati. + Vidjet æete kako se pojavljuje nastavljeni red. + +>> Tipkom <Delete> bri¹ite tekst dok red teksta opet ne stane na red + ekrana. Kontinuacijski red tada nestaje. + +Mo¾ete izbrisati znak Newline kao i bilo koji drugi znak. Brisanje +znaka Newline izmeðu dva reda ih spaja u jedan red. Ako je novonastali +zajednièki red prevelik da stane na ekranski red, bit æe prikazan +kontinuacijskim redom. + +>> Pomaknite kursor na poèetak reda i pritisnite <Delete>. Red æe se + spojiti s redom iznad. + +>> Pritisnite <Return> tako da ponovno umetnete Newline koji ste + izbrisali. + +Upamtite da se veæini Emacsovih naredbi mo¾e zadati brojaè +ponavljanja; ovo ukljuèuje znakove teksta. Ponavljanje znaka teksta +unosi ga nekoliko puta. + +>> Isku¹ajte sad -- upi¹ite C-u 8 * da upi¹ete ********. + +Sada ste nauèili najosnovnije naèine upisivanja u Emacs i ispravljanja +gre¹aka. Sada mo¾ete i brisati po rijeèima ili redovima. Evo sa¾etka +operacija brisanja: + + <Delete> bri¹i znak neposredno pred kursorom + C-d bri¹i znak nakon kursora + + M-<Delete> ubij rijeè prije kursora + M-d ubij rijeè poslije kursora + + C-k ubij od pozicije kursora do kraja reda + M-k ubij do kraja trenutne reèenice + +Uoèite da <Delete> i C-d nasuprot M-<Delete> i M-d pro¹iruju paralelu +zaèetu s C-f i M-f (dobro, <Delete> ba¹ i nije kontrolni znak, ali +nemojmo brinuti o tome). C-k i M-k su na neki naèin slièni C-e i M-e, +po operaciji na redovima, odnosno reèenicama. + +Kad bri¹ete vi¹e od jednog znaka istovremeno, Emacs sprema izbrisani +tekst, tako da ga mo¾ete dobiti natrag. Vraæanje ubijenog teksta zove +se "dobavljanje" (eng. yanking). Mo¾ete dobaviti ubijeni tekst bilo +na isto mjesto gdje je bio ubijen, bilo na neko drugo mjesto u +tekstu. Mo¾ete dobaviti tekst nekoliko puta, èime æete dobiti +vi¹estruke kopije. Komanda za dobavljanje je C-y. + +Uoèite da je razlika izmeðu "ubijanja" i "brisanja" neèega u tome ¹to +se ubijeni tekst mo¾e dobaviti natrag, a izbrisani ne mo¾e. Opæenito, +naredbe koje uklanjaju puno teksta spreme izbrisani tekst, dok ga +naredbe koje bri¹u samo jedan znak ili samo prazne linije i razmake ne +spremaju. + +>> Pomaknite kursor na poèetak reda koji nije prazan. + Zatim pritisnite C-k da ubijete tekst u tom redu. +>> Stisnite C-k drugi put. Vidjet æete da ubija Newline koji prati + taj red. + +Uoèite da jedan C-k ubija sadr¾aj reda, dok drugi C-k ubija sam red, i +mièe sve druge redove prema gore. C-k tretira numerièki argument na +specijalan naèin: ubija toliko redova, i njihov sadr¾aj. Ovo nije +obièno ponavljanje. C-u 2 C-k ubija dva reda i njihove newline; +pritiskanje C-k dvaput ne bi dalo taj rezultat. + +Da povratite zadnji ubijeni tekst i stavite ga gdje je kursor +trenutno, pritisnite C-y. + +>> Poku¹ajte; pritisnite C-y da dobavite tekst. + +Gledajte na C-y kao da dobavljate natrag ne¹to ¹to vam je netko uzeo. +Uoèite da ako ponovite C-k nekoliko puta, sav tekst bit æe spremljen +zajedno, tako da æe ga C-y dobaviti odjednom. + +>> Uèinite to sad, pritisnite C-k nekoliko puta. + +Sad, da bi vratili ubijeni tekst: + +>> Stisnite C-y. Tad spustite kursor nekoliko linija ni¾e i opet + stisnite C-y. Sada vidite kako se kopira tekst. + +©to napraviti ako imate tekst koji ¾elite dobaviti, ali onda ubijete +ne¹to drugo? C-y bi dobavio zadnji tekst. Ali prethodni tekst nije +izgubljen. Mo¾ete ga povratiti koristeæi naredbu M-y. Nakon ¹to +pritisnete C-y i dobijete zadnje ubijeni tekst, pritiskanje M-y ga +zamjenjuje s prethodno ubijenim tekstom. Uzastopno pozivanje M-y +dobavlja sve ranije i ranije tekstove. Kad doðete do teksta koji ste +tra¾ili, ne morate uèiniti ni¹ta posebno da ga zadr¾ite. Samo +nastavite s editiranjem, ostaviv¹i dobavljeni tekst gdje jest. + +Ako pritisnete M-y dovoljno puta, vratit æete se na polaznu toèku +(zadnji ubijeni tekst). + +>> Ubijte jedan red, pomièite se po tekstu, ubijte drugi red. + Zatim pritisnite C-y da biste dobili natrag drugi ubijeni red. + Zatim napravite M-y pa æe taj tekst biti zamijenjen prvim ubijenim + redom. Napravite jo¹ par puta M-y i pogledajte ¹to dobivate. + Nastavite s M-y dok ne vratite drugi ubijeni red, a zatim M-y + pritisnite jo¹ par puta. Ako ¾elite, mo¾ete poku¹ati proslijediti + naredbi M-y pozitivne i negativne argumente. + + +* PONI©TENJE +------------ + +Ako napravite izmjenu u tekstu, pa se zatim predomislite, mo¾ete +poni¹titi (eng. "undo") promjenu naredbom undo, C-x u. + +Obièno, C-x u poni¹tava promjene koje su rezultat jedne naredbe; ako +ponovite C-x u nekoliko puta uzastopce, svako novo ponavljanje +poni¹tava uèinak jo¹ jedne naredbe. + +Ali, postoje dva izuzetka: naredbe koje ne mijenjaju tekst se ne +raèunaju (ovo ukljuèuje naredbe koje mièu kursor i pomièu tekst), a +samo-umeæuæi znakovi se obièno grupiraju u skupine od po 20 (da se +umanji broj C-x u koje morate stisnuti da biste poni¹tili unos +teksta). + +>> Ubijte ovu liniju s C-k, zatim utipkajte C-x u i trebala bi se + ponovno pojaviti. + +C-_ je alternativna naredba za poni¹tenje; ona radi isto kao C-x u, +ali ju je lak¹e utipkati nekoliko puta za redom. Mana C-_ je da na +nekim tipkovnicama nije oèigledno kako je utipkati. Zato ostavljamo i +C-x u. Na nekim terminalima mo¾ete dobiti C-_ kombinacijom CTRL i /. + +Numerièki argument naredbi C-_ ili C-x u slu¾i kao brojaè ponavljanja. + + +* DATOTEKE +---------- + +Da biste za stalno spremili izmjene na tekstu koji editirate, morate ga +spremiti u datoteku. Ako to ne uèinite, tekst æe nestati kada izaðete +iz Emacsa. Svoje izmjene stavljate u datoteku tako ¹to je prvo +"naðete" (ovo se jo¹ naziva i "posjeta" datoteci). + +Nala¾enje datoteke znaèi da vidite sadr¾aj datoteke unutar Emacsa. U +neku ruku, ovo je kao da editirate samu datoteku. Meðutim, izmjene +koje napravite koristeæi Emacs ne postaju trajne dok niste "snimili" +datoteku. Tako mo¾ete izbjeæi ostavljanje poluzavr¹ene datoteke u +sustavu, ako to ne ¾elite. Èak i kad snimate, Emacs ostavlja izvornu +datoteku pod promijenjenim imenom, za sluèaj da se kasnije +predomislite. + +Ako pogledate pri dnu ekrana, vidjet æete red koji poèinje i zavr¹ava +s crticama, i sadr¾i niz "XEmacs: TUTORIAL.hr". Ovaj dio ekrana +uvijek pokazuje naziv datoteke koju posjeæujete. U ovom trenutku vi +posjeæujete datoteku koja se zove "TUTORIAL", a koja je va¹a osobna +kopija Emacsovih uputa. Koju god datoteku na¹li, njen æe se naziv +pojaviti na tom istom mjestu. + +Naredbe za pronala¾enje i spremanje datoteka se razlikuju od drugih +naredbi koje ste dosad upoznali, po tome ¹to se sastoje od dva znaka. +Obje poèinju znakom Control-x; mnoge od njih rade s datotekama, +spremnicima i povezanim stvarima. Ove naredbe su dugaèke dva, tri ili +èetiri znaka. + +Jo¹ jedna stvar u vezi naredbe za nala¾enje datoteke je da morate reæi +koju datoteku ¾elite. Ka¾emo da naredba "èita argument s terminala" +(u ovom sluèaju, argument je naziv datoteke). Kad utipkate naredbu + + C-x C-f Naði datoteku + +Emacs tra¾i od vas da upi¹ete naziv datoteke. Naziv datoteke koji +upi¹ete pojavljuje se u donjem redu ekrana. Taj donji red naziva se +minispremnik (minibuffer) kad se koristi za tu vrstu unosa. Mo¾ete +koristiti uobièajene Emacsove naredbe da editirate naziv datoteke. + +Dok unosite naziv datoteke (ili za bilo kojeg unosa iz minispremnika), +mo¾ete otkazati naredbu pomoæu C-g. + +>> Upi¹ite C-x C-f, potom C-g. Ovo otkazuje minispremnik, a takoðer + otkazuje i naredbu C-x C-f koja je koristila minispremnik. Tako + nijedna datoteka neæe biti pronaðena. + +Kad zavr¹ite s upisom imena datoteke, stisnite <Return> za kraj. Tad +æe naredba C-x C-f otpoèeti svoj posao, i naæi datoteku koju ste +izabrali. Minispremnik nestaje kad naredba C-x C-f zavr¹i. + +Ubrzo æe se sadr¾aj datoteke pojaviti na ekranu, i moæi æete editirati +sadr¾aj. Kad po¾elite trajno saèuvati svoje izmjene, upi¹ite naredbu + + C-x C-s Spremi datoteku + +Ovo kopira tekst unutar Emacsa u datoteku na disku. Prvi put kad ovo +uèinite, Emacs æe preimenovati izvornu datoteku u novo ime, tako da je +ne izgubite. Novo se ime tvori dodavanjem znaka ~ na izvorno ime +datoteke. + +Kad snimanje zavr¹i, Emacs ispi¹e ime snimljene datoteke. Trebali +biste snimati relativno èesto, tako da ne izgubite puno ako sustav +padne. + +>> Upisav¹i C-x C-s, spremite svoju kopiju uputa. + Na dnu ekrana bi trebalo pisati "Wrote ...TUTORIAL.hr". + +Primjedba: Na nekim sustavima, tipkanje C-x C-s æe zamrznuti ekran, i +neæete vi¹e vidjeti Emacsov output. To znaèi da "prednost" +operativnog sustava zvana "kontrola toka" (eng. flow control) presreæe +C-s i ne da mu da doðe do Emacsa. Odmrznite sustav tipkom C-q. Tada +pogledajte odjeljak "Spontaneous Entry to Incremental Search" +Emacsovog manuala za savjet kako se nositi s ovom "predno¹æu". + +Mo¾ete naæi postojeæu datoteku, da je pogledate ili editirate. Mo¾ete +takoðer naæi i datoteku koja jo¹ ne postoji. Tako se stvaraju nove +datoteke Emacsom: naðite datoteku, koja æe ispoèetka biti prazna, i +poènite unositi tekst u datoteku. Kad zatra¾ite "snimanje" datoteke, +Emacs æe zaista stvoriti datoteku s tekstom koji ste unijeli. Od tad +pa nadalje, mo¾ete smatrati da editirate veæ postojeæu datoteku. + + +* SPREMNICI +----------- + +Ako naðete jo¹ jednu datoteku s C-x C-f, ona prva ostaje unutar +Emacsa. Mo¾ete se vratiti natrag na nju nalazeæi je opet s C-x C-f. +Ovako mo¾ete otvoriti prilièan broj datoteka unutar Emacsa. + +>> Stvorite datoteku imena "foo" tipkajuæi C-x C-f foo <Return>. + Tad unesite neki tekst, editirajte ga, i snimite "foo" utipkav¹i + C-x C-s. + Konaèno, upi¹ite C-x C-f TUTORIAL.hr <Return> da se vratite na + upute. + +Emacs pohranjuje tekst svake datoteke u objektu zvanom "spremnik" +(eng. buffer). Nala¾enje datoteke otvara novi spremnik unutar +Emacsa. Popis spremnika koji se nalaze u trenutnom pozivu Emacsa +mo¾ete dobiti sa + + C-x C-b Izlistaj spremnike + +>> Sada isku¹ajte C-x C-b. + +Uoèite kako svaki spremnik ima naziv, a mo¾e imati i ime datoteke koje +se odnosi na datoteku èiji sadr¾aj je u njemu. Neki spremnici ne +odgovaraju ni jednoj datoteci. Na primjer, spremnik "*Buffer List*" nema +ni jednu datoteku. To je spremnik koji sadr¾i spisak spremnika koji +je stvorila naredba C-x C-b. BILO KOJI tekst koji vidite u nekom +Emacsovom prozoru uvijek je dio nekog spremnika. + +>> Pritisnite C-x 1 da se rije¹ite spiska spremnika. + +Ako promijenite tekst jedne datoteke, zatim naðete drugu datoteku, ova +prva neæe biti snimljena. Njene promjene ostaju unutar Emacsa, u +spremniku te datoteke. Ovo je korisno, ali to i znaèi da je potreban +pogodan naèin snimanja datoteke prvog spremnika. Bilo bi nespretno +prebacivati se natrag u spremnik s C-x C-f samo zato da ga se snimi s +C-x C-s. Zato imamo + + C-x s Snimi neke spremnike. + +C-x s vas pita za svaki spremnik koji sadr¾i izmjene koje niste +snimili. Za svaki takav spremnik pita vas da li ga ¾elite snimiti. + +>> Upi¹ite red teksta, potom upi¹ite C-x s. + Pitat æe vas ¾elite li snimiti spremnik s nazivom TUTORIAL.hr. + Odgovorite potvrdno na pitanje, tipkajuæi "y". + + +* UPORABA IZBORNIKA +------------------- + +Ako ste na X terminalu, uoèit æete izbornik na vrhu Emacsovog prozora. +Mo¾ete koristiti izbornik za pristup svim uobièajenim Emacsovim +naredbama, kao ¹to su "find file". Ovo æe vam u poèetku biti lak¹e, +jer neæete morati pamtiti tipke za neku naredbu. Jednom kad vam rad u +Emacsu postane ugodan, lako æete poèeti koristiti naredbe s +tipkovnice, jer svaka stavka izbornika sadr¾i i odgovarajuæu tipku za +pokretanje naredbe. + +Uoèite da postoji puno stavki koje nemaju ekvivalent na tipkovnici. +Na primjer, izbornik "Buffers" prikazuje sve raspolo¾ive spremnike +redosljedom posljednje uporabe. Mo¾ete se prebaciti na bilo koji +spremnik tako da jednostavno izaberete njegov naziv u izborniku +"Buffers". + + +* UPORABA MI©A +-------------- + +Kad radite pod X-ima, Emacs je u potpunosti integriran s mi¹em. +Mo¾ete pozicionirati tekstualni kursor pritisnuv¹i lijevu tipku mi¹a +na ¾eljenom mjestu, mo¾ete izabrati tekst povlaèeæi lijevu tipku mi¹a +po ¾eljenom tekstu. (Ili, na drugi naèin, pritisnuti lijevu tipku +mi¹a s jedne strane, zatim se pomaknuti na drugu stranu, i koristiti +Shift i tipku mi¹a za izbor teksta.) + +Ako ¾elite ubiti izabrani tekst, mo¾ete pritisnuti C-w, ili izabrati +Cut u izborniku Edit. Uoèite da ovo dvoje *nije* isto: C-w samo +sprema tekst unutar Emacsa (slièno C-k, kako je opisano gore), dok Cut +radi ovo, i jo¹ sprema tekst u X clipboard, gdje do njega mogu +pristupiti ostale aplikacije. + +Tekst s X clipboarda mo¾ete dobiti koristeæi stavku Paste izbornika +Edit. + +Srednja tipka mi¹a se obièno koristi za izbor stvari koje su vidljive +na ekranu. Na primjer, ako uðete u Info (Emacsovu on-line +dokumentaciju) koristeæi C-h i ili izbornik Help, mo¾ete pratiti +osvijetljeni link pritisnuv¹i srednju tipku mi¹a na njemu. Slièno, +ako tipkate naziv datoteke (npr. na "Find File" promptu) i pritisnete +TAB da vidite moguænosti, mo¾ete stisnuti srednju tipku mi¹a na neku +od moguænosti, da je izaberete. + +Desna tipka mi¹a poziva "skoèni" izbornik. Sadr¾aj ovog izbornika +ovisi o modu u kojem se trenutno nalazite, i obièno sadr¾i nekoliko +èesto kori¹tenih naredbi, tako da se do njih lak¹e doðe. + +>> Sada pritisnite desnu tipku mi¹a. + +Morat æete dr¾ati tipku da zadr¾ite izbornik. + + +* PRO©IRENJE SKUPA NAREDBI +-------------------------- + +Emacsovih naredbi ima puno puno vi¹e nego ¹to bi ikad moglo stati na +sve kontrolne i meta znakove. Emacs ovo zaobilazi pro¹irenim +(eXtended) naredbama. One dolaze u dva oblika: + + C-x Pro¹iri znak. Praæena jednim znakom. + M-x Pro¹irena naredba s imenom. Praæena dugim imenom. + +Postoje naredbe koje jesu korisne, ali ih se rabi manje nego naredbe o +kojima smo dosad govorili. Veæ ste vidjeli dvije: naredbe s +datotekama C-x C-f za nala¾enje i C-x C-s za snimanje. Jo¹ jedan +primjer je naredba kojom se izlazi iz Emacsa -- to je naredba C-x +C-c. (ne brinite o gubljenju izmjena koje ste napravili; C-x C-c vam +nudi da snimite svaku izmijenjenu datoteku prije no ¹to izaðe iz +Emacsa). + +Naredbom C-z *privremeno* izlazite iz Emacsa -- tako da se mo¾ete +nakon nekog vremena opet vratiti u Emacs. + +Na sustavima koji to dozvoljavaju, C-z "suspendira" Emacs; to jest, +vraæa se u ljusku, ali ne uni¹tava Emacs. U veæini ljuski, mo¾ete +nastaviti rad Emacsa naredbom `fg', ili s `%emacs'. + +Na sustavima koji ne podr¾avaju suspendiranje, C-z stvara podljusku +koja radi pod Emacsom, tako da mo¾ete pokrenuti druge programe i +naknadno se vratiti u Emacs; ona neæe zaista "izaæi" iz Emacsa. U +ovom sluèaju, ljuskina naredba `exit' je uobièajen naèin povratka iz +podljuske u Emacs. + +Vrijeme za C-x C-c je onda kad se kanite odlogirati. Takoðer, to je +ispravna stvar kad je Emacs pozvan iz èitaèa po¹te, ili nekog drugog +programa, jer se oni ne moraju znati nositi sa suspendiranjem Emacsa. +U normalnim okolnostima, meðutim, ako se ne kanite odlogirati, bolje +je suspendirati Emacs s C-z nego izaæi iz njega. + +Postoji puno C-x naredbi. Evo spiska onih koje ste nauèili: + + C-x C-f Naði datoteku. + C-x C-s Snimi datoteku. + C-x C-b Popis spremnika. + C-x C-c Izaði iz Emacsa. + C-x u Poni¹ti zadnju naredbu. + +Imenovane pro¹irene naredbe su naredbe koje se jo¹ rjeðe koriste, ili +se koriste samo unutar stanovitih modova. Primjer je naredba +replace-string, koja globalno zamjenjuje jedan niz drugim. Kad +napi¹ete M-x, Emacs æe vam dati prompt na dnu ekrana, a vi trebate +samo napisati naziv naredbe. U ovom sluèaju, "replace-string". Samo +napi¹ite "repl s<TAB>", i Emacs æe dovr¹iti ime. Zavr¹ite naziv +naredbe s <Return>. + +Naredba replace-string tra¾i dva argumenta -- niz koji se zamjenjuje, +i niz kojim æe se zamijeniti. Zavr¹ite svaki argument s <Return>. + +>> Pomaknite kursor na prazan red dva reda ispod ovoga. Zatim + napi¹ite M-x repl s <Return>promijenio<Return>izmijenio<Return>. + + Primijetite kako se ovaj red promijenio: zamijenili ste rijeè + p-r-o-m-i-j-e-n-i-o s "izmijenio" gdje god se ova pojavila, nakon + poèetnog polo¾aja kursora. + + +* AUTOMATSKO SNIMANJE +--------------------- + +Kada ste promijenili datoteku, ali je jo¹ niste snimili, va¹e bi +izmjene mogle biti izgubljene ako raèunalo padne. Da vas za¹titi od +ovoga, Emacs povremeno ispisuje "auto save" (automatsko snimanje) +datoteku za svaku datoteku koju editirate. Auto-save datoteka ima # +na poèetku i na kraju imena; na primjer, ako se va¹a datoteka zove +"hello.c", njezina æe se auto-save datoteka zvati "#hello.c#". Kad +snimite datoteku na normalan naèin, Emacs æe izbrisati njezinu +auto-save datoteku. + +Ako raèunalo padne, mo¾ete obnoviti svoje automatski spremljene +promjene tako ¹to normalno naðete datoteku, i napi¹ete +M-x recover file <Return>. Kad vas pita za potvrdu, upi¹ite +yes<return> za nastavak i vratite automatski snimljene podatke. + + +* PROSTOR ZA PORUKE +------------------- + +Ako Emacs vidi da pi¹ete naredbe polako, pokazat æe vam ih na dnu +ekrana na mjestu koje se zove "prostor za poruke" (eng. echo area). +Prostor za poruke je na najni¾em redu ekrana. + + +* STATUSNI RED +-------------- + +Red odmah iznad prostora za poruke se zove "statusni red" +(eng. modeline). Statusni red izgleda otprilike ovako: + +--**-XEmacs: TUTORIAL.hr (Fundamental)--L670--58%---------------- + +Ovaj red pru¾a korisne informacije o statusu Emacsa i tekstu koji +editirate. + +Veæ znate ¹to je ime datoteke -- to je datoteka koju ste na¹li. +-NN%-- predstavlja va¹ trenutni polo¾aj u tekstu; to znaèi da je NN +postotaka teksta iznad vrha ekrana. Ako je vrh teksta na ekranu, +pisat æe --Top-- umjesto --00%--. Ako je kraj teksta na ekranu, pisat +æe --Bot--. Ako gledate u tako kratak tekst da sav stane na ekran, u +statusnoj liniji æe pisati --All--. + +Zvjezdice na poèetku znaèe da ste napravili izmjene na tekstu. +Neposredno po posjeti ili snimanju datoteke, taj dio statusne linije +nema zvjezdica, veæ samo crtice. + +Dio statusne linije u zagradama govori u kojem se modu editiranja +nalazite. Podrazumijeva se Fundamentalni mod, koji trenutno koristite. +On je primjer "glavnog moda". + +Emacs ima puno razlièitih glavnih modova. Neki od njih su predviðeni +za editiranje razlièitih jezika i/ili vrsta teksta, kao ¹to je Lisp +mod, tekst mod, itd. U bilo kojem trenutku jedan i samo jedan glavni +mod je aktivan, i njegovo se ime nalazi na statusnom redu, gdje sada +stoji "Fundamental". + +Svaki glavni mod èini da se nekoliko naredbi pona¹a razlièito. Na +primjer, postoje naredbe za stvaranje komentara u programu, a buduæi +da svaki programski jezik ima drugaèiju predod¾bu o tome kako komentar +izgleda, svaki glavni mod razlièito unosi komentare. Svaki glavni mod +je ime jedne pro¹irene naredbe, ¹to je i naèin kako se mo¾ete +prebaciti u taj mod. Na primjer, M-x fundamental-mode je naredba koja +vas prebacuje u Fundamental mod. + +Ako editirate tekst na hrvatskom, kao ¹to je ova datoteka, vjerojatno +biste trebali koristiti tekstualni mod. +>> Napi¹ite M-x text-mode<Return>. + +Ne brinite, nijedna od naredbi koje ste nauèili neæe promijeniti Emacs +na znaèajan naèin. Ali mo¾ete uoèiti da M-f i M-b sad tretiraju +apostrofe kao dio rijeèi. U fundamentalnom modu M-f i M-b su +tretirali apostrofe kao separatore rijeèi. + +Glavni modovi obièno rade suptilne izmjene poput navedene: veæina +naredbi rade "isti posao" u svakom glavnom modu, ali funkcioniraju s +malom razlikom. + +Da biste vidjeli dokumentaciju trenutnog glavnog moda, pritisnite +C-h m. + +>> Pritisnite jo¹ jednom C-u C-v da dovedete ovu liniju do vrha ekrana. +>> Utipkajte C-h m, da vidite kako se tekstualni mod razlikuje od + fundamentalnog moda. +>> Pritisnite q da uklonite dokumentaciju s ekrana. + +Glavni modovi se nazivaju glavnima, jer postoje jo¹ i sporedni +modovi. Sporedni su modovi nisu zamjena za glavne modove, veæ njihova +usputna modifikacija. Svaki sporedni mod mo¾e biti ukljuèen ili +iskljuèen za sebe, neovisno o ostalim sporednim modovima, i neovisno o +glavnom modu. Tako mo¾ete ne biti niti u jednom sporednom modu, ili u +jednom sporednom modu, ili u kombinaciji nekoliko sporednih modova. + +Jedan vrlo koristan sporedni mod, naroèito za editiranje hrvatskog +teksta, jest mod za automatsko popunjavanje (Auto Fill mode). Kad je +ovaj mod ukljuèen, Emacs automatski lomi linije izmeðu rijeèi kad god +umetanjem teksta stvorite red koji je pre¹irok. + +Mo¾ete ukljuèiti Auto Fill mod pisanjem M-x auto-fill-mode<Return>. +Kad je mod ukljuèen, iskljuèujete ga s M-x auto-fill-mode<Return>. +Kad je mod iskljuèen, ova ga naredba ukljuèuje, kad je ukljuèen, ona +ga iskljuèuje. + +>> Napi¹ite M-x auto-fill-mode<Return> sad. Potom umeæite tekst "asdf " + dok god se red ne razdvoji na dva dijela. Morate stavljati razmake + izmeðu, jer Auto Fill lomi redove samo na razmacima. + +Rub je obièno postavljen na 70 znakova, ali ga mo¾ete promijeniti +naredbom C-x f. Rub koji ¾elite postaviti pode¹avate numerièkim +argumentom. + +>> Utipkajte C-x f s argumentom 20. (C-u 2 0 C-x f). + Potom upi¹ite neki tekst, i gledajte kako Emacs lomi redove dulje + od 20 znakova. Tad postavite rub natrag na 70 ponovno + upotrijebiv¹i C-x f. + +Ako napravite promjene u sredini paragrafa, Auto Fill mod ga neæe +cijelog reformatirati. +Za preoblikovanje paragrafa, utipkajte M-q (Meta-q) s kursorom unutar +paragrafa. + +>> Pomaknite kursor na prethodni paragraf, i stisnite M-q. + + +* TRA®ENJE +---------- + +Emacs mo¾e tra¾iti nizove (grupe uzastopnih znakova ili rijeèi) bilo +prema naprijed ili prema natrag kroz tekst. Tra¾enje niza je naredba +kojom se pomièe kursor; ona æe pomaknuti kursor do sljedeæeg mjesta na +kom se niz pojavljuje. + +Emacsova naredba za tra¾enje se razlikuje od sliènih naredbi veæine +editora po tome ¹to je "postupna" (eng. incremental). To znaèi da se +pretra¾ivanje odvija dok upisujete niz koji tra¾ite. + +Naredba kojom poèinjete naredbu je C-s za tra¾enje prema naprijed, i +C-r za tra¾enje unatrag. ALI ÈEKAJTE! Nemojte ih odmah isprobati. + +Kad utipkate C-s, primijetit æete da se tekst "I-search" pojavljuje +kao prompt u prostoru za poruke. Ovo vam ka¾e da je Emacs u stanju +postupnog tra¾enja, i da èeka da upi¹ete ¹to ¾elite tra¾iti. +<Return> zaustavlja tra¾enje. + +>> Sad stisnite C-s da zapoènete pretra¾ivanje. POLAKO, znak po znak, + utipkajte rijeè `kursor', radeæi stanku izmeðu znakova da uoèite + ¹to se dogaða s kursorom. + Sad ste na¹li "kursor", jednom. +>> Stisnite C-s opet, da naðete sljedeæe pojavljivanje "kursora". +>> Sad stisnite <Delete> èetiri puta, i gledajte kako se kursor + pomièe. +>> Stisnite <RET> da prekinete tra¾enje. + +Jeste li vidjeli ¹to se dogodilo? Za vrijeme inkrementalnog tra¾enja, +Emacs poku¹ava otiæi na mjesto gdje se pojavljuje niz kojeg ste do sad +utipkali, osvjetljavajuæi ga zbog preglednosti. Za odlazak na +sljedeæe mjesto gdje se "kursor" pojavljuje, samo opet stisnite C-s. +Ako ni jedno takvo mjesto ne postoji, Emacs æe se oglasiti zvuènim +signalom i reæi vam da pretraga niju uspjela ("failing"). Pretragu +mo¾ete prekinuti i pomoæu C-g. + + +PRIMJEDBA: Na nekim sustavima, tipkanje C-s æe smrznuti sustav i vi¹e +neæete vidjeti daljnji Emacsov output. To pokazuje da "prednost" +operativnog sustava zvana "kontrola toka" (eng. flow control) presreæe +C-s i ne da mu da doðe do Emacsa. Pritisak na C-q æe odmrznuti ekran. +Tad pogledajte odjeljak "Spontaneous Entry to Incremental Search" +Emacsovog manuala za savjet kako se nositi s ovom "predno¹æu". + +Ako za vrijeme postupnog tra¾enja pritisnete <Delete>, uoèit æete +da je zadnji znak niza izbrisan i da se pretraga vratila na zadnje +mjesto. Na primjer, pretpostavimo da ste stisnuli "k" ne bi li na¹li +prvo pojavljivanje "k". Ako sad stisnete "u", kursor æe se pomaknuti +na mjesto prvog pojavljivanja "ku". Sad stisnite <Delete>. Ovo æe +ukloniti "u" iz tra¾enog niza, i pomaknuti kursor natrag na prvu +pojavu "k". + +Ako ste usred tra¾enja i stisnete kontrolni ili meta znak (s nekoliko +iznimki -- znakova koji imaju posebno znaèenje pri tra¾enju, kao ¹to +su C-s i C-r), tra¾enje se zaustavlja. + +C-s zapoèinje pretragu koja tra¾i bilo koju pojavu tra¾enog niza NAKON +trenutnog polo¾aja kursora. Ako ¾elite tra¾iti ne¹to ¹to se +pojavljuje ranije u tekstu, stisnite C-r. Sve ¹to smo rekli za C-s +vrijedi i za C-r, jedino ¹to je smjer pretrage suprotan. + + +* VI©ESTRUKI PROZORI +-------------------- + +Jedna od lijepih stvari u Emacsu je ¹to mo¾ete prikazati vi¹e prozora +na ekranu istovremeno. + +>> Dovedite kursor do ovog reda i stisnite C-u 0 C-l. + +>> Sad stisnite C-x 2, ¹to razdvaja ekran na dva prozora. + Oba prozora prikazuju ove upute. Kursor ostaje u gornjem prozoru. + +>> Stisnite C-M-v da pomaknete donji prozor. + (Ako nemate pravu tipku Meta, stisnite ESC C-v.) + +>> Stisnite C-x o ("o" kao eng. "other", drugi) da pomaknete kursor u + donji prozor. +>> U donjem se prozoru pomièite s C-v i M-v. + Nastavite èitati ove upute u gornjem prozoru. + +>> Opet stisnite C-x o da pomaknete kursor natrag u gornji prozor. + Kursor u gornjem prozoru je upravo gdje je prije bio. + +Mo¾ete stalno koristiti C-x o za pomicanje meðu prozorima. Svaki +prozor ima vlastiti polo¾aj kursora, ali samo jedan prozor zapravo +prikazuje kursor. Sve uobièajene naredbe za editiranja djeluju na +prozoru u kojem je kursor. Taj prozor nazivamo "izabrani prozor" +(eng. selected window). + +Naredba C-M-v korisna je kad editirate tekst u jednom prozoru, a drugi +koristite za referencu. Tada mo¾ete dr¾ati kursor uvijek u prozoru +gdje editirate, a napredovati kroz onaj drugi s C-M-v. + +C-M-v je primjer CONTROL-META znaka. Ako imate pravu tipku META, +mo¾ete dobiti C-M-v dr¾eæi zajedno i CTRL i META, dok tipkate v. Nema +veze da li je CTRL ili META "prvi", jer obje ove tipke rade +mijenjajuæi znakove koji pi¹ete. + +Ako nemate pravu META tipku, a umjesto nje koristite ESC, tad je +poredak va¾an: morate stisnuti ESC praæen s CTRL-v; CTRL-ESC v neæe +raditi. Razlog za ovo je ¹to je ESC tipka za sebe, a ne modifikator. + +>> Pritisnite C-x 1 (u gornjem prozoru) da se rije¹ite donjeg + prozora. + +(Da ste stisnuli C-x 1 u donjem prozoru, rije¹ili biste se gornjeg. +Ovu naredbu mo¾ete shvatiti kao "Ostavi samo jedan prozor -- onaj u +kojem veæ jesam.") + +Ne morate prikazivati isti spremnik u oba prozora. Ako pritisnete C-x +C-f da naðete datoteku u jednom prozoru, drugi se prozor ne mijenja. +Mo¾ete naæi datoteku u svakom prozoru neovisno o drugima. + +Evo jo¹ jednog naèina da upotrijebite dva prozora za prikaz dvije +razlièite stvari: + +>> Utipkajte C-x 4 C-f, a zatim ime neke od va¹ih datoteka. + Zavr¹ite s <Return>. Uoèite da se navedena datoteka pojavila u + donjem prozoru, a takoðer i kursor. + +>> Pritisnite C-x o za povrat u gornji prozor, i C-x 1 da uklonite + donji. + + +* REKURZIVNE RAZINE EDITIRANJA +------------------------------ + +Ponekad æete po¾eljeti uæi u ono ¹to se zove "rekurzivna razina +editiranja" (eng. recursive editing level). Ovo je naznaèeno uglatim +zagradama u statusnom redu, koje okru¾uju okrugle zagrade oko naziva +moda. Na primjer, vidjeli biste [(Fundamental)] umjesto +(Fundamental). + +Za izlazak iz rekurzivnog editiranja, pritisnite ESC ESC ESC. To je +vi¹enamjenska naredba za "izlazak". Mo¾ete je koristiti i za +uklanjanje dodatnih prozora, kao i za izlazak iz minispremnika. + +>> Stisnite M-x za ulazak u minispremnik; potom utipkajte ESC ESC ESC + za izlaz. + +Iz rekurzivne razine editiranja ne mo¾ete izaæi s C-g. To je zato ¹to +se C-g koristi za otkazivanje naredbi i argumenata UNUTAR te razine +editiranja. + + +* DODATNA POMOÆ +--------------- + +U ovim smo uputama poku¹ali dati upravo toliko informacija da mo¾ete +poèeti koristiti Emacs. Toliko je toga prisutno u Emacsu da bi bilo +nemoguæe sve to ovdje objasniti. Meðutim, mo¾da po¾elite nauèiti vi¹e +o Emacsu, jer on ima jo¹ puno korisnih prednosti. Emacs ima naredbe +za èitanje dokumentacije o Emacsovim naredbama. Ove naredbe "pomoæi" +sve poèinju sa znakom Control-h, koji se zove "znak za pomoæ" +(eng. the Help character). + +Za kori¹tenje naredbi pomoæi, stisnite znak C-h, praæen znakom koji +ka¾e koju vrstu pomoæi ¾elite. Ako ste ZAISTA izgubljeni, stisnite +C-h ? i Emacs æe vam reæi koje vrste pomoæi mo¾e dati. Ako stisnete +C-h, ali se predomislite, samo pritisnite C-g za otkaz pomoæi. + +(Na nekim je sistemima promijenjeno znaèenje C-h. Ovo se zaista ne bi +smjelo raditi, pa se po¾alite sistemskom administratoru. U meðuvremenu, +ako C-h ne prikazuje poruku o pomoæi na dnu ekrana, poku¹ajte upisati +M-x help RET umjesto toga.) + +Osnovna naredba pomoæi je C-h c. Napi¹ite C-h, potom c, i znak ili +niz znakova, i Emacs æe pokazati vrlo kratak opis naredbe. + +>> Stisnite C-h c Control-p. + Poruka bi trebala biti poput: + + C-p runs the command previous-line + + (C-p pokreæe naredbu previous-line) + +Ovo vam ka¾e "ime funkcije". Imena funkcija se koriste uglavnom za +mijenjanje i pro¹irivanje Emacsa. Ali buduæi da se imena funkcija +biraju tako da pokazuju ¹to naredba radi, ona mogu poslu¾iti i kao +vrlo kratka dokumentacija -- dovoljna da vas podsjeti na naredbu koju +veæ znate. + +Vi¹e-znakovne naredbe kao ¹to su C-x C-s i (ako nemate tipku META, +EDIT ili ALT) <ESC>v su takoðer dozvoljene nakon C-h c. + +Za vi¹e podataka o naredbi, pritisnite C-h k umjesto C-h c. + +>> Stisnite C-h k Control-p. + +Osim imena, sad vidite i dokumentaciju funkcije u Emacsovom prozoru. +Kad zavr¹ite s èitanjem ispisa, stisnite q da se rije¹ite teksta. + +Evo nekoliko korisnih moguænosti C-h: + + C-h f Opi¹i funkciju. Upi¹ete ime funkcije. + +>> Poku¹ajte stisnuti C-h f previous-line<Return>. + Ovo æe ispisati sve ¹to Emacs zna o funkciji koja implementira + naredbu C-p. + + C-h a Hiper Apropos. Upi¹ite rijeè, i Emacs æe popisati sve + funkcije i varijable èija imena sadr¾e rijeè. Naredbe + koje se mogu izvr¹iti s Meta-x bit æe oznaèene + zvjezdicom slijeva. + +>> Utipkajte C-h a newline<Return>. + +Ovo prikazuje hipertekstualni spisak svih funkcija i varijabli s +"newline" u imenima. Stisnite <Return>, ili pritisnite srednju tipku +mi¹a da saznate vi¹e o funkciji ili varijabli. Stisnite `q' za izlaz +iz hiper-aproposa. + + +* ZAKLJUÈAK +----------- + +Upamtite, za trajan izlaz iz Emacsa stisnite C-x C-c. Za privremeni +izlaz u ljusku upotrijebite C-z. (pod X-ima, ovo ikonizira trenutni +Emacsov okvir.) + +Ove upute su predviðene da budu razumljive svim novim korisnicima, pa +ako vam je ne¹to ovdje nejasno, nemojte sjediti i kriviti sebe - +¾alite se! + + +KOPIRANJE +--------- + +Ove upute potjeèu iz duge loze Emacsovih uputa, poèev¹i od onih koje +je napisao Stuart Cracraft za izvorni Emacs. Ben Wing je dopisao +poglavlje o X Windowsima. Martin Buchholz i Hrvoje Nik¹iæ su dodali +jo¹ ispravki vezanih uz XEmacs. + +Na Hrvatski preveo Hrvoje Nik¹iæ, uz dodatnu lekturu Denisa Pleiæa. + +Ova verzija uputa je, kao i GNU Emacs, pod autorskim pravima, i dolazi +s dozvolom redistribuiranja uz sljedeæe uvjete: + +(c) 1985, 1996 Free Software Foundation, sva prava zadr¾ana. + + Svakome je dozvoljeno praviti ili distribuirati nepromijenjene + kopije ovog dokumenta, na bilo kojem mediju, uz uvjet da su + saèuvane poruka o autorskim pravima i dozvolama, i da distributer + daje drugima prava za daljnju redistribuciju, kako ovdje pi¹e. + + Dozvoljena je distribucija izmijenjenih verzija ovog dokumenta ili + njegovih djelova, pod gore navedenim uvjetima, uz dodatni uvjet da + sadr¾i obavijest o zadnjoj promjeni. + +Uvjeti kopiranja samog Emacsa su slo¾eniji, ali u istom duhu. Molimo +vas da proèitate datoteku COPYING, i da podijelite kopije GNU Emacsa +svojim prijateljima. Pomozite nam zgaziti opstrukcionizam +("vlasni¹tvo") nad softverom koristeæi, pi¹uæi i dijeleæi slobodan +softver! + + +This tutorial descends from a long line of Emacs tutorials +starting with the one written by Stuart Cracraft for the original Emacs. +Ben Wing updated the tutorial for X Windows. Martin Buchholz and +Hrvoje Niksic added more corrections for XEmacs. + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1985, 1996 Free Software Foundation + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are more complex, but in the +same spirit. Please read the file COPYING and then do give copies of +GNU Emacs to your friends. Help stamp out software obstructionism +("ownership") by using, writing, and sharing free software!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.jp Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,741 @@ + ============================== + $BF|K\8l(B GNUEMACS(Mule) $BF~LgJT(B + ============================== + +$BCm0U!'(B $B$3$NF~LgJT$O!"!V=,$&$h$j47$l$m!W$r%b%C%H!<$K:n@.$5$l$F$$$^(B + $B$9!#(B">>" $B$+$i;O$^$k9T$O!"$=$N;~2?$r$9$Y$-$+$r;X<($7$F$$$^$9!#(B + + + Mule $B$N%3%^%s%I$rF~NO$9$k$H$-$K$O!"0lHLE*$K%3%s%H%m!<%k!&%-!<!J%-!<!&(B +$B%H%C%W$K!"(BCTRL $B$"$k$$$O!"(BCTL $B$H=q$$$F$"$k!K$d%a%?!&%-!<!JIaDL!"%(%9%1!<%W!&(B +$B%-!<$r;H$&!K$,;H$o$l$^$9!#$=$3$G!"(BCONTROL $B$H$+(B META $B$H$+=q$/Be$o$j$K!"<!$N(B +$B$h$&$J5-9f$r;H$&$3$H$K$7$^$9!#(B + +C-<$BJ8;z(B> $B%3%s%H%m!<%k!&%-!<$r2!$7$?$^$^!"(B<$BJ8;z(B>$B%-!<$r2!$7$^$9!#Nc$($P!"(B + C-f $B$O!"%3%s%H%m!<%k!&%-!<$r2!$7$J$,$i(B f $B$N%-!<$r2!$9$3$H$r(B + $B0UL#$7$^$9!#(B +<<Blank lines inserted here by startup of help-with-tutorial>> + >> $B$=$l$G$O!"(BC-v$B!J(BView Next Screen; $B<!$N2hLL$r8+$k!K$r%?%$%W$7$F(B + $B$_$F2<$5$$!#<!$N2hLL$K?J$`$3$H$,$G$-$^$9!#(B + $B0J9_!"0l2hLL$rFI$_=*$($k$?$S$KF1MM$K$7$F<!$N2hLL$KFI$_?J$s$G(B + $B2<$5$$!#(B + +ESC <$BJ8;z(B> $B%(%9%1!<%W!&%-!<$r2!$7$F$+$iN%$7!"$=$l$+$i(B<$BJ8;z(B>$B%-!<$r2!$7$^(B + $B$9!#(B + +$BCm0U!'(B <$BJ8;z(B>$B$O!"BgJ8;z$G$b>.J8;z$G$b%3%^%s%I$H$7$F$OF1$80UL#$K$J$j(B + $B$^$9!#%a%?%-!<$,;H$($k$J$i$P(B ESC <$BJ8;z(B> $B$NBe$o$j$K(B M-<$BJ8;z(B> + ($B%a%?%-!<$r2!$7$?$^$^(B<$BJ8;z(B>$B%-!<$r2!$9(B) $B$,;H$($^$9!#(B + +$B=EMW$G$9!'(B Emacs$B$r=*N;$5$;$?$$;~$O!"(BC-x C-c $B$r%?%$%W$7$^$9!#(BEmacs$B$r(Bcsh + $B$+$i5/F0$7$F$$$k>l9g!"%5%9%Z%s%I$9$k!J0l;~E*$K;_$a$k(B)$B$3$H$,(B + $B=PMh$^$9!#(BEmacs$B$r%5%9%Z%s%I$9$k$K$O!"(BC-z$B$r%?%$%W$7$^$9!#(B + + + $B$5$F!"$3$l$+$i$O!"0l2hLLJ,FI$_=*$($?$i!"(BC-v $B$rF~NO$7$F9T$C$F2<$5$$!#(B + + $BA0$N2hLL$H<!$N2hLL$H$G$O!"I=<($5$l$kFbMF$K2?9TJ8$+$N=E$J$j$,$"$j$^$9!#(B +$B$3$l$O!"I=<($5$l$F$$$kFbMF$,O"B3$7$F$$$k$3$H$,$9$0H=$k$h$&$K$9$k$?$a$G$9!#(B + + + $B$^$:$O!"%U%!%$%k$NCf$r0\F0$7$F9T$/J}K!$rCN$kI,MW$,$"$j$^$9!#(BC-v $B$K$h(B +$B$C$F@h$K?J$`$3$H$O$b$&H=$j$^$7$?!#85$KLa$k$K$O!"(BESC v $B$r%?%$%W$7$^$9!#(B + + >> ESC v $B$H(B C-v $B$r;H$C$F!"A08e$K0\F0$9$k$3$H$r2?2s$+;n$7$F$_$J$5$$!#(B + +$BMWLs(B +==== + $B%U%!%$%k$r2hLLKh$K8+$F9T$/$K$O!"<!$N%3%^%s%I$r;H$$$^$9!#(B + + C-v $BA0$K0l2hLLJ,?J$`(B + ESC v $B8e$m$K0l2hLLJ,La$k(B + C-l $B2hLL$r=q$-D>$9!#$3$N$H$-!"85%+!<%=%k$N$"$C$?9T$,(B + $B2hLL$NCf1{$K$/$k$h$&$K$9$k(B + + >> $B:#%+!<%=%k$,$I$3$K$"$k$+!"$=$N6a$/$K$I$s$J%F%-%9%H$,=q$+$l$F$$$k(B + $B$+$r3P$($J$5$$!#(BC-l $B$r%?%$%W$7!"%+!<%=%k$,$I$3$K0\F0$7$?$+!"$=$N(B + $B6a$/$N%F%-%9%H$O$I$&$J$C$?$+$rD4$Y$F$_$J$5$$!#(B + +$B4pK\E*$J%+!<%=%k$N@)8f(B +====================== + + $B2hLLKh$N0\F0$O$G$-$k$h$&$K$J$j$^$7$?!#:#EY$O!"2hLL$NCf$G!"FCDj$N>l=j$K(B +$B0\F0$9$k$?$a$NJ}K!$r21$($^$7$g$&!#$3$l$K$O$$$/$D$+$N$d$jJ}$,$"$j$^$9!#0l$D(B +$B$NJ}K!$O!"A0(B(previous)$B<!(B(next)$B@h(B(forward)$B8e(B(backward)$B$K0\F0$9$k%3%^%s%I$r;H(B +$B$&$3$H$G$9!#$3$l$i$N%3%^%s%I$O$=$l$>$l!"(BC-p, C-n, C-f,C-b $B$K3d$jEv$F$i$l$F(B +$B$*$j!"8=:_$N>l=j$+$i?7$7$$>l=j$K%+!<%=%k$r0\F0$5$;$^$9!#?^$G=q$1$P!"(B + + + $BA0$N9T!$(BC-p + : + : + $B8e$NJ8;z!$(BC-b .... $B8=:_$N%+!<%=%k0LCV(B .... $B@h$NJ8;z!$(BC-f + : + : + $B<!$N9T!$(BC-n + + + $B$3$l$i$O!"$=$l$>$l!"(BPrevious, Next, Backward, Forward $B$NF,J8;z$K$J$C$F(B +$B$$$k$N$G!"21$($d$9$$$G$7$g$&!#$3$l$i$O!"4pK\E*$J%+!<%=%k0\F0%3%^%s%I$G$"$j!"(B +$B$$$D$G$b;H$&$b$N$G$9!#(B + + >> C-n $B$r2?2s$+%?%$%W$7!"!J:#!"$"$J$?$,FI$s$G$$$k!K$3$N9T$^$G%+!<%=(B + $B%k$r0\F0$5$;$J$5$$!#(B + + >> C-f $B$r;H$C$F9T$NCf$[$I$K0\F0$7!"(BC-p $B$G2?9T$+>e$K0\F0$7$F$_$J$5(B + $B$$!#%+!<%=%k$N0LCV$NJQ2=$KCm0U$7$J$5$$!#(B + + >> $B9T$N@hF,$G(B C-b $B$r%?%$%W$7$F$_$J$5$$!#%+!<%=%k$O$I$3$K0\F0$7$^$9$+(B + $B!)$5$i$K$b$&>/$7(B C-b $B$r%?%$%W$7!":#EY$O(B C-f $B$G9TKv$NJ}$KLa$j$J$5(B + $B$$!#%+!<%=%k$,9TKv$r1[$($k$H$I$&$J$j$^$9$+!)(B + + + $B2hLL$N@hF,$dKvHx$r1[$($F%+!<%=%k$r0\F0$5$;$h$&$H$9$k$H!"$=$NJ}8~$K$"$k(B +$B%F%-%9%H$,0\F0$7$FMh$F!"%+!<%=%k$O>o$K2hLLFb$K$"$k$h$&$K$5$l$^$9!#(B + + >> C-n $B$r;H$C$F!"%+!<%=%k$r2hLL$N2<C<$h$j2<$K0\F0$5$;$F$_$J$5$$!#2?(B + $B$,5/$3$j$^$7$?$+!)%+!<%=%k$N0LCV$O$I$&JQ$j$^$7$?$+!)(B + + $B0lJ8;zC10L$N0\F0$G$O$^$I$m$C$3$7$$$H;W$&$J$i!"C18lC10L$G0\F0$9$k$3$H$b(B +$B$G$-$^$9!#(BESC f $B$G0lC18lJ,@h$K?J$_!"(BESC b $B$G0lC18lJ,A0$KLa$j$^$9!#(B + +$BCm0U!'(B $BF|K\8l$K$D$$$F$O!"C18l$N@Z$lL\$rG'<1$9$k$3$H$O$G$-$^$;$s$,!"(B + $B5?;wE*$JJ8@a$rC18l$N@Z$lL\$H$7$F$$$^$9!#(B + + >> ESC f $B$d(B ESC b $B$r2?2s$+%?%$%W$7$F$_$J$5$$!#(BC-f $B$d(B C-b $B$HJ;MQ$7$F(B + $B$_$J$5$$!#(B + + C-f $B$d(B C-b $B$KBP$9$k!"(BESC f $B$d(B ESC b $B$NN`;w@-$KCmL\$7$^$7$g$&!#B?$/$N(B +$B>l9g!"(BESC <$BJ8;z(B>$B$OJ8=q4X78$N=hM}$K;H$o$l!"0lJ}(BC-<$BJ8;z(B>$B$O$=$l$h$j$b$b$C$H4p(B +$BK\E*$JBP>]!JJ8;z$H$+9T$H$+!K$KBP$9$kA`:n$K;H$o$l$^$9!#(B + + C-a $B$H(B C-e $B$bCN$C$F$$$FJXMx$J%3%^%s%I$G$9!#(BC-a $B$O%+!<%=%k$r9T$N@hF,$K(B +$B0\F0$5$;!"(BC-e $B$O9T$NKvHx$K0\F0$5$;$^$9!#(B + + + >> C-a $B$r#22s!"$=$l$+$i(B C-e $B$r#22sF~NO$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I(B + $B$r#22s0J>e7+JV$7$F$b!"%+!<%=%k$O$=$l0J>e0\F0$7$J$$$3$H$KCm0U!#(B + + $B$"$HFs$D!"4JC1$J%+!<%=%k0\F0%3%^%s%I$,$"$j$^$9!#%U%!%$%k$N@hF,$K0\F0$9(B +$B$k(B ESC < $B$H!"%U%!%$%k$NKvHx$K0\F0$9$k(B ESC > $B$G$9!#(B + + $B%F%-%9%HCf$G%+!<%=%k$NB8:_$9$k0LCV$r!V%]%$%s%H!W$H8F$S$^$9!#8@$$$+$($l(B +$B$P!"%+!<%=%k$O!"%F%-%9%H$N$I$3$K%]%$%s%H$,$"$k$+$r2hLL>e$G<($7$F$$$k$N$G$9!#(B + + $B0J2<$KC1=c$J0\F0A`:n$K$D$$$FMWLs$7$^$9!#$3$N$J$+$K$O!"C18l$d9TC10L$G$N(B +$B0\F0%3%^%s%I$b4^$^$l$F$$$^$9!#(B + + C-f $B0lJ8;z@h$K?J$`(B + C-b $B0lJ8;z8e$KLa$k(B + + ESC f $B0lC18l@h$K?J$`(B + ESC b $B0lC18l8e$KLa$k(B + + C-n $B<!$N9T$K0\F0(B + C-p $BA0$N9T$K0\F0(B + + ESC ] $BCJMn$N=*$o$j$K0\F0(B + ESC [ $BCJMn$N@hF,$K0\F0(B + + C-a $B9T$N:G=i$K0\F0(B + C-e $B9T$N:G8e$K0\F0(B + + ESC < $B%U%!%$%k$N:G=i$K0\F0(B + ESC > $B%U%!%$%k$N:G8e$K0\F0(B + + >> $B3F!9$N%3%^%s%I$r;n$7$F$_$J$5$$!#$3$l$i$N%3%^%s%I$O!":G$b$7$P$7$P(B + $B;H$o$l$k$b$N$G$9!#:G8e$NFs$D$G$O!"$3$N>l=j$H$ON%$l$?$H$3$m$K0\F0(B + $B$9$k$N$G!"(B C-v $B$d(B ESC v $B$r;H$C$F$3$3$KLa$C$FMh$k$h$&$K$7$J$5$$!#(B + + Emacs$B$NB>$N%3%^%s%I$HF1MM$K!"$3$l$i$N%3%^%s%I$K$O!"7+$jJV$7$N2s?t$r;X(B +$BDj$9$k0z?t(B $B$rM?$($k$3$H$,$G$-$^$9!#$=$N$?$a$K$O!"%3%^%s%I$rF~NO$9$kA0$K!"(B +C-u$B$KB3$$$F7+$jJV$92s?t$rF~NO$7$^$9!#(B + + $BNc$($P!"(BC-u 8 C-f $B$H$9$k$H!"#8J8;zJ,@h$K0\F0$7$^$9!#(B + + >> C-n $B$"$k$$$O(B C-p $B$KE,Ev$J0z?t$r;XDj$7$F!"0l2s$N0\F0$G$J$k$Y$/$3(B + $B$N9T$N6a$/$KMh$k$h$&$K$7$F$_$J$5$$!#(B + + C-v $B$d(B ESC v $B$K$D$$$F$O>/$70c$$$^$9!#$3$N>l9g!";XDj$5$l$??t$N9T$@$12h(B +$BLL$r0\F0$9$k$3$H$K$J$j$^$9!#(B + + >> C-u 3 C-v $B$HF~NO$7$F$_$J$5$$!#(B + + $B85$KLa$k$K$O!"(BC-u 3 ESC v $B$r;H$($P$h$$$N$G$9!#(B + +$BCf;_%3%^%s%I(B +============ + + C-g $B$H$$$&%3%^%s%I$G!"F~NO$rI,MW$H$9$k$h$&$J%3%^%s%I$rCf;_$9$k$3$H$,(B +$B$G$-$^$9!#Nc$($P!"0z?t$rF~NO$7$F$$$kESCf$d!"#2$D0J>e$N%-!<F~NO$rI,MW$H$9$k(B +$B%3%^%s%I$rF~NO$7$F$$$k:GCf$K!"$=$l$r$d$a$?$/$J$C$?$i!"(BC-g $B$r;H$($PNI$$$N$G(B +$B$9!#(B + + >> C-u 100 $B$r%?%$%W$7$F0z?t$r#1#0#0$K@_Dj$7!"(BC-g $B$r%?%$%W$7$J$5$$!#(B + $B$=$N$"$H$G(B C-f $B$r%?%$%W$7$F$_$J$5$$!#2?J8;z0\F0$7$^$7$?$+!)$b$7(B + $B4V0c$C$F(B ESC $B$rF~NO$7$F$7$^$C$?;~$b!"(BC-g $B$rF~NO$9$l$P<h$j>C$;$^(B + $B$9!#(B + +$B%(%i!<(B +====== + + $B;~$K$O!"(BEmacs$B$G5v$5$l$F$$$J$$A`:n$r$7$F$7$^$&$3$H$,$"$j$^$9!#Nc$($P!"(B +$B%3%^%s%I$NDj5A$5$l$F$$$J$$%3%s%H%m!<%k!&%-!<$rF~NO$7$F$7$^$C$?;~$K$O!"(BEmacs +$B$O%Y%k$rLD$i$7!"$5$i$K!"2hLL$N0lHV2<$K!"2?$,0-$+$C$?$+$rI=<($7$^$9!#(B + + Emacs$B$N%P!<%8%g%s$K$h$C$F$O!"$3$NF~LgJT$K=q$+$l$F$$$k$3$H$r<B9T$G$-$J(B +$B$$>l9g$,$"$jF@$^$9!#$=$NMM$J>l9g$K$O!"%(%i!<%a%C%;!<%8$,I=<($5$l$^$9$+$i!"(B +$B2?$+%+!<%=%k0\F0%-!<$r2!$7$F!"$=$N<!$NItJ,$K?J$s$G2<$5$$!#(B + +$B%&%#%s%I%&(B +========== + + Emacs$B$O4v$D$b$N%&%#%s%I%&$r;}$D$3$H$H!"$=$N$=$l$>$l$KBP$7$F%F%-%9%H$r(B +$BI=<($9$k$3$H$,$G$-$^$9!#%X%k%W$d!"4v$D$+$N%3%^%s%I$+$i$N=PNO$rI=<($9$k$?$a(B +$B$K8=$l$?M>J,$J%&%#%s%I%&$r>C$9$?$a$K!"<!$N%3%^%s%I$rCN$kI,MW$,$"$j$^$9!#(B + + C-x 1 $B%&%#%s%I%&$r#1$D$K$9$k!#(B + + C-x 1 $B$O!"B>$N%&%#%s%I%&$r>C$7$F!"%+!<%=%k$N$"$k%&%#%s%I%&$r!"2hLLA4BN(B +$B$K9-$2$^$9!#(B + + >> $B%+!<%=%k$r$3$N9T$K;}$C$F$-$F!"(BC-u 0 C-l $B$H%?%$%W$7$^$9!#(B + + >> C-h k C-f $B$H%?%$%W$7$J$5$$!#?7$7$$%&%#%s%I%&$,(B C-f $B%3%^%s%I$N%I%-(B + $B%e%a%s%H$rI=<($9$k$?$a$K8=$l$k$HF1;~$K!"$3$N%&%#%s%I%&$,$I$N$h$&(B + $B$K=L$`$+$r4Q;!$7$J$5$$!#(B + + >> C-x 1$B$H%?%$%W$7$F!"%I%-%e%a%s%H$N8=$o$l$F$$$?%&%#%s%I%&$r>C$7$J$5(B + $B$$!#(B + +$BA^F~$H:o=|(B +========== + + $B%F%-%9%H$r%?%$%W$7$?$1$l$P!"C1$K$=$l$r%?%$%W$9$k$@$1$G9=$$$^$;$s!#L\$K(B +$B8+$($kJ8;z!J(B'A','7','*','$B$"(B'$B$J$I!K$O(BEmacs$B$K$h$C$F%F%-%9%H$G$"$k$H$_$J$5$l!"(B +$B$=$N$^$^A^F~$5$l$^$9!#9T$N=*$o$j$O2~9TJ8;z$GI=$5$l!"$3$l$rF~NO$9$k$K$O(B +<Return> $B$r%?%$%W$7$^$9!#(B + + $BD>A0$KF~NO$7$?J8;z$r:o=|$9$k$K$O!"(B<Delete> $B$rF~NO$7$^$9!#(B<Delete> $B$O!"(B +$B%-!<%\!<%I$G!V(BDelete$B!W$H=q$$$F$"$k%-!<$r2!$7$FF~NO$7$^$9!#!V(BDelete$B!W$N$+$o(B +$B$j$K!V(BRubout$B!W$H=q$$$F$"$k$+$bCN$l$^$;$s!#$h$j0lHLE*$K$O!"(B<Delete> $B$O!"8=:_(B +$B%+!<%=%k$N$"$k0LCV$ND>A0$NJ8;z$r:o=|$7$^$9!#(B + + >> $BJ8;z$r$$$/$D$+%?%$%W$7!"$=$l$+$i$=$l$i$r(B <Delete> $B$r;H$C$F:o=|$7(B + $B$J$5$$!#(B + + >> $B1&%^!<%8%s$r1[$($k$^$G%F%-%9%H$r%?%$%W$7$J$5$$!#%F%-%9%H$,0l9T$N(B + $BI}0J>e$KD9$/$J$k$H!"$=$N9T$O2hLL$+$i$O$_=P$7$F!V7QB3!W$5$l$^$9!#(B + $B1&C<$K$"$k(B'\'$B5-9f$O!"$=$N9T$,7QB3$5$l$F$$$k$3$H$rI=$7$F$$$^$9!#(B + Emacs$B$O!"8=:_JT=8Cf$N0LCV$,8+$($k$h$&$K9T$r%9%/%m!<%k$7$^$9!#2hLL(B + $B$N1&$"$k$$$O:8$NC<$K$"$k(B'\'$B5-9f$O!"$=$NJ}8~$K9T$,$^$@B3$$$F$$$k$3(B + $B$H$rI=$7$F$$$^$9!#(B + + $B$3$l$O!"J8>O$G@bL@$9$k$h$j<B:]$K$d$C$?J}$,$h$/H=$k$G$7$g$&!#(B + + >> $B@h$[$IF~NO$7$?!"7QB3$5$l$?9T$N>e$K%+!<%=%k$r$b$C$F$$$-!"(BC-d $B$G%F(B + $B%-%9%H$r:o=|$7$F!"%F%-%9%H$,0l9T$K<}$^$k$h$&$K$7$F$_$J$5$$!#7QB3(B + $B$rI=$9(B'\'$B5-9f$O>C$($^$7$?$M!#(B + + >> $B%+!<%=%k$r9T$N@hF,$K0\F0$7!"(B<Delete> $B$rF~NO$7$J$5$$!#$3$l$O$=$N9T(B + $B$ND>A0$N9T6g@Z$j$r:o=|$9$k$N$G!"$=$N9T$,A0$N9T$H$D$J$,$C$F$7$^$$(B + $B$^$9!#$D$J$,$C$?9T$,2hLL$NI}$h$jD9$/$J$k$H!"7QB3$NI=<($,$5$l$k$G(B + $B$7$g$&!#(B + + >> <Return> $B$r2!$7$F!"$b$&0lEY9T6g@Z$j$rA^F~$7$J$5$$!#(B + + Emacs$B$N$[$H$s$I$N%3%^%s%I$O!"7+$jJV$7$N2s?t$rM?$($k$3$H$,$G$-$^$9!#$3(B +$B$N$3$H$O!"J8;z$NA^F~$K$D$$$F$bEv$F$O$^$j$^$9!#(B + + >> C-u 8 * $B$HF~NO$7$F$_$J$5$$!#$I$&$J$j$^$7$?$+!#(B + + $BFs$D$N9T$N4V$K6uGr9T$r:n$j$?$$>l9g$K$O!"FsHVL\$N9T$N@hF,$K9T$-!"(BC-o $B$r(B +$BF~NO$7$^$9!#(B + + >> $BE,Ev$J9T$N@hF,$K9T$-!"$=$3$G(B C-o $B$rF~NO$7$F$_$J$5$$!#(B + + $B$3$l$G!"(BEmacs$B$G!"%F%-%9%H$rF~NO$7!"$^$?4V0c$$$r=$@5$9$k$b$C$H$b4pK\E*(B +$B$JJ}K!$r3X$s$@$3$H$K$J$j$^$9!#J8;z$HF1$8MM$K!"C18l$d9T$b:o=|$9$k$3$H$,$G$-(B +$B$^$9!#:o=|A`:n$K$D$$$FMWLs$9$k$H<!$N$h$&$K$J$j$^$9!#(B + + <Delete> $B%+!<%=%k$ND>A0$NJ8;z$r:o=|(B + C-d $B%+!<%=%k$N$"$kJ8;z$r:o=|(B + + ESC <Delete> $B%+!<%=%k$ND>A0$NC18l$r:o=|(B + ESC d $B%+!<%=%k0LCV0J9_$K$"$kC18l$r:o=|(B + + C-k $B%+!<%=%k0LCV$+$i9TKv$^$G$r:o=|(B + + $B2?$+$r:o=|$7$?8e$G!"$=$l$r85$KLa$7$?$/$J$k$3$H$,$"$j$^$9!#(BEmacs$B$O!"0l(B +$BJ8;z$h$j$bBg$-$$C10L$G:o=|$r9T$C$?;~$K$O!":o=|$7$?FbMF$rJ]B8$7$F$*$-$^$9!#(B +$B85$KLa$9$K$O!"(BC-y $B$r;H$$$^$9!#Cm0U$7$?$$$N$O!"(BC-y $B$r:o=|$r9T$C$?>l=j$@$1$G(B +$B$O$J$/!"$I$3$K$G$b=PMh$k$3$H$G$9!#(BC-y $B$O!"J]B8$5$l$?%F%-%9%H$r8=:_%+!<%=%k(B +$B$N$"$k>l=j$KA^F~$9$k$?$a$N%3%^%s%I$G$9$+$i!"$3$l$r;H$C$F%F%-%9%H$N0\F0$r9T(B +$B$&$3$H$,$G$-$^$9!#(B + + $B:o=|$r9T$&%3%^%s%I$K$O!"(B"Delete" $B%3%^%s%I$H!"(B"Kill" $B%3%^%s%I$H$,$"$j$^(B +$B$9!#(B"Kill" $B%3%^%s%I$G$O:o=|$5$l$?$b$N$OJ]B8$5$l$^$9$,!"(B"Delete" $B%3%^%s%I$G(B +$B$OJ]B8$5$l$^$;$s!#$?$@$7!"7+$jJV$72s?t$,M?$($i$l$k$H!"J]B8$5$l$^$9!#(B + + >> C-n $B$r#22s$[$I%?%$%W$7$F!"2hLL$NE,Ev$J>l=j$K0\F0$7$J$5$$!#$=$7$F!"(B + C-k $B$G!"$=$N9T$r:o=|$7$J$5$$!#(B + + $B0l2sL\$N(B C-k $B$G$=$N9T$NFbMF$,:o=|$5$l!"$b$&0lEY(B C-k $B$rF~NO$9$k$H!"$=$N(B +$B9T<+?H$,:o=|$5$l$^$9!#$b$7!"(BC-k $B$K7+$jJV$72s?t$r;XDj$7$?>l9g$K$O!"$=$N2s?t(B +$B$@$1$N9T$,!JFbMF$H9T<+?H$H$,F1;~$K!K:o=|$5$l$^$9!#(B + + $B:#:o=|$5$l$?%F%-%9%H$O!"J]B8$5$l$F$$$k$N$G!"$=$l$r<h$j=P$9$3$H$,$G$-$^(B +$B$9!#$=$N$?$a$K$O!"(BC-y $B$r%?%$%W$7$^$9!#(B + + >> C-y $B$r;n$7$F$_$J$5$$!#(B + + C-k $B$r2?EY$bB3$1$F9T$&$H!":o=|$5$l$k%F%-%9%H$O!"$^$H$a$FJ]B8$5$l!"(BC-y +$B$G!"$=$NA4$F$,<h$j=P$5$l$^$9!#(B + + >> C-k $B$r2?EY$b%?%$%W$7$F$_$J$5$$!#(B + + >> $B%F%-%9%H$r<h$j=P$9$K$O!"(BC-y $B$G$9!#%+!<%=%k$r?t9T2<$K0\F0$5$;!"$b(B + $B$&0lEY(B C-y $B$r%?%$%W$7$F$_$J$5$$!#$3$l$G%F%-%9%H$N%3%T!<$,$G$-$k$o(B + $B$1$G$9!#(B + + $B8=:_2?$+$N%F%-%9%H$,J]B8$5$l$F$$$F!"$5$i$KB>$N%F%-%9%H$r:o=|$9$k$H$I$&(B +$B$J$k$G$7$g$&$+!#(BC-y $B$O!"$b$C$H$b:G6a:o=|$5$l$?$b$N$r<h$j=P$7$^$9!#(B + + + >> $B9T$r:o=|$7!"%+!<%=%k$r0\F0$5$;!"JL$N9T$r:o=|$7$J$5$$!#(BC-y $B$r9T$&(B + $B$H!"#2HVL\$N9T$,F@$i$l$^$9!#(B + +$B<h$j>C$7(B(UNDO) +============== + + $B$$$D$G$b!"%F%-%9%H$rJQ99$7$?$1$l$I$b!"$=$l$r$b$H$KLa$7$?$$$H$-$O(BC-x u +$B$GD>$j$^$9!#IaDL$O4V0c$($?%3%^%s%I$rL58z$K$9$kF/$-$r$7$^$9!#7+$jJV$7$F(BUNDO +$B$r9T$J$*$&$H$9$k;~$O!"2?EY$b$=$N%3%^%s%I$r9T$J$($P=PMh$k$h$&$K$J$C$F$$$^$9!#(B + + >> $B$3$N9T$r(BC-k$B$G>C$7$F2<$5$$!#$=$7$F!"(BC-x u$B$GLa$7$F2<$5$$!#(B + + C-_$B$O!"(BUNDO$B$r9T$J$&!"$b$&0l$D$N%3%^%s%I$G$9!#5!G=$O!"(BC-x u$B$HF1$8$G$9!#(B + + C-_$B$d(BC-x u$B$K(BUNDO$B$N2s?t$r!"M?$($k$3$H$,=PMh$^$9!#(B + + +$B%U%!%$%k(B +======== + + $B%F%-%9%H$X$NJQ99$r1J5WE*$K$9$k$?$a$K$O!"$=$l$r%U%!%$%k$KJ]B8$7$J$1$l$P(B +$B$J$j$^$;$s!#J]B8$5$l$J$$$H!"$[$I$3$7$?JQ99$O!"(BEmacs$B$r=*N;$9$k$HF1;~$K<:$o$l(B +$B$F$7$^$$$^$9!#(B + + $B$$$^8+$F$$$k%U%!%$%k$KBP$7$F!"$"$J$?$NJT=8$r9T$C$?$b$N$r=q$-9~$_$^$9!#(B +$B$$$^8+$F$$$k%U%!%$%k$H$O!"4JC1$K$$$($PJT=8$7$F$$$k%U%!%$%k<+BN$N$3$H$G$9!#(B + + $B$"$J$?$,%U%!%$%k$r%;!<%V!JJ]B8$9$k!K$9$k$^$G!":#$^$G$NJQ99$OJT=8$7$F$$(B +$B$k%U%!%$%k$K=q$-9~$^$l$k;v$O$"$j$^$;$s!#$=$l$O!"$"$J$?$,$=$N$h$&$K9T$$$?$/(B +$B$J$$$N$K!"ESCf$^$GJQ99$r2C$($?$b$N$,>!<j$K=q$-9~$^$l$k$h$&$J;v$,$J$$$h$&$K(B +$B$G$9!#(B + + $B%;!<%V$r9T$C$?8e$G$5$(JQ99$7$?$b$N$,4V0c$C$F$$$?;~$N$?$a$K(BEmacs$B$OL>A0(B +$B$rJQ$($F%*%j%8%J%k$N%U%!%$%k$r;D$7$^$9!#(B + +$BHw9M(B: $B$^$?!"(BEmacs$B$OITB,$N;vBV$KBP$7!"0lDj$N%?%$%_%s%0$4$H$K<+F0E*(B + $B$KJT=8$7$F$$$k%U%!%$%k$NFbMF$rL>A0$rJQ$($?%U%!%$%k$K%;!<%V$7(B + $B$^$9!#$3$l$K$h$C$F!"K|0l$N>l9g$O9T$C$?$NJQ99$KBP$7:G>.8B$NHo(B + $B32$G:Q$`$h$&$K$J$C$F$$$^$9!#(B + + $B2hLL$N2<$NJ}$r8+$k$H!"$3$N$h$&$J46$8$G%b!<%I%i%$%s$,I=<($5$l$F$$$k$H;W(B +$B$$$^$9!#(B + + +($BNc(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- + + + $B$3$N(BEmacs$B%A%e!<%H%j%"%k$N%3%T!<$O(BMULE.tut$B$H8F$P$l$F$$$^$9!#%U%!%$%k$r(B +$B%U%!%$%s%I!J%U%!%$%k$r8+$D$1$F%P%C%U%!$KFI$_9~$`$3$H!K$9$k$H!"(BMULE.tut$B$NIt(B +$BJ,$KI=<($5$l$^$9!#Nc$($P!"(Bnew-file$B$H$$$&L>A0$N%U%!%$%k$r%U%!%$%s%I$7$?$J$i(B +$B$P!"(B"Mule: new-file"$B$H$$$&%b!<%I%i%$%s$K$J$k$G$7$g$&!#(B + +$BCm0U!'(B $B%b!<%I%i%$%s$K$D$$$F$O8e$[$I@bL@$7$^$9!#>/$7$*BT$A$r!#(B + + $B%U%!%$%k$r%U%!%$%s%I$7$?$j!"%;!<%V$7$?$j$9$k%3%^%s%I$O!"$3$l$^$G$N$b$N(B +$B$H$O0c$$!"#2$D$NJ8;z$+$i$J$C$F$$$^$9!#(BC-x $B$KB3$$$FF~NO$9$kJ8;z$,!"%U%!%$%k(B +$B$KBP$7$F9T$&A`:n$rI=$7$^$9!#(B + + $B$b$&0l$D$3$l$^$G$N$b$N$H0c$&E@$O!"%U%!%$%s%I$N;~!"%U%!%$%kL>$r(BEmacs$B$K(B +$BLd$o$l$^$9!#$3$N$3$H$r!"C<Kv$+$i0z?t$rFI$_9~$s$G$/$k%3%^%s%I$H8@$C$F$$$^$9!#(B + +$BCm0U!'(B $B$3$N>l9g$O%U%!%$%kL>$G$9!#(B + + C-x C-f $B%U%!%$%k$r8+$D$1$k!J%U%!%$%s%I$9$k!K(B + + Emacs$B$O%U%!%$%kL>$rJ9$$$F$-$^$9!#$=$l$O!"2hLL$N2<$N9T$K8=$l$^$9!#%U%!(B +$B%$%kL>$r;XDj$7$F$$$kItJ,$O!"%_%K%P%C%U%!$H8F$P$l$k$b$N$G$9!#%_%K%P%C%U%!$O(B +$B$3$NMM$J;H$o$lJ}$r$7$^$9!#%U%!%$%kL>$KB3$$$F!"%j%?!<%s%-!<$r2!$9$H!"%_%K%P(B +$B%C%U%!$KI=<($5$l$F$$$?FbMF$O$b$&I,MW$G$O$J$/$J$k$N$G>C$($F$7$^$$$^$9!#(B + + >> C-x C-f$B$H%?%$%W$7$?8e$K(BC-g$B$H%?%$%W$7$F2<$5$$!#%_%K%P%C%U%!$NFbMF(B + $B$r<h$j>C$7!"$^$?!"(BC-x C-f$B%3%^%s%I$b<h$j>C$7$^$9!#$H8@$&Lu$G!"2?$b(B + $B%U%!%$%k$r8+$D$1$k$h$&$J$3$H$O$7$^$;$s!#(B + + $B:#EY$O%U%!%$%k$r%;!<%V$7$F$_$^$7$g$&!#:#$^$G$NJQ99$rJ]B8$9$k$?$a$K$O<!(B +$B$N$h$&$J%3%^%s%I$r;H$$$^$9!#(B + + C-x C-s $B%U%!%$%k$r%;!<%V$9$k(B + + Emacs$B$NFbMF$O%U%!%$%k$K=q$-=P$5$l$^$9!#%;!<%V$9$k;~!"%*%j%8%J%k$N(B +$B%U%!%$%k$O?7$7$$L>A0$r$D$1$i$l$F;D$5$l$F$$$k$N$GFbMF$O<:$o$l$^$;$s!#$=(B +$B$N?7$7$$L>A0$O%*%j%8%J%k$N%U%!%$%k$NL>A0$K(B'~'$B$r$D$1$?$b$N$G$9!#(B + + $B%;!<%V$,=*$o$k$H!"(BEmacs$B$O%;!<%V$7$?%U%!%$%k$NL>A0$rI=<($7$^$9!#(B + + >> C-x C-s$B$H%?%$%W$7$F%A%e!<%H%j%"%k$N%3%T!<$r%;!<%V$7$F2<$5$$!#$=$N(B + $B;~!"2hLL$N2<$NJ}$K(B"Wrote ...../MULE.tut"$B$HI=<($5$l$^$9!#(B + + $B?7$7$$%U%!%$%k$r:n$k;~!"$"$?$+$b0JA0$+$i$"$C$?%U%!%$%k$r%U%!%$%s%I$9$k(B +$B$h$&$J%U%j$r$7$^$9!#$=$&$7$F!"$=$N%U%!%$%s%I$7$?%U%!%$%k$K%?%$%W$7$F$$$-$^(B +$B$9!#(B + + $B%U%!%$%k$r%;!<%V$7$h$&$H$7$?;~$K=i$a$F!"(BEmacs$B$O:#$^$GJT=8$7$F$$$?FbMF(B +$B$r%U%!%$%k$NCf$K=q$-9~$_$^$9!#(B + + +$B%P%C%U%!(B +======== + + $B$b$7!"#2HVL\$N%U%!%$%k$r(B C-x C-f $B$G<h$j=P$9$H!"#1HVL\$N%U%!%$%k$O(BEmacs +$BFbIt$K;D$j$^$9!#(BEmacs$BFbIt$K$"$k%U%!%$%k$+$i%F%-%9%H$rFI$_9~$s$GJ]B8$7$F$$$k(B +$B$b$N$O%P%C%U%!$H8F$P$l$^$9!#%U%!%$%k$N<h$j=P$7$O!"(BEmacs$BFbIt$K?7$7$$%P%C%U%!(B +$B$r:n$j$^$9!#(B + + Emacs$B$NCf$KJ]B8$7$F$$$k%P%C%U%!$N%j%9%H$r8+$k$K$O!"<!$N$h$&$K%?%$%W$7(B +$B$^$9!#(B + + C-x C-b + + >> C-x C-b $B$H%?%$%W$7$J$5$$!#$=$l$>$l$N%P%C%U%!$,$I$N$h$&$KL>A0$r;}(B + $B$C$F$$$k$+!"$=$7$F!"$I$N$h$&$J%U%!%$%kL>$r$D$1$F$$$k$N$+4Q;!$7$J(B + $B$5$$!#(B + + $B%P%C%U%!$K$O%U%!%$%k$H0lCW$J$$$b$N$b$"$j$^$9!#$?$H$($P!"(B +"*Buffer List*" $B$H$$$&%U%!%$%k$O$"$j$^$;$s!#$3$l$O(B C-x C-b $B$K$h$C$F:n$i$l(B +$B$?%P%C%U%!%j%9%H$KBP$7$F$N%P%C%U%!$G$9!#(B + + $B$"$J$?$,8+$F$$$k(BEmacs$B%&%#%s%I%&Fb$K$"$k!"$I$s$J%F%-%9%H$G$b!"$$$:$l$+(B +$B$N%P%C%U%!Fb$K$"$j$^$9!#(B + + >> $B%P%C%U%!%j%9%H$r>C$9$?$a(B C-x 1 $B$H%?%$%W$7$J$5$$!#(B + + $B$b$7!"$"$k%U%!%$%k$N%F%-%9%H$KJQ99$r9T$J$C$F$+$i!"B>$N%U%!%$%k$r<h$j=P(B +$B$7$?$H$7$?$i!":G=i$N%U%!%$%k$O%;!<%V$5$l$F$$$^$;$s!#$=$NJQ99$O(BEmacs$BFbIt$N%U(B +$B%!%$%k$HBP1~$9$k%P%C%U%!$NCf$@$1$K9T$J$o$l$F$$$^$9!#(B + + $B#2HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$r:n$C$?$j!"%(%G%#%C%H$7$?$j$7$F$b!"(B +$B#1HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$K$O2?$b1F6A$rM?$($^$;$s!#$3$l$O$H$F$b;H(B +$B$$0W$/!"$^$?!"#1HVL\$N%U%!%$%k$KBP1~$9$k%P%C%U%!$r<h$C$F$*$/$?$a$KLr$KN)$D(B +$BJ}K!$G$9!#(B + + C-x C-s $B$G%P%C%U%!$r%;!<%V$9$k$?$a$K(B C-x C-f $B$G%P%C%U%!$r@Z$jBX$($k$N(B +$B$OLq2p$G$9!#$=$3$G<!$N%3%^%s%I$r;H$$$^$9!#(B + + C-x s $B8=:_$"$k%P%C%U%!$r%;!<%V$9$k!#(B + + C-x s $B$OFbMF$rJQ$($?%P%C%U%!A4$F$r%U%!%$%k$K%;!<%V$7$^$9!#$3$N;~!"$R$H(B +$B$D$R$H$D$N(B($B%;!<%V$5$l$k$Y$-(B)$B%P%C%U%!$KBP$7$F!"%;!<%V$9$k$+!"$7$J$$$+$r(By$B$+(Bn +$B$GLd$o$l$^$9!#$3$NI=<($O2hLL$N2<$N9T$KI=<($5$l$^$9!#Nc$($P!"$3$N$h$&$K$G$9!#(B + + Save file /usr/private/yours/MULE.tut? (y or n) + + + +$B%3%^%s%I$N3HD%(B +============== + + $B%(%G%#%?$K$O!"%3%s%H%m!<%k!&%-!<$d%a%?!&%-!<$GF~NO$G$-$k$b$N$h$j$b$:$C(B +$B$HB?$/$N%3%^%s%I$,$"$j$^$9!#$3$l$i$r07$&$?$a$K!"3HD%!J(BeXtend$B!K%3%^%s%I$r(B +$B;H$$$^$9!#$=$l$K$O!"0J2<$N#2$D$N<oN`$,$"$j$^$9!#(B + + C-x $BJ8;z$K$h$k3HD%!#B3$1$F0lJ8;z$rF~NO$7$^$9!#(B + ESC x $BL>A0$K$h$k3HD%!#B3$1$F%3%^%s%I$NL>A0$rF~NO$7$^$9!#(B + + $B$3$l$i$O0lHL$K!"JXMx$@$1$l$I$b!"$3$l$^$G8+$F$-$?$b$N$[$IIQHK$K$OMQ$$$i(B +$B$l$J$$%3%^%s%I$N$?$a$N$b$N$G$9!#(BC-x C-f $B!J%U%!%$%s%I!K$d(B C-x C-s$B!J%;!<%V!K(B +$B$O$3$NCg4V$G$9!#B>$K!"(BC-x C-c$B!J%(%G%#%?$N=*N;!K$b$=$&$G$9!#(B + + C-z$B$O(BEmacs$B$rH4$1$k$N$KNI$/;H$o$l$kJ}K!$G$9!#(BEmacs$B$r=*N;$9$k$3$H$J$/!"(B +$B0lC6!"(Bcsh$B$N%l%Y%k$KLa$k$K$O0lHVNI$$J}K!$H8@$($k$G$7$g$&!#(BC-z$B$r9T$J$o$l$F$b(B +Emacs$B$O%9%H%C%W$7$F$$$k$@$1$G!"FbMF$,GK2u$5$l$k$H$$$&$3$H$O$"$j$^$;$s!#(B + +$BCm0U(B: $B$?$@$7(BX-window$B$G9T$J$C$F$$$k>l9g!"$b$7$/$O;HMQ$7$F$$$k%7%'%k(B + $B$,(Bsh$B$N;~$O!"$3$N8B$j$G$O$"$j$^$;$s!#(B + + + C-x $B%3%^%s%I$O!"$?$/$5$s$"$j$^$9!#$9$G$K3X$s$@$b$N$O0J2<$N$b$N$G$9!#(B + + C-x C-f $B%U%!%$%k$NJT=8!J(BFind$B!K(B + C-x C-s $B%U%!%$%k$NJ]B8!J(BSave$B!K(B + C-x C-b $B%P%C%U%!%j%9%H$NI=<((B + C-x C-c $B%(%G%#%?$r=*N;$9$k!#%U%!%$%k$NJ]B8$O!"<+F0E*$K$O9T$o$l$^$;(B + $B$s!#$7$+$7!"$b$7%U%!%$%k$,JQ99$5$l$F$$$l$P!"%U%!%$%k$NJ]B8(B + $B$r$9$k$N$+$I$&$+$rJ9$$$F$-$^$9!#J]B8$7$F=*N;$9$kIaDL$NJ}K!(B + $B$O!"(BC-x C-s C-x C-c $B$H$9$k$3$H$G$9!#(B + + $BL>A0$K$h$k3HD%%3%^%s%I$K$O!"$"$^$j;H$o$l$J$$$b$N$d!"FCDj$N%b!<%I$G$7$+(B +$B;H$o$J$$$b$N$J$I$,$"$j$^$9!#Nc$H$7$F!"(B"command-apropos" $B$r$H$j$"$2$^$9!#$3(B +$B$N%3%^%s%I$O%-!<%o!<%I$rF~NO$5$;!"$=$l$K%^%C%A$9$kA4$F$N%3%^%s%I$NL>A0$rI=(B +$B<($7$^$9!#(BESC x $B$H%?%$%W$9$k$H!"%9%/%j!<%s$N2<$K(B "M-x" $B$,I=<($5$l$^$9!#$3$l(B +$B$KBP$7$F!"<B9T$9$k%3%^%s%I$NL>A0!J:#$N>l9g!"(B"command-apropos"$B!K$rF~NO$7$^$9!#(B +"command-a" $B$^$GF~NO$7$?8e%9%Z!<%9$rF~$l$l$P!"8e$NItJ,$O<+F0E*$KJd$o$l$^$9!#(B +$B$3$N8e!"%-!<%o!<%I$rJ9$+$l$^$9$+$i!"CN$j$?$$J8;zNs$r%?%$%W$7$^$9!#$J$*!"%-!<(B +$B%o!<%I$rF~$l$J$$$H!"A4$F$N%3%^%s%I$,I=<($5$l$^$9!#(B + + >> ESC x $B$r%?%$%W$7!"B3$1$F!"(B"command-apropos<Return>" $B$"$k$$$O(B + "command-a<Space><Return>" $B$H%?%$%W$7$^$9!#<!$K!"(B"kanji<Return>" + $B$H%?%$%W$7$^$9!#(B + + $B8=$l$?!V%&%#%s%I%&!W$r>C$9$K$O!"(BC-x 1 $B$H%?%$%W$7$^$9!#(B + +$B%b!<%I%i%$%s(B +============ + + $B$b$7$f$C$/$j$H%3%^%s%I$rBG$C$?$J$i$P!"2hLL$N2<Dl$N%(%3!<%(%j%"$H8F$P$l(B +$B$k>l=j$KBG$C$?$b$N$,I=<($5$l$^$9!#%(%3!<%(%j%"$O2hLL$N(B1$B$P$s2<$N9T$G$9!#$=$N(B +$B$9$0>e$N9T$O!"%b!<%I%i%$%s$H8F$P$l$F$$$^$9!#%b!<%I%i%$%s$O$3$s$JIw$KI=<($5(B +$B$l$F$$$k$G$7$g$&!#(B + + [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- + + +$BCm0U(B: NN%$B$N(BNN$B$O?t;z$,F~$C$F$$$^$9!#$"$J$?$,;H$C$F$$$k(BEmacs$B$N%b!<(B + $B%I%i%$%s$H0c$&$+$bCN$l$J$$$1$I!"92$F$J$$$h$&$K!#Nc$($P!";~4V(B + $B$d(Buptime$B$,I=<($5$l$F$$$k$N$O!"(Bdisplay-time$B$H$$$&5!G=$,F0$$$F(B + $B$$$k$+$i$G$9!#(B + + $B$3$N9T$K$h$C$FB?$/$NM-MQ$J>pJs$,F@$i$l$^$9!#(B + + + $B:#!"$"$J$?$,8+$F$$$k%U%!%$%kL>$rI=<($7$F$$$^$9!#(BNN%$B$O8=:_%9%/%j!<%s>e(B +$B$K%U%!%$%k$N0lHV>e$+$i2?%Q!<%;%s%HL\$,I=<($5$l$F$$$k$+$r<($7$F$$$^$9!#%U%!(B +$B%$%k$N0lHV:G=i$rI=<($7$F$$$k$J$i$P!"(B--Top--$B$HI=<($5$l$F$^$9!#%U%!%$%k$N0lHV(B +$B:G8e$rI=<($7$F$$$k$J$i$P!"(B--Bot--$B$HI=<($5$l$^$9!#2hLL$NCf$K%U%!%$%k$NA4$F$,(B +$BI=<($5$l$F$$$k$J$i$P!"(B--All--$B$HI=<($5$l$^$9!#(B + + $B%b!<%I%i%$%s$N>.3g8L$NCf$O!":#$I$s$J%b!<%I$KF~$C$F$$$k$+$r<($7$F$$$^$9!#(B +$B8=:_$O!"%G%U%)%k%H$N(BFundamental$B$KF~$C$F$$$^$9!#$3$l$b%a%8%c!<%b!<%I$N0lNc$G(B +$B$9!#(B + + Emacs$B$O(BLisp mode$B$d(BText mode$B$N$h$&$J$3$H$J$k%W%m%0%i%`8@8l$d%F%-%9%H$K(B +$BBP$7$F%(%G%#%C%H$r9T$&$?$a$N4v$D$+$N%a%8%c!<%b!<%I$r;}$C$F$$$^$9!#$I$s$J;~(B +$B$G$bI,$:$$$:$l$+$N%a%8%c!<%b!<%I$N>uBV$K$J$C$F$$$^$9!#(B + + $B$=$l$>$l$N%a%8%c!<%b!<%I$O4v$D$+$N%3%^%s%I$rA4$/0c$&?6$kIq$$$K$7$F$7$^(B +$B$$$^$9!#Nc$r>e$2$F$_$^$7$g$&!#%W%m%0%i%`$NCf$K%3%a%s%H$r:n$k%3%^%s%I$,$"$j(B +$B$^$9!#%3%a%s%H$r$I$NMM$J7A<0$K$9$k$+$O!"3F%W%m%0%i%`8@8l$K$h$C$F0c$$$^$9$,!"(B +$B$=$l$>$l$N%a%8%c!<%b!<%I$O!"$-$A$s$HF~$l$F$/$l$^$9!#(B + + $B$=$l$>$l$N%a%8%c!<%b!<%I$KF~$k$?$a$N%3%^%s%I$O%b!<%IL>$N3HD%$5$l$?$b$N(B +$B$K$J$C$F$$$^$9!#Nc$($P!"(BM-x fundamental-mode$B$O(BFundamental$B$KF~$k$?$a$N$b$N$G(B +$B$9!#(B + + $B$b$7!"1Q8l$r%(%G%#%C%H$9$k$J$i$P!"(BText mode$B$KF~$j$^$9!#(B + + >> M-x text-mode <Retuen>$B$H%?%$%W$7$J$5$$!#(B + + $B8=:_$N%a%8%c!<%b!<%I$K$D$$$F$N%I%-%e%a%s%H$r8+$?$$;~$O!"(BC-h m$B$H%?%$%W(B +$B$7$^$9!#(B + + >> C-h m $B$r;H$C$F(BText mode$B$H(BFundamental mode$B$N0c$$$rD4$Y$J$5$$!#(B + + >> C-x 1$B$G%I%-%e%a%s%H$r2hLL$+$i>C$7$J$5$$!#(B + + $B:8C<$N(B '[--]' $B$O8=:_$N%-!<F~NO$N%b!<%I$r<($7$F$$$^$9!#(B[--] $B$N;~$K$O(B +$B1Q8l%"%k%U%!%Y%C%H$,$=$N$^$^F~NO$G$-$^$9!#F~NO%b!<%I$K$D$$$F$N>\$7$$@bL@$O(B +$B!V$?$^$4!W$N%^%K%e%"%k$rD4$Y$F2<$5$$!#(B + + $B$=$N$9$01&$K$O%3!<%IBN7O(B (coding-system) $B$K4X$9$k%U%i%0$N>uBV$,I=(B +$B<($5$l$F$$$^$9!#(BMule $B$O!"%U%!%$%kF~=PNO!"F~NO!"2hLL=PNO$K$D$$$F!"$=$l$>$lFH(B +$BN)$K%3!<%IBN7O$r;XDj$5$;$k$3$H$,=PMh$^$9$,!"DL>o$O%U%!%$%kMQ$N%3!<%IBN7O$N(B +$B%K!<%b%K%C%/$N$_I=<($7$F$$$^$9!#(B + + >> $B%b!<%I%i%$%s>e$K(B"J:","S:",$B$b$7$/$O(B "E:"$B$,I=<($5$l$F$$$k$+$I$&$+3N(B + $BG'$7$J$5$$!#(B + + $B:G=i$N0lJ8;z$,%3!<%IBN7O$N%K!<%b%K%C%/!"<!$N(B ':' $B$,8=:_1Q8l0J30$NJ8;z(B +$B!JF|K\8l!"Cf9q8l$J$I!K$b$A$c$s$HI=<($9$k$H$$$&$3$H$r<($7$F$$$^$9!#(BJ$B$O(BJUNET +$B$G;H$o$l$F$$$k(B JIS $B%3!<%I!"(BS $B$O(B Shift-JIS$B!"(BE $B$OF|K\8l(BEUC $B$r<($7$F$$$^$9!#(B +$BB?9q8l$NI=<($NM-L5$O(B C-x C-k t $B$G(B ON/OFF$B$N%H%0%k$,$G$-$^$9!#(B + + $B<!$NNc$O!"0lEYB?9q8lI=<($r(BOFF$B$7$F$+$i!"$b$&0lEY(BON$B$r9T$C$F$_$^$9!#(B + + >> C-x C-k t$B$r(B2$BEY9T$$$J$5$$!#(B + + $BF~NO%b!<%I$,(BJIS$B%3!<%I$N@_Dj$H$J$C$F$$$k;~!"$b$7$"$J$?$N;H$C$F$$$kC<Kv(B +$B$K%a%?!&%-!<$,IU$$$F$$$k$J$i!"%(%9%1!<%W!&%-!<$NBe$o$j$K$=$l$r;H$&$3$H$,=P(B +$BMh$^$9!#$=$N;~!"%a%?!&%-!<$N;H$$J}$O%3%s%H%m!<%k!&%-!<$HF1MM$K2!$7$J$,$iJ8(B +$B;z$r%?%$%W$7$^$9!#(BESC <$BJ8;z(B>$B$b(BM-<$BJ8;z(B>$B$bF1$8F/$-$r$7$^$9!#:#$^$G$N@bL@$G(BESC +<$BJ8;z(B>$B$H9T$J$C$F$$$?$H$3$m$,!"(BM-<$BJ8;z(B>$B$H$J$j$^$9!#Cm0U$7$J$1$l$P$J$i$J$$$N(B +$B$O!"%7%U%H(BJIS$B$d(BEUC$B%3!<%I$N;~$O;HMQ$G$-$^$;$s!#(B + + $B%3!<%IBN7O$N$N@Z$jBX$($O!"3F!9$N%P%C%U%!$KBP$7$F$N$_M-8z$G$9!#$=$l$>$l(B +$B$N!"%3!<%IBN7O;XDj$K$D$$$F$O!"(BC-h a coding-system <Return>$B$G8+$k$3$H(B +$B$,=PMh$^$9!#(B + + >> C-h a coding-system <Return>$B$G=P$F$/$k%I%-%e%a%s%HCf$N!"(B + set-display-coding-system, set-file-coding-system, + set-process-coding-system $B$N@bL@$rFI$_$J$5$$!#(B + +$B8!:w(B +===== + + $BJ8;zNs$r!"%U%!%$%kFb$G!"A0J}Kt$O8eJ}$K!"C5$9;v$,$G$-$^$9!#8!:w$r;O$a$k(B +$B%3%^%s%I$O!"%+!<%=%k0LCV0J9_$r8!:w$9$k$J$i$P(B C-s$B!"%+!<%=%k0LCV0JA0$J$i$P(B +C-r $B$G$9!#(BC-s $B$r%?%$%W$9$k$H!"%(%3!<%(%j%"$K(B "I-search:"$B$H$$$&J8;zNs$,%W%m(B +$B%s%W%H$H$7$FI=<($5$l$^$9!#(BESC$B$r2!$9$H!"=*N;$G$-$^$9!#(B + + + >> C-s$B$G8!:w$,;O$^$j$^$9!#$=$l$+$i!"$f$C$/$j$H#1J8;z$:$D(B"cursor"$B$H$$(B + $B$&C18l$rF~NO$7$^$9!##1J8;zF~NO$9$k$4$H$K!"%+!<%=%k$O!"$I$s$JF0$-(B + $B$r$7$^$9$+(B? + + >> $B$b$EY(B C-s $B$r%?%$%W$9$k$H!"<!$N(B"cursor"$B$r8+$D$1$i$l$^$9!#(B + + >> <Delete>$B$r#42sF~NO$7$F!"%+!<%=%k$NF0$-$r8+$J$5$$!#(B + + >> ESC$B$r2!$7$F!"=*N;$7$^$9!#(B + + $BC5$7$?$$J8;zNs$r%?%$%WCf$G$b!"%?%$%W$7$?J8;zItJ,$@$1$G!"8!:w$r;O$a$^$9!#(B +$B<!$NJ8;z$rC5$9$K$O!":F$S(BC-s$B$r%?%$%W$7$^$9!#$b$7!"J8;zNs$,B8:_$7$J$+$C$?$i!"(B +$B%a%C%;!<%8$,I=<($5$l$^$9!#(BC-g $B$G$b=*N;$G$-$^$9!#(B + + $B8!:w<B9TCf$K(B<Delete>$B$rF~NO$9$k$H!"8!:wJ8;zNs$N#1HV8e$m$NJ8;z$,>C$($^$9!#(B +$B$=$7$F!"%+!<%=%k$O!"A02s$N0LCV$KLa$j$^$9!#$?$H$($P!"(B"cu"$B$H%?%$%W$7$F!":G=i(B +$B$N(B"cu"$B$N0LCV$K%+!<%=%k$,F0$$$?$H$7$^$9!#$3$3$G(B<Delete>$B$rF~NO$9$k$H!"%5!<%A(B +$B%i%$%s$N(B'u'$B$,>C$(!"%+!<%=%k$O!"(B'u'$B$r%?%$%W$9$kA0$K!"%+!<%=%k$,$"$C$?(B'c'$B$N0L(B +$BCV$K!"0\F0$7$^$9!#(B + + $B8!:w<B9TCf$K!"(BC-s $B$d(B C-r $B0J30$N%3%s%H%m!<%kJ8;z$r%?%$%W$9$k$H!"8!:w$O(B +$B=*N;$7$^$9!#(B + + C-s $B$O!"8=:_$N%+!<%=%k0LCV0J9_$K=P$F$/$k8!:wJ8;zNs$rC5$7$^$9!#$b$7!"A0(B +$B$NJ}$rC5$7$?$+$C$?$i!"(BC-r $B$r%?%$%W$9$k$3$H$G!"5UJ}8~8!:w$,$G$-$^$9!#(BC-s $B$H(B +C-r $B$O!"8!:w$NJ}8~$,H?BP$J$@$1$G!"A4$FF1$8F/$-$r$7$^$9!#(B + +$B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k(B + + $B$H$-$I$-!"!JITK\0U$K!K%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$H8F$P$l$k>uBV$K(B +$BF~$k$3$H$,$"$j$^$9!#%a%8%c!<%b!<%I$N>.3g8L(B'()'$B$N2s$j$rCf3g8L(B'[]'$B$G0O$s$@$b(B +$B$N$,%b!<%I%i%$%s>e$KI=<($5$l$^$9!#Nc$($P!"(B(Fundamental)$B$HI=<($5$l$kBe$o$j$K(B +[(Fundamental)]$B$N$h$&$K$J$j$^$9!#(B + +$BCm0U(B: $B$3$3$G$O%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k<+BN$K$D$$$F$O@bL@$7(B + $B$^$;$s!#(B + + $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1$G$k$?$a$K$O!"(BM-x top-level +<Return>$B$H%?%$%W$7$^$9!#(B + + >> $B;n$7$F$_$F2<$5$$!#%9%/%j!<%s$NDl$K(B"Back to top level"$B$HI=<($5$l$^(B + $B$9!#(B + + $BK\Ev$O!"$3$N;n$_$,9T$o$l$?;~$O!"$9$G$K%H%C%W%l%Y%k$K$$$?$N$G$9!#(BM-x +top-level$B$O!"2?$b1F6A$rM?$($F$$$^$;$s!#(B + + $B%j%+!<%7%V(B $B%(%G%#%F%#%s%0(B $B%l%Y%k$+$iH4$1=P$k$N$KBP$7$F$O(BC-g$B$O8z$-$^$;(B +$B$s!#(B + + +$B%X%k%W(B +====== + + Emacs$B$K$O!"$?$/$5$s$NLr$KN)$D5!G=$,$"$j!"$3$3$G!"$9$Y$F$r@bL@$9$k$3$H(B +$B$O!"IT2DG=$G$9!#$7$+$7!"$^$@CN$i$J$$B?$/$N5!G=$r3X$V$?$a$K$O!"(B<HELP>$B$H8F$P(B +$B$l$k(B C-h $B$r%?%$%W$9$k$3$H$G!"$?$/$5$s$N>pJs$r<j$KF~$l$k$3$H$,$G$-$^$9!#(B + + $B;H$$J}$O!"(BC-h $B$r%?%$%W$7!"B3$$$FI,MW$J%*%W%7%g%s$r#1J8;z%?%$%W$7$^$9!#(B +$B$o$+$i$J$1$l$P!"(BC-h ? $B$H%?%$%W$9$k$H!"$I$s$J%*%W%7%g%s$,$"$k$N$+I=<($5$l$^(B +$B$9!#$b$7!"(BC-h $B$r%?%$%W$7$F$+$i5$$,JQ$o$C$?$i!"(BC-g $B$r%?%$%W$9$l$P!"<h$j>C$9(B +$B$3$H$,$G$-$^$9!#(B + + $B:G$b4pK\E*$J$b$N$O!"(BC-h c $B$G$9!#$3$l$KB3$$$F%-!<$rF~NO$9$k$H!"$=$N%3%^(B +$B%s%I$K$D$$$F$NC;$$@bL@$rI=<($7$^$9!#(B + + >> C-h c C-p $B$H%?%$%W$7$F$_$J$5$$!#(B"C-p runs the command previous- + line"$B$N$h$&$J%a%C%;!<%8$,I=<($5$l$k$O$:$G$9!#(B + + $B8+$?$3$H$O$"$k$,!"3P$($F$O$$$J$$%3%^%s%I$b;W$$=P$;$k$N$G$9!#(BC-x C-s $B$N(B +$B$h$&$JJ#?t$G#1$D$N%3%^%s%I$b(BC-h c $B$N8e$m$KB3$1$i$l$^$9!#(B + + $B$b$C$H>\$7$/CN$j$?$+$C$?$i!"(Bc $B$NBe$o$j$K(B k $B$r;XDj$7$^$9!#(B + + >> C-h k C-p $B$H%?%$%W$7$F$_$J$5$$!#(B + + Emacs$B$N%&%#%s%I%&$K!"%3%^%s%I$NL>A0$H5!G=$,I=<($5$l$^$9!#FI$_=*$($?$i!"(B +C-x 1 $B$H%?%$%W$9$k$H!"H4$1$i$l$^$9!#(B + + $BB>$K$bLr$KN)$D%*%W%7%g%s$,$"$j$^$9!#(B + + C-h f $B%U%!%s%/%7%g%sL>$rF~NO$9$k$H!"%U%!%s%/%7%g%s$rI=<($7$^$9!#(B + + >> C-h f previous-line $B$r%?%$%W$7!"(B<Return> $B$r2!$7$J$5$$!#(BC-p $B%3%^%s(B + $B%I$r<B9T$9$k%U%!%s%/%7%g%s$K$D$$$F$N>pJs$rI=<($7$^$9!#(B + + C-h a $B%-!<%o!<%I$rF~NO$9$k$H!"L>A0$K$=$N%-!<%o!<%I$r4^$`!"A4$F$N%3(B + $B%^%s%I$rI=<($7$^$9!#$3$l$i$N%3%^%s%I$O$9$Y$F(BESC x $B$G<B9T$G$-(B + $B$^$9!#(B + + >> C-h a file $B$H%?%$%W$7!"(B<Return>$B$r2!$7$J$5$$!#L>A0$K(B"file"$B$H$$$&J8(B + $B;z$r;}$DA4$F$N%3%^%s%I$rI=<($7$^$9!#$^$?!"(Bfind-file $B$d(B write-file + $B$H$$$&L>$N(B C-x C-f $B$d(B C-x C-w $B$N$h$&$J%3%^%s%I$bI=<($5$l$^$9!#(B + +$B$*$o$j$K(B +======== + +$BK:$l$:$K!'(B $B=*N;$9$k$K$O!"(BC-x C-c $B$H$7$^$9!#(B + + + $B$3$NF~LgJT$O!"$^$C$?$/$N=i?4<T$K$b$o$+$j$d$9$$$h$&$K$H0U?^$7$F$$$^$9!#(B +$B$G$9$+$i!"$b$72?$+$o$+$j$K$/$$E@$,$"$C$?$J$i!"0l?M$G6rCT$r8@$&$N$G$O$J$/!"(B +$BJ86g$r$D$1$F2<$5$$!#(B + + + $B$b$7!"(BEMACS $B$r2?F|$+$G$b;H$C$F$_$l$P!"$=$l$r$d$a$F$7$^$&$3$H$J$I$G$-$J(B +$B$/$J$k$G$7$g$&!#:G=i$O8MOG$&$+$bCN$l$^$;$s!#$7$+$7!"$=$l$O$I$s$J%(%G%#%?$G(B +$B$bF1MM$G$9!#(BEMACS $B$N$h$&$K!"Hs>o$KB?$/$N$3$H$,$G$-$k>l9g$K$OFC$K$=$&$G$7$g(B +$B$&!#$=$7$F!"(BEMACS $B$G$O!"<B:]!"2?$G$b$G$-$k$N$G$9$+$i!#(B + + + +$B<U<-(B +===== + $B$3$NJ8=q$O!"(BJUNET$B$GN.$5$l$?(B"$BF|K\8l(B MicroEMACS (kemacs) $BF~LgJT(B" $B$r(BGNUE- +macs (Nemacs)$B$N(BTutorial$BMQ$K=q$-49$($?$b$N$G$9!#(B + + Jonathan Payne $B$K$h$k(B "JOVE Tutorial" (19 January 86) $B$rJQ99$7$?$b$N$G(B + $B$"$j!"$=$l$O$b$H$b$H$O!"(BCCA-UNIX$B$N(BSteve Zimmerman $B$K$h$C$FJQ99$5$l$?!"(B + MIT $B$N(B "Teach-Emacs" $BF~LgJT(B (31 October 85) $B$r!J$5$i$K!KJQ99$7$?$b$N$G(B + $B$7$?!#(B + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +$BFCJL$J<U<-(B +========== + + $B:G=i$K$3$l$NF|K\8lLu$r:n$i$l$?!"(BSANETO Takanori$B$5$s!#$3$NJ8>O$O(BGMW + +Wnn + Nemacs$B$r;H$C$F=q$-$^$7$?!#$=$N$h$&$JAG@2$i$7$$%W%m%0%i%`$r:n$C$?J}!9(B +$B$X46<U$N0U$rI=$7$?$$$H;W$$$^$9!#K]Lu$H$+!"F~NO$H$+$r?'!9$H<jEA$C$F$/$l$?!"(B +$BF#86>M;R$5$s!"$I$&$b$"$j$,$H$&!#(B + + + + + +$B8mLu!"13!"$=$NB>!"$NJ8@U$O!"0J2<$N<T$K$"$j$^$9!#(B + + $BNkLZM5?.(B hironobu@sra.co.jp + + +Update/Add - December 1987 by Hironobu Suzuki +Update/Add - November 1989 by Ken'ichi Handa +Update/Add - January 1990 by Shigeki Yoshida +Update/Add - March 1992 by Kenichi HANDA
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.kr Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,776 @@ + ============================== + $(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B + ============================== + +$(CAV@G(B: $(C@L(B $(C@T9.Fm@:(B, "$(C9h?l1b:84Y(B $(C@M<wGXAv1b(B"$(C8&(B $(C8pEd7N(B $(C@[<:5G>n(B + $(C@V=@4O4Y(B. ">>" $(C7N:NEM(B $(C=C@[GO4B(B $(CG`@:(B, $(C1W(B $(C6'(B $(C9+>y@;(B $(CGX>_(B + $(CGO4B0!8&(B $(CAv=CGO0m(B $(C@V=@4O4Y(B. + + Mule $(C@G(B $(C8m7I>n8&(B $(C@T7BGR(B $(C6'?!4B(B, $(C@O9]@{@87N(B $(CD\F.7Q(B*$(CE0(B($(CE0(B*$(CEi?!(B, +CTRL $(C6G4B(B, CTL $(C6s0m(B $(C=a@V4Y(B)$(C3*(B $(C8^E8(B*$(CE0(B($(C:8Ek(B, $(C@L=:DI@LGA(B*$(CE08&(B $(C;g?kGQ4Y(B)$(C0!(B +$(C;g?k5K4O4Y(B. $(C1W7!<-(B, CONTROL $(C@L6s5g0!(B META $(C6s0m(B $(C>24B(B $(C4k=E?!(B, $(C4Y@=0z00@:(B +$(C1bH#8&(B $(C;g?kGO4B(B $(C0M@87N(B $(CGU4O4Y(B. + +C-<$(C9.@Z(B> $(CD\F.7Q(B*$(CE08&(B $(C4)8%C$(B, <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. $(C?98&(B $(C5i8i(B, + C-f $(C4B(B, $(CD\F.7Q(B*$(CE08&(B $(C4)8#8i<-(B f $(CE08&(B $(C4)8#4B(B $(C0M@;(B + $(C@G9LGU4O4Y(B. +<<Blank lines inserted here by startup of help-with-tutorial>> + >> $(C1W7/8i(B, C-v (View Next Screen; $(C4Y@=@G(B $(CH-8i@;(B $(C:;4Y(B) $(C8&(B $(CE8@LGA(B + $(CGO?)(B $(C:8<<?d(B. $(C4Y@=@G(B $(CH-8i@87N(B $(C0%(B $(C<v(B $(C@V=@4O4Y(B. + From now on, you'll be expected to do this whenever you finish + reading the screen. + +ESC <$(C9.@Z(B> $(C@L=:DI@LGA(B*$(CE08&(B $(C4)8#0m3*<-(B, $(C1W(B $(C5Z(B <$(C9.@Z(B>$(CE08&(B $(C4)8(4O4Y(B. + +$(CAV@G(B: <$(C9.@Z(B>$(C4B(B, $(C4k9.@Z3*(B $(C<R9.@Z4B(B $(C8m7I>n7N<-4B(B $(C00@:(B $(C@G9L0!(B + $(C5K4O4Y(B. $(C8^E8E08&(B $(C;g?kGR(B $(C<v(B $(C@V@88i(B ESC <$(C9.@Z(B> $(C4k=E?!(B M- + <$(C9.@Z(B> ($(C8^E8E08&(B $(C4)8%C$(B<$(C9.@Z(B>$(CE08&(B $(C4)8%4Y(B) $(C8&(B $(C;g?kGR(B $(C<v(B + $(C@V=@4O4Y(B. + +$(CA_?dGU4O4Y(B: Emacs$(C8&(B $(CA>7a=CE00m(B $(C=M@;(B $(C6'4B(B, C-x C-c $(C8&(B $(CE8@LGAGU4O4Y(B. + Emacs$(C8&(B csh$(C7N:NEM(B $(C1b5?GO0m(B $(C@V4B(B $(C0f?l(B, $(C<-=:Ff5eGO4B(B($(C@O=C(B + $(C@{@87N(B $(CA_4\GQ4Y(B)$(CGR(B $(C<v0!(B $(C@V=@4O4Y(B. Emacs$(C8&(B $(C<-=:Ff5eGO4B(B + $(C5%4B(B, C-z$(C8&(B $(CE8@LGAGU4O4Y(B. + + $(C1W7/8i(B, $(C@LA&:NEM4B(B, $(CGQH-8i@;(B $(C4Y(B $(C@P>z@88i(B, C-v $(C8&(B $(C@T7BGO?)(B $(CAV<<?d(B. + + $(C>U@G(B $(CH-8i0z(B $(C4Y@=(B $(CH-8i?!4B(B, $(CG%=C5G4B(B $(C3;?k?!(B $(C8nG`@G(B $(C9.@L(B $(CA_:95G0m(B +$(C@V=@4O4Y(B. $(CG%=C5G0m(B $(C@V4B(B $(C3;?k@L(B $(C?,<S5G>n(B $(C@V4B(B $(C0M@;(B $(C>K(B $(C<v(B $(C@V557O(B $(CGO1b(B $(C@'(B +$(CGQ(B $(C0M@T4O4Y(B. + + + $(C$^8U@z(B, $(CH-@O(B $(C<S@;(B $(C@L5?GO?)(B $(C0!4B(B $(C9f9}@;(B $(C>K(B $(CGJ?d0!(B $(C@V=@4O4Y(B. C-v +$(C?!(B $(C@GGO?)(B $(C>U@87N(B $(CAxG`GO4B(B $(C0M@:(B $(C@L9L(B $(C>K>R=@4O4Y(B. $(C?x7!@G(B $(C@Z8.7N(B $(C5G59>F(B +$(C0!4B5%4B(B, ESC v $(C8&(B $(CE8@LGAGU4O4Y(B. + + >> ESC v $(C?M(B C-v $(C8&(B $(C;g?kGO?)(B, $(C@|HD7N(B $(C@L5?GO4B(B $(C0M@;(B $(C8n9x(B $(C=C55GO?)(B + $(C:8<<?d(B. + +$(C?d>`(B +==== + $(CH-@O@;(B $(CH-8i4\@'7N(B $(C:80m(B $(C0!4B5%4B(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-v $(C>U@87N(B $(CGQ(B $(CH-8i:P(B $(CAxG`GQ4Y(B + ESC v $(C5Z7N(B $(CGQ(B $(CH-8i:P(B $(C5G59>F0#4Y(B + C-l $(CH-8i@;(B $(C4Y=C>44Y(B. $(C@L(B $(C6'(B, $(C?x7!(B $(CD?<-0!(B $(C@V>z4x(B $(CG`@L(B + $(CH-8i@G(B $(CA_>S?!(B $(C?@557O(B $(CGQ4Y(B + + >> $(CAv1](B $(CD?<-0!(B $(C>n5p?!(B $(C@V4B0!(B, $(C1W(B $(C1YC3?!(B $(C>n62(B $(CEX=:F.0!(B $(C=aA.(B $(C@V4B(B + $(C0!8&(B $(C1b>oGO<<?d(B. C-l $(C8&(B $(CE8@LGAGO0m(B, $(CD?<-0!(B $(C>n5p7N(B $(C@L5?GO?44B(B + $(C0!(B, $(C1W(B $(C1YC3@G(B $(CEX=:F.4B(B $(C>n6;0T(B $(C5G>z4B0!8&(B $(CA6;gGO?)(B $(C:8<<?d(B. + +$(C1b:;@{@N(B $(CD?<-@G(B $(CA&>n(B +====================== + + $(CH-8i4\@'@G(B $(C@L5?@:(B $(CGR(B $(C<v(B $(C@V0T(B $(C5G>z=@4O4Y(B. $(C@LA&4B(B, $(CH-8i(B $(C3;?!<-(B, $(CF/(B +$(CA$@G(B $(C@e<R7N(B $(C@L5?GO1b(B $(C@'GQ(B $(C9f9}@;(B $(C@MH|=C4Y(B. $(C@L0M?!4B(B $(C8n0!Av@G(B $(C9f9}@L(B $(C@V(B +$(C=@4O4Y(B. $(CGQ0!Av(B $(C9f9}@:(B, $(C@|(B(previous)$(CHD(B(next)$(C>U(B(forward)$(C5Z(B(backward)$(C7N(B +$(C@L5?GO4B(B $(C8m7I>n8&(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. $(C@L5i@G(B $(C8m7I>n4B(B $(C0"0"(B, C-p, C-n, +C-f, C-b $(C?!(B $(CGR4g5G>n(B $(C@V0m(B, $(CGv@g@G(B $(C@e<R7N:NEM(B $(C;u7N?n(B $(C@e<R7N(B $(CD?<-8&(B $(C@L5?(B +$(C=CE54O4Y(B. $(C1W82@87N(B $(C1W8.8i(B, + + + $(C@L@|@G(B $(CG`(B, C-p + : + : + $(C5Z@G(B $(C9.@Z(B, C-b .... $(CGv@g@G(B $(CD?<-@'D!(B .... $(C@|9f@G(B $(C9.@Z(B, C-f + : + : + $(C4Y@=(B $(CG`(B, C-n + + + $(C@L5i@:(B, $(C0"0"(B, Previous, Next, Backward, Forward $(C@G(B $(C8S8.9.@Z7N(B $(C5G(B +$(C>n(B $(C@V@89G7N(B, $(C?\?l1b(B $(C=,?o(B $(C0M@T4O4Y(B. $(C@L5i@:(B, $(C1b:;@{@N(B $(CD?<-@L5?(B $(C8m7I>n@L0m(B +, $(C@ZAV(B $(C;g?kGO4B(B $(C0M@T4O4Y(B. + + >> C-n $(C@;(B $(C8nH8A$55(B $(CE8@LGAGO0m(B, ($(CAv1](B, $(C4g=E@L(B $(C@P0m(B $(C@V4B(B) $(C@L(B $(CG`1n(B + $(CAv(B $(CD?<-8&(B $(C@L5?=CE0<<?d(B. + + >> C-f $(C8&(B $(C;g?kGO?)(B $(CG`@G(B $(CA_0#A$557N(B $(C@L5?GO0m(B, C-p $(C@87N(B $(C8nG`A$55(B + $(C@'7N(B $(C@L5?GO?)(B $(C:8<<?d(B. $(CD?<-@'D!@G(B $(C:/H-?!(B $(CAV@GGO<<?d(B. + + >> $(CG`@G(B $(C<15N?!<-(B C-b $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(CD?<-4B(B $(C>n5p7N(B $(C@L5?GU(B + $(C4O1n(B? $(C4Y=C(B $(CA61](B $(C4u(B C-b $(C8&(B $(CE8@LGAGO0m(B, $(C@L9x@:(B C-f $(C7N(B $(CG`3!(B $(CBJ(B + $(C@87N(B $(C5G59>F0!<<?d(B. $(CD?<-0!(B $(CG`3!@;(B $(C3Q@88i(B $(C>n6;0T(B $(C5K4O1n(B? + + + $(CH-8i@G(B $(C<15N3*(B $(C8;9L8&(B $(C3Q>n<-(B $(CD?<-8&(B $(C@L5?=CE07A0m(B $(CGO8i(B, $(C1W(B $(C9fGb?!(B +$(C@V4B(B $(CEX=:F.0!(B $(C@L5?GO?)(B $(C?@0m(B, $(CD?<-4B(B $(CGW;s(B $(CH-8i3;?!(B $(C@V557O(B $(C5K4O4Y(B. + + >> C-n $(C@;(B $(C;g?kGO?)(B, $(CD?<-8&(B $(CH-8i@G(B $(CGO4\:84Y(B $(C9X@87N(B $(C@L5?=CDQ(B $(C:8<<(B + $(C?d(B. $(C9+>y@L(B $(C@O>n334O1n(B? $(CD?<-@G(B $(C@'D!4B(B $(C>n6;0T(B $(C:/GO?4=@4O1n(B? + + $(CGQ9.@Z(B $(C4\@'@G(B $(C@L5?@87N4B(B $(C9x0E7S4Y0m(B $(C;}0"5G8i(B, $(C4\>n4\@'7N(B $(C@L5?GR(B +$(C<v55(B $(C@V=@4O4Y(B. ESC f $(C7N(B $(CGQ(B $(C4\>n:P(B $(C>U@87N(B $(CAxG`GO0m(B, ESC b $(C7N(B $(CGQ(B $(C4\>n:P(B +$(C@L@|@87N(B $(C5G59>F0)4O4Y(B. + +$(CAV@G(B: $(C@O:;>n?!(B $(C4kGX<-4B(B, $(C4\>n@G(B $(C2w4B(B $(C4\@'@;(B $(C@N=DGR(B $(C<v(B $(C>x=@4O(B + $(C4Y88(B, $(C@G;g@{@N(B $(C9.@}@;(B $(C4\>n@G(B $(C2w4B(B $(C4\@'7N<-(B $(CGO0m(B $(C@V=@4O(B + $(C4Y(B. + + >> ESC f $(C3*(B ESC b $(C8&(B $(C8nH8A$55(B $(CE8@LGAGO?)(B $(C:8<<?d(B. C-f $(C3*(B C-b $(C?M(B + $(C:4?kGO?)(B $(C:8<<?d(B. + + C-f $(C3*(B C-b $(C?!(B $(C4kGQ(B, ESC f $(C3*(B ESC b $(C@G(B $(C@/;g<:?!(B $(CAV8qGO<<?d(B. $(C4k:N:P(B +$(C@G(B $(C0f?l(B, ESC <$(C9.@Z(B>$(C4B(B $(C9.<-0|0h@G(B $(CC38.?!(B $(C;g?k5G0m(B, $(CGQFm(B C-<$(C9.@Z(B>$(C4B(B $(C1W0M(B +$(C:84Y55(B $(C4u?m(B $(C1b:;@{@N(B $(C4k;s(B($(C9.@Z6s5g0!(B $(CG`@L6s5g0!(B)$(C?!(B $(C4kGQ(B $(CA6@[?!(B $(C;g?k5K(B +$(C4O4Y(B. + + C-a $(C?M(B C-e $(C55(B $(C>K0m(B $(C@V@88i(B $(CFm8.GQ(B $(C8m7I>n@T4O4Y(B. C-a $(C4B(B $(CD?<-8&(B $(CG`@G(B +$(C<15N7N(B $(C@L5?=CE00m(B, C-e $(C4B(B $(CG`@G(B $(C3!@87N(B $(C@L5?=CE54O4Y(B. + + >> C-a $(C8&(B 2$(CH8(B, $(C1W8.0m3*<-(B C-e $(C8&(B 2$(CH8(B $(C@T7BGO?)(B $(C:8<<?d(B. $(C@L5i@G(B $(C8m(B + $(C7I>n8&(B 2$(CH8@L;s(B $(C9]:9GO4u6s55(B, $(CD?<-4B(B $(C1W(B $(C@L;s(B $(C@L5?GOAv(B $(C>J4B(B $(C0M(B + $(C?!(B $(CAV@G(B. + + $(C5N0!Av(B $(C4u(B, $(C0#4\GQ(B $(CD?<-(B $(C@L5?(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C<15N7N(B $(C@L5?(B +$(CGO4B(B ESC < $(C?M(B, $(CH-@O@G(B $(C3!@87N(B $(C@L5?GO4B(B ESC > $(C@T4O4Y(B. + + $(CEX=:F.(B $(C3;?!<-(B, $(CD?<-0!(B $(CA8@gGO4B(B $(C@'D!8&(B "$(CFw@NF.(B"$(C6s0m(B $(C:N8(4O4Y(B. $(C9Y2Y(B +$(C>n(B $(C8;GO8i(B, $(CD?<-4B(B, $(CEX=:F.@G(B $(C>n5p?!(B $(C@V4B0!8&(B $(CH-8i@'?!(B $(C3*E83;0m(B $(C@V4B(B $(C0M(B +$(C@T4O4Y(B. + + $(C>F7!?!(B $(C4\<xGQ(B $(C@L5?A6@[?!(B $(C4kGX<-(B $(C?d>`GU4O4Y(B. $(C@L(B $(CA_?!4B(B, $(C4\>n3*(B $(CG`(B +$(C4\@'7N@G(B $(C@L5?8m7I>n55(B $(CFwGT5G>n(B $(C@V=@4O4Y(B. + + C-f $(CGQ(B $(C9.@Z(B $(C>U@87N(B $(CAxG`GQ4Y(B + C-b $(CGQ(B $(C9.@Z(B $(C5Z7N(B $(C5G59>F0#4Y(B + + ESC f $(CGQ(B $(C4\>n(B $(C>U@87N(B $(CAxG`GQ4Y(B + ESC b $(CGQ(B $(C4\>n(B $(C5Z7N(B $(C5G59>F0#4Y(B + + C-n $(C4Y@=(B $(CG`@87N(B $(C@L5?(B + C-p $(C@L@|(B $(CG`@87N(B $(C@L5?(B + + ESC ] $(C4\6t@G(B $(C3!@87N(B $(C@L5?(B + ESC [ $(C4\6t@G(B $(C<15N7N(B $(C@L5?(B + + C-a $(CG`@G(B $(CCVCJ7N(B $(C@L5?(B + C-e $(CG`@G(B $(CCVHD7N(B $(C@L5?(B + + ESC < $(CH-@O@G(B $(CCVCJ7N(B $(C@L5?(B + ESC > $(CH-@O@G(B $(CCVHD7N(B $(C@L5?(B + + >> $(C0"0"@G(B $(C8m7I>n8&(B $(C=C55GO?)(B $(C:8<<?d(B. $(C@L5i@G(B $(C8m7I>n4B(B, $(C0!@e(B $(C@ZAV(B + $(C;g?k5G4B(B $(C0M@T4O4Y(B. $(CCVHD@G(B $(C5N0!Av4B(B, $(C@L(B $(C@e<R?M4B(B $(C63>nAx(B $(C0w@8(B + $(C7N(B $(C@L5?GO1b(B $(C6'9.?!(B, C-v $(C3*(B ESC v $(C8&(B $(C;g?kGO?)(B $(C?)1b7N(B $(C5G59>F(B + $(C?@557O(B $(CGO<<?d(B. + + Emacs$(C@G(B $(C4Y8%(B $(C8m7I?M(B $(C6H00@L(B, $(C@L5i@G(B $(C8m7I>n?!4B(B, $(C9]:9H8<v8&(B $(CAvA$GO(B +$(C4B(B $(C@N<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. $(C@L8&(B $(C@'GX<-4B(B, $(C8m7I>n8&(B $(C@T7BGO1b(B $(C@|?!(B, C-u +$(C?!(B $(C@L>n<-(B $(C9]:9GO4B(B $(CH8<v8&(B $(C@T7BGU4O4Y(B. + + $(CNc?98&(B $(C5i8i(B, C-u 8 C-f $(C6s0m(B $(CGO8i(B, 8$(C9.@Z:P(B $(C>U@87N(B $(C@L5?GU4O4Y(B. + + >> C-n $(CH$@:(B C-p $(C?!(B $(C@{4gGQ(B $(C@N<v8&(B $(CAvA$GO0m(B, $(C@OH8@G(B $(C@L5?@87N(B $(C0!4I(B + $(CGQGQ(B, $(C@L(B $(CG`@G(B $(C1YC3?!(B $(C?@557O(B $(CGO?)(B $(C:8<<?d(B. + + C-v $(C3*(B ESC v $(C?!(B $(C4kGX<-4B(B $(CA61](B $(C4Y8(4O4Y(B. $(C@L(B $(C0f?l(B, $(CAvA$5H(B $(C<v@G(B $(CG`88(B +$(CH-8i@;(B $(C@L5?GO4B(B $(C0M@L(B $(C5K4O4Y(B. + + >> C-u 3 C-v $(C6s0m(B $(C@T7BGO?)(B $(C:8<<?d(B. + + $(C?x7!(B $(C@Z8.7N(B $(C5G59>F0!4B5%4B(B, C-u 3 ESC v $(C8&(B $(C;g?kGO8i(B $(C5K4O4Y(B. + +$(CA_Av8m7I>n(B +========== + + C-g $(C6s4B(B $(C8m7I>n@L8g(B, $(C@T7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C0M0z(B $(C00@:(B $(C8m7I>n8&(B $(CA_AvGR(B +$(C<v(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, $(C@N<v8&(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_@L3*(B, 2$(C03(B $(C@L;s@G(B $(CE0@T(B +$(C7B@;(B $(CGJ?d7N(B $(CGO4B(B $(C8m7I>n8&(B $(CGQC"(B $(C@T7BGO0m(B $(C@V4B(B $(C55A_?!(B, $(C1W0M@;(B $(CA_AvGO0m(B $(C=M(B +$(C@88i(B, C-g $(C8&;g?kGO8i(B $(C5K4O4Y(B. + + >> C-u 100 $(C8&(B $(CE8@LGAGO?)(B $(C@N<v8&(B 100$(C@87N(B $(C<3A$GO0m(B, C-g $(C8&(B $(CE8@LGA(B + $(CGO<<?d(B. $(C1W(B $(C5Z?!(B C-f $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(C8n9.@Z(B $(C@L5?GO?4=@(B + $(C4O1n(B? $(C88>`(B, $(C@_8xGO?)(B ESC $(C8&(B $(C@T7BGX(B $(C9v7H@;(B $(C6'55(B, C-g $(C8&(B $(C@T7BGO(B + $(C8i(B $(CCk<R=CE3(B $(C<v(B $(C@V=@4O4Y(B. + +$(C?!7/(B +==== + + $(C6'7N4B(B, Emacs$(C?!<-(B $(CGc?k5G0m(B $(C@VAv(B $(C>J4B(B $(CA6@[@;(B $(CGX9v8.4B(B $(C@{@L(B $(C@V=@4O(B +$(C4Y(B. $(C?98&(B $(C5i8i(B, $(C8m7I>n0!(B $(CA$@G5G>n(B $(C@VAv(B $(C>J4B(B $(CD\F.7Q(B*$(CE08&(B $(C@T7BGX(B $(C9v80(B $(C6'(B +$(C?!4B(B, Emacs$(C4B(B $(C:'@;(B $(C?o8.0m(B, $(C1W8.0m(B, $(CH-8i@G(B $(CA&@O(B $(C9X?!(B, $(C9+>y@L(B $(C3*;&4B(B $(C0!(B +$(C8&(B $(CG%=CGU4O4Y(B. + + Emacs $(C9vA/?!(B $(C5{6s<-4B(B, $(C@L(B $(C@T9.Fm?!(B $(C>2?)A.(B $(C@V4B(B $(C0M@;(B $(C=GG`GR(B $(C<v(B $(C>x(B +$(C4B(B $(C0f?l0!(B $(C@V@;(B $(C<v(B $(C@V=@4O4Y(B. $(C1W?M(B $(C00@:(B $(C0f?l?!4B(B, $(C?!7/8^<<Av0!(B $(CG%=C5G9G(B +$(C7N(B, $(C>n4@(B $(C0M@N0!(B $(C@L5?E08&(B $(C4)8#0m(B, $(C1W(B $(C4Y@=@G(B $(C:N:P@87N(B $(CAxG`GO?)(B $(CAV<<?d(B. + +$(C@)55?l(B +====== + + Emacs$(C4B(B $(C8n03@G(B $(C@)55?l8&(B $(C0!Av4B(B $(C0M0z(B, $(C1W(B $(C0"0"?!(B $(C4kGO?)(B $(CEX=:F.8&(B $(CG%(B +$(C=CGR(B $(C<v(B $(C@V=@4O4Y(B. $(CGoGA3*(B, $(C8n0!Av@G(B $(C8m7I>n7N:NEM@G(B $(CCb7B@;(B $(CG%=CGO1b(B $(C@'GO(B +$(C?)(B $(C3*E83-(B $(C?):P@G(B $(C@)55?l8&(B $(CAv?l1b(B $(C@'GO?)(B, $(C4Y@=@G(B $(C8m7I>n8&(B $(C>K(B $(CGJ?d0!(B $(C@V=@(B +$(C4O4Y(B. + + C-x 1 $(C@)55?l8&(B 1$(C037N(B $(CGQ4Y(B. + + C-x 1 $(C4B(B, $(C4Y8%(B $(C@)55?l8&(B $(CAv?l0m(B, $(CD?<-0!(B $(C@V4B(B $(C@)55?l8&(B, $(CH-8i@|C<7N(B +$(CH.@eGU4O4Y(B. + + >> $(CD?<-8&(B $(C@L(B $(CG`?!(B $(C0.0m(B $(C?M<-(B, C-u 0 C-l $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + >> C-h k C-f $(C6s0m(B $(CE8@LGAGO<<?d(B. $(C;u7N?n(B $(C@)55?l0!(B C-f $(C8m7I>n@G(B $(C55(B + $(CE%8UF.8&(B $(CG%=CGO1b(B $(C@'GO?)(B $(C3*E8320z(B $(C5?=C?!(B, $(C@L(B $(C@)55?l0!(B $(C>n6;0T(B + $(CAY>n5e4B0!(B $(C0|B{GO<<?d(B. + + >> C-x 1$(C@L6s0m(B $(CE8@LGAGO0m(B, $(C55E%8UF.0!(B $(C3*E8354x(B $(C@)55?l8&(B $(CAv?l<<(B + $(C?d(B. + +$(C;p@T0z(B $(C;hA&(B +=========== + + $(CEX=:F.8&(B $(CE8@LGAGO0m(B $(C=M@88i(B, $(C4\<xHw(B $(C1W0M@;(B $(CE8@LGAGO4B(B $(C0M88@87N(B $(C1&(B +$(CBz=@4O4Y(B. $(C4+?!(B $(C:8@L4B(B $(C9.@Z(B ('A','7','*','$(C$"(B'$(C5n(B)$(C@:(B Emacs$(C?!(B $(C@GGO?)(B $(CEX=:(B +$(CF.6s0m(B $(C0#AV5G0m(B,$(C1W4k7N(B $(C;p@T5K4O4Y(B. $(CG`@G(B $(C3!@:(B $(C03G`9.@Z7N(B $(C3*E83*0m(B, $(C@L(B +$(C0M@;(B $(C@T7BGO4B5%4B(B<Return> $(C@;(B $(CE8@LGAGU4O4Y(B. + + $(CAw@|?!(B $(C@T7BGQ(B $(C9.@Z8&(B $(C;hA&GO4B5%4B(B, <Delete> $(C8&(B $(C@T7BGU4O4Y(B. +<Delete> $(C4B(B,$(CE0:85e?!<-(B "Delete"$(C6s0m(B $(C=a@V4B(B $(CE08&(B $(C4-7/<-(B $(C@T7BGU4O4Y(B. +"Delete" $(C4k=E?!(B"Rubout"$(C6s0m(B $(C=a@V@;(B $(CAv55(B $(C8p8(4O4Y(B. $(C:84Y(B $(C@O9]@{@87N(B, +<Delete> $(C4B(B, $(CGv@gD?<-0!(B $(C@V4B(B $(C@'D!@G(B $(CAw@|@G(B $(C9.@Z8&(B $(C;hA&GU4O4Y(B. + + >> $(C9.@Z8&(B $(C8n03A$55(B $(CE8@LGAGO0m(B, $(C1W8.0m3*<-(B $(C1W0M@;(B <Delete> $(C8&(B $(C;g(B + $(C?kGO?)(B $(C;hA&GO<<?d(B. + + >> $(C?@8%BJ86Ax@;(B $(C3Q@;(B $(C6'1nAv(B $(CEX=:F.8&(B $(CE8@LGAGO<<?d(B. $(CEX=:F.0!(B $(CGQ(B + $(CG`@G(B $(CFx(B $(C@L;s@87N(B $(C1f0T(B $(C5G8i(B, $(C1W(B $(CG`@:(B $(CH-8i@87N:NEM(B $(C:q>nA.3*?M(B + "$(C0h<S(B"$(C5K4O4Y(B. $(C?l4\?!(B $(C@V4B(B '\'$(C1bH#4B(B, $(C1W(B $(CG`@L(B $(C0h<S5G0m(B $(C@V4B(B + $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. Emacs$(C4B(B, $(CGv@g(B $(CFmA}A_@G(B $(C@'D!0!(B $(C:8@L(B + $(C557O(B $(CG`@;(B $(C=:E)7QGU4O4Y(B. $(CH-8i@G(B $(C?@8%BJ(B $(CH$@:(B $(C?^BJ@G(B $(C3!?!(B $(C@V4B(B + '\'$(C1bH#4B(B, $(C1W(B $(C9fGb?!(B $(CG`@L(B $(C>FAw(B $(C@L>nAv0m(B $(C@V4B(B $(C0M@;(B $(C3*E83;0m(B + $(C@V=@4O4Y(B. + + $(C@L0M@:(B, $(C1[7N(B $(C<38mGO4B(B $(C0M:84Y(B $(C=GA&7N(B $(CGX:84B(B $(CFm@L(B $(C@_(B $(C>K(B $(C<v(B $(C@V0ZAv?d(B. + + >> $(CA61]@|(B $(C@T7BGQ(B, $(C0h<S5H(B $(CG`@G(B $(C@'?!(B $(CD?<-8&(B $(C0.0m0!<-(B, C-d $(C7N(B $(CEX(B + $(C=:F.8&(B $(C;hA&GO0m(B, $(CEX=:F.0!(B $(CGQG`?!(B $(C5i>n0!557O(B $(CGX:8<<?d(B. $(C0h<S@;(B + $(C3*E83;4B(B '\'$(C1bH#4B(B $(CAv?vA3Av?d(B? + + >> $(CD?<-8&(B $(CG`@G(B $(C<15N7N(B $(C@L5?GO0m(B, <Delete> $(C8&(B $(C@T7BGO<<?d(B. $(C@L0M@:(B + $(C1W(B $(CG`@G(B $(CAw@|@G(B $(CG`(B $(C4\6tAv@=@;(B $(C;hA&GO9G7N(B, $(C1W(B $(CG`@L(B $(C>U@G(B $(CG`0z(B + $(C@L>nA.(B $(C9v834O4Y(B. $(C@L>nAx(B $(CG`@L(B $(CH-8i@G(B $(CFx:84Y(B $(C1f0T(B $(C5G8i(B, $(C0h<S(B + $(CG%=C0!(B $(C5G0ZAv?d(B. + + >> <Return> $(C8&(B $(C4)8#0m(B, $(CGQ9x(B $(C4u(B $(CG`4\6tAv@=@;(B $(C;p@TGO<<?d(B. + + Emacs$(C@G(B $(C4k:N:P@G(B $(C8m7I>n4B(B, $(C9]:9(B $(CH8<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. $(C@L0M@:(B, $(C9.(B +$(C@Z(B $(C;p@T?!(B $(C4kGX<-55(B $(C@{?k5K4O4Y(B. + + >> C-u 8 * $(C6s0m(B $(C@T7BGO?)(B $(C:8<<?d(B. $(C>n6;0T(B $(C5G>z=@4O1n(B? + + $(C5N03@G(B $(CG`(B $(C;g@L?!(B $(C0x9iG`@;(B $(C885i0m(B $(C=M@:(B $(C0f?l?!4B(B, $(C5N9xB0(B $(CG`@G(B $(C<15N(B +$(C7N(B $(C0!<-(B, C-o $(C8&(B $(C@T7BGU4O4Y(B. + + >> $(C@{4gHw(B $(CG`@G(B $(C<15N?!(B $(C0!<-(B, $(C0E1b<-(B C-o $(C8&(B $(C@T7BGO?)(B $(C:8<<?d(B. + + $(C@L0M@87N(B, Emacs$(C?!<-(B, $(CEX=:F.8&(B $(C@T7BGO0m(B, $(C6GGQ(B $(CF280(B $(C0M@;(B $(C<vA$GO4B(B +$(C0!@e(B $(C1b:;@{@N(B $(C9f9}@;(B $(C9h?n(B $(C0M@L(B $(C5G>z=@4O4Y(B. $(C9.@Z?M(B $(C00@L(B, $(C4\>n3*(B $(CG`55(B +$(C;hA&GR(B $(C<v(B $(C@V=@4O4Y(B. $(C;hA&A6@[?!(B $(C4kGX<-(B $(C?d>`GO8i(B $(C4Y@=0z(B $(C00=@4O4Y(B. + + <Delete> $(CD?<-Aw@|@G(B $(C9.@Z8&(B $(C;hA&(B + C-d $(CD?<-0!(B $(C@V4B(B $(C9.@Z8&(B $(C;hA&(B + + ESC <Delete> $(CD?<-Aw@|@G(B $(C4\>n8&(B $(C;hA&(B + ESC d $(CD?<-@'D!(B $(C@LHD?!(B $(C@V4B(B $(C4\>n8&(B $(C;hA&(B + + C-k $(CD?<-@'D!7N:NEM(B $(CG`3!1nAv8&(B $(C;hA&(B + + $(C9+>y@N0!8&(B $(C;hA&GQ(B $(CHD?!(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'0!(B $(C@V=@4O(B +$(C4Y(B. Emacs$(C4B(B, $(CGQ9.@Z:84Y(B $(CE+(B $(C4\@'7N(B $(C;hA&8&(B $(CG`GQ(B $(C6'?!4B(B, $(C;hA&GQ(B $(C3;?k@;(B +$(C:8A8GO?)(B $(C5S4O4Y(B. $(C?x7!4k7N(B $(C5G598.4B5%4B(B, C-y $(C8&(B $(C;g?kGU4O4Y(B. $(CAV@GGX>_(B +$(CGO4B(B $(C0M@:(B, C-y $(C8&(B $(C;hA&8&(B $(CG`GQ(B $(C@e<R88@L(B $(C>F4O6s(B, $(C>n5p?!<-6s55(B $(CGR(B $(C<v(B $(C@V4Y(B +$(C4B(B $(C0M@T4O4Y(B. C-y $(C4B(B, $(C:8A85H(B $(CEX=:F.8&(B $(CGv@g(B $(CD?<-0!(B $(C@V4B(B $(C@e<R?!(B $(C;p@TGO1b(B +$(C@'GQ(B $(C8m7I>n@L9G7N(B, $(C@L0M@;(B $(C;g?kGO?)(B $(CEX=:F.8&(B $(C@L5?GR(B $(C<v(B $(C@V=@4O4Y(B. + + $(C;hA&8&(B $(CG`GO4B(B $(C8m7I>n?!4B(B, "Delete" $(C8m7I>n?M(B, "Kill" $(C8m7I>n0!(B $(C@V=@(B +$(C4O4Y(B. "Kill" $(C8m7I>n?!<-4B(B $(C;hA&5H(B $(C0M@:(B $(C:8A85GAv88(B, "Delete"$(C?!<-4B(B $(C:8A8(B +$(C5GAv(B $(C>J=@4O4Y(B. $(C4\(B, $(C9]:9H8<v0!(B $(CAV>nAv8i(B, $(C:8A85K4O4Y(B. + + >> C-n $(C@;(B 2$(CH8(B $(CA$55(B $(CE8@LGAGO0m(B, $(CH-8i@G(B $(C@{4gGQ(B $(C@e<R7N(B $(C@L5?GO<<?d(B. + $(C1W8.0m(B, C-k $(C7N(B, $(C1W(B $(CG`@;(B $(C;hA&GO<<?d(B. + + $(CC99xB0@G(B C-k $(C7N(B $(C1W(B $(CG`@G(B $(C3;?k@L(B $(C;hA&5G0m(B, $(CGQ9x4u(B C-k $(C8&(B $(C@T7BGO8i(B, +$(C1W(B $(CG`(B $(C@Z=E@L(B $(C;hA&5K4O4Y(B. $(C88>`(B, C-k $(C?!(B $(C9]:9H8<v8&(B $(CAvA$GQ(B $(C0f?l?!4B(B, $(C1W(B +$(CH8<v88E-@G(B $(CG`@L(B($(C3;?k0z(B $(CG`@Z=E0!(B $(C5?=C?!(B)$(C;hA&5K4O4Y(B. + + $(CAv1](B $(C;hA&5H(B $(CEX=:F.4B(B, $(C:8A85G0m(B $(C@V@89G7N(B, $(C1W0M@;(B $(C2t3>(B $(C<v(B $(C@V=@4O4Y(B. +$(C@L8&(B $(C@'GX<-4B(B, C-y $(C8&(B $(CE8@LGAGU4O4Y(B. + + >> C-y $(C8&(B $(C=CGhGO?)(B $(C:8<<?d(B. + + C-k $(C8&(B $(C8n9x@L3*(B $(C0h<SGO?)(B $(CG`GO8i(B, $(C;hA&5H(B $(CEX=:F.4B(B, $(CA$8.5G>n(B $(C:8A85G(B +$(C0m(B, C-y$(C7N(B, $(C1W(B $(C@|:N0!(B $(C2t3;>nA}4O4Y(B. + + >> C-k $(C8&(B $(C8n9x(B $(CE8@LGAGO?)(B $(C:8<<?d(B. + + >> $(CEX=:F.8&(B $(C2t3;4B5%4B(B, C-y $(C@T4O4Y(B. $(CD?<-8&(B $(C8nG`(B $(C9X@87N(B $(C@L5?=CE0(B + $(C0m(B, $(CGQ9x(B $(C4u(B C-y $(C8&(B $(CE8@LGAGO?)(B $(C:8<<?d(B. $(C@L0M@87N(B $(CEX=:F.@G(B $(C:9;g(B + $(C0!(B $(C5K4O4Y(B. + + $(CGv@g(B $(C>n62(B $(CEX=:F.0!(B $(C:8A85G>n(B $(C@V0m(B, $(C4u183*(B $(C4Y8%(B $(CEX=:F.8&(B $(C;hA&GO8i(B +$(C>n6;0T(B $(C5G0Z=@4O1n(B? C-y$(C4B(B, $(C0!@e(B $(CCV1Y(B $(C;hA&5H(B $(C0M@;(B $(C2tA}>n3@4O4Y(B. + + >> $(CG`@;(B $(C;hA&GO0m(B, $(CD?<-8&(B $(C@L5?=CE00m(B, $(C4Y8%(B $(CG`@;(B $(C;hA&GO<<?d(B. C-y + $(C8&(B $(CG`GO8i(B, 2$(C9xB0@G(B $(CG`@L(B $(C3*?I4O4Y(B. + +$(CCk<R(B(UNDO) +========== + + $(C>pA&6s55(B, $(CEX=:F.8&(B $(C:/0fGO?4Av88(B, $(C1W0M@;(B $(C?x7!4k7N(B $(C5G598.0m(B $(C=M@;(B $(C6'(B +$(C4B(B C-x u$(C7N(B $(C0mD(4O4Y(B. $(C:8Ek@:(B $(C@_8x5H(B $(C8m7I>n8&(B $(C9+H?7N(B $(CGO4B(B $(C@[5?@;(B $(CGU4O4Y(B. +$(C9]:9GX<-(B UNDO$(C8&(B $(CG`GO7A0m(B $(CGR(B $(C6'4B(B, $(C8n9x@L3*(B $(C1W(B $(C8m7I>n8&(B $(CG`GO8i(B $(C5G557O(B +$(C5G>n(B $(C@V=@4O4Y(B. + + >> $(C@L(B $(CG`@;(B C-k$(C7N(B $(CAv?l<<?d(B. $(C1W8.0m(B, C-x u$(C7N(B $(C5G598.<<?d(B. + + C-_$(C4B(B, UNDO$(C8&(B $(CG`GO4B(B, $(C6G(B $(CGO3*@G(B $(C8m7I>n@T4O4Y(B. $(C1b4I@:(B, C-x u$(C?M(B $(C00(B + $(C=@4O4Y(B. + + C-_$(C3*(B C-x u$(C?!(B UNDO$(C@G(B $(CH8<v8&(B $(CAY(B $(C<v(B $(C@V=@4O4Y(B. + + +$(CH-@O(B +==== + + $(CEX=:F.@G(B $(C:/0f@;(B $(C?518@{@87N(B $(CGO1b(B $(C@'GX<-4B(B, $(C1W0M@;(B $(CH-@O?!(B $(C:8A8GO?)(B +$(C>_(B $(CGU4O4Y(B. $(C:8A8GOAv(B $(C>J@88i(B, $(CG`GQ(B $(C:/0f@:(B, Emacs$(C8&(B $(CA>7aGO8i(B $(C5?=C?!(B $(C@R>n(B +$(C9v8.0T(B $(C5K4O4Y(B. + + $(CAv1](B $(C:80m(B $(C@V4B(B $(CH-@O?!(B $(C4kGX<-(B, $(C4g=E@L(B $(CFmA}@;(B $(CG`GQ(B $(C0M@;(B $(C=a3V=@4O4Y(B. +$(CAv1](B, $(C:80m(B $(C@V4B(B $(CH-@O@L6u(B $(C0M@:(B, $(C0#4\Hw(B $(C8;GO8i(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O(B $(C@ZC<@T(B +$(C4O4Y(B. + + $(C4g=E@L(B $(CH-@O@;(B $(C<<@L:j(B($(C:8A8GQ4Y(B)$(CGO1b(B $(C1nAv(B, $(CAv1]1nAv@G(B $(C:/0f@:(B $(CFmA}GO(B +$(C0m@V4B(B $(CH-@O?!(B $(C=a3V4B(B $(C0M@:(B $(C>F4U4O4Y(B. $(C1W0M@:(B, $(C4g=E@L(B $(C@L?M(B $(C00@L(B $(C:/0fGO0m(B +$(C=MAv(B $(C>J@:5%55(B, $(C55A_1nAv(B $(C:/0f@;(B $(C0!GQ(B $(C0M@L(B $(CA&8Z4k7N(B $(C=a3V>nAv4B(B $(C@O@L(B $(C>x55(B +$(C7O(B $(CGO1b(B $(C@'GX<-(B $(C@T4O4Y(B. + + $(C<<@L:j@;(B $(CG`GQ(B $(C5ZA6Bw(B $(C:/0fGQ(B $(C0M@L(B $(C@_8x(B $(C5G>n(B $(C@V@;(B $(C6'8&(B $(C@'GO?)(B Emacs +$(C4B(B $(C@L8'@;(B $(C:/0fGO?)(B $(C?x:;(B $(CH-@O@;(B $(C321i4O4Y(B. + +$(C:q0m(B: $(C6GGQ(B, Emacs$(C4B(B $(C?9CxGR(B $(C<v(B $(C>x4B(B $(C;sEB?!(B $(C4k:qGO?)(B, $(C@OA$GQ(B $(C=C(B + $(C0#0#0]@87N(B $(C@Z5?@{@87N(B $(CFmA}GO0m(B $(C@V4B(B $(CH-@O@G(B $(C3;?k@;(B $(C@L8'(B + $(C@;(B $(C:/0fGQ(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L0M?!(B $(C@GGX(B, $(C88@O@G(B $(C0f?l(B + $(C4B(B $(CG`GQ(B $(C:/0f?!(B $(C4kGO?)(B $(CCV<RGQ@G(B $(CGGGX7N(B $(C3!3;557O(B $(CGO0m(B $(C@V(B + $(C=@4O4Y(B. + + $(CH-8i@G(B $(C>F7!(B $(CBJ@;(B $(C:88i(B, $(C@L?M(B $(C00@:(B $(C6f@87N(B $(C8p5e6s@N@L(B $(CG%=C5G>n(B $(C@V4Y(B +$(C0m(B $(C;}0"GU4O4Y(B. + +($(C?9(B) [--]J:--**-Mule: MULE.tut (Fundamental) ---55%-------------- + + + $(C@L(B Emacs$(CF)Ed8.>s@G(B $(C:9;g:;@:(B MULE.tut$(C@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(CH-@O(B +$(C@;(B $(CH-@N5e(B($(CH-@O@;(B $(CC#>F<-(B $(C9vF[?!(B $(C@P>n3V4B(B $(C0M(B)$(CGO8i(B, MULE.tut$(C@G(B $(C:N:P?!(B $(CG%=C(B +$(C5K4O4Y(B. $(C?98&(B $(C5i8i(B, new-file$(C@L6s4B(B $(C@L8'@G(B $(CH-@O@;(B $(CH-@N5eGO?44Y8i(B, "Mule: +new-file"$(C@L6s4B(B $(C8p5e6s@N@L(B $(C5G0ZAv?d(B. + +$(CAV@G(B: $(C8p5e6s@N?!(B $(C4kGX<-4B(B $(C3*A_?!(B $(C<38mGO0Z=@4O4Y(B. $(C@a1q(B $(C1b4Y8.=C(B + $(C1b8&(B. + + $(CH-@O@;(B $(CH-@N5eGO0E3*(B, $(C<<@L:jGO4B(B $(C8m7I>n4B(B, $(CAv1]1nAv@G(B $(C0M0z4B(B $(C4^8.(B, +2$(C03@G(B $(C9.@Z7N(B $(C5G>n(B $(C@V=@4O4Y(B. C-x $(C?!(B $(C@L>n<-(B $(C@T7BGO4B(B $(C9.@Z0!(B, $(CH-@O?!(B $(C4kGX(B +$(C<-(B $(CG`GO4B(B $(CA6@[@;(B $(C3*E83@4O4Y(B. + + $(CGQ0!Av(B $(C4u(B, $(CAv1]1nAv@G(B $(C0M0z(B $(C4Y8%(B $(CA!@:(B, $(CH-@N5e(B $(C=C(B, $(CH-@O8m@;(B Emacs$(C0!(B +$(C90>n:>4O4Y(B. $(C@L0M@;(B, $(C4\8;7N:NEM(B $(C@N<v8&(B $(C@P>n5i?)?@4B(B $(C8m7I>n6s0m(B $(C8;GO0m(B +$(C@V=@4O4Y(B. + + +$(CAV@G(B: $(C@L(B $(C0f?l4B(B $(CH-@O8m(B $(C@T4O4Y(B. + + C-x C-f $(CH-@O@;(B $(CC#4B4Y(B($(CH-@N5eGQ4Y(B) + + Emacs$(C4B(B $(CH-@O8m@;(B $(C90>n?I4O4Y(B. $(C@L0M@:(B, $(CH-8i9X@G(B $(CG`?!(B $(C3*E8334O4Y(B. +$(CH-@O8m@;(B $(CAvA$GO0m(B $(C@V4B(B $(C:N:P@:(B, $(C9L4O9vF[6s0m(B $(C:R8.?l4B(B $(C0M@T4O4Y(B. $(C9L4O9v(B +$(CF[4B(B $(C@L?M(B $(C00@L(B $(C;g?k5K4O4Y(B. $(CH-@O8m?!(B $(C@L>n<-(B, $(C8.4xE08&(B $(C4)8#8i(B, $(C9L4O9vF[(B +$(C?!(B $(CG%=C5G>nAx(B $(C3;?k@:(B $(C4u(B $(CGJ?dGOAv(B $(C>J1b(B $(C6'9.?!(B $(CAv?vA.(B $(C9v834O4Y(B. + + >> C-x C-f$(C6s0m(B $(CE8@LGAGQ(B $(C5Z?!(B C-g$(C6s0m(B $(CE8@LGAGO<<?d(B. $(C9L4O9vF[@G(B + $(C3;?k@;(B $(CCk<RGO0m(B, $(C6GGQ(B, C-x C-f$(C8m7I>n55(B $(CCk<RGU4O4Y(B. $(C@L780T(B + $(CGO?)(B, $(C>n62(B $(CH-@O55(B $(CC#Av(B $(C>J=@4O4Y(B. + + $(C@L9x?!4B(B $(CH-@O@;(B $(C<<@L:jGO?)(B $(C:8<<?d(B. $(CAv1]1nAv@G(B $(C:/0f@;(B $(C:8A8GO1b(B $(C@'(B +$(CGX<-4B(B $(C4Y@=0z(B $(C00@:(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-x C-s $(CH-@O@;(B $(C<<@L:jGQ4Y(B + + Emacs$(C@G(B $(C3;?k@:(B $(CH-@O?!(B $(C=a3;>nA}4O4Y(B. $(C<<@L:jGR(B $(C6'(B, $(C?x:;@G(B $(CH-@O@:(B $(C;u(B +$(C7N?n(B $(C@L8'@;(B $(C:Y?)<-(B $(C320\Av1b(B $(C@V@89G7N(B $(C3;?k@:(B $(C>x>nAvAv(B $(C>J=@4O4Y(B. $(C@L(B $(C;u(B +$(C7N?n(B $(C@L8'@:(B $(C?x:;@G(B $(CH-@O@G(B $(C@L8'?!(B '~'$(C8&(B $(C:Y@N(B $(C0M@T4O4Y(B. + + $(C%;<<@L:j0!(B $(C3!3*8i(B, Emacs$(C4B(B $(C<<@L:jGQ(B $(CH-@O@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. + + >> C-x C-s$(C6s0m(B $(CE8@LGAGO0m(B $(CF)Ed8.>s@G(B $(C:9;g:;@;(B $(C<<@L:jGO<<?d(B. + $(C@L(B $(C6'(B, $(CH-8i(B $(C9XBJ?!(B "Wrote ...../MULE.tut"$(C6s0m(B $(CG%=C5K4O4Y(B. + + $(C;u7N?n(B $(CH-@O@;(B $(C885i(B $(C6'(B, $(C86D!(B $(C@L@|:NEM(B $(C@V4x(B $(CH-@O@;(B $(CH-@N5eGO4B(B $(C5mGQ(B +$(C5?@[@;(B $(CGU4O4Y(B. $(C1W780T(B $(CGO?)(B, $(CH-@N5eGQ(B $(CH-@O?!(B $(CE8@LGAGO?)(B $(C0)4O4Y(B. + + $(C%UH-@O@;(B $(C<<@L:jGO7A0m(B $(CG_@;(B $(C4k(B $(C:q7N<R(B, Emacs$(C4B(B $(CAv1]1nAv(B $(CFmA}GO0m(B +$(C@V4x(B $(C3;?k@;(B $(CH-@O(B $(C3;?!(B $(C=a3V=@4O4Y(B. + + +$(C9vF[(B +==== + + $(C88>`(B, 2$(C9xB0@G(B $(CH-@O@;(B C-x C-f $(C7N(B $(C2(3;8i(B, 1$(C9xB0@G(B $(CH-@O@:(B Emacs$(C3;:N(B +$(C?!(B $(C32=@4O4Y(B. Emacs$(C3;:N?!(B $(C@V4B(B $(CH-@O7N:NEM(B $(CEX=:F.8&(B $(C@P>n3V>n(B $(C:8A8GO0m@V(B +$(C4B(B $(C0M@:(B $(C9vF[6s0m(B $(C:R8.?s4O4Y(B. $(CH-@O@;(B $(C2(3;4B(B $(C0M@:(B, Emacs$(C3;:N?!(B $(C;u7N?n(B +$(C9vF[8&(B $(C885l4O4Y(B. + + Emacs $(C3;?!(B $(C:8A8GO0m(B $(C@V4B(B $(C9vF[@G(B $(C8.=:F.8&(B $(C:84B5%4B(B, $(C4Y@=0z(B $(C00@L(B +$(CE8@LGAGU4O4Y(B. + + C-x C-b + + >> C-x C-b $(C6s0m(B $(CE8@LGAGO<<?d(B. $(C0"0"@G(B $(C9vF[0!(B $(C>n60GQ(B $(C@L8'@;(B $(C0.(B + $(C0m(B $(C@V4B0!(B, $(C1W8.0m(B, $(C>n60GQ(B $(CH-@O8m@;(B $(C:Y@L0m(B $(C@V4B(B $(C0M@N0!(B $(C0|B{(B + $(CGO<<?d(B. + + $(C9vF[?!4B(B $(CH-@O0z(B $(C@OD!GOAv(B $(C>J4B(B $(C0M55(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, "*Buffer +List*" $(C6s4B(B $(CH-@O@:(B $(C>x=@4O4Y(B. $(C@L0M@:(B C-x C-b $(C?!(B $(C@GGO?)(B $(C885i>nAx(B $(C9vF[8.(B +$(C=:F.?!(B $(C4kGQ(B $(C9vF[@T4O4Y(B. + + $(C4g=E@L(B $(C:80m(B $(C@V4B(B Emacs$(C@)55?l3;?!(B $(C@V4B(B, $(C>n60GQ(B $(CEX=:F.6s55(B, $(C>n4@0M(B +$(C@N0!@G(B $(C9vF[3;?!(B $(C@V=@4O4Y(B. + + >> $(C9vF[8.=:F.8&(B $(CAv?l1b(B $(C@'GX(B C-x 1 $(C6s0m(B $(CE8@LGAGO<<?d(B. + + $(C88>`(B, $(C>n62(B $(CH-@O@G(B $(CEX=:F.?!(B $(C:/0f@;(B $(CG`GO0m3*<-(B, $(C4Y8%(B $(CH-@O@;(B $(C2(3;>z(B +$(C4Y0m(B $(CG_4Y8i(B, $(CCVCJ@G(B $(CH-@O@:(B $(C<<@L:j5G>n(B $(C@VAv(B $(C>J=@4O4Y(B. $(C1W(B $(C:/0f@:(B Emacs +$(C3;:N@G(B $(CH-@O0z(B $(C4k@@GO4B(B $(C9vF[(B $(C3;?!88(B $(CG`GO?)A.(B $(C@V=@4O4Y(B. + + 2$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(C885i1b55GO0m(B, $(C?!5pF.GO4u6s55(B, 1$(C9x(B +$(CB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[?!4B(B $(C>F9+71(B $(C?5Gb@;(B $(CAVAv(B $(C>J=@4O4Y(B. $(C@L0M@:(B $(C4k(B +$(C4\Hw(B $(C;g?kGO1b(B $(C=10T(B, $(C6GGQ(B, 1$(C9xB0@G(B $(CH-@O?!(B $(C4k@@GO4B(B $(C9vF[8&(B $(CH.:8GO?)(B $(C5N(B +$(C1b(B $(C@'GO?)(B $(C55?r@L(B $(C5G4B(B $(C9f9}@T4O4Y(B. + + C-x C-s $(C7N(B $(C9vF[8&(B $(C<<@L:jGO1b(B $(C@'GO?)(B C-x C-f $(C7N(B $(C9vF[8&(B $(C13C<GO4B(B $(C0M(B +$(C@:(B $(C1MBz=@4O4Y(B. $(C1W7!<-(B $(C>F7!@G(B $(C8m7I>n8&(B $(C;g?kGU4O4Y(B. + + C-x s $(CGv@g(B $(C@V4B(B $(C9vF[8&(B $(C<<@L:jGQ4Y(B. + + C-x s $(C4B(B $(C3;?k@;(B $(C9Y2[(B $(C9vF[(B $(C@|C<8&(B $(CH-@O?!(B $(C<<@L:jGU4O4Y(B. $(C@L(B $(C6'(B, $(CGO3*(B +$(CGO3*@G(B ($(C<<@L:j5G>n>_(B $(CGR(B)$(C9vF[?!(B $(C4kGO?)(B, $(C<<@L:jGO4B0!(B, $(CGOAv(B $(C>J4B0!8&(B y$(C3*(B +n$(C@87N(B $(C9/=@4O4Y(B. $(C@L(B $(CG%=C4B(B $(CH-8i(B $(C9X@G(B $(CG`?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, $(C>F7!?M(B +$(C00=@4O4Y(B. + + Save file /usr/private/yours/MULE.tut? (y or n) + + + +$(C8m7I>n@G(B $(CH.@e(B +============= + + $(C?!5pEM?!4B(B, $(CD\F.7Q(B*$(CE03*(B $(C8^EM(B*$(CE07N(B $(C@T7BGR(B $(C<v(B $(C@V4B(B $(C0M:84Y55(B $(CHN>@(B +$(C89@:(B $(C8m7I>n0!(B $(C@V=@4O4Y(B. $(C@L0M5i@;(B $(C4Y7g1b(B $(C@'GO?)(B, $(CH.@e(B(eXtend) $(C8m7I>n8&(B +$(C;g?kGU4O4Y(B. $(C@L0M?!4B(B, $(C>F7!@G(B 2$(C0!Av(B $(CA>7y0!(B $(C@V=@4O4Y(B. + + C-x $(C9.@Z?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(CGQ9.@Z8&(B $(C@T7BGU4O4Y(B. + ESC x $(C@L8'?!(B $(C@GGQ(B $(CH.@e(B. $(C@L>n<-(B $(C8m7I>n@G(B $(C@L8'@;(B $(C@T7BGU4O4Y(B. + + $(C@L0M5i@:(B $(C@O9]@{@87N(B, $(CFm8.GOAv88(B, $(CAv1]1nAv(B $(C:8>F?B(B $(C0M0z(B $(CA61](B $(C:s9xGO(B +$(C0T4B(B $(C;g?k5GAv(B $(C>J4B(B $(C8m7I>n8&(B $(C@'GQ(B $(C0M@T4O4Y(B. C-x C-f ($(CH-@N5e(B)$(C3*(B C-x C-s +($(C<<@L:j(B)$(C4B(B $(C@L(B $(C:N7y@T4O4Y(B. $(C@L?\?!(B, C-x C-c($(C?!5pEM@G(B $(CA>7a(B)$(C55(B $(C1W78=@4O4Y(B. + + C-z$(C4B(B Emacs$(C?!<-(B $(C:|A.3*?@4@5%?!(B $(C@ZAV(B $(C;g?k5G4B(B $(C9f9}@T4O4Y(B. Emacs$(C8&(B +$(CA>7aGO4B(B $(C0M@L(B $(C>F4O6s(B, $(C@O4\(B, csh$(C@G(B $(C79:'?!(B $(C5G59>F0!4B5%?!4B(B $(CA&@O(B $(CAA@:(B $(C9f(B +$(C9}@L6s0m(B $(C8;GR(B $(C<v@V0ZAv?d(B. C-z$(C8&(B $(CG`GO4u6s55(B Emacs$(C4B(B $(C=:EiGO0m(B $(C@V@;(B $(C;S(B, +$(C3;?k@L(B $(CFD1+5G4B(B $(C0M@:>F4U4O4Y(B. + +$(CAV@G(B: $(C4\(B, X-window$(C?!<-(B $(CG`GO0m(B $(C@V4B(B $(C0f?l(B, $(CH$@:(B $(C;g?kGO0m(B $(C@V4B(B + $(C=)@L(B sh$(C@O(B $(C6'4B(B, $(C1W78Av(B $(C>J=@4O4Y(B. + + C-x $(C8m7I>n4B(B,$(C89@L(B $(C@V=@4O4Y(B. $(C@L9L(B $(C9h?n(B $(C0M@:(B $(C>F7!@G(B $(C0M@T4O4Y(B. + + C-x C-f $(CH-@O@G(B $(CFmA}(B(Find) + C-x C-s $(CH-@O@G(B $(C:8A8(B(Save) + C-x C-b $(C9vF[8.=:F.@G(B $(CG%=C(B + C-x C-c $(C?!F<EM8&(B $(CA>7aGQ4Y(B. $(CH-@O@G(B $(C:8A8@:(B, $(C@Z5?@{@87N4B(B $(CG`GO?)(B + $(CAvAv(B $(C>J4B4Y(B. $(C1W7/3*(B, $(CH-@O@L(B $(C:/0f5G>n(B $(C@V@88i(B, $(CH-@O@G(B $(C:8(B + $(CA8@;(B $(CGO4B0!(B, $(C>F4Q0!8&(B $(C90>n?I4O4Y(B. $(C:8A8GO?)(B $(CA>7aGO4B(B $(C:8(B + $(CEk@G(B $(C9f9}(B, C-x C-s C-x C-c $(C7N(B $(CGO4B(B $(C0M@T4O4Y(B. + + $(C@L8'?!(B $(C@GGQ(B $(CH.@e8m7I>n?!4B(B, $(C1W4YAv(B $(C;g?k5GAv(B $(C>J4B(B $(C0M@L3*(B, $(CF/A$@G(B +$(C8p5e?!<-9[?!(B $(C;g?k5GAv(B $(C>J4B(B $(C0M5n@L(B $(C@V=@4O4Y(B. $(C?97N<-(B, "command-apropos" +$(C8&(B $(C5l4O4Y(B. $(C@L(B $(C8m7I>n4B(B $(CE0?v5e8&(B $(C@T7B=CE00m(B, $(C1W0M?!(B $(C8ED!GO4B(B $(C8p5g(B $(C8m7I(B +$(C>n@G(B $(C@L8'@;(B $(CG%=CGU4O4Y(B. ESC x $(C6s0m(B $(CE8@LGAGO8i(B, $(C=:E)80(B $(C9X?!(B "M-x" $(C0!(B $(CG%(B +$(C=C5K4O4Y(B. $(C@L0M?!(B $(C4kGO?)(B, $(C=GG`GO4B(B $(C8m7I>n@G(B $(C@L8'(B($(CAv1]@G(B $(C0f?l(B, +"command-apropos")$(C8&(B $(C@T7BGU4O4Y(B. "command-a" $(C1nAv(B $(C@T7BGQ(B $(C5Z(B $(C=:Fd@L=:(B +$(C8&(B $(CD!8i(B, $(C5Z@G(B $(C:N:P@:(B $(C@Z5?@{@87N(B $(C8^?vA}4O4Y(B. $(C@L(B $(CHD(B, $(CE0?v5e8&(B $(C90@89G7N(B, +$(C>K0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAGU4O4Y(B. $(C6GGQ(B, $(CE0?v5e8&(B $(C@T7BGOAv(B $(C>J@88i(B, $(C8p5g(B +$(C8m7I>n0!(B $(CG%=C5K4O4Y(B. + + >> ESC x $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B, "command-apropos<Return>" $(CH$@:(B + "command-a<Space><Return>" $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. $(C4Y@=?!(B, + "kanji<Return>"$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + $(C3*E83-(B "$(C@)55?l(B"$(C8&(B $(CAv?l4B5%4B(B, C-x 1 $(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + +$(C8p5e6s@N(B +======== + + $(C88>`(B $(CC5C5Hw(B $(C8m7I>n8&(B $(CCF4Y8i(B, $(CH-8i@G(B $(C9XBJ@G(B $(C?!DZ?!8.>n6s0m(B $(C:R8.4B(B +$(C@e<R?!(B, $(CD#(B $(C0M@L(B $(CG%=C5K4O4Y(B. $(C?!DZ?!8.>n4B(B $(CH-8i@G(B $(CA&@O(B $(C9X(B $(CG`@T4O4Y(B. $(C1W(B +$(C9Y7N(B $(C@'@G(B $(CG`@:(B, $(C8p5e6s@N@L6s0m(B $(C:R8.0m(B $(C@V=@4O4Y(B. $(C8p5e6s@N@:(B $(C@L7/GQ(B $(C=D@8(B +$(C7N(B $(CG%=C5G>n(B $(C@V0ZAv?d(B. + + [--]J:--**-Mule: MULE.tut (Fundamental) ---NN%-------------- + + +$(CAV@G(B: NN%$(C@G(B NN$(C@:(B $(C<}@Z0!(B $(C5i>n(B $(C@V=@4O4Y(B. $(C4g=E@L(B $(C;g?kGO0m(B $(C@V4B(B + Emacs$(C@G(B $(C8p5e6s@N0z(B $(C4Y8&(B $(CAv55(B $(C8p8#Av88(B, $(C4gH2GOAv(B $(C8;557O(B. + $(C?98&(B $(C5i8i(B, $(C=C0#@L3*(B uptime$(C@L(B $(CG%=C5G0m(B $(C@V4B(B $(C0M@:(B, + display-time$(C@L6s4B(B $(C1b4I@L(B $(C@[5?GO0m(B $(C@V1b(B $(C6'9.@T4O4Y(B. + + $(C@L(B $(CG`?!(B $(C@GGO?)(B $(C89@:(B $(C@/?kGQ(B $(CA$:80!(B $(C>r>nA}4O4Y(B. + + + $(CAv1](B, $(C4g=E@L(B $(C:80m(B $(C@V4B(B $(CH-@O8m@;(B $(CG%=CGO0m(B $(C@V=@4O4Y(B. NN%$(C@:(B $(CGv@g(B $(C=:(B +$(CE)80@'?!(B $(CH-@O@G(B $(CA&@O(B $(C@'?!<-:NEM(B $(C8n(B $(CF[<>F.B00!(B $(CG%=C5G0m(B $(C@V4B(B $(C0!8&(B $(C3*E8(B +$(C3;0m(B $(C@V=@4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVCJ8&(B $(CG%=CGO0m(B $(C@V@88i(B, --Top--$(C6s0m(B $(CG%=C5K(B +$(C4O4Y(B. $(CH-@O@G(B $(C0!@e(B $(CCVHD8&(B $(CG%=CGO0m(B $(C@V4Y8i(B, --Bot--$(C6s0m(B $(CG%=C5K4O4Y(B. $(CH-8i(B +$(C3;?!(B $(CH-@O(B $(C@|:N0!(B $(CG%=C5G0m(B $(C@V4Y8i(B, --All--$(C6s0m(B $(CG%=C5K4O4Y(B. + + $(C8p5e6s@N@G(B $(C<R0}H#(B $(C3;?!4B(B, $(CAv1](B $(C>n60GQ(B $(C8p5e?!(B $(C5i>n@V4B(B $(C0!8&(B $(C3*E8(B +$(C3;0m(B $(C@V=@4O4Y(B. $(CGv@g4B(B, $(C5pFzF.@N(B Fundamental$(C?!(B $(C5i>n0!(B $(C@V=@4O4Y(B. $(C@L0M55(B +$(C8^@LA.8p5e@G(B $(CGO3*@G(B $(C?9@T4O4Y(B. + + Emacs$(C4B(B Lisp mode$(C3*(B Text mode$(C?M(B $(C00@L(B, $(C4Y8%(B $(CGA7N1W7%>p>n3*(B $(CEX=:F.(B +$(C?!(B $(C4kGO?)(B $(C?!5pF.8&(B $(CG`GO1b(B $(C@'GQ(B $(C8n0!Av@G(B $(C8^@LA.8p5e8&(B $(C0.0m(B $(C@V=@4O4Y(B. +$(C>n62(B $(C6'6s55(B $(C9]5e=C(B $(C>n4@0M@N0!@G(B $(C8^@LA.8p5e@G(B $(C;sEB7N(B $(C5G>n(B $(C@V=@4O4Y(B. + + $(C0"0"@G(B $(C8^@LA.8p5e4B(B $(C8n0!Av@G(B $(C8m7I>n8&(B $(C@|Gt(B $(C4Y8%(B $(CG`5?@87N(B $(CGO?)(B $(C9v(B +$(C834O4Y(B. $(C?98&(B $(C5i>n(B $(C:8=J4O4Y(B. $(CGA7N1W7%(B $(C3;?!(B $(C8m7I>n8&(B $(C885e4B(B $(C8m7I>n0!(B $(C@V(B +$(C=@4O4Y(B. $(C8m7I>n8&(B $(C>n60GQ(B $(CG|=D@87N(B $(CGO4B0!4B(B, $(C0"(B $(CGA7N1W7%>p>n?!(B $(C5{6s<-(B +$(C4Y8#Av88(B, $(C0"0"@G(B $(C8^@LA.8p5e4B(B, $(C9]5e=C(B $(C3V>nA]4O4Y(B. + + $(C0"0"@G(B $(C8^@LA.8p5e?!(B $(C5i>n0!1b(B $(C@'GQ(B $(C8m7I>n4B(B $(C8p5e8m@L(B $(CH.@e5H(B $(C0M@87N(B +$(C5G>n(B $(C@V=@4O4Y(B. $(C?98&(B $(C5i8i(B, M-x fundamental-mode$(C4B(B Fundamental$(C7N(B $(C5i>n0!(B +$(C1b(B $(C@'GQ(B $(C0M@T4O4Y(B. + + $(C88>`(B, $(C?5>n8&(B $(C?!5pF.GQ4Y8i(B, Text mode$(C7N(B $(C5i>n0)4O4Y(B. + + >> M-x text-mode <Return>$(C6s0m(B $(CE8@LGAGO<<?d(B. + + $(CGv@g@G(B $(C8^@LA.8p5e?!(B $(C4kGQ(B $(C55E%8UF.8&(B $(C:80m(B $(C=M@;(B $(C6'4B(B, C-h m$(C@L6s0m(B +$(CE8@LGAGU4O4Y(B. + + >> C-h m $(C8&(B $(C;g?kGO?)(B Text mode$(C?M(B Fundamental mode$(C@G(B $(CBw@L8&(B $(C>K>F(B + $(C:8<<?d(B. + + >> C-x 1$(C7N(B $(C55E%8UF.8&(B $(CH-8i@87N:NEM(B $(CAv?l<<?d(B. + + $(C?^BJ(B $(C3!@G(B '[--]' $(C@:(B $(CGv@g@G(B $(CE0@T7B@G(B $(C8p5e8&(B $(C3*E83;0m(B $(C@V=@4O4Y(B. +[--] $(C@N(B $(C6'?!4B?5>n(B $(C>KFD:*@;(B $(C1W4k7N(B $(C@T7BGR(B $(C<v(B $(C@V=@4O4Y(B. $(C@T7B8p5e?!(B $(C4kGQ(B +$(C;s<<GQ(B $(C<38m@:(B "$(CE8860m(B" $(C8^4:>s@;(B $(C:8<<?d(B. + + $(C1W(B $(C9Y7N(B $(C?@8%BJ?!4B(B $(CDZ5eC<0T(B (coding-system) $(C?!(B $(C0|GQ(B $(CGA7!1W@G(B $(C;sEB(B +$(C0!(B $(CG%=C5G>n(B $(C@V=@4O4Y(B. Mule $(C@:(B, $(CH-@O@TCb7B(B, $(C@T7B(B, $(CH-8iCb7B?!(B $(C4kGO?)(B, $(C0"(B +$(C0"(B $(C5683@{@87N(B $(CDZ5eC<0h8&(B $(CAvA$=CE3(B $(C<v(B $(C@VAv88(B, $(CEk;s@:(B $(CH-@O?k@G(B $(CDZ5eC<0h@G(B +$(C4:8p4P88(B $(CG%=CGO0m@V=@4O4Y(B. + + >> $(C8p5e6s@N(B $(C@'?!(B "J:","S:", $(CH$@:(B "E:"$(C0!(B $(CG%=C5G>n(B $(C@V4B0!(B $(CH.@N(B + $(CGO<<?d(B. + + $(CCVCJ@G(B $(CGQ(B $(C9.@Z0!(B $(CDZ5eC<0h@G(B $(C4:8p4P(B, $(C4Y@=@G(B ':' $(C0!(B $(CGv@g(B $(C?5>n(B $(C@L?\(B +$(C@G(B $(C9.@Z(B($(C@O:;>n(B, $(CGQ19>n5n(B)$(C55(B $(CG%=CGQ4Y4B(B $(C0M@;(B $(C3*E83;0m(B $(C@V=@4O4Y(B. J$(C4B(B +JUNET$(C@87N(B $(C;g?k5G0m(B $(C@V4B(B JIS $(CDZ5e(B, S $(C4B(B Shift-JIS, E $(C4B(B $(C@O:;>n(BEUC $(C8&(B $(C3*(B +$(CE83;0m(B $(C@V=@4O4Y(B. $(C4Y19>n(B $(CG%=C@G(B $(C@/9+4B(B C-x C-k t $(C7N(B ON/OFF$(C@G(B $(CEd1[@L(B $(C0!(B +$(C4IGU4O4Y(B. + + $(C4Y@=@G(B $(C?94B(B, $(C@O4\(B $(C4Y19>nG%=C8&(B OFF$(CGO0m3*<-(B, $(C4Y=C(B $(CGQ9x(B ON$(C@;(B $(CG`GO?)(B +$(C:>4O4Y(B. + + >> C-x C-k t$(C8&(B 2$(C9x(B $(CG`GO<<?d(B. + + $(C@T7B8p5e0!(B JIS$(CDZ5e@G(B $(C<3A$@L(B $(C5G>n(B $(C@V@;(B $(C6'(B, $(C88>`(B $(C4g=E@L(B $(C;g?kGO0m(B $(C@V(B +$(C4B(B $(C4\8;?!(B $(C8^EM(B*$(CE00!(B $(C:Y>n(B $(C@V@88i(B, $(C@L=:DI@LGA(B*$(CE0(B $(C4k=E?!(B $(C1W0M@;(B $(C;g?kGO4B(B +$(C0M@L(B $(C0!4IGU4O4Y(B. $(C@L(B $(C6'(B, $(C8^EM(B*$(CE0@G(B $(C;g?k9f9}@:(B $(CD\F.7Q(B*$(CE0?M(B $(C00@L(B $(C4)8#8i<-(B +$(C9.@Z8&(B $(CE8@LGAGU4O4Y(B. ESC <$(C9.@Z(B>$(C55(B M-<$(C9.@Z(B>$(C55(B $(C00@:(B $(C@[5?@;(B $(CGU4O4Y(B. $(CAv1](B +$(C1nAv@G(B $(C<38m?!<-(B ESC <$(C9.@Z(B>$(C6s0m(B $(CG`GO0m(B $(C@V4x(B $(C0w@L(B, M-<$(C9.@Z(B>$(C7N(B $(C5K4O4Y(B. $(CAV(B +$(C@GGX>_(B $(CGO4B(B $(C0M@:(B, $(C=,GAF.(BJIS$(C3*(B EUC$(CDZ5e(B $(C6'4B(B $(C;g?kGR(B $(C<v(B $(C>x=@4O4Y(B. + + $(CDZ5eC<0h@G(B $(C13C<4B(B, $(C0"0"@G(B $(C9vF[?!(B $(C4kGX<-88(B $(C@/H?GU4O4Y(B. $(C0"0"@G(B, $(CDZ(B +$(C5eC<0h(B $(CAvA$?!(B $(C4kGX<-4B(B, C-h a coding-system <Return>$(C@87N:<(B $(C<v(B $(C@V=@4O4Y(B. + + >> C-h a coding-system <Return>$(C@87N(B $(C3*?@4B(B $(C55E%8UF.(B $(C3;@G(B, + set-display-coding-system, set-file-coding-system, + set-process-coding-system $(C@G(B $(C<38m@;(B $(C@P>n:8<<?d(B. + +$(C0K;v(B +==== + + $(C9.@Z?-@;(B, $(CH-@O3;?!<-(B, $(C@|9f(B $(CH$@:(B $(CHD9f@87N(B, $(CC#@;(B $(C<v(B $(C@V=@4O4Y(B. $(C0K;v(B +$(C@;(B $(C=C@[GO4B(B $(C8m7I>n4B(B, $(CD?<-@'D!(B $(C@LHD8&(B $(C0K;vGQ4Y8i(B, C-s, $(CD?<-@'D!(B $(C@L@|@L(B +$(C6s8i(B C-r $(C@T4O4Y(B. C-s $(C8&(B $(CE8@LGAGO8i(B, $(C?!DZ?!8.>n?!(B "I-search:"$(C6s4B(B $(C9.@Z?-(B +$(C@L(B $(CGA7RF.7N<-(B $(CG%=C5K4O4Y(B. ESC$(C8&(B $(C4)8#8i(B, $(CA>7a5K4O4Y(B. + + + >> C-s$(C7N(B $(C0K;v@L(B $(C=C@[5K4O4Y(B. $(C1W8.0m(B, $(CC5C5Hw(B 1$(C9.@Z>?(B "cursor"$(C6s4B(B + $(C4\>n8&(B $(C@T7BGU4O4Y(B. 1$(C9.@Z(B $(C@T7BGR(B $(C6'864Y(B, $(CD?<-4B(B, $(C>n6;0T(B $(C?rAw(B + $(C@T4O1n(B? + + >> $(CGQ9x(B $(C4u(B C-s $(C8&(B $(CE8@LGAGO8i(B, $(C4Y@=@G(B "cursor"$(C8&(B $(CC#@;(B $(C<v(B $(C@V=@4O4Y(B. + + >> <Delete>$(C8&(B 4$(CH8(B $(C@T7BGO0m(B, $(CD?<-@G(B $(C?rAw@S@;(B $(C:8<<?d(B. + + >> ESC$(C8&(B $(C4)8#0m(B, $(CA>7aGU4O4Y(B. + + $(CC#0m(B $(C=M@:(B $(C9.@Z?-@;(B $(CE8@LGAA_?!55(B, $(CE8@LGAGQ(B $(C9.@Z:N:P88@87N(B, $(C0K;v@;(B +$(C=C@[GU4O4Y(B. $(C4Y@=(B $(C9.@Z8&(B $(CC#4B5%4B(B, $(C4Y=C(B C-s$(C8&(B $(CE8@LGAGU4O4Y(B. $(C88>`(B, $(C9.@Z(B +$(C?-@L(B $(CA8@gGOAv(B $(C>J@88i(B, $(C8^<<Av0!(B $(CG%=C5K4O4Y(B. C-g $(C7N55(B $(CA>7a5K4O4Y(B. + + $(C0K;v=GG`A_?!(B, <Delete>$(C8&(B $(C@T7BGO8i(B, $(C0K;v9.@Z?-@G(B $(CA&@O(B $(C5Z@G(B $(C9.@Z0!(B +$(CAv?vA}4O4Y(B. $(C1W8.0m3*<-(B, $(CD?<-4B(B, $(C@L@|9x@G(B $(C@'D!7N(B $(C5G59>F0)4O4Y(B. $(C?98&(B $(C5i(B +$(C8i(B, "cu"$(C6s0m(B $(CE8@LGAGO0m(B, $(CCVCJ@G(B "cu"$(C@G(B $(C@'D!?!(B $(CD?<-0!(B $(C?rAw?44Y0m(B $(CGU=C4Y(B. +$(C?)1b?!<-(B <Delete>$(C8&(B $(C@T7BGO8i(B, $(C<-D!6s@N@G(B 'u'$(C0!(B $(CAv?vAv0m(B, $(CD?<-4B(B 'u'$(C8&(B +$(CE8@LGAGO1b(B $(C@|?!(B, $(CD?<-0!(B $(C@V>z4x(B 'c'$(C@G(B $(C@'D!7N(B,$(C@L5?GU4O4Y(B. + + $(C0K;v=GG`A_?!(B, C-s $(C3*(B C-r $(C@L?\@G(B $(CD\F.7Q9.@Z8&(B $(CE8@LGAGO8i(B, $(C0K;v@:(B +$(CA>7aGU4O4Y(B. + + C-s $(C4B(B, $(CGv@g@G(B $(CD?<-@'D!(B $(C@LHD?!(B $(C3*?@4B(B $(C0K;v9.@Z?-@;(B $(CC#=@4O4Y(B. $(C88>`(B, +$(C@L@|(B $(CBJ@;(B $(CC#0m(B $(C=M@88i(B, C-r $(C@;(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C?*9fGb0K;v@L(B $(C0!4IGU4O(B +$(C4Y(B. C-s $(C?M(BC-r $(C4B(B, $(C0K;v@G(B $(C9fGb@L(B $(C9]4k@O(B $(C;S(B, $(C@|:N(B $(C00@:(B $(C?rAw@S@;(B $(CGU4O4Y(B. + +$(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B + + $(C6'6'7N(B, ($(C:;@G(B $(C>F4O0T(B) $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'@L6s0m(B $(C:R8.4B(B $(C;sEB?!(B $(C5i(B +$(C>n0!4B(B $(C6'0!(B $(C@V=@4O4Y(B. $(C8^@LA.8p5e@G(B $(C<R0}H#(B'()'$(C@G(B $(CAV@'8&(B $(CA_0}H#(B'[]'$(C7N(B $(C5Q(B +$(C7/=Q(B $(C0M@L(B $(C8p5e6s@N(B $(C@'?!(B $(CG%=C5K4O4Y(B. $(C?98&(B $(C5i8i(B, (Fundamental)$(C@L6s0m(B $(CG%=C(B +$(C5G4B(B $(C4k=E?!(B[(Fundamental)]$(C?M(B $(C00@L(B $(C5K4O4Y(B. + +$(CAV@G(B: $(C?)1b?!<-4B(B $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'(B $(C@ZC<?!(B $(C4kGX<-4B(B $(C<38mGOAv(B + $(C>J=@4O4Y(B. + + $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@1b(B $(C@'GX<-4B(B, M-x top-level +<Return>$(C@L6s0m(B $(CE8@LGAGU4O4Y(B. + + >> $(C=CGhGO?)(B $(C:8<<?d(B. $(C=:E)80(B $(C9X?!(B "Back to top level"$(C6s0m(B $(CG%=C5K(B + $(C4O4Y(B. + + $(CK\;g=G@:(B, $(C@L(B $(C=C550!(B $(CG`GO?)A3@;(B $(C6'4B(B, $(C@L9L(B $(CEi79:'?!(B $(C@V>z4x(B $(C0M@T4O(B +$(C4Y(B. M-x top-level$(C@:(B, $(C>F9+71(B $(C?5Gb@;(B $(CAV0m(B $(C@VAv(B $(C>J=@4O4Y(B. + + $(C8.D?=C:j(B $(C?!5pFC(B $(C79:'7N:NEM(B $(C:|A.3*?@4B(B $(C0M?!(B $(C4kGX<-4B(B C-g$(C4B(B $(C5hAv(B $(C>J(B +$(C=@4O4Y(B. + + +$(CGoGA(B +==== + + Emacs$(C?!4B(B, $(C89@:(B $(C55?r1b4I@L(B $(C@V0m(B, $(C?)1b?!<-(B, $(C@|:N8&(B $(C<38mGO4B(B $(C0M@:(B +$(C:R0!4IGU4O4Y(B. $(C1W7/3*(B, $(C>FAw(B $(C8p8#4B(B $(C89@:(B $(C1b4I@;(B $(C9h?l1b(B $(C@'GX<-4B(B, <HELP> +$(C6s0m(B $(C:R8.4B(B C-h $(C8&(B $(CE8@LGAGO4B(B $(C0M@87N(B, $(C89@:(B $(CA$:88&(B $(C@T<vGR(B $(C<v(B $(C@V=@4O4Y(B. + + $(C;g?k9f9}@:(B, C-h $(C8&(B $(CE8@LGAGO0m(B, $(C@L>n<-(B $(CGJ?dGQ(B $(C?I<G@;(B 1$(C9.@Z(B $(CE8@LGA(B +$(CGU4O4Y(B. $(C8p8#0Z@88i(B, C-h ? $(C6s0m(B $(CE8@LGAGO8i(B, $(C>n62(B $(C?I<G@L(B $(C@V4B0!(B $(CG%=C5K(B +$(C4O4Y(B. $(C88>`(B, C-h $(C8&(B $(CE8@LGAGO0m3*<-(B $(C86@=@L(B $(C:/G_4Y8i(B, C-g $(C8&(B $(CE8@LGAGO8i(B, +$(CCk<RGR<v(B $(C@V=@4O4Y(B. + + $(C0!@e(B $(C1b:;@{@N(B $(C0M@:(B, C-h c $(C@T4O4Y(B. $(C@L0M?!(B $(C@L>n<-(B $(CE08&(B $(C@T7BGO8i(B, $(C1W(B +$(C8m7I>n?!(B $(C4kGQ(B $(CB*@:(B $(C<38m@;(B $(CG%=CGU4O4Y(B. + + >> C-h c C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<<?d(B. "C-p runs the command + previous-line"$(C0z(B $(C00@:(B $(C8^<<Av0!(B $(CG%=C5K4O4Y(B. + + $(C:;(B $(C@{@:(B $(C@VAv88(B, $(C1b>oGO0m(B $(C@VAv(B $(C>J@:(B $(C8m7I>n55(B $(C;}0"GX(B $(C3>(B $(C<v(B $(C@V4B(B $(C0M(B +$(C@T4O4Y(B. C-x C-s $(C?M(B $(C00@:(B $(C:9<v@L8i<-(B 1$(C03@G(B $(C8m7I>n55(B C-h c $(C@G(B $(C5Z?!(B $(C@L>n(B +$(CA}4O4Y(B. + + $(C4u?m(B $(C;s<<GO0T(B $(C>K0m(B $(C=M@88i(B, c $(C4k=E?!(B k $(C8&(B $(CAvA$GU4O4Y(B. + + >> C-h k C-p $(C6s0m(B $(CE8@LGAGO?)(B $(C:8<<?d(B. + + Emacs$(C@G(B $(C@)55?l?!(B, $(C8m7I>n@G(B $(C@L8'0z(B $(C1b4I@L(B $(CG%=C5K4O4Y(B. $(C4Y(B $(C@P>z@88i(B, +C-x 1 $(C6s0m(B $(CE8@LGAGO8i(B, $(C:|A.3*?I4O4Y(B. + + $(C@L?\?!55(B $(C55?r@L(B $(C5G4B(B $(C?I<G@L(B $(C@V=@4O4Y(B. + + C-h f $(CFc<G8m@;(B $(C@T7BGO8i(B, $(CFc<G@;(B $(CG%=CGU4O4Y(B. + + >> C-h f previous-line $(C@;(B $(CE8@LGAGO0m(B, <Return> $(C@;(B $(C4)8#<<?d(B. C-p + $(C8m7I>n8&(B $(C=GG`GO4B(B $(CFc<G?!(B $(C4kGQ(B $(CA$:88&(B $(CG%=CGU4O4Y(B. + + C-h a $(CE0?v5e8&(B $(C@T7BGO8i(B, $(C@L8'?!(B $(C1W(B $(CE0?v5e8&(B $(CFwGTGO0m(B, $(C8p5g(B $(C8m(B + $(C7I>n8&(B $(CG%=CGU4O4Y(B. $(C@L(B $(C8m7I>n5i@:(B $(C8p5N(B ESC x $(C7N(B $(C=GG`GR(B + $(C<v(B $(C@V=@4O4Y(B. + + >> C-h a file $(C>K0m(B $(CE8@LGAGO0m(B, <Return>$(C@;(B $(C4)8#<<?d(B. $(C@L8'?!(B + "file"$(C@L6s4B(B $(C9.@Z8&(B $(C0.4B(B $(C8p5g(B $(C8m7I>n8&(B $(CG%=CGU4O4Y(B. $(C6GGQ(B, + find-file $(C@L3*(B write-file$(C6s4B(B $(C@L8'@G(B C-x C-f $(C3*(B C-x C-w $(C?M(B $(C00(B + $(C@:(B $(C8m7I>n55(B $(CG%=C5K4O4Y(B. + +$(C3!@87N(B +====== + +$(C@XAv8;0m(B: $(CA>7aGO4B5%4B(B, C-x C-c $(C6s0m(B $(CGU4O4Y(B. + + + $(C@L(B $(C@T9.Fm@:(B, $(CCJ=I@Z?!0T55(B $(C>K1b(B $(C=10T(B $(CGO557O(B $(C@G55GO0m(B $(C@V=@4O4Y(B. +$(C1W7/9G7N(B, $(CH$=C(B $(C9+>y@N0!(B $(C@LGXGO1b(B $(C>n7A?n(B $(CA!@L(B $(C@V4Y8i(B, $(CH%@Z<-(B $(CG*3d(B +$(CGOAv(B $(C8;0m(B, $(CF.A}@;(B $(C@b>F(B $(CAV<<?d(B. + + + $(C88>`(B, EMACS $(C8&(B $(C8n@OA$55(B $(C;g?kGO0m(B $(C:88i(B, $(C1W0M@;(B $(C1W885P4Y4B(B $(C0M@:(B +$(C8xGO0T(B $(C5I(B $(C0M@T4O4Y(B. $(CCVCJ?!4B(B $(C>n8.5U@}GR(B $(CAv55(B $(C8p8#0Z=@4O4Y(B. $(C1W7/3*(B, +$(C1W0M@:(B $(C>n60GQ(B $(C?!5pEM6s55(B $(C6H(B $(C00=@4O4Y(B. EMACS $(C?M(B $(C00@L(B, $(C4k4\Hw(B $(C89@:(B $(C0M@L(B +$(C0!4IGQ(B $(C0f?l?!4B(B $(CF/Hw(B $(C1W780ZAv?d(B. $(C1W8.0m(B, EMACS $(C?!<-4B(B, $(C=GA&7N(B, $(C9+>y@L(B +$(C3*(B $(CGR(B $(C<v(B $(C@V1b(B $(C6'9.?!(B. + + +$(C0(;g(B +==== + $(C@L(B $(C9.<-4B(B, JUNET$(C?!<-(B $(C9hFw5H(B "$(C@O:;>n(B MicroEMACS (kemacs) $(C@T9.Fm(B" +$(C@;(B GNUE- macs (Nemacs)$(C@G(B Tutorial$(C?k@87N(B $(C0mCD>4(B $(C0M@T4O4Y(B. + + Jonathan Payne $(C?!(B $(C@GGQ(B "JOVE Tutorial" (19 January 86) $(C@;(B $(C:/0fGQ(B + $(C0M@L0m(B, $(C1W0M@:(B $(C?x7!(B, CCA-UNIX$(C@G(B Steve Zimmerman $(C?!(B $(C@GGX<-(B $(C:/0f5H(B, + MIT $(C@G(B "Teach-Emacs" $(C@T9.Fm(B (31 October 85) $(C@;(B ($(C4u?m(B) $(C:/0fGQ(B $(C0M@L(B + $(C>z=@4O4Y(B. + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +$(CF/:0GQ(B $(C0(;g(B +=========== + + $(CCVCJ?!(B $(C@L(B $(C@O:;>n9x?*@;(B $(C@[<:GQ(B, SANETO Takanori$(C>>(B. $(C@L(B $(C9.@e@:(B GMW + +Wnn + Nemacs$(C@;(B $(C;g?kGO?)(B $(C@[<:G_=@4O4Y(B. $(C1W?M(B $(C00@:(B $(CHG8"GQ(B $(CGA7N1W7%@;(B $(C885g(B +$(C8p5g(B $(C:P?!0T(B $(C0(;g@G(B $(C6f@;(B $(CG%GO0m(B $(C=M=@4O4Y(B. $(C9x?*@L6s5g0!(B, $(C@T7B(B $(C5n(B +$(C?)7/8p7N(B $(C55?M(B $(CAX(B $(CHDAvGO6s<n?l2?>>(B, $(C4k4\Hw(B $(C0(;gGU4O4Y(B. + + + +$(C?@?*(B, $(C0EA~(B, $(C@L(B $(C?\@G(B $(C9.C%@:(B $(C>F7!@G(B $(C;g6w?!0T(B $(C@V=@4O4Y(B. + + $BNkLZM5?.(B hironobu@sra.co.jp + + +Update/Add - December 1987 by Hironobu Suzuki +Update/Add - November 1989 by Ken'ichi Handa +Update/Add - January 1990 by Shigeki Yoshida +Update/Add - March 1992 by Kenichi HANDA + + +$(C6G4Y8%(B $(C0(;g(B +=========== + + $(C@L(B $(C9.<-4B(B "$(C@O:;>n(B GNUEMACS(Mule) $(C@T9.Fm(B"$(C@;(B $(CGQ19>n7N(B $(C9x?*GO?)(B, +hemacs$(C7N(B $(C@[<:GQ(B $(C0M@T4O4Y(B. $(C@O:;>n9x?*@;(B $(C4c4gGQ(B $(C8p5g(B $(C:P(B, hemacs$(C8&(B +$(C039_GO?)(B $(CAV=E(B $(C:P(B, $(CF/Hw(B Mule$(C0z(B hemacs$(C@G(B $(CH/0f18C`?!(B $(C89@:(B $(C55?r@;(B $(CAX(B +$(C136G4kGP(B $(C3*0!?@?,18=G(B $(CA9>w;}@N(B Masashi SHIMBO$(C>>?M(B Katsuyoshi +Yamagami$(C>>?!0T(B $(C0(;g@G(B $(C6f@;(B $(C@|GU4O4Y(B. + + 1993. 9. 25 + + $(C136G4kGP(B $(C0xGP:N(B $(C@|1b0xGP0z(B $(C3*0!?@?,18=G(B + Dosam HWANG hwang@forest.kuee.kyoto-u.ac.jp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.no Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1126 @@ +Copyright (c) 1997, Stig Bjørlykke <stigb@tihlde.hist.no> +Se i slutten av dokumentet for vilkår og betingelser. + +Dette dokumentet er basert på den engelske veiledningen, som er +Copyright (c) 1985, 1996 Free Software Foundation, Inc. + + +Dette er den norske brukerveiledningen til Emacs. + +Emacs-kommandoer inkluderer ofte bruk av CONTROL-tasten (noen ganger +merket CTRL eller CTL) eller META-tasten. På noen tastaturer er +META-tasten merket ALT eller EDIT eller noe annet (på Sun-tastaturer +for eksempel, er det "ruter"-tasten til venstre for mellomromstasten). +Hvis du ikke har noen META-tast kan du bruke ESC. Istedenfor å skrive META +eller CONTROL vil vi her bruke følgende forkortelser: + + C-<chr> betyr at du skal holde nede CONTROL-tasten mens du trykker + bokstaven <chr>. Dermed vil C-f bety: hold nede + CONTROL-tasten og trykk f. + M-<chr> betyr at du skal holde nede META-tasten mens du trykker + <chr>. Hvis du ikke har noen META-tast kan du trykke <ESC>, + slippe tasten, og så trykke bokstaven <chr>. + +Viktig: for å avslutte Emacs trykker du C-x C-c. (To tegn.) +Tegnene ">>" helt til venstre angir en veiledning slik at du kan prøve +ut en kommando. For eksempel: +<<Blank lines inserted here by startup of help-with-tutorial>> +>> Trykk C-v (View next screen) for å hoppe til neste skjermbilde. + (kom igjen, hold ned control-tasten og trykk v). Fra nå av + bør du gjøre dette hver gang du er ferdig med å lese et + skjermbilde. + +Merk at det er en overlapping på to linjer når du skifter fra +skjermbilde til skjermbilde. Dette er for at det skal bli en viss +kontinuitet når du skal bevege deg gjennom filen. + +Det første du trenger å vite er hvordan du manøvrerer deg i fra plass +til plass i teksten. Du har allerede lært hvordan du flytter deg ett +skjermbilde framover, med C-v. For å flytte deg et skjermbilde +bakover trykker du M-v (hold ned META-tasten og trykk v, eller trykk +<ESC>v hvis du ikke har META-, EDIT- eller ALT-tast). + +>> Prøv å trykke M-v og så C-v noen ganger. + + +* OPPSUMMERING +-------------- + +Følgende kommandoer er nyttige for å se hele skjermbilder: + + C-v Flytt ett skjermbilde framover. + M-v Flytt ett skjermbilde bakover. + C-l Rensker skjermen og plasser teksten der markøren står + på midten av skjermbildet. (Det var control-(liten L), + ikke control-1. Control-1 har en helt annen mening, + som beskrevet nedenfor.) + +>> Finn markøren og se hva slags tekst som står der. + Trykk C-l. + Finn markøren igjen og se hva slags tekst som står der nå. + + +* GRUNNLEGGENDE MARKØRBEVEGELSER +-------------------------------- + +Det å flytte seg fra skjermbilde til skjermbilde er nyttig, men +hvordan flytter man seg til en spesiell plass innenfor skjermbildet? + +Det er flere måter å gjøre dette på. Den vanligste måter er å bruke +kommandoene C-p, C-b, C-f og C-n. Hver av disse kommandoene flytter +markøren en rad eller kolonne i en bestemt retning på skjermen. Her +vises disse fire kommandoene og i hvilken retning de flytter markøren: + + + Forrige linje (previous), C-p + : + : + Bakover, C-b .... Nåværende markørposisjon .... Framover, C-f + : + : + Neste linje (next), C-n + +>> Flytt markøren til linjen midt i diagrammet ved å bruke C-n og C-p. + Bruk så C-l for å sentrere diagrammet på skjermbildet. + +Dette er sikkert litt enklere å huske hvis du tenker på disse +forkortelsene: P (engelsk previous) for forrige, N for neste, B for +bakover og F for framover. Dette er de grunnleggende kommandoene for +å flytte markøren, og du kommer sikkert til å bruke dem hele tiden, så +det vil være en stor fordel om du lærer dem nå. + +>> Gjør noen C-n slik at du kommer ned til denne linjen. + +>> Flytt deg innover på linjen ved hjelp av noen C-f og så oppover med + noen C-p. Legg merke til hva C-p gjør når markøren står midt i en + linje. + +Tekstlinjer er atskilt med linjeskift-tegn. Den siste linjen i teksten +avsluttes vanligvis med linjeskift, men Emacs krever ikke at du har +det. + +>> Prøv en C-b i begynnelsen av en linje. Dette gjør at markøren + flyttes til slutten av forrige linje. Dette er fordi den flytter + markøren over linjeskiftet. + +C-f flytter også over linjeskift, akkurat som C-b. + +>> Utfør noen flere C-b slik at du får en følelse av hvor markøren + er. Trykk så noen C-f til du kommer til slutten av linjen. Trykk + da en C-f til slik at du flytter markøren til neste linje. + +Når du flytter markøren forbi toppen eller bunnen av skjermbildet vil +teksten utenfor skjermen komme til syne. Dette kalles "scrolling" og +gjør det mulig for Emacs å flytte markøren uten at den forsvinner ut +av skjermbildet. + +>> Prøv å flytte markøren forbi bunnen av skjermbildet ved hjelp av C-n + og se hva som skjer. + +Hvis det går for tregt å flytte markøren ett og ett tegn kan du flytte +den ett og ett ord. M-f (Meta-f) flytter markøren ett ord framover, +og M-b flytter den ett ord bakover. + +>> Utfør noen M-f og M-b. + +Hvis markøren står midt i et ord vil M-f flytte markøren til slutten +av ordet. Hvis du står midt mellom to ord vil M-f flytte markøren til +slutten av det kommende ordet. M-b fungerer på samme måte, bare i +motsatt retning. + +>> Trykk M-f og M-b noen ganger og skift markørposisjon med noen C-f + og C-b slik at du ser hvordan M-f og M-b oppfører seg ved + forskjellig plassering av markøren både i og mellom ord. + +Legg merke til parallellen mellom C-f og C-b på en side, og M-f og M-b +på den andre. Ofte er Meta-kommandoer brukt til operasjoner relatert +til enheter definert av språket (ord, setninger, avsnitt), mens +Control-kommandoer blir brukt på grunnleggende enheter som er +uavhengig av hva man redigerer (bokstaver, linjer, etc.). + +Denne parallellen finnes også mellom linjer og setninger: C-a og C-e +flytter markøren til begynnelsen av linjen, eller til slutten av +linjen, mens M-a og M-e flytter den til begynnelsen eller slutten av +setningen. + +>> Prøv noen C-a, og så noen C-e + Prøv også noen M-a, og så noen M-e + +Se hvordan gjentatte C-a etter hverandre ikke gjør noe, mens flere M-a +fortsetter å flytte markøren til neste setning. Selv om dette ikke +virker selvfølgelig er det ganske naturlig. + +Her er en kort oppsummering av de enkleste markørforflyttnings- +kommandoene, inkludert ord- og setningsforflyttnings-kommandoene: + + C-f Flytte markøren en plass framover + C-b Flytte markøren en plass bakover + + M-f Flytte markøren ett ord framover + M-b Flytte markøren ett ord bakover + + C-n Flytte markøren til neste linje + C-p Flytte markøren til forrige linje + + C-a Flytte markøren til begynnelsen av linjen + C-e Flytte markøren til slutten av linjen + + M-a Flytte markøren til begynnelsen av setningen + M-e Flytte markøren til slutten av sentingen + +>> Prøv ut alle disse kommandoene noen ganger, bare for trening. + Dette er de mest brukte kommandoene. + +To andre viktige markørbevegelses-kommandoer er M-< (Meta Mindre-enn), +som flytter markøren til begynnelsen av teksten, og M-> (Meta +større-enn), som flytter den til slutten av teksten. + +På noen tastaturer er ">" plassert over komma, så man må bruke shift +for å få den fram. På disse tastaturene må man også bruke shift for å +taste M-<. Uten shift-tasten vil det bli M-komma. + +>> Prøv M-< nå for å flytte markøren til begynnelsen av veiledningen. + Bruk så C-v for å flytte markøren tilbake hit igjen. + +>> Prøv også M-> for å flytte markøren til slutten av veiledningen. + Bruk så M-v for å flytte markøren tilbake hit igjen. + +Du kan også flytte markøren ved hjelp av piltastene, hvis terminalen +har piltaster. Vi anbefaler at du lærer deg C-b, C-f, C-n og C-p av +tre grunner. Først fordi de vil fungere på alle slags terminaler. +Nummer to fordi når du først får litt trening i bruk av Emacs vil du +finne ut at det går mye kjappere å bruke control-kombinasjoner enn +piltastene (fordi du slipper å flytte hendene bort fra +touch-plasseringen). Den tredje grunnen er at når du først har lært +deg til å bruke control-tastene blir det lettere å lære seg de mer +avanserte control-funksjonene. + +De fleste av kommandoene i Emacs tar også et numerisk argument. For +de fleste av kommandoene vil dette si repetert utførelse. Måten du +gir en kommando et slikt argument er at du trykker C-u og deretter +tallet, før du taster kommandoen. Hvis du har en META- (eller EDIT- +eller ALT-) tast så finnes det et annet alternativ for å gi numeriske +argumenter: Trykk ned tallet mens du holder META-tasten nede. Vi +anbefaler at du bruker C-u fordi det fungerer på alle slags +terminaler. + +For eksempel: C-u 8 C-f flytter markøren åtte plasser framover. + +>> Prøv kommandoene C-n eller C-p med numerisk argument slik at du + kommer nærmest mulig denne linjen med bare en kommando. + +De fleste kommandoene bruker det numeriske argumentet som en repetert +utførelse. Men det finnes kommandoer som bruker den annerledes. C-v +og M-v er blant disse unntakene. Hvis man gir et argument til en av +disse kommandoene vil skjermbildet flytte seg opp eller ned så mange +linjer som argumentet, isteden for så mange skjermbilder. For +eksempel vil C-u 4 C-v flytte skjermbildet 4 linjer oppover. + +>> Prøv å taste C-u 8 C-v nå. + +Dette burde flyttet skjermbildet 8 linjer oppover. Hvis du ønsker å +flytte det tilbake igjen er det bare å gi samme argument til M-v. + +Hvis du bruker Emacs under X er det sannsynligvis et firkantet område +på høyresiden av Emacs-vinduene, også kalt rullefelt. Dette kan du +også bruker for å forflytte deg innenfor teksten. + +>> Prøv å trykk på den midterste musknappen i det uthevete området på + rullefeltet. Dette burde flyttet skjermbildet til en plass i + teksten avhengig av hvor i rullefeltet du trykket. + +>> Flytt muspekeren til en plass i rullefeltet ca. 1/5 fra toppen og + trykk på venstre musknapp noen ganger. + + +* MARKØRBEVEGELSE PÅ EN X-TERMINAL +---------------------------------- + +Hvis du sitter på en X-terminal vil du sansynligvis finne det mye +enklere å bruke piltastene for å bevege markøren. Venstre-, høyre-, opp- +og ned-pilene beveger markøren i ønsket retning. De fungerer på samme +måte som C-b, C-f, C-p og C-n, men er enklere å taste og huske. Du +kan også bruke C-venstre og C-høyre for å bevege den innenfor ord, og +C-opp og C-ned for å bevege den innenfor blokker (For eksempel +avsnitt hvis du redigerer tekst). Hvis du har tastene merket HOME +(eller BEGIN) og END kan du bruke disse for å gå til henholdsvis +begynnelsen av linjen og slutten av linjen, og C-HOME og C-END vil gå +til henholdsvis begynnelsen av filen og slutten av filen. Hvis +tastaturet har PgUp- og PgDn-taster kan du bruker dem for å gå opp og +ned et skjermbilde av gangen, på samme måte som M-v og C-v. + +Alle disse kan ta numeriske argumenter, som beskrevet ovenfor. Du kan +også benytte en snarvei for å skrive inn disse argumentene: hold ned +CONTROL eller META tasten og skriv inn nummeret. For eksempel for å gå +12 ord til høyre taster du C-1 C-2 C-høyre. Legg merke til at dette +blir svært enkelt å taste fordi du ikke slipper CONTROL-tasten mellom +tastetrykkene. + + +* HVIS EMACS HENGER +------------------- + +Hvis Emacs slutter å reagere på kommandoer kan du trygt stoppe den ved +å trykke C-g. Du kan også bruke C-g for å stoppe en kommando som tar +for lang tid å utføre. + +Det er også mulig å bruke C-g for å avbryte et numerisk argument eller +begynnelsen på en kommando du ikke ønsker å utføre. + +>> Tast C-u 100 for å lage et numerisk argument på 100 og trykk C-g. + Trykk nå C-f. Markøren skal nå flytte seg bare ett steg, + fordi du avbrøt argumentet med C-g. + +Hvis du ved en feiltakelse trykket <ESC> blir du kvitt denne ved å +trykke C-g. + + +* UTILGJENGELIGE KOMMANDOER +--------------------------- + +Enkelte av Emacs-kommandoene er "utilgjengelige" slik at nybegynnere +ikke kan bruke dem uten at de ønsker det. + +Hvis du prøver en av disse utilgjengelige kommandoene vil Emacs komme +med en melding som forteller hvilken kommando det er, og vil spørre om +du virkelig vil fortsette å utføre denne kommandoen. + +Hvis du virkelig ønsker å prøve denne kommandoen trykker du mellomromstast +som svar på spørsmålet. Normalt, hvis du ikke ønsker å kjøre denne +kommandoen, svarer du "n" på spørsmålet. + +>> Tast `C-x n p' (som er en utilgjengelig kommando), + tast n som svar på spørsmålet. + + +* VINDUER +--------- + +Emacs kan ha flere vinduer, og hver av dem kan vise sin egen tekst. +Legg merke til at "vinduer" i Emacs ikke refererer til separate +overlappende vinduer i vindus-systemet, men til separate buffer +innenfor et enkelt X-vindu. (Emacs kan også ha flere X-vinduer, eller +"rammer" i Emacs-terminologi. Dette blir beskrevet senere.) + +Akkurat nå er det best at vi ikke går inn på teknikker for å bruke +flere vinduer, men du trenger å vite hvordan du blir kvitt ekstra +vinduer som kan dukke opp for å vise hjelp, eller utskrift fra enkelte +kommandoer. Det er enkelt: + + C-x 1 Ett vindu (dvs. gjem alle andre vinduer). + +Det er da Control-x etterfulgt av tallet 1. C-x 1 utvider vinduet der +markøren står, slik at det fyller hele skjermbildet og gjemmer alle +andre vinduer. + +>> Flytt markøren til denne linjen og trykk C-u 0 C-l. + +(Husk at C-l renser skjermen og midtstiller linjen der markøren +står. Hvis du gir et numerisk argument til denne kommandoen betyr det +"rensk skjermen og legg linjen der markøren står på linjen angitt av +argumentet" Derfor betyr C-u 0 C-l at skjermen skal renskes og +linjen der markøren står plasseres øverst.) + +>> Tast Control-x 2. + Se hvordan vinduet krympes og et nytt dukker opp med samme + innhold som dette. + +>> Tast C-x 1 for at vinduet skal forsvinne. + + +* INNSETTING OG SLETTING +------------------------ + +Hvis du ønsker å sette inn tekst er det bare å skrive teksten. Tegn +som du kan se, slik som A, 7, *, ol. blir tolket som tekst og blir +satt rett inn. Tast <Retur> (enter-tasten) for å sette inn et +linjeskift. + +Du kan slette det siste tastete tegnet ved å trykke <Delete>. +<Delete> er en tast på tastaturet, og kan også være merket "Del". I +noen tilfeller fungerer også "Backspace" som <Delete>, men ikke +alltid! + +Mere generelt sletter <Delete> tegnet rett foran der markøren er +plassert. + +>> Gjør dette nå -- skriv inn noen tegn og slett dem ved å bruke + <Delete>. Ikke vær redd for å skrive i denne filen, du vil ikke + kunne forandre på den originale veiledningen. Dette er bare en + lokal kopi. + +Når en linje blir for lang til å passe inn på en skjermbredde så +fortsetter den på linjen under. En backslash ("\") i enden av høyre +marg indikerer at linjen fortsetter. Om du kjører Emacs under X vil +du se en liten pil som peker ned til neste linje. + +>> Skriv inn litt tekst slik at du kommer til enden av linjen, og + fortsett å skrive litt til. Du vil da se hvordan + fortsettelseslinjen blir. + +>> Bruk <Delete> for å slette teksten inntil linjen passer på en + skjermbredde igjen. Fortsettelseslinjen vil da forsvinne. + +Du kan slette linjeskift akkurat som andre tegn. Ved å slette +linjeskiftet mellom to linjer blir disse smeltet sammen til en. Hvis +resultatet av denne sammensmeltingen blir for stor til å passe på en +skjermbredde så vil den bli vist med en fortsettelseslinje. + +>> Flytt markøren til begynnelsen av en linje og trykk <Delete>. + Dette vil spleise sammen linjen med linjen over. + +>> Trykk <Return> for å sette inn linjeskiftet du slettet. + +Husk at de fleste Emacs-kommandoene kan ta numeriske argumenter. +Dette gjelder også tekst-tegn. Ved å repetere et tekst-tegn vil det +komme flere ganger. + +>> Prøv det nå: tast C-u 8 * for å sette inn ********. + +Du har nå lært de mest grunnleggende måtene å skrive noe inn i Emacs, +og å rette feil. Du kan slette ord eller linjer også. Her er en +oversikt over kommandoer for sletting: + + <Delete> sletter tegnet som står rett foran markøren + C-d sletter tegnet som står rett under markøren + + M-<Delete> sletter ordet rett foran markøren + M-d sletter ordet rett etter markøren + + C-k sletter fra markøren til slutten av linjen + M-k sletter til slutten av setningen + +Legg merke til at <Delete> og C-d kontra M-<Delete> og M-d fortsetter +parallellen som ble startet av C-f og M-f (vel, <Delete> er ikke +akkurat noe kontroll-tegn, men la oss ikke bry oss om det). C-k og +M-k fungerer på samme måte som C-e og M-e (nesten). + +Når du sletter flere enn ett tegn om gangen vil Emacs lagre den +slettete teksten slik at du han hente den tilbake igjen. Denne +teksten blir kalt "killed text". Å bringe tilbake "killed text" blir +kalt "yanking". Du kan enten hente tilbake "killed text" på samme +plassen som den ble slettet, eller du kan sette den inn en annen plass +i teksten. Du kan også hente den tilbake flere ganger etter hverandre +slik at du får flere like forekomster av den. Kommandoen for å hente +tilbake teksten er C-y. + +Legg merke til at forskjellen mellom "killed text" og "deleted text" +er at "killed text" kan bli hentet tilbake, mens "deleted text" ikke +kan det. Generelt kan man si at kommandoer som sletter flere enn ett +tegn lagrer unna teksten slik at den kan bli hentet tilbake, og +kommandoer som bare sletter ett tegn, eller tomme linjer og mellomrom +ikke lagrer det. + +>> Flytt markøren til begynnelsen av en linje som ikke er tom. + Trykk så C-k for å "kille" teksten på denne linjen. +>> Trykk C-k en gang til. Du vil nå se at den sletter den tomme + linjen som ble stående igjen etter teksten. + +Legg merke til at en enkel C-k bare sletter teksten på linjen, og at +enda en C-k sletter selve linjen og flytter teksten på linjen under en +linje opp. C-k takler numeriske argumenter litt spesielt. Den +sletter så mange linjer OG innholdet i dem. Dette er ikke bare +repetisjon av kommandoen. C-u 2 C-k sletter to linjer samt de tomme +linjene, mens C-k to ganger ikke vil gjøre det. + +Trykk C-y for å hente tilbake teksten som sist ble "killet" der +markøren står. + +>> Prøv dette. Trykk C-k etpar ganger. + +Og hent dem så tilbake igjen: + +>> Trykk C-y. Flytt markøren noen linjer ned og trykk C-y igjen. + Dette er måten å kopiere tekst på. + +Men hva gjør du hvis du har en tekst du ønsker å hente tilbake, og så +"killer" noe nytt? C-y vil hente tilbake den siste teksten som ble +"killet". Men den forrige teksten er ikke fortapt. Du kan få den +tilbake ved å bruke kommandoen M-y. Etter at du har brukt C-y for å +hente tilbake den siste "killed text" vil M-y erstatte denne teksten +med teksten fra den forrige "killed text". Når du har funnet fram til +ønsket tekst trenger du ikke gjøre noe mere for å beholde den. + +Hvis du tastet M-y mange nok ganger vil du komme tilbake til starten +igjen (teksten som sist ble "killet") + +>> "Kill" en linje, flytt markøren til en ny linje og "kill" denne + også. Bruk så C-y for å hente tilbake den siste linjen. Trykk M-y + for å bytte den med den forrige "killete" linjen. Trykk flere M-y + og se hva du får. Fortsett med dette til du får tilbake den første + linjen igjen, og så noen ganger til. Hvis du ønsker kan du prøve + med positive og negative argumenter til M-y. + + +* ANGRE +------- + +Hvis du gjør en forandring i teksten og finner ut at du angrer på det +du har gjort kan du oppheve dette med kommandoen C-x u (undo). + +Normalt vil C-x u oppheve forandringene gjort av den siste utførte +kommandoen. Hvis du repeterer C-x u flere ganger på rad vil hver +repetisjon oppheve enda en utført kommando. + +Men det er to unntak her. Kommandoer som ikke forandrer i teksten +teller ikke (dette inkluderer markørbevegelser og flytte-kommandoer), +og inntastede enkeltbokstaver blir vanligvis gruppert i grupper på opp +til 20 tegn. (Dette er for å redusere antall C-x u'er som trengs for +å angre inntastet tekst.) + +>> "Kill" denne linjen med C-k. C-x u vil få den tilbake igjen. + +C-_ er en alternativ angre-kommando. Den fungerer på samme måte som +C-x u, men er enklere å taste flere ganger på rad. Ulempen med C-_ er +at den er vanskelig å finne fram til på enkelte tastaturer. Det er +derfor vi i tillegg har C-x u. På enkelte terminaler kan du få fram +C-_ ved å trykke / mens CTRL er holdt nede. + +Et numerisk argument til C-_ eller C-x u vil repetere antall +angringer. + + +* FILER +------- + +For at teksten du har forandret på skal lagres permanent må du legge +den i en fil. Hvis ikke vil den forsvinne når du avslutter Emacs. Du +legger teksten i en fil ved først å "finne" denne filen. (Dette blir +også kalt å "besøke" filen.) + +Det å finne en fil betyr at du henter innholdet av filen inn i Emacs. +På mange måter er det som om du forandrer på selve filen, men +forandringene du gjør på filen mens du benytter Emacs vil ikke bli +permanente får du lagrer filen. Dette er fordi du skal slippe å legge +igjen halv-forandrete filer hvis du ikke ønsker det. Og selv når du +lagrer vil Emacs legge igjen en backup-fil i tilfelle du senere +bestemmer deg for at du ikke ønsker disse forandringene. + +Hvis du ser nesten nederst i skjermbildet så vil du se en linje som +begynner og slutter med minustegn, og som inneholder teksten "XEmacs: +TUTORIAL.no". Denne delen av skjermbildet vil alltid vise navnet på +filen du er "inne i". Akkurat nå er du inne i en fil som heter +"TUTORIAL.no" og som er en personlig kopi av Emacs- veiledningen. +Samme hvilken fil du er inne i så vil filnavnet stå akkurat på denne +plassen. + +Kommandoene for å finne filer og lagre filer er litt ulike de andre +kommandoene du har lært fordi de består av to tegn. Begge starter med +tegnet Control-x. Det er faktisk mange kommandoer som starter med +Control-x, og mange av dem har med filer, skjermbilder og slike ting å +gjøre. Disse kommandoene er to, tre eller fire tegn lange. + +En annen ting med kommandoen for å finne filer er at du må fortelle +hvilket filnavn du ønsker. Vi sier at kommandoen "leser et argument +fra terminalen" (i dette tilfellet vil argumentet være navnet på +filen). Etter at du har trykket kommandoen + + C-x C-f Finn en fil + +vil Emacs spørre etter et filnavn. Filnavnet du skriver vil komme +fram på den nederste linjen i skjermbildet. Denne linjen blir kalt +minibuffer når det blir brukt slik. Du kan bruke vanlige +Emacs-redigeringskommandoer for å forandre på filnavnet. + +Mens du holder på å skrive inn filnavnet (eller noe annet i +minibuffret) kan du avbryte med kommandoen C-g. + +>> Tast C-x C-f og så C-g. Dette avbryter minibuffret og avbryter + også C-x C-f kommandoen som brukte minibuffret. + +Når du er ferdig med å skrive filnavnet trykker du <Return> for å +fullføre kommandoen. Da vil C-x C-f kommandoen begynne å lete fram +filen. Minibuffret forsvinner når C-x C-f kommandoen er ferdig. + +Om en liten stund vil filen komme inn i skjermbildet og du kan begynne +å redigere innholdet. Når du ønsker å lagre filen kan du bruke denne +kommandoen + + C-x C-s Lagre fil + +Denne kopierer teksten i skjermbildet over til filen. Første gang +dette gjøres vil Emacs døpe om det originale filnavnet til et nytt +navn slik at den ikke går tapt. Det nye filnavnet blir laget ved at +det blir lagt til en "~" i slutten av det originale filnavnet. + +Når lagringen er utført vil Emacs skrive ut navnet på filen som ble +lagret. Du bør lagre ofte slik at du ikke mister så mye om det skulle +oppstå en system-krasj. + +>> Trykk C-x C-s for å lagre en kopi av denne veiledningen. + Dette skal føre til at "Wrote ...TUTORIAL.no" blir + skrevet ut nederst i skjermbildet. + +NB: På noen systemer vil C-x C-s føre til at skjermen "fryses" og du +vil ikke være istand til å utføre noen flere kommandoer. Dette +indikerer at en operativsystem-egenskap kalt "flytkontroll" har +fanget opp C-s'en og ikke sendt den videre til Emacs. For å fortsette +må du trykke C-q. Se da i avsnittet "Spontaneous Entry to Incremental +Search" i Emacs-manualen for råd om hvordan dette kan avverges. + +Du kan finne en eksisterende fil, enten for å forandre den eller for å +se på den. Du kan også finne en fil som ikke eksisterer. Dette er +måten du lager nye filer med Emacs: finn filen, som er tom til å begynne +med, og start å skrive teksten som skal inn i denne filen. Først når du +lagrer filen vil Emacs virkelig opprette filen med den teksten du har +skrevet. Fra nå av kan du betrakte deg selv som om du skriver i en +fil som allerede eksisterer. + + +* BUFFER +-------- + +Hvis du finner en ny fil med C-x C-f vil den første filen fortsatt +være åpen i Emacs. Du kan bytte tilbake til den ved å finne den på +nytt med C-x C-f. På denne måten kan du ha et stort antall åpne filer +i Emacs. + +>> Lag en fil med navnet "foo" ved å trykke C-x C-f foo <Return>. + Sett inn litt tekst, forandre litt på den, og lagre "foo" ved å + bruke C-x C-s. Skriv tilslutt C-x C-f TUTORIAL.no<Return> + for å komme tilbake til denne veiledningen. + +Emacs lagrer teksten i hver av filene i et objekt kalt "buffer". Når +du finner en ny fil vil det opprettes et nytt buffer i Emacs. For å +se en liste over eksisterende buffer i Emacs kan du trykke + + C-x C-b Utlisting av buffrene. + +>> Prøv C-x C-b nå. + +Se hvordan hvert av buffrene har hvert sitt navn, og at de også kan ha +et filnavn på den filen der innholdet kommer fra. Noen buffre er ikke +knyttet til noen fil, for eksempel bufferet "Buffer List". Det er det +buffret som inneholder listen over buffre som ble generert med C-x +C-b. All teksten du ser i et Emacs-vindu tilhører et buffer. + +>> Tast C-x 1 for å bli kvitt buffer-listen. + +Hvis du gjør forandringer i en av filene og åpner en ny fil så vil ikke +den første filen bli lagret, men forandringene vil fortsatt være i +buffret. Oppretting eller redigering av en ny fil vil ikke påvirke den +første filens buffer. Dette er nyttig, men betyr også at du trenger +en passende måte å lagre den første filens buffer. Det vil bli alt +for omstendig å skifte tilbake til det forrige buffret med C-x C-f for +så å lagre filen med C-x C-s. Derfor har vi kommandoen + + C-x s Lagre noen buffer + +C-x s spør for hvert enkelt buffer som har blitt forandret siden +forrige lagring om du ønsker å lagre dette. + +>> Sett inn en linje med tekst og lagre med C-x s + Du skal nå få et spørsmål om du ønsker å lagre buffret + TUTORIAL.no. Svar ja på spørsmålet ved å taste "y" (yes). + + +* BRUK AV MENYEN +---------------- + +Hvis du bruker en X-terminal vil du sikkert legge merke til menyen på +toppen av skjermbildet. Via denne menyen får du tilgang til de mest +brukte Emacs-kommandoene, slik som "find file". Dette er svært enkelt +i begynnelsen, når du ikke husker alle tastetrykkene som skal til for +hver av kommandoene. Men når du begynner å kjenne Emacs vil det være +lettere å begynne å bruke tastekombinasjonene. Disse står rett ved +siden av menynavnet i menyen. + +Legg merke til at det er mange menypunkter som ikke har en eksakt +tastekombinasjon. For eksempel "Buffers"-menyen, som lister ut alle +tilgjengelige buffre sortert i "sist brukt"-rekkefølge. Du kan enkelt +skifte til et buffer ved å finne navnet på det i "Buffers"-menyen og +velge det. + + +* BRUK AV MUSA +--------------- + +Når du kjører Emacs under X er det muligheter for å bruke musen. Du +kan plassere markøren ved å trykke venstre mustast der du ønsker at +den skal være, og du kan markere tekst ved å holde nede venstre +mustast mens du beveger markøren over teksten du ønsker å markere. +(Eller alternativt: klikk venstre mustast i den ene enden av teksten +du ønsker å markere, flytt muspekeren til den andre enden og bruk +Shift-klikk for å markere teksten.) + +For å "kille" den markerte teksten kan du bruke kommandoen C-w eller +velge Cut fra "Edit"-menyen. Legg merke til at disse *ikke* er +likeverdige. C-w lagrer bare teksten internt i Emacs (ala C-k, som +beskrevet ovenfor), mens Cut legger også teksten i X sitt "clipboard", +der den også blir tilgjengelig for andre applikasjoner. + +For å hente tekst fra X-clipboard'et kan du bruke "Paste" fra "Edit"- +menyen. + +Den midterste musknappen blir vanligvis brukt for å velge "linker" som +er tilgjengelig i skjermbildet. Hvis du for eksempel går inn i Info +(on-line dokumentasjonen til Emacs) ved å bruke C-h i, eller "Help"- +menyen, kan du følge linkene ved å trykke den midterste musknappen. +Og hvis du skriver inn et filnavn (For eksempel "Find File"), og +trykker TAB for å få fram en fillisting, så kan du komplettere filnavnet +ved å trykke den midterste musknappen på filnavnet. + +Ved å trykke høyre musknapp vil du få fram en popup-meny. Innholdet i +denne menyen er avhengig av hvilken modus du er inne i, og vanligvis +inneholder den et par av de mest brukte kommandoene slik at de blir +lett tilgjengelige. + +>> Trykk høyre mustast nå. + +Du er nødt til å holde knappen nede for at menyen skal vises. + + +* UTVIDING AV KOMMANDOSETTET +---------------------------- + +Det finnes mange flere Emacs-kommandoer enn det som er mulig å tilegne +control- eller meta-taster. For å komme rundt dette har Emacs en "X"- +(eXtend) kommando. Denne kommer i to utgaver: + + C-x Tegn-utvidelse. Etterfulgt av et tegn. + M-x Navngitt kommandoutvidelse. Etterfulgt av et + kommandonavn. + +Dette er kommandoer som er generelt viktige, men som blir brukt mindre +enn de kommandoene du allerede har lært. Du har allerede sett to av +dem, C-x C-f for Find, og C-x C-x for Save. Et annet eksempel er +kommandoen for å avslutte Emacs, som har kommandoen C-x C-c. (Ikke +vær redd for å miste eventuelle forandringer du har gjort, C-x C-c vil +sørge for at du får lagret de forandringene du ønsker før Emacs +avslutter.) + +C-z er kommandoen for å avslutte Emacs *midlertidig* slik at du kan +vende tilbake til samme Emacs senere. + +På systemer som tillater det vil C-z suspendere Emacs, dvs. returnere +tilbake til skallet uten å drepe Emacs-prosessen. I de fleste +skallene kan du få tilbake Emacs med kommandoen `fg', eller `%xemacs'. + +På systemer som ikke har implementert denne egenskapen vil C-z +opprette et skall som kjører under Emacs, og som gir deg sjansen til å +kjøre andre programmer og så returnere til Emacs etterpå. Den gir ingen +eksakt avslutning av Emacs. I slike tilfeller vil vanligvis +kommandoen `exit' returnere fra skallet og tilbake til Emacs. + +C-x C-c benyttes når du skal avslutte Emacs. Det er også fornuftig å +avslutte Emacs hvis den har blitt startet opp av et mail-program, +eller andre applikasjoner, siden det ikke er sikkert at de greier å +håndtere suspendering av Emacs. Under normale omstendigheter, hvis du +ikke har tenkt å logge ut, er det bedre å suspendere Emacs med C-z +isteden for å avslutte. + +Det finnes mange C-x kommandoer. Her er en liste over dem du har +lært: + + C-x C-f Finne fil. + C-x C-s Lagre fil. + C-x C-b Utlisting av buffrene. + C-x C-c Avslutte Emacs. + C-x u Angre. + +Navngitte kommandoer er kommandoer som blir brukt mye sjeldnere, eller +kommandoer som bare brukes i bestemte modus. Et eksempel på en slik +kommando er "replace-string", som globalt erstatter en tekststreng med +en annen. Når du taster M-x vil Emacs komme med en prompt nederst i +skjermbildet der du skal skrive inn kommandoen du ønsker å kjøre, i +dette tilfellet "replace-string". Det er bare å skrive "repl s<TAB>", +Emacs vil da fullføre kommandonavnet. Avslutt kommandoen med +<Return>. + +Kommandoen "replace-string" krever to argumenter, tekststrengen som +skal erstattes og tekststrengen som denne skal erstattes med. Du må +avslutte begge argumentene med <Return>. + +>> Flytt markøren til den blanke linjen to linjer under denne. + Trykk M-x repl s<Return>forandret<Return>endret<Return>. + + Legg merke til hvordan denne linjen har blitt forandret, du har + erstattet ordet f-o-r-a-n-d-r-e-t med "endret" alle plassene der + ordet "forandret" forekommer, etter markørpossisjonen. + + +* AUTOMATISK LAGRING +-------------------- + +Når du har gjort forandringer i en fil, men ikke lagret den, vil det +gå tapt hvis maskinen krasjer. Som en beskyttelse mot dette vil Emacs +periodisk lagre en "autosave"-fil for hver av filene du redigerer. +Denne filen har en # i begynnelsen og slutten av filnavnet. Hvis du +for eksempel har en fil med navnet "hallo.c" så vil navnet på +"autosave"-filen bli "#hallo.c#". Når du lagrer filen på vanlig måte +vil Emacs slette unna "autosave"-filen. + +Hvis maskinen krasjer kan du gjenvinne "autosave"-filene ved å +finne filen på vanlig måte (filen du redigerte på, ikke "auto-save"- +filen) og trykke M-x recover file<Return>. Når Emacs vil ha +bekreftelse svarer du yes<Return> for å gjenvinne "autosave"-filen. + + +* ECHO-OMRÅDE +------------- + +Hvis Emacs ser at du skriver kommandoene langsomt så vil den vise dem på +den nederste linjen i skjermbildet i et område som blir kalt "echo +area". Dette området inneholder den nederste linjen i skjermbildet. + + +* MODUSLINJEN +------------- + +Linjen like over echoområdet blir kalt "moduslinje". Denne ser +omtrent slik ut: + +--**-XEmacs: TUTORIAL.no (Fundamental)--L773--68%-------- + +Denne linjen inneholder nyttig informasjon over statusen til Emacs og +teksten du redigerer på. + +Du vet allerede hva filnavnet betyr, det er den filen du har funnet. +-NN%-- forteller den aktuelle posisjonen i teksten, dvs. NN prosent av +teksten befinner seg over toppen av skjermbildet. Hvis toppen av +filen er i skjermbildet vil det stå --Top-- isteden for --00%--, og +hvis slutten av filen er i skjermbildet vil det stå --Bot--. Hvis du +ser på en fil der hele teksten passer inn på en side vil det stå +--All--. + +Stjernene i begynnelsen av linjen forteller at det er blitt foretatt +endringer i filen siden den sist ble lagret. Når du nettopp har åpnet +en fil vil det ikke stå noe her, bare minustegn. + +Den delen av moduslinjen som står inne i parenteser forteller hvilken +redigeringsmodus du bruker. Standardmodusen er "Fundamental", som er +den du bruker nå. Det er et eksempel på en "hovedmodus". + +Emacs har mange forskjellige hovedmoduser. Noen av dem er tiltenkt +redigering av forskjellige programmeringsspråk og/eller typer tekst, +for eksempel Lisp mode, Text mode, ol. Det kan bare være en +hovedmodus om gangen, og modusnavnet vil alltid stå der det står +Fundamental nå. + +Hver hovedmodus gjør at endel kommandoer oppfører seg annerledes. +Det finnes for eksempel kommandoer for å sette inn kommentarer i +programkode, og siden hvert programmeringsspråk har forskjellige måter +å angi kommentarer på må de ulike hovedmodusene sette inn disse +kommentarene på forskjellige måter. Hver hovedmodus har en kommando +som brukes for å skifte til denne modusen på. For eksempel M-x +fundamental-mode er kommandoen for å skifte til Fundamental mode. + +Hvis du skal redigere engelsk (eller norsk) tekst, slik som denne +filen, bør du bruke "Text Mode". + +>> Tast M-x text-mode<Return>. + +Ingen av kommandoene du har lært hittil vil forandre Emacs i noe +særlig grad. Men du kan legge merke til at M-f og M-b nå behandler +apostrofer som en del av ordet. Tidligere, i Fundamental mode, +behandlet M-f og M-b apostrofene som ordskillere. + +Hver hovedmodus gjør vanligvis små forandringer slik som denne, og de +fleste kommandoene gjør det samme i hver hovedmodus, de fungerer bare +litt annerledes. + +For å få fram dokumentasjonen på den hovedmodusen du er inne i nå kan +du trykke C-h m. + +>> Bruk C-u C-v slik at denne linjen kommer nær toppen av + skjermbildet. +>> Trykk C-h m, og se hvordan Text mode er forskjellig fra Fundamental + mode. +>> Trykk q for å fjerne dokumentasjonen fra skjermbildet. + +Hovedmodus blir kalt hovedmodus fordi det også finnes bimodus. +Bimodus er ikke alternativer til hovedmodus, men de modifiserer dem. +Hver bimodus kan bli slått av og på uavhenging av andre bimoduser, og +uavhengig av hovedmodus. Derfor kan du bruke ingen bimodus, en +bimodus, eller en kombinasjon av flere bimoduser. + +En bimodus som er nyttig, spesielt ved redigering av tekst, er "Auto +Fill mode". Når denne er slått på vil Emacs dele linjene automatisk +hvis linjen blir for lang for å passe inn på ett skjermbilde. + +Du kan slå på Auto Fill mode ved å utføre en M-x +auto-fill-mode<Return>. Når denne modusen er på kan du slå den av +igjen ved å utføre en ny M-x auto-fill-mode<Return>. Denne +kommandoen bytter mellom av og på, også kalt "toggle the mode". + +>> Trykk M-x auto-fill-mode<Return> nå. Skriv så inn en linje med + "aoeu " inntil linjen deler seg. Du er nødt til å putte inn + ordskillere, fordi Auto Fill bare brekker linjen ved ordskillere. + +Margen er vanligvis satt til 70 tegn, men du kan endre dette ved å +bruke kommandoen C-x f. Antall tegn blir gitt til kommandoen gjennom +et numerisk argument. + +>> Tast C-x f med et argument på 20. (C-u 20 C-x f). Skriv så inn + noe tekst og legg merke til at Emacs bryter linjer som er lengre + enn 20 tegn. Sett margen tilbake til 70 tegn igjen, ved å bruke + C-x f en gang til. + +Hvis du gjør forandringer midt i en linje så vil ikke Auto Fill mode +kunne reformatere linjene for deg. For å gjøre dette kan du taste M-q +(Meta-q) med markøren inne i det avsnittet du ønsker å reformatere. + +>> Flytt markøren inn i forrige avsnitt og trykk M-q. + + +* SØKING +-------- + +Emacs kan utføre søk etter tekststrenger (grupper med sammenhengende +bokstaver eller ord) enten framover eller bakover i teksten. Når du +søker etter tekst vil markøren flytte seg til den neste plassen der +tekststrengen opptrer. + +Søkemetoden til Emacs er litt forskjellig fra andre søkemetoder +implementert i de fleste andre redigeringsprogrammer på den måten at +den er inkrementell. Dette betyr at søket foregår mens du taster +inn tekststrengen du skal søke etter. + +Kommandoen for å innlede et søk er C-s for å søke framover, og C-r for +å søke bakover. MEN VENT! Ikke prøv dem enda. + +Når du taster C-s vil du legge merke til at teksten "I-search" dukker +opp i echoområdet. Dette forteller deg at Emacs er inne i det som +kalles inkrementellt søk, og venter på at du skal skrive inn det du +leter etter. <Return> avslutter søket. + +>> Trykk nå C-s for å starte et søk. Skriv så, en bokstav om gangen, + ordet 'markør', og legg inn en pause etter hver gang du skriver en + bokstav slik at du får med deg hva som skjer med markøren. + Nå har du søkt etter ordet "markør" en gang. +>> Tast C-s en gang til for å søke etter neste forekomst av ordet + "markør". +>> Trykk nå <Delete> fire ganger og se hvordan markøren beveger seg +>> Trykk <Return> for å avslutte søket. + +La du merke til hva som skjedde? I inkrementell søk prøver Emacs å gå +til den forekomsten av teksten som du har skrevet så langt, og uthever +det slik at du ser hvor den er. For å gå til neste forekomst av ordet +'markør' er det bare å taste C-s en gang til. Hvis det ikke er flere +forekomster vil Emacs komme med et pip og en melding om at søket +midlertidig har feilet. C-g vil også avbryte søket. + +NB: På noen systemer vil C-s føre til at skjermen "fryses" og du +vil ikke være istand til å utføre noen flere kommandoer. Dette +indikerer at en operativsystem-egenskap kalt "flytkontroll" har +fanget opp C-s'en og ikke sendt den videre til Emacs. For å fortsette +må trykke C-q. Se da i avsnittet "Spontaneous Entry to Incremental +Search" i Emacs-manualen for råd om hvordan dette kan avverges. + +Hvis du er inne i et inkrementellt søk og trykker <Delete> vil du legge +merke til at den siste bokstaven i søkestrengen blir slettet og søket +hopper tilbake til den forrige forekomsten fra søket. Hvis du for +eksempel taster "m" for å søke etter den første forekomsten av "m", og +så trykker "a" så vil markøren bevege seg til første forekomst av "ma". +Trykk nå <Delete>. Dette fjerner "a" fra søkestrengen, og markøren +beveger seg tilbake til den første forekomsten av "m". + +Hvis du er midt i et søk og trykker en control- eller meta-kombinasjon +(med et par unntak: tegn som blir brukt under søkingen, slik som C-s +og C-r), vil søket avbrytes. + +C-s starter et søk som leter etter enhver forekomst av søkestrengen +ETTER markørposisjonen. Hvis du skal søke etter en streng tidligere +i teksten må du bruke C-r. Alt vi har fortalt om C-s fungerer også +for C-r, bortsett fra at retningen på søket er i motsatt retning. + + +* FLERE VINDUER +--------------- + +En av egenskapene til Emacs er at du kan vise flere en et buffer på +skjermen samtidig. + +>> Flytt markøren til denne linjen og trykk C-u 0 C-l + +>> Tast nå C-x 2, som vil føre til at skjermen deles i to vinduer. + Begge vinduene viser denne veiledningen. Markøren står i det + øverste vinduet. + +>> Tast C-M-v for å "scrolle" det nederste vinduet. + (Hvis du ikke har Meta-tasten trykker du ESC C-v.) + +>> Tast C-x o ("o" for "other") for å flytte markøren til det + nederste vinduet. + +>> Bruk C-v og M-v i det nederste vinduet for å flytte deg opp og ned + i teksten. Fortsett å les denne anvisningen i det øverste vinduet. + +>> Tast C-x o igjen for å flytte markøren tilbake til det øverste + vinduet. Markøren i det øverste vinduet står på samme plass som + det gjorde før du forlot det. + +Du kan fortsette å bruke C-x o for å bytte mellom de to vinduene. +Hvert av vinduene har sin egen plassering av markøren, men det er bare +ett av vinduene som viser den. Alle redigeringskommandoer fungerer på +det vinduet markøren er synlig i. Vi kaller dette vinduet det valgte +vinduet, eller "selected window". + +Kommandoen C-M-v er nyttig når du redigerer tekst i et vindu og bruker +det andre vinduet for referanser. Da kan du kan ha markøren i det +samme vinduet hele tiden og du kan bruke C-M-v for å flytte deg i det +andre vinduet. + +C-M-v er et eksempel på en CONTROL-META-kombinasjon. Hvis du har +META-tast holder du både CTRL og META nedtrykt mens du trykker v. +Det er ikke nøye hvilken av tastene CTRL og META som trykkes først, +fordi begge fungerer slik at de "modifiserer" de andre tastene du +trykker. + +Hvis du ikke har META-tasten, og bruker ESC isteden, er rekkefølgen +viktig. Du må trykke ESC etterfulgt av CTRL-v, CTRL-ESC v vil ikke +fungere. Dette er fordi ESC er et tegn for seg selv, og fungerer ikke +som "modifikator". + +>> Tast C-x 1 (i det øverste vinduet) for å bli kvitt det nederste + vinduet. + +(Hvis du hadde tastet C-x 1 i det nederste vinduet ville det øverste +forsvunnet. Tenk på denne kommandoen som "Behold bare et vindu, det +som markøren står i.") + +Du er ikke nødt til å ha samme buffer i begge vinduene. Du kan bruke +C-x C-f for å finne en ny fil i et av vinduene, det andre vinduet +forblir uforandret. Du vil merke at vinduene er helt uavhengige. + +Her er en annen måte å bruke to vinduer til å vise to forskjellige +filer: + +>> Tast C-x 4 C-f etterfulgt av et filnavn. Avslutt med <Return>. + Den nye filen vil da dukke opp i det nederste vinduet. Markøren + blir også flyttet dit. + +>> Tast C-x o for å gå tilbake til det øverste vinduet, og C-x 1 for å + bli kvitt det nederste igjen. + + +* REKURSIVE REDIGERINGSNIVÅER +----------------------------- + +Noen ganger kommer du inn i noe som blir kalt "recursive editing +level". Dette blir indikert med hakeparenteser i moduslinjen, og vil +omringe parentesene rundt hovedmodusen. For eksempel vil det da stå +[(Fundamental)] istedenfor (Fundamental). + +For å komme ut av "recursive editing mode" trykker du ESC ESC ESC. +Dette er en generell "kom seg ut" kommando. Du kan også bruke den for +å bli kvitt ekstra vinduer og for å komme deg ut av minibuffret. + +>> Tast M-x for å komme inn i minibuffren. Tast så ESC ESC ESC for å + komme ut. + +Du kan ikke bruke C-g for å komme ut av "recursive editing mode". +Dette er fordi C-g blir brukt for å avbryte kommandoer og argumenter +INNENFOR "recursive editing level". + + +* HVORDAN FINNE MERE HJELP +-------------------------- + +I denne veiledningen har vi prøvd å inkludere akkurat nok informasjon +til at du kan begynne å bruke Emacs. Det er så mange muligheter i +Emacs at det ville vært umulig å forklare her. Men du ønsker sikkert +å lære mer om Emacs siden den har mange nyttige egenskaper. Emacs +tilbyr kommandoer for å lese dokumentasjonen om Emacs-kommandoer. +Disse "hjelp"-kommandoene starter med tastekombinasjonen Control-h, +som blir kalt "the Help character". + +For å bruke denne hjelpen taster du C-h etterfulgt av et tegn som +forklarer hva du vil ha hjelp om. Hvis du virkelig har rotet deg bort +kan du taste C-h ? for at Emacs skal vise hvilken hjelp som er +tilgjengelig. Hvis du har tastet C-h og bestemmer deg for at du ikke +vil ha noen hjelp så kan du taste C-g for å avbryte. + +(På noen servere er C-h rekonfigurert. Dette skal vanligvis ikke +gjøres, og hvis det er det så klag til systemadministratoren. Imens +kan du bruke M-x help<Return> istedenfor.) + +Den mest grunnleggende hjelp-funksjonen er C-h c. Tast C-h, en "c" og +en kommandosekvens. Emacs vil da komme med en beskrivelse av denne +kommandoen. + +>> Tast C-h c Control-p. + Meldingen skal da bli noe slik som + + C-p runs the command previous-line + +Dette forteller navnet til funksjonen. Funksjonsnavn blir stort sett +brukt for å spesialtilpasse og utvide Emacs. Men siden +funksjonsnavnet er valgt for å indikere hvilken kommando den utfører +kan de også fungere som en enkel dokumentasjon, nok for å minne deg på +kommandoer du allerede har lært. + +Flertegnskommandoer, slik som C-x C-s og (hvis du ikke har META, EDIT +eller ALT tast) <ESC>v, er også tillatt etter C-h c. + +For å få mere informasjon om en kommando kan du bruke C-h k isteden +for C-h c. + +>> Tast C-h k Control-p. + +Dette vil komme med en dokumentasjon på funksjonen og navnet i et eget +vindu. For å avslutte hjelpvinduet kan du trykke q. + +Her er flere nyttige C-h opsjoner: + + C-h f Beskrive en funksjon. Du skriver inn funksjonsnavnet. + +>> Prøv å tast C-h f previous-line<Return>. + Dette vil skrive ut informasjonen Emacs har om funksjonen som + implementerer C-p kommandoen. + + C-h a Apropos. Vil liste ut alle funksjoner og variabler + som søkestrengen angir. Kommandoer som kan bli utført + med Meta-x blir markert med en stjerne (*) til venstre + for funksjonsnavnet. + +>> Tast C-h a newline<Return>. + +Dette vil få fram en liste over alle funksjoner og variabler der +"newline" inngår i navnet. Du kan trykke <Return> eller klikk den +midterste musknappen for å finne ut mere om en funksjon eller +variabel. Trykk `q' for å avslutte. + + +* TIL SLUTT +----------- + +Husk at C-x C-c vil avslutte Emacs permanent. For å gå midlertidig +til et skall, slik at du senere kan komme tilbake igjen, bruker du C-z. +(Under X vil dette minimere Emacs.) + +Denne veiledningen er laget for at den skal være forståelig for nye +brukere, så hvis det er noe som er uklart holder det ikke å synes synd +på seg selv: send en mail og klag! + + +KOPIERING / DISTRIBUSJON +------------------------ + +Denne veiledningen stammer fra en hel rekke Emacs-veiledninger, og den +første ble skrevet av Stuart Cracraft for den originale Emacs. Ben +Wing oppdaterte veiledningen for X Windows. Martin Buchholz og Hrvoje +Niksic la til endringer for XEmacs, og Stig Bjørlykke oversatte den +til norsk. + + +This version of the tutorial, like GNU Emacs, is copyrighted, and +comes with permission to distribute copies on certain conditions: + +Copyright (c) 1997, Stig Bjørlykke. + + Permission is granted to anyone to make or distribute verbatim copies + of this document as received, in any medium, provided that the + copyright notice and permission notice are preserved, + and that the distributor grants the recipient permission + for further redistribution as permitted by this notice. + + Permission is granted to distribute modified versions + of this document, or of portions of it, + under the above conditions, provided also that they + carry prominent notices stating who last altered them. + +The conditions for copying Emacs itself are more complex, but in the +same spirit. Please read the file COPYING and then do give copies of +GNU Emacs to your friends. Help stamp out software obstructionism +("ownership") by using, writing, and sharing free software!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/TUTORIAL.th Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,696 @@ + ============================== + GNUEMACS ,T@RIR0-Uh10;Xh19(B (Mule) ,T`0:Wi1M'05i19(B + ============================== + +,TKARB`K05X1(B: ,T`M!JRC)0:Q1:`0:Wi1M'05i1909Ui1(B 0,T6Y1!`0"U1B90"Vi19b4B0BV14K0EQ1!07Uh10Gh1R(B ",TEM'`0Eh19`EB04U1!0Gh1R`0CU1B90CYi1(B" + ,T:CC07Q1407Uh1`0CTh1A05i1904i1GB(B ">>" ,T(P0AU1$S0JQh1'0Gh1R(B 0,T5h1Md;(Pc0Ki17SMPdC(B + + ,Tb4B07Qh1Gd;(B ,T!RC0;i1M9$S0JQh1'c0Ki10!Q1:(B Mule ,T7Sd04i1b4Bc0*i1(B 0,T;Xh1A$M9b7CE(B (0,T;Xh1A07Uh1:9K09i1R0JQ1A0<Q1J(B ,T`0"U1B9d0Gi1(B +0,TGh1R(B CTRL ,TK0CW1M(B CTL) ,TK0CW1M(B 0,T;Xh1A(B META (,Tb4B;!05T1(B ,TKARB06V1'0;Xh1A(B ESC) ,Tc907Uh109Ui1(B ,T`CR(Pc0*i10JQ1-0EQ1!I03l105h1Md;(B +0,T9Ui1(B ,Ta79!RC`0"U1B9`05g1A(B ,Tf(B 0,TGh1R(B CONTROL ,TK0CW1M(B META + +C-<0,T5Q1G0MQ1!IC(B> ,TKARB06V1'(B ,Tc0Ki1!40;Xh1A$M9b7CE0$i1R'd0Gi1(B ,Ta0Ei1G!40;Xh1A(B <0,T5Q1G0MQ1!IC(B> 0,T5Q1GM0Bh1R'`0*h19(B C-f + ,TKARB06V1'(B ,Tc0Ki1!40;Xh1A$M9b7CE0$i1R'd0Gi1(B ,Ta0Ei1G!40;Xh1A(B f +<<Blank lines inserted here by startup of help-with-tutorial>> + >> ,T5M909Ui1"Mc0Ki1EM'!4(B C-v (View Next Screen 0,T4Y1K09i1R05h1Md;(B) 0,T4Y1(B ,T`0>Wh1M`0EWh1M9d;0Mh1R9K09i1R(B + 0,T5h1Md;(B + 0,T5h1M(R!09Ui1`0;g1905i19d;(B 0,T7X1!$0CQi1'07Uh10Mh1R9K09i1RK09Vh1'(B ,Tf(B ,T(:"Mc0Ki17Sc97S9M'`04U1BG0!Q19(B ,T`0>Wh1M`0EWh1M9d;(B + 0,T4Y1K09i1R05h1Md;(B + +ESC <0,T5Q1G0MQ1!IC(B> ,TKARB06V1'(B ,Tc0Ki1!40;Xh1A(B ESC ,Ta0Ei1G;0Eh1MB(B ,TK0EQ1'(R!09Qi190(V1'!40;Xh1A(B <0,T5Q1G0MQ1!IC(B> ,T5RA(B + +,TKARB`K05X1(B: <0,T5Q1G0MQ1!IC(B> ,Td0Ah10Gh1R`0;g1905Q1GcK0-h1K0CW1M05Q1G`0Eg1!(B ,T(Pc0Ki1$GRAKARB`K0AW1M90!Q19`0AWh1M06Y1!c0*i1c9(B + ,T$S0JQh1'(B 0,T6i1RKR!0AU10;Xh1A(B META ,Tc0Ki1!4(B 0,T!g1(PJRARC6c0*i1!RC!4(B M-<0,T5Q1G0MQ1!IC(B> ,Ta79(B + ,T!RC(B ESC <0,T5Q1G0MQ1!IC(B> ,Td04i1(B (0,T$W1Mc0Ki1!40;Xh1A(B META 0,T$i1R'd0Gi1(B ,Ta0Ei1G0(V1'!4(B <0,T5Q1G0MQ1!IC(B>) + +0,T"i1MJS0$Q1-(B: ,T`GER(P`0ET1!c0*i1(B Emacs ,Tc0Ki1!4(B C-x C-c ,TK0CW1Mc9!C03U107Uh10JQh1'(B Emacs ,T(R!(B csh + 0,T!g1JRARC6c0*i1(B suspend (,TK0BX140*Qh1G$CRG(B) ,Td04i1(B ,T!RC(B suspend Emacs ,T7Sd04i1b4B(B + ,T!4(B C-z + + 0,T5h1M(R!09Ui1(B ,T"Mc0Ki10;i1M9$S0JQh1'(B C-v 0,T7X1!(B ,Tf(B ,T$0CQi1'07Uh10Mh1R9(:K09Vh1'K09i1R(B + + ,T@RBc9K09i1R07Uh1a0Ei1G0!Q1:K09i1R06Q14d;(B ,T(P0AU1`09Wi1MKR0+i1S0!Q19M0BYh1:R':CC07Q14(B 0,T7Uh1`0;g19`0*h1909Ui1(B 0,T!g1`0>Wh1Mc0Ki1JRARC60CYi1(B +,Td04i10Gh1R(B ,T`09Wi1MKR07Uh1aJ4'M0BYh109Qi19(B 0,T5h1M`09Wh1M'0!Q19M0BYh1(B + + + 0,T!h1M90MWh19(B ,T(S`0;g19(P05i1M'0CYi10GT108U1!RCbB!0Bi1RB5SaK09h1'd;AR(B ,T@RBc9a0?i1A0"i1M0AY1E`0JU1B0!h1M9(B ,T5RA07Uh1:M!d;(B +,Ta0Ei1G(B 0,T!g10$W1M(B C-v ,Tc0*i1JSK0CQ1:`0EWh1M9d;0"i1R'K09i1R(B 0,T6i1R(P`0EWh1M9!0EQ1:07Uh1`0!h1R(B 0,T!g1c0Ki1!4(B ESC v + + >> ,TEM'c0*i1(B ESC v ,TaEP(B C-v ,T`0>Wh1M`0EWh1M9d;AR04Y1(B 0,TJQ1!JM'JRA$0CQi1'(B + +,TJ0CX1;(B +=== + ,T$S0JQh1'(B ,TJSK0CQ1:`0EWh1M9d;AR07U1EPK09i1R@RBc9a0?i1A0"i1M0AY1E(B 0,T$W1M(B + + C-v ,T`0EWh1M9d;0"i1R'K09i1R(B ,TK09Vh1'K09i1R(M(B + ESC v ,T`0EWh1M9d;0"i1R'K0EQ1'(B ,TK09Vh1'K09i1R(M(B + C-l ,T`0"U1B9K09i1R(McK0Ah1(B ,TaEPc9"3P`04U1BG0!Q19(B 0,T!g1c0Ki1`0EWh1M95SaK09h1'"M'`$M0Cl1`+M0Cl1(B (cursor) + ,Td;M0BYh15C'!ER'(M(B + + >> ,T"Mc0Ki10JQ1'`!504Y10Gh1R(B ,Tc9"3P09Ui1`$M0Cl1`+M0Cl1M0BYh107Uh1dK9(B ,T>0Ci1MA07Qi1'(S0"i1M$GRA07Uh1M0BYh1CM:0"i1R'"M'(B + ,T`$M0Cl1`+M0Cl104i1GB(B ,Ta0Ei1GEM'!4(B C-l 0,T4Y1(B ,T5CG(JM:04Y10Gh1R(B ,T`$M0Cl1`+M0Cl1`0EWh1M9d;M0BYh107Uh1dK9(B + 0,T"i1M$GRA07Uh1M0BYh1CM:0"i1R'`;0EUh1B9d;M0Bh1R'dC(B + +0,TGT108U1bB!0Bi1RB`$M0Cl1`+M0Cl10"Qi190>Wi190R9(B +======================= + + ,T5M909Ui1(B ,T`CR0!g10CYi10GT108U1bB!0Bi1RBd;ARa::07U1EPK09i1Ra0Ei1G(B 0,T5h1Md;(B 0,T!g1AR`0CU1B90CYi10GT108U1bB!0Bi1RBd;07Uh15SaK09h1'c4(B +,T5SaK09h1'K09Vh1'@RBc9K09i1R`04U1BG0!Q19(B 0,T+Vh1'JRARC67Sd04i1KERB0GT108U1(B 0,TGT108U1K09Vh1'0!g10$W1Mc0Ki1c0*i1$S0JQh1'(B ,Td;:CC07Q140!h1M9K09i1R(B +(previous) ,Td;:CC07Q1405h1Md;(B (next) ,Td;04i1R9K09i1R(B (forward) ,Td;04i1R9K0EQ1'(B (backward) ,T$S0JQh1'(B +,T`K0Eh1R09Ui1(B 0,T6Y1!05Qi1'd0Gi107Uh1(B C-p C-n C-f ,TaEP(B C-b ,T5RAES04Q1:(B 0,T+Vh1'(P7Sc0Ki1bB!0Bi1RBd;ARd04i1(B ,Tb4B`07U1B:0!Q1:(B +,T5SaK09h1'0;Q1(0(X10:Q19(B ,TJ0CX1;`0"U1B9`0;g19a<9@R>d04i104Q1'09Ui1(B + + + ,T:CC07Q1407Uh1a0Ei1G(B C-p + : + : + 0,T5Q1G0MQ1!IC04i1R9K0EQ1'(B C-b .... ,T5SaK09h1'`$M0Cl1`+M0Cl10;Q1(0(X10:Q19(B .... 0,T5Q1G0MQ1!IC04i1R9K09i1R(B C-f + : + : + ,T:CC07Q1405h1Md;(B C-n + + + ,T$S0JQh1'`K0Eh1R09Ui1(B ,T`MRAR(R!05Q1G0MQ1!IC05Q1GaC!"M'(B ,T$S0Gh1R(B Previous Next Backward Forward +0,T+Vh1'(P0*h1GBc0Ki1(Sd04i1d0Ah1BR!(B ,T$S0JQh1'`K0Eh1R09Ui1`0;g19$S0JQh1'JSK0CQ1:!RCbB!0Bi1RB0"Qi190>Wi190R9(B 0,T+Vh1'05i1M'c0*i1M0BYh1`JAM(B + + >> ,TEM'!4(B C-n 0,T4Y1KERB(B ,Tf(B ,T$0CQi1'(B ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1AR0BQ1':CC07Q1409Ui1(B (,T:CC07Q1407Uh1!S0EQ1'0Mh1R9(B + ,TM0BYh109Ui1(B) + + >> ,TEM'!4(B C-f 0,T4Y1KERB(B ,Tf(B ,T$0CQi1'(B ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1d;0BQ1'5C'!ER'"M':CC07Q14(B ,Ta0Ei1GEM'(B + ,T!4(B C-p ,T`0EWh1M90"Vi190"i1R':904Y1(B 0,TJQ1'`!504Y104i1GB0Gh1R(B ,T5SaK09h1'"M'`$M0Cl1`+M0Cl1`;0EUh1B9d;M0Bh1R'dC(B + + >> ,TEM'!4(B C-b ,T"3P07Uh1M0BYh107Uh15SaK09h1'K09i1R0JX14"M':CC07Q1404Y1(B 0,TJQ1'`!504Y104i1GB0Gh1R(B ,T`$M0Cl1`+M0Cl1`$0EWh1M9(B + ,Td;M0Bh1R'dC(B ,T(R!09Qi19c0Ki1!4(B C-b 0,TMU1!JM'JRA$0CQi1'(B ,Ta0Ei1G!4(B C-f ,T`0>Wh1M`0EWh1M9d;0BQ1'07i1RB0JX14(B + ,T"M':CC07Q1404Y1(B ,T`$M0Cl1`+M0Cl1(P`0;g19M0Bh1R'dC(B 0,T6i1R!4(9`EB07i1RB:CC07Q14d;(B + + + ,T`GER07Uh1`0EWh1M9`$M0Cl1`+M0Cl1(B ,T(9`EB:CC07Q14aC!0JX14K0CW1M:CC07Q1407i1RB0JX14"M'K09i1Rd;(B ,T`$M0Cl1`+M0Cl1(P(B +,T`0EWh1M9d;0BQ1':CC07Q1405h1Md;c907T1H7R'09Qi19(B ,Tf(B ,TaEP;0CQ1:c0Ki1`$M0Cl1`+M0Cl1!0EQ1:ARM0BYh1:9K09i1R(M`JAM(B + + >> ,TEM'!4(B C-n ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1c0Ki1`EB:CC07Q140Eh1R'0JX14"M'K09i1R(M04Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R(B + ,T`0!T14MPdC0"Vi19(B ,TaEP5SaK09h1'"M'`$M0Cl1`+M0Cl1`;0EUh1B9d;M0Bh1R'dC(B + + 0,T6i1R0CYi10JV1!0Gh1R!RC"0BQ1:d;07U1EP05Q1G0MQ1!IC09Qi190MW14MR40BW14BR4(B 0,T!g1JRARC6c0*i1!RC`0EWh1M9`$M0Cl1`+M0Cl1d;07U1EP$S(B +,Td04i1(B ,T!4(B ESC f ,T`0>Wh1Mc0Ki1`0EWh1M9d;0"i1R'K09i1RK09Vh1'$S(B ,TaEP(B ESC b ,T`0>Wh1Mc0Ki1`0EWh1M9d;0"i1R'K0EQ1'K09Vh1'$S(B + +,TKARB`K05X1(B: ,TJSK0CQ1:@RIRd7B(B 0,TBQ1'd0Ah1JRARC6a0:h1'aB!5SaK09h1'"M'$Sd04i106Y1!05i1M'(B 0,T(V1'd0Ah1(B + ,TJRARC6c0*i1JM'$S0JQh1'09Ui1d04i1(B + + >> ,TEM'!4(B ESC f ,TaEP(B ESC b ,TEM'04Y1KERB(B ,Tf(B ,T$0CQi1'(B ,TaEPEM'c0*i10Ch1GA0!Q1:(B C-f 0,T!Q1:(B C-b 0,T4Y1(B + 0,T4i1GB(B + + ,T(P0JQ1'`!5`0Kg19d04i10Gh1R(B ESC f ,TaEP(B ESC b 0,TAU10CY1;a::$0Ei1RB$0EV1'0!Q1:(B C-f ,TaEP(B C-b ,Tb4B0Jh1G9cK0-h1(B +ESC <0,T5Q1G0MQ1!IC(B> ,T(Pc0*i1`0!Uh1BG0!Q1:!RC0(Q14!RC0"i1M$GRA(B 0,TJh1G9(B C-<0,T5Q1G0MQ1!IC(B> ,T(Pc0*i10!Q1:0JTh1'07Uh1`0;g190>Wi190R9AR!(B +,T!0Gh1R(B (,T`0*h19(B 0,T5Q1G0MQ1!IC(B ,TK0CW1M(B ,T:CC07Q14(B) + + C-a 0,T!Q1:(B C-e ,T`0;g19$S0JQh1'09h1R(P0CYi1d0Gi1(B ,T`>CRP0$h1M90"i1R'JP4G!04U107U1`04U1BG(B C-a ,Tc0*i1JSK0CQ1:`0EWh1M9(B +,T`$M0Cl1`+M0Cl1d;07Uh15SaK09h1'K09i1R0JX14"M':CC07Q14(B C-e ,TJSK0CQ1:`0EWh1M9d;07Uh15SaK09h1'07i1RB0JX14"M':CC07Q14(B + + + >> ,TEM'!4(B C-a 0,T4Y1JM'$0CQi1'(B ,TK0EQ1'(R!09Qi19c0Ki1!4(B C-e 0,T4Y1JM'$0CQi1'(B ,Ta0Ei1GEM'0JQ1'`!504Y10Gh1R(B ,T!RC(B + ,T!4$S0JQh1'09Ui1AR!!0Gh1RJM'$0CQi1'(B ,T(Pd0Ah10*h1GBc0Ki1`0EWh1M9`$M0Cl1`+M0Cl1d;dK9d04i1AR!!0Gh1R09Qi190MU1!(B + + 0,TBQ1'0AU10MU1!JM'$S0JQh1'(B ,TJSK0CQ1:!RC`0EWh1M9`$M0Cl1`+M0Cl1a::0'h1RB(B ,Tf(B 0,T$W1M(B ,T$S0JQh1'(B ESC < ,TJSK0CQ1:!RC`0EWh1M9(B +,T`$M0Cl1`+M0Cl1d;07Uh15SaK09h1'aC!0JX14"M'a0?i1A0"i1M0AY1E(B ,TaEP$S0JQh1'(B ESC > ,TJSK0CQ1:!RC`0EWh1M9d;5SaK09h1'07i1RB0JX14(B + + ,T`CR`0CU1B!5SaK09h1'"M'0"i1M$GRA(B 0,T7Uh10AU1`$M0Cl1`+M0Cl1M0BYh10Gh1R(B "0,T(X14(B (point)" ,TK0CW1M0>Y140MU1!M0Bh1R'K09Vh1'd04i1(B +0,TGh1R(B ,T`$M0Cl1`+M0Cl1(B ,T`0;g190JTh1'07Uh1:M!c0Ki1`CR0CYi10Gh1R(B 0,T(X14(B ,TM0BYh15C'dK9"M'K09i1R(M(B + + ,TJ0CX1;$S0JQh1'JSK0CQ1:!RC`$0EWh1M9d;AR(B 0,T+Vh1'CGA!RC`$0EWh1M907Uh1c9K09h1GB"M'$S(B ,TK09h1GB"M':CC07Q14d0Gi104i1GB(B +,Td04i104Q1'09Ui1(B + + C-f ,Td;0"i1R'K09i1RK09Vh1'05Q1G0MQ1!IC(B + C-b ,T!0EQ1:0"i1R'K0EQ1'K09Vh1'05Q1G0MQ1!IC(B + + ESC f ,Td;0"i1R'K09i1RK09Vh1'$S(B + ESC b ,T!0EQ1:0"i1R'K0EQ1'K09Vh1'$S(B + + C-n ,T`0EWh1M9d;:CC07Q1405h1Md;(B + C-p ,T`0EWh1M9d;:CC07Q1407Uh1a0Ei1G(B + + ESC ] ,T`0EWh1M9d;5SaK09h1'07i1RB0JX14"M'0Bh1MK09i1R(B (paragraph) + ESC [ ,T`0EWh1M9d;5SaK09h1'aC!0JX14"M'0Bh1MK09i1R(B + + C-a ,T`0EWh1M9d;5SaK09h1'aC!0JX14"M':CC07Q14(B + C-e ,T`0EWh1M9d;5SaK09h1'07i1RB0JX14"M':CC07Q14(B + + ESC < ,T`0EWh1M9d;5SaK09h1'aC!0JX14"M'a0?i1A0"i1M0AY1E(B + ESC > ,T`0EWh1M9d;5SaK09h1'07i1RB0JX14"M'a0?i1A0"i1M0AY1E(B + + >> ,TEM'c0*i1$S0JQh1'a05h1EP$S0JQh1'04Y1(B ,T$S0JQh1'`K0Eh1R09Ui1`0;g19$S0JQh1'07Uh1c0*i10!Q190:h1MB0JX14(B ,T$S0JQh1'JM'$S0JQh1'K0EQ1'(B + ,T(P`0EWh1M9`$M0Cl1`+M0Cl1(B ,Td;0BQ1'07Uh107Uh10$h1M90"i1R'd!E(B ,Tc0Ki1EM'c0*i1$S0JQh1'(B C-v ,TaEP(B ESC v ,T`0>Wh1M(B + ,T`0EWh1M9`$M0Cl1`+M0Cl1!0EQ1:AR07Uh15C'09Ui1(B + + ,TJSK0CQ1:$S0JQh1'0MWh19(B ,Tf(B ,T"M'(B Emacs 0,T!g1`0*h190!Q19(B ,T$S0JQh1'`K0Eh1R09Ui1(PJRARC6`0>Th1A05Q1G`0EW1M!(B (argument) +,T`0>Wh1M!SK94(B ,T(S9G9$0CQi1'(B ,Tc9!RC;0/T10:Q105T1'R9d04i1(B ,T!RC!SK94(S9G9$0CQi1'(B ,T7Sd04i1b4B!4(B C-u ,Ta0Ei1G5RA(B +0,T4i1GB(S9G9$0CQi1'07Uh105i1M'!RC0!h1M9(B ,Ta0Ei1G0(V1'0$h1MB!4$S0JQh1'5RA(B + + 0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'(B C-u 8 C-f ,TKARB06V1'(B ,Tc0Ki1`0EWh1M9d;0"i1R'K09i1R(B 8 0,T5Q1G0MQ1!IC(B + + >> ,Tc0Ki1EM'!SK94(S9G9$0CQi1'07Uh1`KARPJAJSK0CQ1:$S0JQh1'(B C-n ,TK0CW1M(B C-p ,T`0>Wh1M`0EWh1M9`$M0Cl1`+M0Cl1(B + ,Tc0Ki1ARM0BYh1c!0Ei1:CC07Q1409Ui1c0Ki1AR!07Uh10JX14`07h1R07Uh1(P7Sd04i1(B ,Tc9!RC`0EWh1M9`$M0Cl1`+M0Cl1$0CQi1'`04U1BG(B + + ,TJSK0CQ1:(B C-v ,TaEP(B ESC v ,T(Pd04i1<Ea5!05h1R'd;0JQ1!`0Eg1!09i1MB(B ,Tc9!C03U109Ui1(B ,T(P`0;g19!RC`0EWh1M9K09i1R(M(B +0,T"Vi19E'(B ,T5RA(S9G9:CC07Q14a79(B + + >> ,TEM'!4(B C-u 3 C-v 0,T4Y1(B + + ,T`0EWh1M9!0EQ1:07Uh1`0!h1Rd04i1b4B(B C-u 3 ESC v + +,T$S0JQh1'B!`0ET1!(B +========= + + ,T$S0JQh1'(B C-g ,Tc0*i1JSK0CQ1:0JQh1'B!`0ET1!$S0JQh1'05h1R'(B ,Tf(B 0,T7Uh105i1M'!RC!RC0;i1M90"i1M0AY1E`0>Th1A`05T1A(B 0,T5Q1GM0Bh1R'`0*h19(B +,TCPK0Gh1R'07Uh1c0Jh105Q1G`0EW1M!(B (argument) ,TM0BYh1(B ,TK0CW1MCPK0Gh1R'$S0JQh1'07Uh105i1M'!RC!40;Xh1AAR!!0Gh1R(B 2 0,T;Xh1A0"Vi19d;(B 0,T6i1R(B +,TKR!05i1M'!RCB!`0ET1!(B 0,T!g1c0Ki1!4(B C-g + + >> ,TEM'!SK94(S9G9$0CQi1'c0Ki1`0;g19(B 100 ,Tb4B!RC!4(B C-u 100 ,Ta0Ei1G!4(B C-g 0,T4Y1(B ,TK0EQ1'(R!09Qi19(B + ,Tc0Ki1EM'!4(B C-f 0,T4Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R`$M0Cl1`+M0Cl1`0EWh1M9d;0!Uh105Q1G0MQ1!IC(B ,TK0CW1M5M907Uh1>ER4d;!4(B + ESC ,Tb4Bd0Ah105Qi1'c((B 0,T!g1JRARC6!4(B C-g ,TB!`0ET1!d04i1(B + +0,T"i1M0<T14>ER4(B (Error) +================ + + ,Tc9:R'$0CQi1'(B ,TMR((P0AU1!RC0JQh1';0/T10:Q105T1'R9:R'M0Bh1R'(B 0,T7Uh1(B Emacs ,TBMA0CQ1:d0Ah1d04i1`0!T140"Vi19(B 0,T5Q1GM0Bh1R'`0*h19(B +,T!RC!4$S0JQh1'$M9b7CE:R'$S0JQh1'(B 0,T7Uh1d0Ah1d04i1!SK94d0Gi1c9(B Emacs 0,T!g1(P7Sc0Ki1(B Emacs 0,TJh1'`0JU1B'`05W1M9(B +,TaEPaJ4'<E07Uh1:CC07Q140Eh1R'0JX14"M'(M(B ,T:M!0Gh1R0<T14>ER4M0Bh1R'dC(B + + ,T$S0JQh1':R'$S0JQh1'07Uh1`0"U1B9d0Gi1c9`M!JRC)0:Q1:09Ui1(B ,TMR(c0*i1d0Ah1d04i10!Q1:(B Emacs ,T:R'0CXh19(B (version) 0,T+Vh1'(P(B +,T7Sc0Ki10AU1!RCaJ4'<E0"i1M0<T14>ER4(B (error) 0,T"Vi19(B ,Tc9!C03U109Ui1(B ,T"Mc0Ki1!40;Xh1AMPdC0!g1d04i1(B ,T`0>Wh1M`0EWh1M9d;0BQ1'0Jh1G9(B +0,T5h1Md;(B + +0,TGT19b40Gl1(B (Window) +============== + + Emacs ,TJRARC6`0;T140GT19b40Gl1d04i1>0Ci1MA0!Q19KERB0GT19b40Gl1(B ,TaEPc0*i10GT19b40Gl1`K0Eh1R09Qi19aJ4'<E0"i1M$GRA(B +0,T5h1R'(B ,Tf(B ,T5RA05i1M'!RCd04i1(B 0,T!h1M90MWh19(B 0,T!g1$GC(P7S$GRA0CYi10(Q1!0!Q1:$S0JQh1'(B 0,T7Uh1c0*i1JSK0CQ1:!RCE:0GT19b40Gl10Jh1G9`0!T19(B +,Tc9`GER07Uh1aJ4'<E0EQ1>08l1"M'$S0JQh1':R'$S0JQh1'(B ,TK0CW1M(B Help ,TMM!`0JU1B0!h1M9(B + + C-x 1 ,T7Sc0Ki1`0;g190GT19b40Gl1`04U1BG(B + + ,T$S0JQh1'(B C-x 1 ,Tc0*i1JSK0CQ1:E:0GT19b40Gl10MWh19(B ,Ta0Ei1G"BRB0GT19b40Gl107Uh10AU1`$M0Cl1`+M0Cl1M0BYh1(B ,Tc0Ki1`05g1A(M`0;g19(B +0,TGT19b40Gl1`04U1BG(B + + >> ,Tc0Ki1`0EWh1M9`$M0Cl1`+M0Cl1AR07Uh1:CC07Q1409Ui1(B ,Ta0Ei1G!4(B C-u 0 C-l + + >> ,TEM'!4(B C-h k C-f 0,T4Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R0GT19b40Gl109Ui1`;0EUh1B9d;M0Bh1R'dC(B ,T`0AWh1M0AU10GT19b40Gl1cK0Ah10+Vh1'(B + ,TM08T1:RB0GT108U1c0*i1$S0JQh1'(B C-f ,T;CR!/0"Vi19(B + + >> ,TEM'!4(B C-x 1 ,T`0>Wh1ME:0GT19b40Gl107Uh1b<0Eh10"Vi19ARcK0Ah1(B ,TMM!(B + +,T!RCa7C!(B (insert) ,TaEP(B ,T!RCE:(B (delete) +=================================== + + ,T:9(B Emacs ,T`CR(PJRARC60>T1A0>l105Q1G0MQ1!IC`0"i1Rd;d04i1`EB(B ,T`0AWh1M05i1M'!RC0>T1A0>l10"i1M$GRA(B Emacs ,T(P(B +0,T6W1M0Gh1R05Q1GK09Q1'0JW1M07Uh1AM'`0Kg19d04i107X1!05Q1G(B (,T`0*h19(B 'A' '7' '*' ',T!(B' ,TaEP0MWh19(B ,Tf(B) ,T`0;g190"i1M$GRA07Uh105i1M'!RC(P(B +,Ta7C!(B (insert) ,T`0"i1Rd;5C'(B ,Tf(B ,T`0AWh1M(P(::CC07Q14(B ,Tc0Ki1!4(B <Return> ,T`0>Wh1M`05T1A0MQ1!IC0"Vi19:CC07Q14cK0Ah1(B +(linefeed character) ,Ta7C!`0"i1Rd;(B + + ,Tc0Ki1!4(B <Delete> ,T`0AWh1M05i1M'!RC(PE:05Q1G0MQ1!IC07Uh1`0>Th1'0>T1A0>l1`0"i1Rd;(B <Delete> ,TKARB06V1'0;Xh1A`0"U1B9(B +,T:90<T1GK09i1Rd0Gi10Gh1R(B "Delete" ,TK0CW1M:R'07U1MR((P`0"U1B9d0Gi1(B "Rubout" 0,T!g1d04i1(B ,Tb4B07Qh1Gd;(B <Delete> +,Tc0*i1JSK0CQ1:E:05Q1G0MQ1!IC07Uh1M0BYh10!h1M9K09i1R5SaK09h1'`$M0Cl1`+M0Cl10;Q1(0(X10:Q19(B + + >> ,TEM'0>T1A0>l105Q1G0MQ1!IC`0"i1Rd;KERB(B ,Tf(B 0,T5Q1G(B ,Ta0Ei1Gc0*i1(B <Delete> ,TE:05Q1G0MQ1!IC`K0Eh1R09Qi1907Ti1'(B + + >> ,TEM'0>T1A0>l10"i1M$GRAE'd;c0Ki1`0!T19"M:"GR(B (right margin) ,T`GER07Uh10>T1A0>l10"i1M$GRA`0"i1Rd;(B + ,TBRG`0!T19$GRA!0Gi1R'"M'K09Vh1':CC07Q14(B ,T:CC07Q1409Qi190!g1(P(B "0,T6Y1!05h1M(B" ,Tc0Ki1BRG`0!T19K09Vh1'K09i1R(M(B + ,Tb4Bc0Jh1`$0CWh1M'KARB(B '\' ,Td0Gi107Uh1"M:"GR0JX14(B ,T`0>Wh1M:M!c0Ki10CYi10Gh1R:CC07Q1409Ui10BQ1'0AU105h1M(B Emacs ,T(P(B + ,T`0EWh1M9(B (scroll) ,TK09i1R(M`0>Wh1Mc0Ki1`0Kg195SaK09h1'07Uh1!S0EQ1'a0!i1d"M0BYh1d04i1M0Bh1R'0*Q14`(9(B 0,T6i1RKR!(B + ,T"M:"GRK0CW1M"M:0+i1RB"M'0AU1`$0CWh1M'KARB(B '\' ,TM0BYh1(B 0,T!g1`0;g19!RC:M!c0Ki10CYi10Gh1R(B ,T:CC07Q1409Qi190BQ1'0AU105h1M(B + ,Td;c907T1H7R'09Qi19(B ,Tf(B + + ,TEM';0/T10:Q105T104Y1`EB(B ,T$'(P0*h1GBc0Ki1`0"i1Rc(0'h1RB!0Gh1R!RCM08T1:RB04i1GB05Q1GK09Q1'0JW1M(B + + >> ,Tc0Ki1"0BQ1:`$M0Cl1`+M0Cl1d;d0Gi1:9:CC07Q140+Vh1'06Y1!05h1Mc0Ki1BRG`0!T19K09Vh1'K09i1R(M(B 0,T7Uh1`0>Th1'0;i1M9`0"i1Rd;`0AWh1M(B + 0,TJQ1!$0CYh109Ui1(B ,Ta0Ei1Gc0*i1(B C-d ,TE:0"i1M$GRAMM!:R'0Jh1G9(B ,T(9$GRABRG"M'0"i1M$GRAM0BYh1@RBc9K09Vh1'(B + ,T:CC07Q14(B 0,TJQ1'`!504Y10Gh1R`$0CWh1M'KARB(B '\' ,T(PKRBd;(B + + >> ,Tc0Ki1`0EWh1M9`$M0Cl1`+M0Cl1d;d0Gi107Uh15SaK09h1'aC!0JX14"M':CC07Q14(B ,Ta0Ei1G!4(B <Delete> 0,T4Y1(B ,T!RC7S(B + ,Ta::09Ui1(B ,T(P7Sc0Ki10JQ1-0EQ1!I03l10$Qh19CPK0Gh1R':CC07Q1406Y1!E:MM!d;(B ,T:CC07Q1409Qi190!g1(P06Y1!`MRd;05h1M0!Q1:(B + ,T:CC07Q140!h1M9K09i1R09Qi19(B ,TCGA0!Q19`0;g19:CC07Q14BRG:CC07Q14`04U1BG(B ,TaEPMR((P0AU10JQ1-0EQ1!I03l105h1M:CC07Q14(B + ,T;CR!/0"Vi19(B + + >> ,Tc0Ki1!4(B <Return> ,T`0>Wh1M`0>Th1A(B 0,T5Q1G0MQ1!IC0"Vi19:CC07Q14cK0Ah1(B ,T!0EQ1:d;M0Bh1R'`04T1A(B + + ,T$S0JQh1'0Jh1G9cK0-h1"M'(B Emacs ,T(PJRARC6!SK94(S9G9$0CQi1'07Uh105i1M'!RCc0Ki1;0/T10:Q105T1d04i1(B ,TCGA07Qi1'!RC(B +,Ta7C!(B (insert) 0,T5Q1G0MQ1!IC04i1GB(B + + + >> ,TEM'0;i1M9$S0JQh1'(B C-u 8 * 0,T4Y1(B 0,TJQ1'`!504Y10Gh1R`0!T14MPdC0"Vi19(B + + 0,T6i1R05i1M'!RC(P`0>Th1A:CC07Q140Gh1R'(B ,Tf(B (blank line) ,TCPK0Gh1R'JM':CC07Q14(B ,Tc0Ki1`0EWh1M9d;07Uh15SaK09h1'(B +,TaC!0JX14"M':CC07Q1407Uh1JM'(B ,Ta0Ei1G!4(B C-o + + >> ,Tc0Ki1`0EWh1M9d;07Uh15SaK09h1'aC!0JX14"M':CC07Q14c40!g1d04i1(B ,Ta0Ei1GEM'!4(B C-o 0,T4Y1(B + + 0,T6V1'5C'09Ui1(B ,T`CR0!g1d04i1`0CU1B90GT108U10>Wi190R9JSK0CQ1:!RC0;i1M90"i1M$GRA(B ,TaEP!RCa0!i107Uh10<T14a0Ei1G(B ,T9M!(R!(P(B +,TE:d04i107U1EP05Q1G0MQ1!ICa0Ei1G(B 0,TBQ1'0AU1$S0JQh1'0+Vh1'JRARC6c0*i1E:d04i1c9`0;g19$S(B ,Tf(B ,TK0CW1M`0;g19:CC07Q14(B ,Tf(B 0,TMU1!04i1GB(B ,TJ0CX1;(B +,T$S0JQh1'JSK0CQ1:!RCE:d04i104Q1'09Ui1(B + + <Delete> ,TE:05Q1G0MQ1!IC07Uh1M0BYh1K09i1R`$M0Cl1`+M0Cl1(B + C-d ,TE:05Q1G0MQ1!IC07Uh1M0BYh107Uh1`$M0Cl1`+M0Cl1(B + + ESC <Delete> ,TE:$S07Uh1M0BYh1K09i1R`$M0Cl1`+M0Cl1(B + ESC d ,TE:$S05Qi1'a05h15SaK09h1'07Uh1`$M0Cl1`+M0Cl1M0BYh1(B + + C-k ,TE::CC07Q1405Qi1'a05h15SaK09h1'07Uh1`$M0Cl1`+M0Cl1M0BYh1(B + + ,Tc9:R'$0CQi1'(B ,T`CRMR(05i1M'!RC(P`MR0Jh1G907Uh1E:d;!0EQ1:0$W19AR(B ,Tb;Ca!CA(B Emacs ,T(P(S0Jh1G907Uh1E:(B +,TMM!d0Gi1(B ,T`GER07Uh1E:0"i1M$GRAc9K09h1GB07Uh1AR!!0Gh1RK09Vh1'05Q1G0MQ1!IC(B ,Tc0Ki1c0*i1$S0JQh1'(B C-y ,T`GER07Uh105i1M'!RC(P`MR(B +0,T"i1M$GRA!0EQ1:0$W19(B 0,TJTh1'07Uh1$GCCP0GQ1'0!g10$W1M(B C-y ,Td0Ah1c0*h1c0*i1d04i1`0>U1B'a0$h15SaK09h1'07Uh1E:0"i1M$GRAMM!`07h1R09Qi19(B ,Ta05h1(P(B +,Tc0*i10!Q1:5SaK09h1'c40!g1d04i1(B C-y ,T`0;g19$S0JQh1'JSK0CQ1:a7C!0"i1M$GRA07Uh1`0!g1:d0Gi1(B ,TE'c95SaK09h1'07Uh10AU1`$M0Cl1`+M0Cl1M0BYh1(B +,T`CRJRARC6c0*i1$GRAJRARC609Ui1c9!RC`$0EWh1M90Bi1RB0"i1M$GRAd04i1(B + + ,T$S0JQh1'JSK0CQ1:!RCE:0AU1M0BYh1JM'a::0$W1M(B ,T$S0JQh1'(B "Delete" 0,T!Q1:(B ,T$S0JQh1'(B "Kill" ,T$S0JQh1'(B "Kill" +,T(P`0!g1:0Jh1G9E:MM!d0Gi1(B ,Ta05h1$S0JQh1'(B "Delete" ,T(Pd0Ah1`0!g1:(B ,Ta05h106i1RKR!c0*i1$S0JQh1'09Ui1KERB(B ,Tf(B ,T$0CQi1'(B 0,T!g1(P`0!g1:(B +0,TJh1G907Uh1E:MM!d0Gi1c0Ki1(B + + >> ,Tc0Ki1!4(B C-n 0,TJQ1!JM'JRA$0CQi1'(B ,T`0>Wh1M`0EWh1M9d;0BQ1'07Uh107Uh1`KARPJA:9K09i1R(M(B ,Ta0Ei1GEM'!4(B C-k ,T`0>Wh1M(B + ,TE::CC07Q1409Qi19MM!04Y1(B + + ,T`0AWh1M!4(B C-k ,T$0CQi1'aC!(B 0,T"i1M$GRAc9:CC07Q1409Qi19(P06Y1!E:MM!(B ,TaEP`0AWh1M!40MU1!(B C-k 0,TMU1!$0CQi1'(B ,T:CC07Q14(B +0,T9Qi19`M'07Qi1':CC07Q140!g1(P06Y1!E:MM!d;04i1GB(B ,Ta05h106i1R!SK94(S9G9$0CQi1'c0Ki10!Q1:$S0JQh1'(B C-k 0,T!g1(PKARB06V1'(B ,Tc0Ki1E:(B +,T:CC07Q14MM!(B (0,T7Qi1'`09Wi1MKRaEP05Q1G:CC07Q14(B) ,T`0;g19(S9G9:CC07Q14(B ,T`07h1R0!Q1:(S9G9$0CQi1'07Uh1!SK94(B + + ,T:CC07Q1407Uh1`0>Th1'E:MM!d;(B ,T(P06Y1!`0!g1:d0Gi1(B ,TaEPJRARC69S!0EQ1:0$W19ARd04i1(B ,Tb4Bc0*i1$S0JQh1'(B C-y + + >> ,TEM'!4(B C-y 0,T4Y1(B + + 0,T"i1M$GRA07Uh106Y1!E:MM!(B ,Tb4B!RC!4(B C-k ,TKERB(B ,Tf(B ,T$0CQi1'(B ,T(P06Y1!`0!g1:CG:CGAd0Gi1(B ,TaEPJRARC69S(B +,T!0EQ1:AR07Qi1'KA4d04i1c9$0CQi1'`04U1BG(B ,Tb4B!RC!4(B C-y + + >> ,TEM'!4(B C-k 0,T4Y1KERB(B ,Tf(B ,T$0CQi1'(B + + >> ,T$S0JQh1'JSK0CQ1:`0CU1B!0"i1M$GRA!0EQ1:AR(B 0,T$W1M(B C-y 0,T!h1M90MWh19c0Ki1`0EWh1M9`$M0Cl1`+M0Cl1E'd;0"i1R'0Eh1R'(B + 0,TJQ1!JM'JRA:CC07Q14(B ,Ta0Ei1GEM'!4(B C-y 0,T4Y1(B 0,T!g1(PJRARC60$Q14EM!(B (copy) 0,T"i1M$GRAd04i1(B + + 0,T6i1R5M909Ui1`0!g1:0"i1M$GRAMPdC:R'M0Bh1R'd0Gi1(B ,Ta0Ei1GE:0"i1M$GRA0MWh19`0>Th1A`0"i1Rd;0MU1!(B ,T(P`0!T14MPdC0"Vi19(B +,T<E0EQ1>08l10$W1M(B C-y ,T(P`0CU1B!0$W19d04i1a0$h1`0>U1B'0"i1M$GRA07Uh1E:MM!$0CQi1'0Eh1R0JX14`07h1R09Qi19(B + + + >> ,TEM'E::CC07Q1404Y1K09Vh1':CC07Q14(B ,Ta0Ei1G`0EWh1M9`$M0Cl1`+M0Cl1d;07Uh10MWh19(B ,Ta0Ei1GE::CC07Q14MM!04Y10MU1!K09Vh1'(B + ,T:CC07Q14(B ,TEM'!4(B C-y 0,T4Y1(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R(Pd04i1a0$h1`0>U1B':CC07Q1407Uh1JM'0$W19`07h1R09Qi19(B + +,T!RC0MQ1904Y1(B (UNDO) +============= + + ,T`GER07Uh1a0!i1d"0"i1M$GRA:R'M0Bh1R'(B ,Ta0Ei1G05i1M'!RC(P`;0EUh1B9!0EQ1:c0Ki1`0;g19M0Bh1R'`04T1A(B 0,T!g1JRARC67Sd04i107X1!(B +,T`0AWh1M04i1GB$S0JQh1'(B C-x u ,Tb4B;!05T1(B ,T(Pc0*i1JSK0CQ1:B!`0ET1!$S0JQh1'(B 0,T7Uh10;i1M9`0"i1Rd;b4Bd0Ah105Qi1'c((B ,TJRARC6c0*i1(B +,T$S0JQh1'09Ui10!Uh1$0CQi1'0!g1d04i15RA05i1M'!RC(B + + >> ,TEM'E::CC07Q1409Ui1MM!04Y1(B 0,T4i1GB$S0JQh1'(B C-k ,Ta0Ei1G`0CU1B!!0EQ1:0$W19AR04i1GB(B C-x u + + ,T$S0JQh1'(B C-_ 0,T!g1`0;g19$S0JQh1'0MQ1904Y10MU1!0MQ19K09Vh1'(B ,T$GRAJRARC6`K0AW1M90!Q1:$S0JQh1'(B C-x u + + ,TJRARC6!SK94(S9G9$0CQi1'c0Ki1$S0JQh1'(B C-_ ,TaEP(B C-x u ,Td04i1(B + + +,Ta0?i1A0"i1M0AY1E(B (File) +============== + + ,T`CR(S`0;g1905i1M'`0!g1:0CQ1!IR(B (save) 0,T"i1M$GRA07Uh1a0!i1d"d0Gi1c9a0?i1A0"i1M0AY1E(B 0,T6i1R05i1M'!RC(Pc0Ki10JTh1'07Uh1(B +,Ta0!i1d"`;0EUh1B9d;M0Bh1R'6RGC(B ,Td0Ah1`0*h1909Qi19(B 0,TJTh1'07Uh1a0!i1d"d;0!g1(PKRBd;(B 0,T7Q1907U107Uh1`0ET1!!RCc0*i1(B Emacs + + ,Ta0?i1A0"i1M0AY1E07Uh1AM'`0Kg19M0BYh1(B 0,T$W1M0JTh1'07Uh10:Q1907V1!0JTh1'07Uh1!S0EQ1'a0!i1d"M0BYh1(B ,TK0CW1M0>Y140'h1RB(B ,Tf(B 0,T!g10$W1Ma0?i1A0"i1M0AY1E07Uh1AM'`0Kg19(B +,TM0BYh10$W1M05Q1Ga0?i1A0"i1M0AY1E07Uh1!S0EQ1'a0!i1d"M0BYh1(B + + ,Ta05h1(9!0Gh1Ra0?i1A0"i1M0AY1E(P06Y1!`0!g1:0CQ1!IR(B (save) ,TE'd;(B ,Ta0?i1A0"i1M0AY1E07Uh106Y1!a0!i1d"M0BYh1(B ,T(Pd0Ah106Y1!`0"U1B907Q1:(B +,TE'd;M0Bh1R'`04g14"R4(B 0,TMQ1909Ui1`0>Wh1M`0;g19!RC0;i1M'0!Q19!RC`0"U1B907Q1:a0?i1A0"i1M0AY1E07Uh1a0!i1d"d;a::$0CVh1'(B ,Tf(B ,T!ER'(B ,Tf(B +,Tb4Bd0Ah1d04i105Qi1'c((B + + ,T9M!(R!09Ui1(B ,T`0>Wh1M`0;g19!RC0;i1M'0!Q19!RC`0!g1:0CQ1!IR(B (save) 0,TJTh1'07Uh1a0!i1d"0<T14d;b4Bd0Ah105Qi1'c((B Emacs +,T(P`;0EUh1B90*Wh1Ma0?i1A0"i1M0AY1E05i19)0:Q1:`0!g1:d0Gi1c0Ki1(B 0,T!h1M9!RC`0!g1:0CQ1!IR(B + +,TKARB`K05X1(B: Emacs 0,TBQ1'0AU1!RC0;i1M'0!Q190MX10:Q105T1`K05X107Uh1$R4d0Ah106V1'(B ,Tb4B!RC`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E07Uh1!S0EQ1'(B + ,Ta0!i1d"M0BYh1`0;g19CPBP(B ,Tf(B ,Tb4Bc0*i10*Wh1Ma0?i1A0"i1M0AY1E05h1R'0!Q19(B 0,T4i1GB0GT108U109Ui1(B ,T(P7Sc0Ki1JRARC6E4(B + ,T$GRA`0JU1BKRB07Uh1MR(`0!T140"Vi19d04i1(B ,Tc0Ki109i1MB07Uh10JX14`07h1R07Uh1(P7Sd04i1(B + + ,T5C'0Jh1G90Eh1R'"M'(M(B ,T(P0AU1:CC07Q14bKA4(B (mode line) ,Tc90EQ1!I3P0"i1R'0Eh1R'aJ4'M0BYh1(B + + +(0,T5Q1GM0Bh1R'(B) [--]J:--**-Mule: TUTORIAL.th (Fundamental) ---55%-------------- + + + ,T)0:Q1:JS`9R"M'(B Tutorial ,T"M'(B Emacs 0,T7Uh1!S0EQ1'0Mh1R9M0BYh109Ui10*Wh1M(B TUTORIAL.th ,T`GER07Uh10JQh1'c0Ki1KR(B +,Ta0?i1A0"i1M0AY1EK0CW1M(B find-file (0,T$i19KRa0?i1A0"i1M0AY1E(B ,Ta0Ei1G0Mh1R9`0"i1RARc90:Q1?`?M0Cl1(B) 0,T!g1(PaJ4'0*Wh1Ma0?i1A0"i1M0AY1Ed0Gi1(B +,T5C'0Jh1G9(B TUTORIAL.th 0,T5Q1GM0Bh1R'`0*h19(B 0,T6i1R0JQh1'c0Ki1KRa0?i1A0"i1M0AY1E0*Wh1M(B new-file ,T:CC07Q14bKA40!g1(PaJ4'(B +,T<E0Gh1R(B "Mule: new-file" + +,TKARB`K05X1(B: ,T(P0AU1$SM08T1:RB`0>Th1A`05T1A`0!Uh1BG0!Q1::CC07Q14bKA4(B (mode line) ,Tc95M9K0EQ1'(B + + ,T$S0JQh1'c0Ki1KRa0?i1A0"i1M0AY1E(B ,TaEP$S0JQh1'c0Ki1`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B 0,TAU10EQ1!I3Pa5!05h1R'(R!$S0JQh1'07Uh10<h1R9(B ,Tf(B ,TAR(B +,T5C'07Uh1(B ,T;CP!M:d;04i1GB(B 2 0,T5Q1G0MQ1!IC(B 0,T$W1M05i1M'!4$S0JQh1':R'M0Bh1R'(B ,T5RAK0EQ1'$S0JQh1'(B C-x 0,T+Vh1'KARB06V1'$S0JQh1'(B +,T`0!Uh1BG0!Q1:a0?i1A0"i1M0AY1E(B + + ,TaEP0MU1!0(X14K09Vh1'(B ,Ta05h1a5!05h1R'(R!$S0JQh1'07Uh10<h1R9AR0$W1M(B ,T`GER0JQh1'c0Ki10$i19KRa0?i1A0"i1M0AY1E(B ,T`CR(P06Y1!(B Emacs +,T6RA0*Wh1M"M'a0?i1A0"i1M0AY1E09Qi19(B ,Tf(B ,T`CR`0CU1B!$S0JQh1'`K0Eh1R09Qi190Gh1R(B ,T$S0JQh1';CP`@707Uh16RA05Q1G`0EW1M!(B (argument) +,T(R!`7M0Cl10AT109Q1E(B + +,TKARB`K05X1(B: ,Tc907Uh109Ui1(B 0,T5Q1G`0EW1M!(B (argument) 0,T$W1M0*Wh1Ma0?i1A0"i1M0AY1E(B + + C-x C-f 0,TJQh1'c0Ki1KR(B (find) ,Ta0?i1A0"i1M0AY1E(B + + ,Ta0Ei1G(B Emacs ,T(P6RA0*Wh1M"M'a0?i1A0"i1M0AY1E(B ,Tb4B;CR!/0"Vi1907Uh10Jh1G90Eh1R'"M'(M(B ,T`CR`0CU1B!0Jh1G907Uh1c0Ki10;i1M9(B +0,T*Wh1Ma0?i1A0"i1M0AY1E09Qi190Gh1R(B 0,TAT109T10:Q1?`?M0Cl1(B (mini buffer) 0,TAT109T10:Q1?`?M0Cl1(P06Y1!c0*i1'R9c90EQ1!I3P09Ui1(B 0,TAT109T10:Q1?`?M0Cl1(B +,T(PKA4K09i1R07Uh1aEPKRBd;(B ,TK0EQ1'(R!07Uh10;i1M90*Wh1Ma0?i1A0"i1M0AY1E(B ,Ta0Ei1G!40;Xh1A(B <Return> + + >> ,TEM'!4(B C-x C-f ,Ta0Ei1G5RA04i1GB(B C-g 0,T4Y1(B ,T`0;g19!RC0JQh1'B!`0ET1!`09Wi1MKRc90AT109T10:Q1?`?M0Cl1(B ,TK0CW1M(B + ,TB!`0ET1!$S0JQh1'(B C-x C-f 0,T4Q1'09Qi19(B Emacs ,T(Pd0Ah10$i19KRa0?i1A0"i1M0AY1Ec4(B ,Tf(B + + ,T$CRG09Ui1(B ,TAREM'`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E04Y1(B ,T`GER07Uh105i1M'!RC`0!g1:0CQ1!IR0JTh1'07Uh1a0!i1d"AR(906V1'5M909Ui1(B 0,T!g1c0Ki1c0*i1(B +,T$S0JQh1'04Q1'09Ui1(B + + C-x C-s ,T`0!g1:0CQ1!IR(B (save) ,Ta0?i1A0"i1M0AY1E(B + + ,Ta0Ei1G`09Wi1MKR07Uh1M0BYh1c9(B Emacs 0,T!g1(P06Y1!`0"U1B9E'd;07Uh1a0?i1A0"i1M0AY1E(B ,T`GER`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B ,Ta0?i1A0"i1M0AY1E(B +0,T5i19)0:Q1:(Pd0Ah10JY1-KRBd;(B ,Ta05h1(P06Y1!`0!g1:d0Gi1c90*Wh1McK0Ah1(B 0,T+Vh1'd04i1AR(R!0*Wh1M`0!h1R07Uh105h1M07i1RB04i1GB(B '~' + + ,TK0EQ1'(R!07Uh1`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E`J0Cg1(a0Ei1G(B Emacs 0,T!g1(PaJ4'0*Wh1Ma0?i1A0"i1M0AY1E07Uh1`0!g1:c0Ki104Y1(B + + >> ,TEM'!4(B C-x C-x ,T`0>Wh1M`0!g1:0CQ1!IRJS`9R"M'(B Tutorial 0,T9Ui104Y1(B 0,T!g1(P`0Kg190Gh1R(B 0,T7Uh10Jh1G90Eh1R'(B + ,T"M'(M(B 0,TAU10"i1M$GRA0Gh1R(B "Wrote ...../TUTORIAL.th" ,T;CR!/0"Vi19(B + + ,T`GER07Uh1(PJ0Ci1R'a0?i1A0"i1M0AY1EcK0Ah1(B 0,T!g1c0Ki17SCRG0!Q1:0Gh1R(P0$i19KR(B (find-file) ,Ta0?i1A0"i1M0AY1E`0!h1R0+Vh1'0AU1(B +,TM0BYh10!h1M9K09i1R09Ui1a0Ei1G(B ,Ta0Ei1G0>T1A0>l10"i1M$GRAE'd;c9a0?i1A0"i1M0AY1E07Uh1KR`(M(B + + ,TaEP`GER07Uh10JQh1'`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E`07h1R09Qi19(B 0,T$W1M5M907Uh1(B Emacs ,T(P`0!g1:`09Wi1MKR07Uh1a0!i1d"AR07Qi1'KA4(B ,TE'(B +,Tc9a0?i1A0"i1M0AY1E`0;g19$0CQi1'aC!(B + + +0,T:Q1?`?M0Cl1(B (Buffer) +=============== + + 0,T6i1RKR!0JQh1'c0Ki1KRa0?i1A0"i1M0AY1E0MQ1907Uh1JM'(B 0,T4i1GB$S0JQh1'(B C-x C-f ,T`09Wi1MKR"M'a0?i1A0"i1M0AY1EaC!(B 0,T!g1(P0BQ1'$'(B +0,T6Y1!`0!g1:0CQ1!IRM0BYh1c9(B Emacs 0,TJTh1'07Uh1`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E07Uh10Mh1R9`0"i1RAR(B 0,T+Vh1'M0BYh1@RBc9(B Emacs ,T`0CU1B!0Gh1R(B +0,T:Q1?`?M0Cl1(B (Buffer) ,T`GER07Uh10Mh1R9a0?i1A0"i1M0AY1EcK0Ah1`0"i1RAR(B Emacs 0,T!g1(PJ0Ci1R'0:Q1?`?M0Cl1cK0Ah1(B 0,T"Vi19AR@RBc9(B + + 0,T6i1R05i1M'!RC(P04Y1CRB!RC"M'0:Q1?`?M0Cl1(B 0,T7Uh106Y1!`0!g1:0CQ1!IRM0BYh1@RBc9(B Emacs 0,T!g1c0Ki1!4$S0JQh1'(B + + C-x C-b + + >> ,TEM'!4(B C-x C-b 0,T4Y1(B 0,TJQ1'`!504Y10Gh1Ra05h1EP0:Q1?`?M0Cl10AU10*Wh1M0Gh1RMPdC(B ,TaEP06Y1!05Qi1'0*Wh1Md0Gi10Gh1R(B + ,TM0Bh1R'dC(B ,Tc9(B Emacs + + 0,TAU1:R'0:Q1?`?M0Cl1(B 0,T7Uh1d0Ah10AU10$Yh10!Q1:a0?i1A0"i1M0AY1E(0CT1'(B ,Tf(B 0,T5Q1GM0Bh1R'`0*h19(B ,Td0Ah10AU1a0?i1A0"i1M0AY1E07Uh10AU10*Wh1M0Gh1R(B "*Buffer +List*" ,TM0BYh1(0CT1'(B ,Tf(B ,Ta05h1`0;g190:Q1?`?M0Cl107Uh1J0Ci1R'0"Vi19AR`0>Wh1MaJ4'CRB!RC0:Q1?`?M0Cl1(B ,Tb4B$S0JQh1'(B C-x C-b + + 0,T"i1M$GRA07X1!0"i1M$GRA07Uh1;CR!/M0BYh1c90GT19b40Gl1"M'(B Emacs 0,T9Qi19(B ,T(PM0BYh1c90:Q1?`?M0Cl1c40:Q1?`?M0Cl1K09Vh1'`JAM(B + + >> ,TEM'!4(B C-x 1 ,T`0>Wh1ME:CRB!RC0:Q1?`?M0Cl1MM!04Y1(B + + ,T!RC`0CU1B!a0?i1A0"i1M0AY1E0MWh190"Vi19ARa0!i1d"(B ,T5M907Uh1!S0EQ1'a0!i1d"a0?i1A0"i1M0AY1EK09Vh1'M0BYh109Qi19(B ,T(Pd0Ah17Sc0Ki1a0?i1A0"i1M0AY1E(B +,TaC!06Y1!`0!g1:0CQ1!IR(B 0,TJTh1'07Uh1a0!i1d"d;c9a0?i1A0"i1M0AY1EaC!(P06Y1!0:Q1907V1!d0Gi1c90:Q1?`?M0Cl1"M'a0?i1A0"i1M0AY1E09Qi19(B ,T`07h1R09Qi19(B + + ,T!RCJ0Ci1R'0:Q1?`?M0Cl1cK0Ah10"Vi19(B ,TJSK0CQ1:a0!i1d"a0?i1A0"i1M0AY1E0MQ1907Uh1JM'(B ,Ta0Ei1Ga0!i1MPdC:R'M0Bh1R'c90:Q1?`?M0Cl109Qi19(B +,T(Pd0Ah10AU1<Ec4(B ,Tf(B 0,T5h1M0:Q1?`?M0Cl1"M'a0?i1A0"i1M0AY1E0MQ1907Uh1K09Vh1'07Qi1'0JTi19(B 0,T(X1409Ui17Sc0Ki1JRARC6`0!g1:a0?i1A0"i1M0AY1EaC!d0Gi1`0>Wh1M(B +,Ta0!i1d"c95M9K0EQ1'(B + + ,Ta05h1`GER07Uh105i1M'!RC(P`0!g1:0CQ1!IR(B (save) 0,T:Q1?`?M0Cl1E'd;c9a0?i1A0"i1M0AY1E(B 0,T4i1GB$S0JQh1'(B C-x C-s 0,T9Qi19(B +,T(P05i1M'J0GT170+l1d;0BQ1'0:Q1?`?M0Cl107Uh105i1M'!RC(P`0!g1:(B 0,T4i1GB$S0JQh1'(B C-x C-f 0,T+Vh1'0$h1M90"i1R'0BXh1'BR!(B ,T`CR0AU1$S0JQh1'0+Vh1'(B +,Tc0*i1JSK0CQ1:!RC09Ui1b4B`)>RP(B 0,T$W1M(B + + C-x s ,T`0!g1:0CQ1!IR(B (save) 0,T7X1!0:Q1?`?M0Cl107Uh10AU1M0BYh1(B + + C-x s ,T(P`0!g1:0CQ1!IR07X1!0:Q1?`?M0Cl107Uh106Y1!a0!i1d"`09Wi1MKRd;(B ,TE'c9a0?i1A0"i1M0AY1E(B ,Tb4B(P6RA0!h1M90Gh1R(Pc0Ki1(B +,T`0!g1:0:Q1?`?M0Cl109Ui1dKA(B y ,TK0CW1M(B n 0,T!Q1:0:Q1?`?M0Cl1a05h1EP0:Q1?`?M0Cl1(B ,T$S6RA(P;CR!/c90Jh1G90Eh1R'"M'K09i1R(M(B 0,T4Q1'(B +0,T5Q1GM0Bh1R'09Ui1(B + + Save file /usr/private/yours/TUTORIAL.th? (y or n) + + + +,T!RC"BRB$S0JQh1'(B (extension) +======================= + + ,Tc9b;Ca!CA(B Editor 0,T9Ui1(B 0,TAU1(S9G9$S0JQh1'AR!!0Gh1R(B ,T(S9G9$S0JQh1'0+Vh1'JRARC6!4d04i1b4B0;Xh1A$M9b7CE(B +,TK0CW1M0;Xh1A(B META ,Td04i1KA4(B ,T$S0JQh1'"BRB(B (eXtend) 0,TAU1d0Gi1`0>Wh1Mc0Ki1JRARC6c0*i1$S0JQh1'`K0Eh1R09Ui1d04i1KA4(B 0,TAU1M0BYh1(B 2 +,Ta::(B 0,T4Q1'09Ui1(B + + C-x ,T"BRB`0>Th1A04i1GB05Q1G0MQ1!IC(B ,TJSK0CQ1:!405Q1G0MQ1!IC5RA`0"i1Rd;(B 1 0,T5Q1G(B + ESC x ,T"BRB`0>Th1A04i1GB0*Wh1M$S0JQh1'(B ,TJSK0CQ1:!40*Wh1M$S0JQh1'5RA`0"i1Rd;07Qi1'KA4(B + + ,T$S0JQh1';CP`@709Ui1(B 0,T!g1`0;g19$S0JQh1'07Uh10AU1;CPbB*09l1(B ,Ta05h10Jh1G9cK0-h1(P06Y1!`0CU1B!c0*i1(B 0,T9i1MB$0CQi1'!0Gh1R$S0JQh1'07Qh1Gd;(B +0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'KRa0?i1A0"i1M0AY1E(B (find) C-x C-f ,T$S0JQh1'`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B (save) C-x C-s +,T$S0JQh1'(B C-x C-c (,T`0ET1!(B Editor) 0,T5h1R'0!g1`0;g19K09Vh1'c9$S0JQh1'`K0Eh1R09Ui1(B + + ,T$S0JQh1'(B C-z ,T`0;g19$S0JQh1'07Uh1c0*i1c9c9!RCMM!(R!(B Emacs 0,T$h1M90"i1R'0:h1MB(B ,T$S0JQh1'09Ui1(Pd0Ah1B!`0ET1!(B +Emacs ,T`EB07U1`04U1BG(B ,Ta05h1(PK0BX14(B Emacs ,Td0Gi10*Qh1G$CRG(B ,T`0>Wh1Mc0Ki1JRARC6!0EQ1:d;c0*i1(B csh ,Td04i10MU1!(B ,T!RC!4(B +C-z 0,T(V1'`0;g19!RCK0BX14(B Emacs ,Td0Gi10*Qh1G$CRG`07h1R09Qi19(B ,T(Pd0Ah17S$GRA`0JU1BKRBc0Ki10!Q1:`09Wi1MKR07Uh1a0!i1d"d;(B + +,TKARB`K05X1(B: ,Ta05h170Gh1R(B ,Tc9!C03U107Uh1c0*i1:9(B X-window ,TK0CW1Mc0*i1(B sh ,TM0BYh1(B 0,T!g1(Pd0Ah10AU1$GRAJRARC609Ui1(B + + + ,T$S0JQh1';CP`@7(B C-x 0,TAU1AR!ARBKERB$S0JQh1'(B ,T$S0JQh1'07Uh1M08T1:RBd;a0Ei1G0AU104Q1'09Ui1(B + + C-x C-f ,TKRa0?i1A0"i1M0AY1E(B (find) ,TJSK0CQ1:a0!i1d"(B + C-x C-s ,T`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E(B (save) + C-x C-b ,TaJ4'CRB!RC0:Q1?`?M0Cl1(B (buffer list) + C-x C-c ,T`0ET1!!RCc0*i1(B Editor ,TaEP`0!g1:0CQ1!IRa0?i1A0"i1M0AY1Eb4B0MQ15b90AQ105T1(B ,Ta05h106i1RKR!0AU1a0?i1A(B + 0,T"i1M0AY1E:R'0MQ1906Y1!a0!i1d"(B 0,T!g1c0Ki16RA0Gh1R(P`0!g1:0CQ1!IRa0?i1A0"i1M0AY1E09Qi19dKA(B ,Tb4B07Qh1Gd;(B + ,T!RCMM!(R!(B Emacs ,T7Sd04i1b4B$S0JQh1'(B C-x C-s C-x C-c 0,T$W1Mc0Ki1`0!g1:0CQ1!IR(B + 0,T!h1M9a0Ei1G0(V1'`0ET1!(B + + ,T$S0JQh1'"BRB`0>Th1Aa::0*Wh1M09Qi19(B ,Tc0*i1JSK0CQ1:$S0JQh1'07Uh1d0Ah10$h1MBd04i1c0*i1(B ,TK0CW1M$S0JQh1'07Uh1c0*i1`)>RP0!Q1:bKA40>T1`HI:R'(B +,TbKA4(B 0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'(B "command-apropos" 0,T+Vh1'(P6RA(B 0,T$U10Bl1`0GT10Cl14(B (keyword) ,Ta0Ei1GaJ4'<E(B +,T$S0JQh1'07X1!$S0JQh1'07Uh10AU10*Wh1M`0!Uh1BG0"i1M'0!Q1:0!Q1:0$U10Bl1`0GT10Cl1409Qi19(B ,T`GER(P0JQh1'$S0JQh1'09Ui1(B 0,T!g1c0Ki1!4(B ESC x ,Ta0Ei1G(P0AU105Q1G0MQ1!IC(B +"M-x" ,T;CR!/0"Vi1907Uh10Jh1G90Eh1R'"M'(M(B ,T(R!09Qi190!g1c0Ki1c0Jh10*Wh1M$S0JQh1'07Uh105i1M'!RC(B (,Tc9!C03U109Ui10$W1M(B +"command-apropos") ,T`0AWh1M0;i1M90"i1M0AY1Ed;06V1'(B "command-a" ,Ta0Ei1G!4(B SPACE BAR 0,TJh1G907Uh1`K0EW1M"M'(B +0,T*Wh1M$S0JQh1'0!g1(P06Y1!`05T1A`05g1A(B (completion) ,Tc0Ki1`M'b4B0MQ15b90AQ105T1(B ,TK0EQ1'(R!09Qi19(B ,T(P06Y1!6RA0$U10Bl1`0GT10Cl14(B 0,T!g1c0Ki1(B +,T!4JRB0MQ1!"CP(B (string) 0,T7Uh105i1M'!RC0CYi1E'd;(B 0,T5i1M'd0Ah1c0Jh10$U10Bl1`0GT10Cl14MPdC`EB(B 0,T!g1(Pd04i1$S0JQh1'07Qi1'KA407Uh10AU1M0BYh1(B + + >> ,TEM'!4(B ESC x ,T5RA04i1GB(B "command-apropos<Return>" ,TK0CW1M(B + "command-a<Space><Return>" ,TK0EQ1'(R!09Qi190!g1!4(B "kanji<Return>" 0,T4Y1(B + + ,Tc0Ki1!4(B C-x 1 ,T`GER05i1M'!RC(PE:(B "0,TGT19b40Gl1(B" 0,T7Uh1b<0Eh10"Vi19ARcK0Ah1(B + +,T:CC07Q14bKA4(B (Mode Line) +===================== + + ,T`GER07Uh10>T1A0>l1$S0JQh1'`0"i1Rd;0*i1R(B ,Tf(B Emacs ,T(PaJ4'0JTh1'07Uh10>T1A0>l1E'd;5C':CC07Q140Eh1R'0JX14"M'(M0+Vh1'`0CU1B!(B +0,TGh1R(B echo area ,T:CC07Q140+Vh1'M0BYh106Q140"Vi19ARK09Vh1':CC07Q14(B ,T`0CU1B!0Gh1R:CC07Q14bKA4(B (mode line) ,T:CC07Q14(B +,TbKA40AU10EQ1!I3P04Q1'09Ui1(B + + + [--]J:--**-Mule: TUTORIAL.th (Fundamental) ---NN%-------------- + + +,TKARB`K05X1(B: ,T5C'0Jh1G9(B NN ,T"M'(B NN% ,T(P0AU105Q1G`E"c0Jh1M0BYh1(B ,T:CC07Q14bKA407Uh1aJ4'M0BYh1MR((Pa5!05h1R'(B + ,Td;(R!05Q1GM0Bh1R'0:i1R'(B ,Ta05h10!g1d0Ah1`0;g19dC(B 0,T5Q1GM0Bh1R'`0*h19(B ,TMR((P0AU1`GERK0CW1M(B uptime + ,TaJ4'<EM0BYh1(B 0,TMQ1909Ui1`0;g19$GRAJRARC6"M'b;Ca!CA(B display-time + + ,T:CC07Q1409Ui10AU10"i1M0AY1E07Uh1`0;g19;CPbB*09l1M0BYh1KERBM0Bh1R'(B + + + 0,T"i1M0AY1EaC!0$W1M(B 0,T*Wh1Ma0?i1A0"i1M0AY1E07Uh1!S0EQ1'0Mh1R9M0BYh1(B 0,T5Q1G`E"(B NN% ,T(PaJ4'c0Ki10CYi10Gh1R!S0EQ1'aJ4'<E0Jh1G9dK9(B +,T"M'a0?i1A0"i1M0AY1EM0BYh1(B ,Tb4B0$T14`0;g19`;M0Cl1`+905l1(B 0,T6i1R`0;g190Jh1G9:90JX14"M'a0?i1A0"i1M0AY1EM0BYh10!g1(P0AU10"i1M$GRA0Gh1R(B +--Top-- ,TaJ4'M0BYh1(B 0,T6i1R`0;g190Jh1G90Eh1R'0JX140!g1(P0AU10"i1M$GRA0Gh1R(B --Bot-- 0,T6i1RKR!JRARC6aJ4'a0?i1A0"i1M0AY1E(B +0,T7Qi1'KA4:9K09i1R(Md04i1(B 0,T!g1(P0AU10"i1M$GRA0Gh1R(B --All-- ,TaJ4'M0BYh1(B + + ,T@RBc9G'`0Eg1:"M':CC07Q14bKA4(B ,T(PaJ4'c0Ki10CYi10Gh1R5M909Ui1M0BYh1c9bKA4(B (mode) ,TMPdC(B ,Tc905Q1GM0Bh1R'(B +0,T"i1R':90$W1M(B ,TM0BYh1c9bKA4(B Fundamental 0,T+Vh1'`0;g19bKA4`0CTh1A05i19(B (default) ,TbKA409Ui1`0;g19K09Vh1'c9bKA4(B +,TK0EQ1!(B (Major Mode) + + Emacs 0,TAU1bKA4K0EQ1!(B (Major Mode) ,TJSK0CQ1:!RCb;Ca!CA@RIR(B ,TK0CW1M!RCa0!i10"i1M$GRA(B ,T`0*h19(B +Lisp mode Text mode ,TaEPbKA40MWh19(B ,Tf(B 0,TMU1!KERBbKA4(B ,Tb4B;!05T1(B Emacs ,T(PM0BYh1c9bKA4K0EQ1!(B +,TbKA4c4bKA4K09Vh1'`JAM(B + + ,T$S0JQh1':R'$S0JQh1'(P0AU1>D05T1!CCA07Uh1a5!05h1R'0!Q19b4B0JTi19`0*T1'(B ,T`0AWh1MM0BYh1c9bKA4K0EQ1!07Uh105h1R'0!Q19(B 0,T5Q1GM0Bh1R'(B +,T`0*h19(B ,T`GERb;Ca!CA@RIR(B ,T(P0AU1$S0JQh1'JSK0CQ1:J0Ci1R'(B ,TKARB`K05X1(B (comment) ,TM0BYh1(B ,T`09Wh1M'(R!0GT108U1c0Jh1(B +,TKARB`K05X1"M'@RIRa05h1EP@RIRa5!05h1R'0!Q19(B ,T$S0JQh1'09Ui10!g1(Pa5!05h1R'0!Q19d;c9a05h1EPbKA4K0EQ1!(B ,T`0>Wh1Mc0Ki1(B +,TJRARC6c0Jh1KARB`K05X1c9a05h1EP@RIRd04i1M0Bh1R'06Y1!05i1M'(B + + ,T$S0JQh1'JSK0CQ1:!RC`;0EUh1B9bKA4c0Ki1`0;g19bKA4K0EQ1!0MWh19(B 0,T$W1M$S0JQh1'"BRB(B (extend) 0,T+Vh1'0*Wh1M$S0JQh1'`0;g190*Wh1M(B +,TbKA4(B 0,T5Q1GM0Bh1R'`0*h19(B ,T$S0JQh1'(B M-x fundamental-mode 0,T$W1M$S0JQh1'JSK0CQ1:`;0EUh1B9bKA4`0;g19bKA4(B +Fundamental + + ,T`GER07Uh1(Pa0!i1d"a0?i1A0"i1M0AY1E@RIR0MQ1'!DI(B 0,T!g1c0Ki1c0*i1(B Text mode + + >> ,TEM'0;i1M9$S0JQh1'(B M-x text-mode<Return> + + 0,T6i1R05i1M'!RCKR0"i1M0AY1E`0>Th1A`0!Uh1BG0!Q1:bKA4K0EQ1!07Uh1c0*i1M0BYh1c90;Q1(0(X10:Q19(B 0,T!g1c0Ki10;i1M9$S0JQh1'(B C-h m + + >> ,Tc0Ki1!4(B C-h m ,T`0>Wh1M0HV1!IR0"i1Ma5!05h1R'CPK0Gh1R'(B Text mode 0,T!Q1:(B Fundamental mode + + >> ,Tc0Ki1!4(B C-x 1 ,T`0>Wh1ME:`M!JRCMM!(R!(M(B + + ,T5C'0Jh1G90+i1RB"M':CC07Q14bKA4(B ,T(P0AU10JQ1-0EQ1!I03l1(B '[--]' ,T`0>Wh1MaJ4'bKA4JSK0CQ1:!RC0;i1M90"i1M0AY1E(B +(input mode) ,TM0BYh1(B 0,TJQ1-0EQ1!I03l1(B [--] ,TKARB06V1'JRARC60;i1M90"i1M0AY1Ed04i104i1GB05Q1G0MQ1!IC@RIR0MQ1'!DI(B +(English alphabets) ,T!0CX13R0Mh1R90$Yh10AW1M"M'(B "Tamago" ,TJSK0CQ1:CRBEP`0MU1B4"M'0GT108U1c0*i1(B + + ,TaEP5C'04i1R9"GR"M'0JQ1-0EQ1!I03l109Qi19(B ,T(P0AU1`$0CWh1M'KARBaJ4'J6R9P"M'(B flag ,T"M'CP::C0KQ1J(B +(coding-system) ,TM0BYh1(B Mule ,TJRARC6!SK94CP::C0KQ1JaB!`)>RPJSK0CQ1:(B ,T!RC`0!g1:0Mh1R9a0?i1A0"i1M0AY1E(B +,T!RC0;i1M90"i1M0AY1E(R!0$U10Bl1:M0Cl14(B ,T!RCaJ4'<EMM!7R'(M(B ,Td04i10MT1JCP(R!0!Q19(B ,Ta05h1b4B;!05T1(PaJ4'`)>RP(B +0,TJQ1-0EQ1!I03l10*h1GB(S(B (mnemonic) ,T"M'CP::C0KQ1JJSK0CQ1:!RC`0!g1:0Mh1R9a0?i1A0"i1M0AY1E(B ,T`07h1R09Qi19(B + + >> ,T5CG(04Y10Gh1R0AU10JQ1-0EQ1!I03l1(B ,T$0Ei1RB$0EV1'0!Q1:(B "J:" "S:" "E:" ,TaJ4'M0BYh107Uh1:CC07Q14bKA4K0CW1Md0Ah1(B + + 0,T5Q1G0MQ1!IC05Q1GaC!0$W1M(B 0,TJQ1-0EQ1!I03l10*h1GB(S(B (mnemonic) ,T"M'CP::C0KQ1J07Uh1c0*i1M0BYh1(B 0,T5Q1G(B ':' ,TaJ4'c0Ki10CYi1(B +0,TGh1R0AU105Q1G0MQ1!IC"M'@RIR0MWh19(B ,T9M!(R!@RIR0MQ1'!DIaJ4'M0BYh1(B (,T`0*h19(B ,T@RIR0(U19(B ,T@RIR0-Uh10;Xh19(B ,T`0;g1905i19(B) 0,T5Q1G(B J +,TKARB06V1'(B ,TC0KQ1J07Uh1c0*i10!Q1:(B JUNET 0,T$W1M(B ,TC0KQ1J(B JIS 0,T5Q1G(B S ,TKARB06V1'(B Shift-JIS ,TaEP(B 0,T5Q1G(B E ,TKARB06V1'(B +,TC0KQ1J(B EUC ,T@RIR0-Uh10;Xh19(B ,T(PJ0EQ1:`;0EUh1B9(B (toggle) ,T!RCaJ4'<E@RIR9R9R*R05T1d04i1b4B(B C-x C-k t + + 0,T5Q1GM0Bh1R'0"i1R'0Eh1R'(B 0,T$W1M!RCJ0EQ1:`;0EUh1B9d0Ah1c0Ki1aJ4'@RIR9R9R*R05T1(B ,Ta0Ei1GJ0EQ1:!0EQ1:0MU1!$0CQi1'K09Vh1'(B + + >> ,TEM'0;i1M9$S0JQh1'(B C-x C-k t 0,T4Y1JM'$0CQi1'(B + + 0,T6i1R`7M0Cl10AT109Q1E07Uh1c0*i1M0BYh10AU10;Xh1A(B META ,TaEPbKA407Uh1c0*i1M0BYh1`0;g19C0KQ1J(B JIS ,T`CR0!g1(PJRARC6c0*i10;Xh1A(B META +,Ta79!RC!40;Xh1A(B ESCAPE ,Td04i1(B 0,TGT108U1c0*i1(P`K0AW1M90!Q1:!RCc0*i10;Xh1A$M9b7CE(B 0,T$W1Mc0Ki1!40;Xh1A(B META 0,T$i1R'd0Gi1a0Ei1G0(V1'(B +,T!405Q1G0MQ1!IC5RA(B M-<0,T5Q1G0MQ1!IC(B> ,T(P7SK09i1R07Uh1`K0AW1M90!Q1:(B ESC <0,T5Q1G0MQ1!IC(B> 0,T9Qh190$W1M(B 0,T7X1!M0Bh1R'07Uh1M08T1:RBAR(B +,T(906V1'0(X1409Ui1(B ,T(P0BQ1'$'0AU1<E`K0AW1M9`04T1A(B ,TK0EQ1'(R!`;0EUh1B9(B ESC <0,T5Q1G0MQ1!IC(B> ,Tc0Ki1`0;g19(B M-<0,T5Q1G0MQ1!IC(B> ,Ta05h10"i1M(B +,T$GCCP0GQ1'0!g10$W1M(B 0,T;Xh1A(B META ,T(Pd0Ah1JRARC6c0*i1d04i10!Q1:C0KQ1J(B Shift-JIS ,TaEP(B EUC + + ,T!RC`;0EUh1B9CP::C0KQ1J(P0AU1<Ea0$h1`0>U1B'0!Q1:a05h1EP0:Q1?`?M0Cl1`07h1R09Qi19(B ,TJRARC604Y1$S0JQh1'`0!Uh1BG0!Q1:CP::C0KQ1J(B +,Td04i1b4B$S0JQh1'(B C-h a coding-system <Return> + + >> ,Tc0Ki10;i1M9$S0JQh1'(B C-h a coding-system <Return> ,Ta0Ei1G0Mh1R9CRBEP`0MU1B4"M'$S0JQh1'(B + set-display-coding-system set-file-coding-system ,TaEP(B + set-process-coding-system ,T(R!`M!JRC07Uh1;CR!/0"Vi19(B + +,T!RC0$i19KR(B (search) +================ + + Emacs ,TJRARC60$i19KRJRB0MQ1!"CP(B (string) ,T@RBc9a0?i1A0"i1M0AY1Ed;7R'0"i1R'K09i1RK0CW1M0"i1R'K0EQ1'd04i1(B +0,T6i1R05i1M'!RC0$i19KRd;7R'0"i1R'K09i1R"M'5SaK09h1'`$M0Cl1`+M0Cl1(B (cursor) 0,T!g1c0Ki1!4(B C-s 0,T6i1R05i1M'!RC0$i19KR(B +,Td;7R'0"i1R'K0EQ1'"M'5SaK09h1'`$M0Cl1`+M0Cl1(B 0,T!g1c0Ki1!4(B C-r ,TK0EQ1'(R!09Qi19(P0AU10"i1M$GRA0Gh1R(B "I-search:" +,T;CR!/0"Vi195C'(B echo area ,TB!`0ET1!!RC0$i19KRd04i104i1GB!RC!4(B ESC + + + >> ,T!4(B C-s ,T`0>Wh1M`0CTh1A!RC0$i19KR(B ,Ta0Ei1G!405Q1G0MQ1!IC"M'$S0Gh1R(B "cursor" ,TE'd;07U1EP05Q1GM0Bh1R'(B + 0,T*i1R(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R`$M0Cl1`+M0Cl1"0BQ1:d;M0Bh1R'dC(B + + >> ,TEM'!4(B C-s 0,T4Y10MU1!K09Vh1'$0CQi1'`0>Wh1M0$i19KR$S0Gh1R(B "cursor" 0,T5Q1G05h1Md;(B + + >> ,T!4(B <Delete> 0,T4Y1(B 4 ,T$0CQi1'(B ,Ta0Ei1G0JQ1'`!504Y10Gh1R!RC`$0EWh1M907Uh1"M'`$M0Cl1`+M0Cl1(B + + >> ,T!4(B ESC ,T`0>Wh1MB!`0ET1!!RC0$i19KR(B + + ,T!RC0$i19KR(P`0CTh1A0"Vi1907Q1907U1(B ,Tc9CPK0Gh1R'07Uh10>T1A0>l1JRB0MQ1!"CP07Uh105i1M'!RC(P0$i19KR(B ,T`0"i1Rd;`0>U1B':R'0Jh1G9(B +0,T6i1R05i1M'!RC(P0$i19KR05Q1G05h1Md;(B 0,T!g1c0Ki1!4(B C-s 0,TMU1!K09Vh1'$0CQi1'(B 0,T6i1RKR!0$i19KRJRB0MQ1!"CP07Uh10;i1M9`0"i1Rd;d0Ah1>:(B 0,T!g1(B +,T(P0AU10"i1M$GRA;CR!/0"Vi19(B ,Tc0Ki1!4(B C-g ,T`0>Wh1MB!`0ET1!(B + + ,TCPK0Gh1R'07Uh10$i19KRM0BYh1(B 0,T6i1R!4(B <Delete> 0,T5Q1G0MQ1!IC05Q1G0JX1407i1RBc9JRB0MQ1!"CP0!g1(P06Y1!E:d;(B ,Ta0Ei1G(B +,T`$M0Cl1`+M0Cl10!g1(P!0EQ1:d;5SaK09h1'0!h1M9K09i1R(B 0,T5Q1GM0Bh1R'`0*h19(B 0,T6i1R!4(B "cu" 0,T!g1(P0$i19KRd;06V1'5SaK09h1'07Uh10AU1$S0Gh1R(B +"cu" ,Ta05h106i1R!4(B <Delete> ,Tc90(Q1'KGP09Ui1(B 0,T5Q1G(B 'u' ,Tc9(B search line 0,T!g1(PKRBd;(B ,Ta0Ei1G`$M0Cl1`+M0Cl1(B +,T(P"0BQ1:!0EQ1:d;07Uh15SaK09h1'07Uh10AU105Q1G(B 'c' ,TM0BYh1(B + + 0,T6i1R!405Q1G0MQ1!IC$M9b7CE(B (control character) 0,T5Q1G0MWh19(B ,T9M!`K09W1M(R!(B C-s ,TK0CW1M(B C-r +,T!RC0$i19KR0!g1(P0JTi190JX14E'(B + + ,T$S0JQh1'(B C-s ,T(P0$i19KRJRB0MQ1!"CP07Uh105i1M'!RC(B ,Td;7R'0"i1R'K09i1R"M'5SaK09h1'`$M0Cl1`+M0Cl1(B 0,T6i1R05i1M'!RC(B +0,T$i19KRd;7R'07T1HK0EQ1'(B 0,T!g1c0Ki1!4(B C-r 0,T9Qh190$W1M(B ,TJRARC6c0*i1(B C-s ,TaEP(B C-r ,TJ0EQ1:0!Q19`0>Wh1M0$i19KRd;d04i1c907Qi1'(B +,TJM'07T1H7R'(B C-s ,TaEP(B C-r ,T7SK09i1R07Uh1`K0AW1M90!Q1907X1!;CP!RC(B ,T(P05h1R'0!Q190!g15C'07T1H7R'!RC0$i19KR`07h1R09Qi19(B + +Recursive Editing Level + + ,T:R'07U1(B ,T`CRMR((PK0EX14`0"i1Rd;M0BYh1c9J6R9P07Uh1`0CU1B!0Gh1R(B Recursive Editing Level ,Td04i1b4B(B +,Td0Ah105Qi1'c((B ,Tc9bKA409Ui1(B ,T`$0CWh1M'KARBG'`0Eg1:(B '()' 0,T7Uh1aJ4'0*Wh1MbKA4K0EQ1!(B (major mode) ,TM0BYh1(P0AU1G'`0Eg1:(B +'[]' 0,TEi1MA(B ,T`0>Th1A0"Vi190MU1!K09Vh1'0*Qi19(B 0,T5Q1GM0Bh1R'`0*h19(B 0,T6i1R`04T1A`0;g19(B (Fundamental) ,TM0BYh1(B 0,T!g1(P`;0EUh1B9`0;g19(B +[(Fundamental)] ,Ta79(B + +,TKARB`K05X1(B: ,T`CR(Pd0Ah1M08T1:RB`0!Uh1BG0!Q1:(B Recursive Editing Level ,Tc907Uh109Ui1(B + + ,Tc0Ki1!4(B M-x top-level <Return> ,T`0>Wh1M07Uh1(PMM!(R!(B Recursive Editing Level + + >> ,TEM'!404Y1(B ,T5C'0Jh1G90Eh1R'"M'(M(P0AU10"i1M$GRA0Gh1R(B "Back to top level" ,T;CR!/0"Vi19(B + + ,T`09Wh1M'(R!(B ,T`CRM0BYh1c9CP04Q1::90JX14(B (top level) ,TM0BYh1a0Ei1G(B ,T$S0JQh1'09Ui10(V1'd0Ah10AU1<Ec4(B ,Tf(B + + ,Td0Ah1JRARC6c0*i1(B ,T$S0JQh1'(B C-g ,T`0>Wh1M07Uh1(PMM!(R!(B Recursive Editing Level ,Td04i1(B + + +Help +==== + + Emacs 0,TAU1$GRAJRARC607Uh10AU1;CPbB*09l1(B ,TAR!ARBKERBM0Bh1R'(B 0,T+Vh1'd0Ah1JRARC6M08T1:RBd04i1KA4c907Uh109Ui1(B +,Ta05h1`CR(PJRARC6`0CU1B!c0*i1(B <HELP> ,T`0>Wh1M07Uh1(P`0CU1B90CYi1$GRAJRARC6`K0Eh1R09Ui1(B ,Td04i1b4B!RC!4(B C-h 0,T+Vh1'(P(B +0,T*h1GBc0Ki1`CRd04i10CQ1:0CYi10"i1M0AY1E`0>Th1A`05T1AKERBM0Bh1R'(B + + 0,TGT108U1c0*i10$W1Mc0Ki1!4(B C-h ,Ta0Ei1G5RA04i1GB05Q1G`0EW1M!(B (option) 0,TMU1!K09Vh1'05Q1G0MQ1!IC(B 0,T6i1Rd0Ah10CYi10Gh1R(P05i1M'c0*i1(B +0,T5Q1G`0EW1M!MPdC(B 0,T!g1c0Ki1!4(B C-h ? ,Ta0Ei1G(P0AU1$SM08T1:RB`0!Uh1BG0!Q1:05Q1G`0EW1M!;CR!/0"Vi19(B ,Td04i1KR!`;0EUh1B9c((P(B +,Td0Ah1`0CU1B!(B HELP ,TK0EQ1'(R!!4(B C-h 0,T!g1c0Ki1!4(B C-g ,T`0>Wh1MB!`0ET1!d04i1(B + + ,T$S0JQh1'(B HELP 0,T>Wi190R907Uh10JX140MQ19K09Vh1'0!g10$W1M(B C-h c ,Ta0Ei1G5RA04i1GB!RC!4$S0JQh1':R'$S0JQh1'(B 0,T+Vh1'(Pc0Ki1$S(B +,TM08T1:RB0JQi19(B ,Tf(B ,T`0!Uh1BG0!Q1:$S0JQh1'09Qi19(B + + >> ,TEM'!4(B C-h c C-p 0,T4Y1(B 0,T+Vh1'(Pc0Ki10"i1M$GRA0Gh1R(B + "C-p runs the command previous-line" + + ,T$S0JQh1'09Ui1(P0*h1GB0CWi1M0?Wi19$GRA(S(B ,T`0!Uh1BG0!Q1:$S0JQh1'07Uh1`$B0<h1R95Ra0Ei1G(B ,Ta05h1(Sd0Ah1d04i1(B ,Td04i1`0;g19M0Bh1R'04U1(B ,T$S0JQh1'(B +0,T7Uh10AU1AR!!0Gh1RK09Vh1'05Q1G0MQ1!IC(B ,T`0*h19(B C-x C-s 0,T!g1JRARC6!45RAK0EQ1'(B C-h c ,Td04i1(B + + 0,T6i1RKR!05i1M'!RC0CYi1CRBEP`0MU1B4AR!!0Gh1R09Ui1(B 0,T!g1c0Ki1c0*i1(B k ,Ta7905Q1G(B c + + >> ,TEM'!4(B C-h k C-p 0,T4Y1(B + + 0,T!g1(P0AU10GT19b40Gl1`0>Th1Ac9(B Emacs 0,TMU1!K09Vh1'0MQ19(B ,T`0>Wh1MaJ4'CRBEP`0MU1B4"M'$S0JQh1'09Qi19(B ,T`0AWh1M0Mh1R9(:a0Ei1G(B +0,T!g1c0Ki1!4(B C-x 1 ,T`0>Th1AE:0GT19b40Gl1MM!(B + + 0,T5Q1G`0EW1M!0MWh1907Uh10AU1;CPbB*09l1(B 0,TAU104Q1'09Ui1(B + + C-h f ,Tc0Ki1c0Jh10*Wh1M"M'$S0JQh1'(B ,T`0>Wh1MaJ4'CRBEP`0MU1B4`0!Uh1BG0!Q1:$S0JQh1'09Qi19(B + + >> ,Tc0Ki1!4(B C-h f previous-line ,Ta0Ei1G5RA04i1GB(B <Return> ,T`0>Wh1MaJ4'CRBEP`0MU1B4`0!Uh1BG(B + 0,T!Q1:$S0JQh1'0+Vh1'`0CU1B!c0*i1d04i1(R!!RC!4(B C-p + + C-h a ,Ta0Ei1G5RA04i1GB0$U10Bl1`0GT10Cl14(B (keyword) ,T`0>Wh1MaJ4'$S0JQh1'07X1!$S0JQh1'(B 0,T7Uh10AU10$U10Bl1`0GT10Cl14(B ,TCGAM0BYh1(B + ,T$S0JQh1'`K0Eh1R09Ui1JRARC6`0CU1B!c0*i1d04i1b4B!RC!4(B ESC x + + >> ,TEM'!4(B C-h a file ,Ta0Ei1G5RA04i1GB(B <Return> ,T`0>Wh1MaJ4'0*Wh1M$S0JQh1'07X1!$S0JQh1'07Uh10AU1$S0Gh1R(B + "file" ,TCGAM0BYh1(B 0,T+Vh1'(P0AU1(B find-file ,TaEP(B write-file 0,T7Uh1`0CU1B!c0*i1d04i1b4B!RC!4(B + C-x C-f ,TaEP(B C-x C-w ,TCGAM0BYh104i1GB(B + +0,T7i1RB0JX1409Ui1(B +====== + +,TM0Bh1R0EW1A(B: ,T$S0JQh1'JSK0CQ1:!RC`0ET1!(B Emacs 0,T$W1M(B C-x C-c + + + ,T`M!JRC)0:Q1:`0:Wi1M'05i1909Ui1(B 0,T5Qi1'c(`0"U1B90"Vi19JSK0CQ1:0<Yi107Uh1`0CTh1A0KQ14cK0Ah1(B ,Tb4B`)>RP(B 0,T6i1RKR!0AU10(X14dK907Uh1d0Ah1(B +,T`0"i1Rc((B 0,T!g1M0Bh1R0AQ1Ga05h1b7I05Q1G`M'(B ,Ta05h1"Mc0Ki1bB9$GRA0<T14AR0BQ1'0<Yi1`0"U1B9a79(B + + + ,TK0EQ1'(R!c0*i1(B EMACS 0,T4Y10JQ1!JM'JRA0GQ19(B 0,T!g1$'(P0*T19d;`M'(B ,Tc95M9aC!(B ,TMR((P0AU10(X1407Uh10CYi10JV1!0JQ1:J9aEP(B +,Td0Ah1`0"i1Rc(M0BYh10:i1R'(B ,Ta05h10JTh1'09Ui10Bh1MA`0!T140"Vi19`JAM(B ,T`GERa05h1`0CTh1Ac0*i1(B Editor ,TcK0Ah1c4(B ,Tf(B 0,T!g15RA(B ,Tb4B`)>RP(B +,TM0Bh1R'0BTh1'0!Q1:(B EMACS ,T`09Wh1M'(R!`0;g19b;Ca!CA07Uh10AU1$GRAJRARC6KER!KERBAR!(B 0,TMQ1907Uh1(0CT1'a0Ei1G(B EMACS +,T7Sd04i107X1!0JTh1'07X1!M0Bh1R'(B + + + +,T"M"M:0$X13(B +======= + ,T`M!JRC)0:Q1:09Ui1(B 0,T4Q14a;E'AR(R!(B "MicroEMACS (kemacs) ,T@RIR0-Uh10;Xh19(B ,T`0:Wi1M'05i19(B" 0,T+Vh1'd04i1AR(R!(B +JUNET ,T`0>Wh1Mc0Ki1c0*i1`0;g19(B Tutorial ,TJSK0CQ1:(B GNUEmacs (Nemacs) + + ,T`M!JRC09Ui1(B 0,T4Q14a;E'AR(R!(B "JOVE Tutorial" (19 ,TA!CR$A(B 86) ,T"M'(B Jonathan Payne + 0,T+Vh1'04Q14a;E'AR(R!`M!JRC"M'(B Steve Zimmerman ,Ta0Kh1'(B CCA-UNIX 0,T+Vh1'04Q14a;E'(B (0,TMU1!07U1(B) ,TAR(B + ,T(R!`M!JRC(B "Teach-Emacs" ,T)0:Q1:`0:Wi1M'05i19(B (31 0,T5X1ER$A(B 85) ,T"M'(B MIT + + Update - February 1986 by Dana Hoggatt. + + Update - December 1986 by Kim Leburg. + + Update/Translate - July 1987 by SANETO Takanori + +,T"M"M:0$X13`0;g190>T1`HI(B +============== + + 0,T$X13(B SANETO Takanori (,T+R`9b5P(B ,T7R!Rb90CT1(B) 0,T<Yi1a;E@RIR0-Uh10;Xh19)0:Q1:aC!0JX14(B ,T`M!JRC)0:Q1:09Ui1(B +,T`0"U1B904i1GB(B GMW + Wnn + Nemacs ,T"MaJ4'$GRA"M:0$X13(B ,Ta04h10<Yi107Uh1J0Ci1R'b;Ca!CA0JX140GT1`HI`K0Eh1R09Ui10"Vi19(B +,TaEP"M"M:0$X13(B 0,T$X13(B Fujiwara Shoko 0,T7Uh1c0Ki1$GRA0*h1GB`K0EW1Mc9!RCa;E(B ,T!RC0;i1M90"i1M0AY1E(B ,TaEPM0Bh1R'0MWh190MU1!(B +,TKERB(B ,Tf(B ,TM0Bh1R'(B + + + + +,T"M0CQ1:0<T14*M:(B ,T!RCa;E07Uh10<T14>ER4(B 0,T"i1M0AY1E`07g1((B ,TaEP0MWh19(B ,Tf(B ,Td0Gi1a05h1`0>U1B'0<Yi1`04U1BG(B + + 0,T+X10+Y10!T1(B 0,TNT1bCb90:X1(B@sra.co.jp + + +Update/Add - December 1987 by Hironobu Suzuki +Update/Add - November 1989 by Ken'ichi Handa +Update/Add - January 1990 by Shigeki Yoshida +Update/Add - March 1992 by Kenichi HANDA + +Translated into Thai + - September 1994 by Manop Wongsaisuwan
--- a/etc/mine/pad.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"47 6 1 1", -/* colors */ -"` s None c None", -/* pixels */ -"```````````````````````````````````````````````", -"```````````````````````````````````````````````", -"```````````````````````````````````````````````", -"```````````````````````````````````````````````", -"```````````````````````````````````````````````", -"```````````````````````````````````````````````" -};
--- a/etc/mine/splash.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"340 78 15 1", -/* colors */ -"` c #3038C0", -"a c #484C88", -"b c #D0CCD8", -"c s None c None", -"d c #E89CA0", -"e c #985458", -"f c #481010", -"g c #A8ACB0", -"h c #909098", -"i c #901020", -"j c #787878", -"k c #080C10", -"l c #E05460", -"m c #686C88", -"n c #D01428", -/* pixels */ -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbbbbbbbbbbbbbccccbbbbbbbbbbcccccbbbbbbbbbbbbbbbbbghhhhhhhhgbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccg```````````````ccccm`````````bcccg``````````````````````````mbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccch```````````kkkkcccbam``````kkgccchka`````````kkkkk`````````khcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbgmm```````kkjggccccbb````kkfjbcccbgba```````kkjggghak``````khcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccb```````khbbbbcccbh```kkhbbbbccccbm```````kgbbbbbbbgm````kbbbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbm``````kjbbbbbbbg```kkgbbbbbbbccb````````kbbbbbbbbbbm```fggbbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccch```````aggggbbb```kkgggggggbbbbb```````kahggggbbbbbg``kfhhggbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccb```````fjhhgbbm``kkbbgghhggbbbbh```````kajjhhggbbbbb``kmhhhgbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccba``````kmjhbbm``kkgbbghhhggbbcbm```````kmmjjhgbbbbbb``khhjhgbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccch```````ajgbm``kkgcbbgghggbbccb```````kkmmmjggbbcccb``kghhhgbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccg```````fgbm``kkgcbbbggggbbccbg```````kammjhgbbgbcccbkagghhgbcccccbccccccbbbcccccccccbbbccccccccccccccccccbbbcccccccccccccccccccccccbbbccccccccccccccbbbcccccbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccb```````abm``kkgccbbgggbbbcccbh```````kammjhgbm`hbcccggbgggbbbbbbggmcccbbgmmmbcccccbbgmmmgcccccccccccccbbghmmhccbbbggbcccccccccccbbghmmmgcccccccccbbghmmmhbbbgmbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccm``````mh``kkhccbbgggbbbccccbm```````kmmmjhbg``kbcccccbbbhhmmm````aacbga`````gcccbg``````mcccccccccccbga``````bh````agccccccccbbh```a````gccccccbbm`````a`mm``abcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccg`````````kkhbbbbbggbbbcccccb```````kkmmmhbba``kccccccbbb`````````kjbg````````gcbh````````accccccccbbh`````ka`ha`````accccccbbg````kfg````jcccccbm````kkam````kbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccb````````kkmbbbbbggbbbcccccbg```````amhhgbgm``kacccccccbbbam``````kbh`````````mbg``````````jccccccbbm````kkfgma`````kmcccccbbm````kabg`````hcccbg````kacccm```kccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccm```````kahgbbgggbbbccccccbm```````bhhhhm````kgccbbccccbbbh``````gba`kg``````bh`akmm``````abbbccbbm````kkgcbh``````kgbbbcbbm````kkbba`````fbbcbm````kccbbg```kbbbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccch```````fjhgggggbbbcccccccba`````````````````kbbbbbbcccccbh`````mg`mkab`````aj`akfbm`````kagbbbbbm`````kjbbbh``````kbbbbbbm`````kbcb``````kbbbb`````abbbbba``abbbbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccb```````kmjhhggbbbccccccccb````````k`````````kbbbbbbcccccbm`````gaakabg`````m`akabb``````kahggbbh`````kabbbbm`````kaggggbh`````kmbbb``````kggbb``````bggggh`kagggbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbm``````kajjhggbbccccccccbh```````kfakkfa```kmbbggbbcccccb`````ma`fkhgh```````kfhbg``````kmjhgbg``````kbbggbm`````kmhhhbg``````kbbggh````kahhgb``````mghggh`kjggggbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbg````````amjhgbbcccccccccbm```````kmmmjhg```kjggggbbcccccg`````m`akmhbm```````kmjbm``````kmmjgba`````kmbgggb``````khjjhba`````kmbggggjkkkkjjjhga`````ajhhgbhkjggggbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbga````````kmjhgbccccccccccb```````kkmmmjhgm``kghhhgbbccccbh```````kajhb```````kamhb``````kfmmjbh``````kgghhgg`````kfjjjgg``````kgghhhggbhhghjjhgh``````ahhgbbbbbgggbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbg``aa``````kmjhgbccccccccccg```````kammmjhgm`kkhhhhgbbccccba``````kkmjgh``````kkmmgg``````kmmmhb``````kaghhhbm`````kajmjba`````kfghhhhgbbbbghjjhgg```````ahgbbcbbggbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbg```kh```````ajhgbcccccccccbh```````kammmjhbm`kahhjhgbbccccb```````kamjbm``````kammbm``````kjmmgh``````khhjjhb``````kjjmhg``````kmhhjhggbbbbgghhggbh```````agbbcbbbbbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbba``kkg```````kjhgbcccccccccbm```````kmmmjhgbm`khghhggbccccbh``````kkmmhb``````kajmhb``````kajmmbm`````kfghjjgg`````kkjjjgh``````khhjjhgbbccbbggggbbcm```````mgbbbbbbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbm``kkbba``````kmjgbbccccccccb```````kkmmmjggbgakbggggmbccccbm``````kmmmgg``````kjmmgh``````kmjmhb``````kahjjhbm`````kajjjbm``````khjjjhgbccccbbbbbbccc````````ggbbbbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbm``kkbcbh```````ajhgbcccccccbh```````kammjhgbbcggbbgbm`mbcccb``````kkjmmbm`````kkjmmbm``````kjjmhh``````kjjjjgg``````kjjjjb``````kfjjjhgbbcccccbbbbccccb```````agbbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbm``kkbccbg```````kjhgbcccccccbm```````kmmmjhgbccccbbbh``kcccbg``````kammjb``````kmjmjb``````kahmjgh``````khjjjbh``````khjjjb``````kajmjhgbcbccccccggccccch``````khgbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbm``kkgccbbba``````kjhgbbccccccba```````kmmmjgbbccccbbg``kacccbh``````kmmmhg``````khjmhg``````kjbmjgm`````kfjmjgg``````kfhgjhb``````kammjhgbbbhccccch`hbcccch``````ahgbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbbbbbbbbbbbbbkccccccccccbh``kkgccbbbbm```````ajhbbccccccg```````kkmmmhgbbccccbg```kjcccbm`````kkjmmgh`````kfjjmgh``````kbh`agm`````kajmhbm``````kmbjahb``````kammjgbbbm`acccbh`kgccccba`````khgbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbbbbbbbbbbbbkkcccccccccbh```kgccbbbggh```````fjhgbcccccbh```````kammjhgbcccbbh````kbcbbb``````kajmjba`````kmjmjbm`````khg`akhm``````amhbh`m`````kgg`afbm``````ammhgbbm``khccbm``hccccch`````kjhgbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkcccccccbbh```kaccbbbggbb````````jhgbbccccbm```````kmmmjhgbcbbgm`````fcbbbh``````kjmmhg``````khjmjb``````hba`kfgh``````hgbh`mm`````bg``kabh``````jhhgbbm``kacccbm``accccbb````kfjhgbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkfccccccbbm````accbbbggbbb````````mhgbbcccbg````````fmmmhgbbbgm``````kmbbbbm``````kjmmgh`````kfjjjjb``````aa``kjgg```````ma``mm`````m``kkgbb```````ahhm```kkbcccba```bbbbbg````kamjhgbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkccccbbh``````ahbbbgbbbhm`````````hggbbbgh`````````mgbbbghma````````kgbbgb``````kajmjbm`````kmjmjhg````````kkahgba`````````kfm```````kkjgbbg````````````kkbccbbb````hbbbbm```kkjjjhgbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkcccccm``````````hgggg```````````````bbg````````````````````````````kbgggg``````kmjmjg``````khjmjhgj``````kkajggbb````````kkgb``````kkahgbbbh``````````kkbccbbbb`````mhha```kkhjjjhgbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkcccccbakkkkkkkkkkmgbbjkkkkkkkkkkkkkkkbbjkkkkkkkkkkkkkkkkkkkkkkkkkkkagghhghkkkkkkjmmjhhkkkkkkhjjjhbba```kkkajjhgbbg`````kkkhgbg````kkajhggbbbgk``````kkabbbbbbbg`kkk``````kkfgghjjhgbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkccccccbgggghhjjmmhgbbbgggghhjmaaaaamjbbbgggghhjmaaaaaamjhhggghhhhhjhhhhhgghghhjjjmjhgghhhhjjjjjhgbbcjaaaammjjhggbbgakkkkajhggghfkkammjjhgbbbbbmfkkkkajgbbbbbbbbgkgbgakkkkahbbghhhgbbcccccdddcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkcccccccccccbbgghhhgbbcccccbbghjmmmjhggbbccccbbghjjmmmjhgbbbbbbbbbgghhjhggbcccbghjjjhgbbccbghjjjhgbcccbbghjmjjhggbbbbggjjmjjhggggghjjmjjhggbbbbbghjjjjhggggggbbbcccbbggggbbbbbghhhgbbccccblnnnbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkccccccccccbbgghhhhgbbcccccbbghjjjjjhhgbbbccbbbghhjjjjhhgbbbbbbbggghhhhhgbbcccbghhjhgbbcccbgghhhgbbcccbbghjjjhhgbbbcbbghjjjjhhggggghjjjhhgbbccbbgghjjjjhhggggbbccccbbgggggbbbbggggbbcccccblnnnkbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkccccccccccbbggghgggbbbcccbbbgghhhhhhggbbbbcbbbgghhhhhhggbbbbbbbgggghhggbbccccbbgghggbbcccbbgggggbcccccbbghhhggbbbcccbbghhhhhggbbbgghhhhgbbbcccbbgghhhhhhgggbbccccccbgggggbbbggggbbccccccblnnnkbbbccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkccccccccccbbbbggggbbbcccccbbbggggggggbbbbccbbbbgggggggbbbbbbbbbbbgggggbbbccccbbbggbbbccccbbbggbbbcccccbbbggggbbbcccccbbggggggbbbbbbggggbbbcccccbbbgggggggbbbcccccccbbbbbbbbbbbbbbcccccccclnnnkggbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkcccccccccccbbbbbbbbbcccccccbbbbbbbbbbbbbcccccbbbbbbbbbbbbbbbbbbbbbbbbbbcccccccbbbbbbccccccbbbbbbcccccccbbbbbbbccccccccbbbbbbbbccccbbbbbbcccccccccbbbbbbbbbbcccccccccbbbbbbbbbbbbccccccccccefkkhgbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbcccccccccbcccccccccccccccbbbbccccccccccccccccccccccccccccccccccchjjhgbbcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbkkkkkkkkkkkkkkkccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbccccbbbbcccccccccccccccbbggggbbcccccccccccccbbbbccccccccccccccccbbbbbcccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccckkkkkkkkkkkkkkkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbdddddddbccbdddddddcbdddddddllldcddllllbcccccccddddddddbggbbccccccdddddbbddlllldcccccccccccbddlllllldcccccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbbbbbbbbbbbbbkbbbbbbbbbbbbbbbkbbbbbbbbbbbbbbbkbbbbbbbbbbbbbbbkbbbbbbbbbbbbbbbkbbbbbbbbbbbbbbbkcccccccccccccccccccccccccccccccccccccccccccccccccccccclnnnnnnnbcbnnnnnnneblnnnnlnnnnnldnnnnnngccccccbnnnnnnnebbbbccccccdnnnnldnnnnnnndcccccccccbdlnnnnnnnnndcccccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbbbbbbbbbbbbkkbbbbbbbbbbbbbbkkbbbbbbbbbbbbbbkkbbbbbbbbbbbbbbkkbbbbbbbbbbbbbbkkbbbbbbbbbbbbbbkkccccccccccccccccccccccccccccccccccccccccccccccccccccccdnnnnnnikbblnnnnnniadnnnnnniinnnnnninnnigbbccccnnnnnnnfjbbcccccccbnnnnnnnniinnnnebbcccccbdnnnniiiinnnnlbbccccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccgfnnnikagbbdnnnkkkaggdnnnfkalnnnnkkhlnnkgbbcccckkadnnfmgbbcccccccbdnnnnikkaalnnijbbcccbdnnnnkkfaafinnnibbcccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkfbbggggggggggggkfbbggggggggggggkfbbggggggggggggkfbbggggggggggggkfbbggggggggggggkfccccccccccccccccccccccccccccccccccccccccccccccccccccccccbgnnnehgddnnnkkmmhgbdnnikahdnnnfkjglnnfggbcccccbbdnnfmggbccccccccdnnnikahhhdlnnfgbbccdlnnnkkjhhhhhennnabbccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbhnnneddnnnkkmjjhgbdnnffmjdlnnkajhdnnfmgbbccccbbdnnfahgbccccccccdnnnkkjjhhglnnfjgbccdnnnkkhhhhhhhglnnihgbcccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbhnnnlnnnkkjjjhggbdnnfamjdlnnkamhdnnfahgbccccbbdnnfahgbccccccccdnnikamjhggdnnfagbbbdnnnhddddddbbddnnnagbbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbhnnnnnfkhhhhggbbdnnfajhdlnnkmjgdnnfahgbcccccbdnnfahgbccccccccdnnifmmhgbbdnnfahgbblnnnlllllllllllnnnkhgbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbdnnnikmhhhgbbbbdnnfajhblnnkjjgdnnfahgbccccccdnnfahgbbcccccccdnnifjjhbbbdnnfahgbblnnnnnnnnnnnnnnnnnkjgbbcccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbdlnnnnejjhgbbcccdnnfahgblnnkjhgdnnfahgbccccccdnnfahgbbcccccccdnnifjhgbcbdnnfahgbblnniiiiiiiiiiiiiifkjhbbcccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbdlnnfnnnejhgbccccdnnfahgblnnkhhgdnnfahgbbcccccdnnfmhgbbcccccccdnnifjhgbccdnnfahgbblnnfkkkfffffffffffajhbbcccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccccbdlnnfkannnehgbccccdnnfmhgblnnkhhgdnnfmhgbbcccccdnnfmhgbbcccccccdnnifhhgbccdnnfmhgbbdnniammjjhhhhhhghjjhgbbcccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkccccccccccccccccccccccccccccccccccccccccccccccccccccccccbdlnnfkmhmnnnegbbcccdnnfmhgblnnkhhgdnnfmhgbbcccccdnnfmhgbbcccccccdnnifhhgbccdnnfmhgbbbnnnammjhhggggdddhhggbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccccbdlnnikmhhhhnnnebbccbdnnimhgblnnkhhgdnnfmhgbbccccbdnnijggbbcccccccdnnnahhgbbbdnnimhgbbclnnnhjhggbbddlnnnggbbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkbbggggggggggggkkcccccccccccccccccccccccccccccccccccccccccccccccccccccbddlnnnlaghgddlnnnlgbddlnnlljgblnnljhgdnnlehgdddddddlnnlddddddccccdddnnlljhgbddlnnlljgbbcbnnnnldddddlnnnnikbbbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbkkkkkkkkkkkkkkkbkkkkkkkkkkkkkkkbkkkkkkkkkkkkkkkbkkkkkkkkkkkkkkkbkkkkkkkkkkkkkkkbkkkkkkkkkkkkkkkcccccccccccccccccccccccccccccccccccccccccccccccccccccbnnnnnnnnjhglnnnnnnndlnnnnnnnhblnnnnjgdnnnnegdnnnnnnnnnnnnnnnnecccdnnnnnnnmgblnnnnnnnhgbccbnnnnnnnnnnnnnikfgbbccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccckkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkcccccccccccccccccccccccccccccccccccccccccccccccccccccclnnnnnnikhghnnnnnniklnnnnnnikglnnnnkggnnnnkmgnnnnnnnnnnnnnnnnkhbcbnnnnnnnkgbdnnnnnnikgbbcbginnnnnnnnifkkahgbbccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccakkkkkkkhgbhkkkkkkfgakkkkkkkggakkkkhggkkkkmgbkkkkkkkkkkkkkkkkhbbcgkkkkkkkhgbjkkkkkkfgbbcbbgakfffffkkkahhhggbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbghjjjhgbbbghjjjjhggghhjjhhgbgghhhgbbghhhgbbbbgghhhjjjjhhhhggbbcbbghjjjhgbbbbghjjhggbccbbggjammmmhhhhhhgbbccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbghhhhggbbbbghhhhggggghhhhggbbgggggbbbggggbbbbggghhhhhhhhhggbbbcbbgghhhggbbbbghhhhgbbcccbbggghhhhhhhgggbbcccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbggggbbbcbbbggggbbbbbggggbbbbbbbbbbbbbbbbbbbbbbgggggggggggbbbcccbbbgggbbbcbbbggggbbcccccbbbbgggggggbbbbccccccccccccc", -"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccbbbbbbcccccbbbbbbbbbbbbbbbccccbbbccccbbbbccccbbbbbbbbbbbbbbbcccccbbbbbbcccccbbbbbbccccccccbbbbbbbbbbbccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc", -"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc" -};
--- a/etc/sample.emacs Mon Aug 13 10:02:48 2007 +0200 +++ b/etc/sample.emacs Mon Aug 13 10:03:52 2007 +0200 @@ -197,17 +197,18 @@ '(pointer)) (error nil)) ; returns nil if an error occurred. (set-glyph-image gc-pointer-glyph file)))) - - ;; Add `dired' to the File menu - (add-menu-button '("File") ["Edit Directory" dired t]) + + (when (featurep 'menubar) + ;; Add `dired' to the File menu + (add-menu-button '("File") ["Edit Directory" dired t]) - ;; Here's a way to add scrollbar-like buttons to the menubar - (add-menu-button nil ["Top" beginning-of-buffer t]) - (add-menu-button nil ["<<<" scroll-down t]) - (add-menu-button nil [" . " recenter t]) - (add-menu-button nil [">>>" scroll-up t]) - (add-menu-button nil ["Bot" end-of-buffer t]) - + ;; Here's a way to add scrollbar-like buttons to the menubar + (add-menu-button nil ["Top" beginning-of-buffer t]) + (add-menu-button nil ["<<<" scroll-down t]) + (add-menu-button nil [" . " recenter t]) + (add-menu-button nil [">>>" scroll-up t]) + (add-menu-button nil ["Bot" end-of-buffer t])) + ;; Change the behavior of mouse button 2 (which is normally ;; bound to `mouse-yank'), so that it inserts the selected text ;; at point (where the text cursor is), instead of at the
--- a/etc/sgml/CATALOG Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -PUBLIC "-//IETF//ENTITIES Added Latin 1 for HTML//EN" html-latin.sgml -PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML" html-latin.sgml -PUBLIC "-//IETF//ENTITIES icons for HTML//EN" html-icons.sgml -PUBLIC "-//IETF//ENTITIES Math and Greek for HTML//EN" html-math.sgml -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd -PUBLIC "-//IETF//DTD HTML//EN//3.0" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN//" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN//" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN//3.0" html-3.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN//3.0" html-3s.dtd -PUBLIC "-//W3O//DTD W3 HTML Strict 3.0//EN//" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN//3.0" html-3s.dtd -PUBLIC "HTML" html.dtd -PUBLIC "-//IETF//DTD HTML//EN" html.dtd -PUBLIC "-//IETF//DTD HTML//EN//2.0" html.dtd -PUBLIC "-//IETF//DTD HTML 2.0//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN//2.0" html.dtd -PUBLIC "-//IETF//DTD HTML Level 1//EN" html-1.dtd -PUBLIC "-//IETF//DTD HTML Level 1//EN//2.0" html-1.dtd -PUBLIC "-//IETF//DTD HTML Level 0//EN" html-0.dtd -PUBLIC "-//IETF//DTD HTML Level 0//EN//2.0" html-0.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN//2.0" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN//2.0" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN" html-1s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN//2.0" html-1s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN" html-0s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN//2.0" html-0s.dtd -PUBLIC "-//Netscape Comm. Corp.//DTD HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML 2.0//EN" html-mcom.dtd -PUBLIC "-//Netscape Comm. Corp.//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML 2.0//EN" html-mcoms.dtd -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava HTML//EN" html-hj.dtd -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava Strict HTML//EN" html-hjs.dtd -PUBLIC "-//WebTechs//DTD PUML 1.0//EN" puml.dtd -PUBLIC "-//SQ//DTD HTML 2.0 HoTMetaL + extensions//EN" SQ.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML//EN" iehtml.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//EN" iehtml-s.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 Tables//EN" ietables.dtd -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd -PUBLIC "-//W3C//DTD HTML 3.2 Final//EN" html-3.2f.dtd -PUBLIC "-//W3C//DTD HTML Experimental 19960712//EN" html-cougar.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 3.0 Tables//EN" ie3tables.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 3.0 HTML//EN" ie30.dtd -PUBLIC "+//Silmaril//DTD HTML Pro v0r11 19970101//EN" htmlpro.dtd -DOCTYPE HTML html-3.2f.dtd -DOCTYPE HTML-3 html-3.dtd
--- a/etc/sgml/ECAT Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -FILE html.dtd [ HTML.Recommended "INCLUDE" ] cdtd/html-r -FILE html.dtd [ ] cdtd/html -FILE html-2.dtd [ ] cdtd/html-2 -FILE html-3.dtd [ ] cdtd/html-3 -FILE html-mcom.dtd [ ] cdtd/html-mcom -FILE html-3.2.dtd [ ] cdtd/html-3.2 -FILE html-hj.dtd [ ] cdtd/html-hj -FILE iehtml.dtd [ ] cdtd/iehtml -FILE html-3.2f.dtd [] cdtd/html-3.2f
--- a/etc/sgml/ISO_8879=1986/entities/Added_Latin_1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOlat1 PUBLIC - "ISO 8879:1986//ENTITIES Added Latin 1//EN"> - %ISOlat1; ---> -<!ENTITY aacute SDATA "[aacute]"--=small a, acute accent--> -<!ENTITY Aacute SDATA "[Aacute]"--=capital A, acute accent--> -<!ENTITY acirc SDATA "[acirc ]"--=small a, circumflex accent--> -<!ENTITY Acirc SDATA "[Acirc ]"--=capital A, circumflex accent--> -<!ENTITY agrave SDATA "[agrave]"--=small a, grave accent--> -<!ENTITY Agrave SDATA "[Agrave]"--=capital A, grave accent--> -<!ENTITY aring SDATA "[aring ]"--=small a, ring--> -<!ENTITY Aring SDATA "[Aring ]"--=capital A, ring--> -<!ENTITY atilde SDATA "[atilde]"--=small a, tilde--> -<!ENTITY Atilde SDATA "[Atilde]"--=capital A, tilde--> -<!ENTITY auml SDATA "[auml ]"--=small a, dieresis or umlaut mark--> -<!ENTITY Auml SDATA "[Auml ]"--=capital A, dieresis or umlaut mark--> -<!ENTITY aelig SDATA "[aelig ]"--=small ae diphthong (ligature)--> -<!ENTITY AElig SDATA "[AElig ]"--=capital AE diphthong (ligature)--> -<!ENTITY ccedil SDATA "[ccedil]"--=small c, cedilla--> -<!ENTITY Ccedil SDATA "[Ccedil]"--=capital C, cedilla--> -<!ENTITY eth SDATA "[eth ]"--=small eth, Icelandic--> -<!ENTITY ETH SDATA "[ETH ]"--=capital Eth, Icelandic--> -<!ENTITY eacute SDATA "[eacute]"--=small e, acute accent--> -<!ENTITY Eacute SDATA "[Eacute]"--=capital E, acute accent--> -<!ENTITY ecirc SDATA "[ecirc ]"--=small e, circumflex accent--> -<!ENTITY Ecirc SDATA "[Ecirc ]"--=capital E, circumflex accent--> -<!ENTITY egrave SDATA "[egrave]"--=small e, grave accent--> -<!ENTITY Egrave SDATA "[Egrave]"--=capital E, grave accent--> -<!ENTITY euml SDATA "[euml ]"--=small e, dieresis or umlaut mark--> -<!ENTITY Euml SDATA "[Euml ]"--=capital E, dieresis or umlaut mark--> -<!ENTITY iacute SDATA "[iacute]"--=small i, acute accent--> -<!ENTITY Iacute SDATA "[Iacute]"--=capital I, acute accent--> -<!ENTITY icirc SDATA "[icirc ]"--=small i, circumflex accent--> -<!ENTITY Icirc SDATA "[Icirc ]"--=capital I, circumflex accent--> -<!ENTITY igrave SDATA "[igrave]"--=small i, grave accent--> -<!ENTITY Igrave SDATA "[Igrave]"--=capital I, grave accent--> -<!ENTITY iuml SDATA "[iuml ]"--=small i, dieresis or umlaut mark--> -<!ENTITY Iuml SDATA "[Iuml ]"--=capital I, dieresis or umlaut mark--> -<!ENTITY ntilde SDATA "[ntilde]"--=small n, tilde--> -<!ENTITY Ntilde SDATA "[Ntilde]"--=capital N, tilde--> -<!ENTITY oacute SDATA "[oacute]"--=small o, acute accent--> -<!ENTITY Oacute SDATA "[Oacute]"--=capital O, acute accent--> -<!ENTITY ocirc SDATA "[ocirc ]"--=small o, circumflex accent--> -<!ENTITY Ocirc SDATA "[Ocirc ]"--=capital O, circumflex accent--> -<!ENTITY ograve SDATA "[ograve]"--=small o, grave accent--> -<!ENTITY Ograve SDATA "[Ograve]"--=capital O, grave accent--> -<!ENTITY oslash SDATA "[oslash]"--=small o, slash--> -<!ENTITY Oslash SDATA "[Oslash]"--=capital O, slash--> -<!ENTITY otilde SDATA "[otilde]"--=small o, tilde--> -<!ENTITY Otilde SDATA "[Otilde]"--=capital O, tilde--> -<!ENTITY ouml SDATA "[ouml ]"--=small o, dieresis or umlaut mark--> -<!ENTITY Ouml SDATA "[Ouml ]"--=capital O, dieresis or umlaut mark--> -<!ENTITY szlig SDATA "[szlig ]"--=small sharp s, German (sz ligature)--> -<!ENTITY thorn SDATA "[thorn ]"--=small thorn, Icelandic--> -<!ENTITY THORN SDATA "[THORN ]"--=capital THORN, Icelandic--> -<!ENTITY uacute SDATA "[uacute]"--=small u, acute accent--> -<!ENTITY Uacute SDATA "[Uacute]"--=capital U, acute accent--> -<!ENTITY ucirc SDATA "[ucirc ]"--=small u, circumflex accent--> -<!ENTITY Ucirc SDATA "[Ucirc ]"--=capital U, circumflex accent--> -<!ENTITY ugrave SDATA "[ugrave]"--=small u, grave accent--> -<!ENTITY Ugrave SDATA "[Ugrave]"--=capital U, grave accent--> -<!ENTITY uuml SDATA "[uuml ]"--=small u, dieresis or umlaut mark--> -<!ENTITY Uuml SDATA "[Uuml ]"--=capital U, dieresis or umlaut mark--> -<!ENTITY yacute SDATA "[yacute]"--=small y, acute accent--> -<!ENTITY Yacute SDATA "[Yacute]"--=capital Y, acute accent--> -<!ENTITY yuml SDATA "[yuml ]"--=small y, dieresis or umlaut mark-->
--- a/etc/sgml/ISO_8879=1986/entities/Added_Latin_1_for_HTML Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOlat1 PUBLIC - "ISO 8879:1986//ENTITIES Added Latin 1//EN"> - %ISOlat1; ---> -<!ENTITY aacute SDATA "[aacute]"--=small a, acute accent--> -<!ENTITY Aacute SDATA "[Aacute]"--=capital A, acute accent--> -<!ENTITY acirc SDATA "[acirc ]"--=small a, circumflex accent--> -<!ENTITY Acirc SDATA "[Acirc ]"--=capital A, circumflex accent--> -<!ENTITY agrave SDATA "[agrave]"--=small a, grave accent--> -<!ENTITY Agrave SDATA "[Agrave]"--=capital A, grave accent--> -<!ENTITY aring SDATA "[aring ]"--=small a, ring--> -<!ENTITY Aring SDATA "[Aring ]"--=capital A, ring--> -<!ENTITY atilde SDATA "[atilde]"--=small a, tilde--> -<!ENTITY Atilde SDATA "[Atilde]"--=capital A, tilde--> -<!ENTITY auml SDATA "[auml ]"--=small a, dieresis or umlaut mark--> -<!ENTITY Auml SDATA "[Auml ]"--=capital A, dieresis or umlaut mark--> -<!ENTITY aelig SDATA "[aelig ]"--=small ae diphthong (ligature)--> -<!ENTITY AElig SDATA "[AElig ]"--=capital AE diphthong (ligature)--> -<!ENTITY ccedil SDATA "[ccedil]"--=small c, cedilla--> -<!ENTITY Ccedil SDATA "[Ccedil]"--=capital C, cedilla--> -<!ENTITY eth SDATA "[eth ]"--=small eth, Icelandic--> -<!ENTITY ETH SDATA "[ETH ]"--=capital Eth, Icelandic--> -<!ENTITY eacute SDATA "[eacute]"--=small e, acute accent--> -<!ENTITY Eacute SDATA "[Eacute]"--=capital E, acute accent--> -<!ENTITY ecirc SDATA "[ecirc ]"--=small e, circumflex accent--> -<!ENTITY Ecirc SDATA "[Ecirc ]"--=capital E, circumflex accent--> -<!ENTITY egrave SDATA "[egrave]"--=small e, grave accent--> -<!ENTITY Egrave SDATA "[Egrave]"--=capital E, grave accent--> -<!ENTITY euml SDATA "[euml ]"--=small e, dieresis or umlaut mark--> -<!ENTITY Euml SDATA "[Euml ]"--=capital E, dieresis or umlaut mark--> -<!ENTITY iacute SDATA "[iacute]"--=small i, acute accent--> -<!ENTITY Iacute SDATA "[Iacute]"--=capital I, acute accent--> -<!ENTITY icirc SDATA "[icirc ]"--=small i, circumflex accent--> -<!ENTITY Icirc SDATA "[Icirc ]"--=capital I, circumflex accent--> -<!ENTITY igrave SDATA "[igrave]"--=small i, grave accent--> -<!ENTITY Igrave SDATA "[Igrave]"--=capital I, grave accent--> -<!ENTITY iuml SDATA "[iuml ]"--=small i, dieresis or umlaut mark--> -<!ENTITY Iuml SDATA "[Iuml ]"--=capital I, dieresis or umlaut mark--> -<!ENTITY ntilde SDATA "[ntilde]"--=small n, tilde--> -<!ENTITY Ntilde SDATA "[Ntilde]"--=capital N, tilde--> -<!ENTITY oacute SDATA "[oacute]"--=small o, acute accent--> -<!ENTITY Oacute SDATA "[Oacute]"--=capital O, acute accent--> -<!ENTITY ocirc SDATA "[ocirc ]"--=small o, circumflex accent--> -<!ENTITY Ocirc SDATA "[Ocirc ]"--=capital O, circumflex accent--> -<!ENTITY ograve SDATA "[ograve]"--=small o, grave accent--> -<!ENTITY Ograve SDATA "[Ograve]"--=capital O, grave accent--> -<!ENTITY oslash SDATA "[oslash]"--=small o, slash--> -<!ENTITY Oslash SDATA "[Oslash]"--=capital O, slash--> -<!ENTITY otilde SDATA "[otilde]"--=small o, tilde--> -<!ENTITY Otilde SDATA "[Otilde]"--=capital O, tilde--> -<!ENTITY ouml SDATA "[ouml ]"--=small o, dieresis or umlaut mark--> -<!ENTITY Ouml SDATA "[Ouml ]"--=capital O, dieresis or umlaut mark--> -<!ENTITY szlig SDATA "[szlig ]"--=small sharp s, German (sz ligature)--> -<!ENTITY thorn SDATA "[thorn ]"--=small thorn, Icelandic--> -<!ENTITY THORN SDATA "[THORN ]"--=capital THORN, Icelandic--> -<!ENTITY uacute SDATA "[uacute]"--=small u, acute accent--> -<!ENTITY Uacute SDATA "[Uacute]"--=capital U, acute accent--> -<!ENTITY ucirc SDATA "[ucirc ]"--=small u, circumflex accent--> -<!ENTITY Ucirc SDATA "[Ucirc ]"--=capital U, circumflex accent--> -<!ENTITY ugrave SDATA "[ugrave]"--=small u, grave accent--> -<!ENTITY Ugrave SDATA "[Ugrave]"--=capital U, grave accent--> -<!ENTITY uuml SDATA "[uuml ]"--=small u, dieresis or umlaut mark--> -<!ENTITY Uuml SDATA "[Uuml ]"--=capital U, dieresis or umlaut mark--> -<!ENTITY yacute SDATA "[yacute]"--=small y, acute accent--> -<!ENTITY Yacute SDATA "[Yacute]"--=capital Y, acute accent--> -<!ENTITY yuml SDATA "[yuml ]"--=small y, dieresis or umlaut mark-->
--- a/etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Delimiters Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsc PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Delimiters//EN"> - %ISOamsc; ---> -<!ENTITY rceil SDATA "[rceil ]"--/rceil C: right ceiling--> -<!ENTITY rfloor SDATA "[rfloor]"--/rfloor C: right floor--> -<!ENTITY rpargt SDATA "[rpargt]"--/rightparengtr C: right paren, gt--> -<!ENTITY urcorn SDATA "[urcorn]"--/urcorner C: upper right corner--> -<!ENTITY drcorn SDATA "[drcorn]"--/lrcorner C: downward right corner--> -<!ENTITY lceil SDATA "[lceil ]"--/lceil O: left ceiling--> -<!ENTITY lfloor SDATA "[lfloor]"--/lfloor O: left floor--> -<!ENTITY lpargt SDATA "[lpargt]"--/leftparengtr O: left parenthesis, gt--> -<!ENTITY ulcorn SDATA "[ulcorn]"--/ulcorner O: upper left corner--> -<!ENTITY dlcorn SDATA "[dlcorn]"--/llcorner O: downward left corner-->
--- a/etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Ordinary Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamso PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Ordinary//EN"> - %ISOamso; ---> -<!ENTITY ang SDATA "[ang ]"--/angle - angle--> -<!ENTITY angmsd SDATA "[angmsd]"--/measuredangle - angle-measured--> -<!ENTITY beth SDATA "[beth ]"--/beth - beth, Hebrew--> -<!ENTITY bprime SDATA "[bprime]"--/backprime - reverse prime--> -<!ENTITY comp SDATA "[comp ]"--/complement - complement sign--> -<!ENTITY daleth SDATA "[daleth]"--/daleth - daleth, Hebrew--> -<!ENTITY ell SDATA "[ell ]"--/ell - cursive small l--> -<!ENTITY empty SDATA "[empty ]"--/emptyset /varnothing =small o, slash--> -<!ENTITY gimel SDATA "[gimel ]"--/gimel - gimel, Hebrew--> -<!ENTITY image SDATA "[image ]"--/Im - imaginary--> -<!ENTITY inodot SDATA "[inodot]"--/imath =small i, no dot--> -<!ENTITY jnodot SDATA "[jnodot]"--/jmath - small j, no dot--> -<!ENTITY nexist SDATA "[nexist]"--/nexists - negated exists--> -<!ENTITY oS SDATA "[oS ]"--/circledS - capital S in circle--> -<!ENTITY planck SDATA "[planck]"--/hbar /hslash - Planck's over 2pi--> -<!ENTITY real SDATA "[real ]"--/Re - real--> -<!ENTITY sbsol SDATA "[sbsol ]"--/sbs - short reverse solidus--> -<!ENTITY vprime SDATA "[vprime]"--/varprime - prime, variant--> -<!ENTITY weierp SDATA "[weierp]"--/wp - Weierstrass p-->
--- a/etc/sgml/ISO_8879=1986/entities/Added_Math_Symbols:_Relations Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsr PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Relations//EN"> - %ISOamsr; ---> -<!ENTITY ape SDATA "[ape ]"--/approxeq R: approximate, equals--> -<!ENTITY asymp SDATA "[asymp ]"--/asymp R: asymptotically equal to--> -<!ENTITY bcong SDATA "[bcong ]"--/backcong R: reverse congruent--> -<!ENTITY bepsi SDATA "[bepsi ]"--/backepsilon R: such that--> -<!ENTITY bowtie SDATA "[bowtie]"--/bowtie R:--> -<!ENTITY bsim SDATA "[bsim ]"--/backsim R: reverse similar--> -<!ENTITY bsime SDATA "[bsime ]"--/backsimeq R: reverse similar, eq--> -<!ENTITY bump SDATA "[bump ]"--/Bumpeq R: bumpy equals--> -<!ENTITY bumpe SDATA "[bumpe ]"--/bumpeq R: bumpy equals, equals--> -<!ENTITY cire SDATA "[cire ]"--/circeq R: circle, equals--> -<!ENTITY colone SDATA "[colone]"--/coloneq R: colon, equals--> -<!ENTITY cuepr SDATA "[cuepr ]"--/curlyeqprec R: curly eq, precedes--> -<!ENTITY cuesc SDATA "[cuesc ]"--/curlyeqsucc R: curly eq, succeeds--> -<!ENTITY cupre SDATA "[cupre ]"--/curlypreceq R: curly precedes, eq--> -<!ENTITY dashv SDATA "[dashv ]"--/dashv R: dash, vertical--> -<!ENTITY ecir SDATA "[ecir ]"--/eqcirc R: circle on equals sign--> -<!ENTITY ecolon SDATA "[ecolon]"--/eqcolon R: equals, colon--> -<!ENTITY eDot SDATA "[eDot ]"--/doteqdot /Doteq R: eq, even dots--> -<!ENTITY esdot SDATA "[esdot ]"--/doteq R: equals, single dot above--> -<!ENTITY efDot SDATA "[efDot ]"--/fallingdotseq R: eq, falling dots--> -<!ENTITY egs SDATA "[egs ]"--/eqslantgtr R: equal-or-gtr, slanted--> -<!ENTITY els SDATA "[els ]"--/eqslantless R: eq-or-less, slanted--> -<!ENTITY erDot SDATA "[erDot ]"--/risingdotseq R: eq, rising dots--> -<!ENTITY fork SDATA "[fork ]"--/pitchfork R: pitchfork--> -<!ENTITY frown SDATA "[frown ]"--/frown R: down curve--> -<!ENTITY gap SDATA "[gap ]"--/gtrapprox R: greater, approximate--> -<!ENTITY gsdot SDATA "[gsdot ]"--/gtrdot R: greater than, single dot--> -<!ENTITY gE SDATA "[gE ]"--/geqq R: greater, double equals--> -<!ENTITY gel SDATA "[gel ]"--/gtreqless R: greater, equals, less--> -<!ENTITY gEl SDATA "[gEl ]"--/gtreqqless R: gt, dbl equals, less--> -<!ENTITY ges SDATA "[ges ]"--/geqslant R: gt-or-equal, slanted--> -<!ENTITY Gg SDATA "[Gg ]"--/ggg /Gg /gggtr R: triple gtr-than--> -<!ENTITY gl SDATA "[gl ]"--/gtrless R: greater, less--> -<!ENTITY gsim SDATA "[gsim ]"--/gtrsim R: greater, similar--> -<!ENTITY Gt SDATA "[Gt ]"--/gg R: dbl greater-than sign--> -<!ENTITY lap SDATA "[lap ]"--/lessapprox R: less, approximate--> -<!ENTITY ldot SDATA "[ldot ]"--/lessdot R: less than, with dot--> -<!ENTITY lE SDATA "[lE ]"--/leqq R: less, double equals--> -<!ENTITY lEg SDATA "[lEg ]"--/lesseqqgtr R: less, dbl eq, greater--> -<!ENTITY leg SDATA "[leg ]"--/lesseqgtr R: less, eq, greater--> -<!ENTITY les SDATA "[les ]"--/leqslant R: less-than-or-eq, slant--> -<!ENTITY lg SDATA "[lg ]"--/lessgtr R: less, greater--> -<!ENTITY Ll SDATA "[Ll ]"--/Ll /lll /llless R: triple less-than--> -<!ENTITY lsim SDATA "[lsim ]"--/lesssim R: less, similar--> -<!ENTITY Lt SDATA "[Lt ]"--/ll R: double less-than sign--> -<!ENTITY ltrie SDATA "[ltrie ]"--/trianglelefteq R: left triangle, eq--> -<!ENTITY mid SDATA "[mid ]"--/mid R:--> -<!ENTITY models SDATA "[models]"--/models R:--> -<!ENTITY pr SDATA "[pr ]"--/prec R: precedes--> -<!ENTITY prap SDATA "[prap ]"--/precapprox R: precedes, approximate--> -<!ENTITY pre SDATA "[pre ]"--/preceq R: precedes, equals--> -<!ENTITY prsim SDATA "[prsim ]"--/precsim R: precedes, similar--> -<!ENTITY rtrie SDATA "[rtrie ]"--/trianglerighteq R: right tri, eq--> -<!ENTITY samalg SDATA "[samalg]"--/smallamalg R: small amalg--> -<!ENTITY sc SDATA "[sc ]"--/succ R: succeeds--> -<!ENTITY scap SDATA "[scap ]"--/succapprox R: succeeds, approximate--> -<!ENTITY sccue SDATA "[sccue ]"--/succcurlyeq R: succeeds, curly eq--> -<!ENTITY sce SDATA "[sce ]"--/succeq R: succeeds, equals--> -<!ENTITY scsim SDATA "[scsim ]"--/succsim R: succeeds, similar--> -<!ENTITY sfrown SDATA "[sfrown]"--/smallfrown R: small down curve--> -<!ENTITY smid SDATA "[smid ]"--/shortmid R:--> -<!ENTITY smile SDATA "[smile ]"--/smile R: up curve--> -<!ENTITY spar SDATA "[spar ]"--/shortparallel R: short parallel--> -<!ENTITY sqsub SDATA "[sqsub ]"--/sqsubset R: square subset--> -<!ENTITY sqsube SDATA "[sqsube]"--/sqsubseteq R: square subset, equals--> -<!ENTITY sqsup SDATA "[sqsup ]"--/sqsupset R: square superset--> -<!ENTITY sqsupe SDATA "[sqsupe]"--/sqsupseteq R: square superset, eq--> -<!ENTITY ssmile SDATA "[ssmile]"--/smallsmile R: small up curve--> -<!ENTITY Sub SDATA "[Sub ]"--/Subset R: double subset--> -<!ENTITY subE SDATA "[subE ]"--/subseteqq R: subset, dbl equals--> -<!ENTITY Sup SDATA "[Sup ]"--/Supset R: dbl superset--> -<!ENTITY supE SDATA "[supE ]"--/supseteqq R: superset, dbl equals--> -<!ENTITY thkap SDATA "[thkap ]"--/thickapprox R: thick approximate--> -<!ENTITY thksim SDATA "[thksim]"--/thicksim R: thick similar--> -<!ENTITY trie SDATA "[trie ]"--/triangleq R: triangle, equals--> -<!ENTITY twixt SDATA "[twixt ]"--/between R: between--> -<!ENTITY vdash SDATA "[vdash ]"--/vdash R: vertical, dash--> -<!ENTITY Vdash SDATA "[Vdash ]"--/Vdash R: dbl vertical, dash--> -<!ENTITY vDash SDATA "[vDash ]"--/vDash R: vertical, dbl dash--> -<!ENTITY veebar SDATA "[veebar]"--/veebar R: logical or, bar below--> -<!ENTITY vltri SDATA "[vltri ]"--/vartriangleleft R: l tri, open, var--> -<!ENTITY vprop SDATA "[vprop ]"--/varpropto R: proportional, variant--> -<!ENTITY vrtri SDATA "[vrtri ]"--/vartriangleright R: r tri, open, var--> -<!ENTITY Vvdash SDATA "[Vvdash]"--/Vvdash R: triple vertical, dash-->
--- a/etc/sgml/ISO_8879=1986/entities/Diacritical_Marks Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOdia PUBLIC - "ISO 8879:1986//ENTITIES Diacritical Marks//EN"> - %ISOdia; ---> -<!ENTITY acute SDATA "[acute ]"--=acute accent--> -<!ENTITY breve SDATA "[breve ]"--=breve--> -<!ENTITY caron SDATA "[caron ]"--=caron--> -<!ENTITY cedil SDATA "[cedil ]"--=cedilla--> -<!ENTITY circ SDATA "[circ ]"--=circumflex accent--> -<!ENTITY dblac SDATA "[dblac ]"--=double acute accent--> -<!ENTITY die SDATA "[die ]"--=dieresis--> -<!ENTITY dot SDATA "[dot ]"--=dot above--> -<!ENTITY grave SDATA "[grave ]"--=grave accent--> -<!ENTITY macr SDATA "[macr ]"--=macron--> -<!ENTITY ogon SDATA "[ogon ]"--=ogonek--> -<!ENTITY ring SDATA "[ring ]"--=ring--> -<!ENTITY tilde SDATA "[tilde ]"--=tilde--> -<!ENTITY uml SDATA "[uml ]"--=umlaut mark-->
--- a/etc/sgml/ISO_8879=1986/entities/General_Technical Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOtech PUBLIC - "ISO 8879:1986//ENTITIES General Technical//EN"> - %ISOtech; ---> -<!ENTITY aleph SDATA "[aleph ]"--/aleph =aleph, Hebrew--> -<!ENTITY and SDATA "[and ]"--/wedge /land B: =logical and--> -<!ENTITY ang90 SDATA "[ang90 ]"--=right (90 degree) angle--> -<!ENTITY angsph SDATA "[angsph]"--/sphericalangle =angle-spherical--> -<!ENTITY ap SDATA "[ap ]"--/approx R: =approximate--> -<!ENTITY becaus SDATA "[becaus]"--/because R: =because--> -<!ENTITY bottom SDATA "[bottom]"--/bot B: =perpendicular--> -<!ENTITY cap SDATA "[cap ]"--/cap B: =intersection--> -<!ENTITY cong SDATA "[cong ]"--/cong R: =congruent with--> -<!ENTITY conint SDATA "[conint]"--/oint L: =contour integral operator--> -<!ENTITY cup SDATA "[cup ]"--/cup B: =union or logical sum--> -<!ENTITY equiv SDATA "[equiv ]"--/equiv R: =identical with--> -<!ENTITY exist SDATA "[exist ]"--/exists =at least one exists--> -<!ENTITY forall SDATA "[forall]"--/forall =for all--> -<!ENTITY fnof SDATA "[fnof ]"--=function of (italic small f)--> -<!ENTITY ge SDATA "[ge ]"--/geq /ge R: =greater-than-or-equal--> -<!ENTITY iff SDATA "[iff ]"--/iff =if and only if--> -<!ENTITY infin SDATA "[infin ]"--/infty =infinity--> -<!ENTITY int SDATA "[int ]"--/int L: =integral operator--> -<!ENTITY isin SDATA "[isin ]"--/in R: =set membership--> -<!ENTITY lang SDATA "[lang ]"--/langle O: =left angle bracket--> -<!ENTITY lArr SDATA "[lArr ]"--/Leftarrow A: =is implied by--> -<!ENTITY le SDATA "[le ]"--/leq /le R: =less-than-or-equal--> -<!ENTITY minus SDATA "[minus ]"--B: =minus sign--> -<!ENTITY mnplus SDATA "[mnplus]"--/mp B: =minus-or-plus sign--> -<!ENTITY nabla SDATA "[nabla ]"--/nabla =del, Hamilton operator--> -<!ENTITY ne SDATA "[ne ]"--/ne /neq R: =not equal--> -<!ENTITY ni SDATA "[ni ]"--/ni /owns R: =contains--> -<!ENTITY or SDATA "[or ]"--/vee /lor B: =logical or--> -<!ENTITY par SDATA "[par ]"--/parallel R: =parallel--> -<!ENTITY part SDATA "[part ]"--/partial =partial differential--> -<!ENTITY permil SDATA "[permil]"--=per thousand--> -<!ENTITY perp SDATA "[perp ]"--/perp R: =perpendicular--> -<!ENTITY prime SDATA "[prime ]"--/prime =prime or minute--> -<!ENTITY Prime SDATA "[Prime ]"--=double prime or second--> -<!ENTITY prop SDATA "[prop ]"--/propto R: =is proportional to--> -<!ENTITY radic SDATA "[radic ]"--/surd =radical--> -<!ENTITY rang SDATA "[rang ]"--/rangle C: =right angle bracket--> -<!ENTITY rArr SDATA "[rArr ]"--/Rightarrow A: =implies--> -<!ENTITY sim SDATA "[sim ]"--/sim R: =similar--> -<!ENTITY sime SDATA "[sime ]"--/simeq R: =similar, equals--> -<!ENTITY square SDATA "[square]"--/square B: =square--> -<!ENTITY sub SDATA "[sub ]"--/subset R: =subset or is implied by--> -<!ENTITY sube SDATA "[sube ]"--/subseteq R: =subset, equals--> -<!ENTITY sup SDATA "[sup ]"--/supset R: =superset or implies--> -<!ENTITY supe SDATA "[supe ]"--/supseteq R: =superset, equals--> -<!ENTITY there4 SDATA "[there4]"--/therefore R: =therefore--> -<!ENTITY Verbar SDATA "[Verbar]"--/Vert =dbl vertical bar--> - -<!ENTITY angst SDATA "[angst ]"--Angstrom =capital A, ring--> -<!ENTITY bernou SDATA "[bernou]"--Bernoulli function (script capital B)--> -<!ENTITY compfn SDATA "[compfn]"--B: composite function (small circle)--> -<!ENTITY Dot SDATA "[Dot ]"--=dieresis or umlaut mark--> -<!ENTITY DotDot SDATA "[DotDot]"--four dots above--> -<!ENTITY hamilt SDATA "[hamilt]"--Hamiltonian (script capital H)--> -<!ENTITY lagran SDATA "[lagran]"--Lagrangian (script capital L)--> -<!ENTITY lowast SDATA "[lowast]"--low asterisk--> -<!ENTITY notin SDATA "[notin ]"--N: negated set membership--> -<!ENTITY order SDATA "[order ]"--order of (script small o)--> -<!ENTITY phmmat SDATA "[phmmat]"--physics M-matrix (script capital M)--> -<!ENTITY tdot SDATA "[tdot ]"--three dots above--> -<!ENTITY tprime SDATA "[tprime]"--triple prime--> -<!ENTITY wedgeq SDATA "[wedgeq]"--R: corresponds to (wedge, equals)-->
--- a/etc/sgml/ISO_8879=1986/entities/Greek_Symbols Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOgrk3 PUBLIC - "ISO 8879:1986//ENTITIES Greek Symbols//EN"> - %ISOgrk3; ---> -<!ENTITY alpha SDATA "[alpha ]"--=small alpha, Greek--> -<!ENTITY beta SDATA "[beta ]"--=small beta, Greek--> -<!ENTITY gamma SDATA "[gamma ]"--=small gamma, Greek--> -<!ENTITY Gamma SDATA "[Gamma ]"--=capital Gamma, Greek--> -<!ENTITY gammad SDATA "[gammad]"--/digamma--> -<!ENTITY delta SDATA "[delta ]"--=small delta, Greek--> -<!ENTITY Delta SDATA "[Delta ]"--=capital Delta, Greek--> -<!ENTITY epsi SDATA "[epsi ]"--=small epsilon, Greek--> -<!ENTITY epsiv SDATA "[epsiv ]"--/varepsilon--> -<!ENTITY epsis SDATA "[epsis ]"--/straightepsilon--> -<!ENTITY zeta SDATA "[zeta ]"--=small zeta, Greek--> -<!ENTITY eta SDATA "[eta ]"--=small eta, Greek--> -<!ENTITY thetas SDATA "[thetas]"--straight theta--> -<!ENTITY Theta SDATA "[Theta ]"--=capital Theta, Greek--> -<!ENTITY thetav SDATA "[thetav]"--/vartheta - curly or open theta--> -<!ENTITY iota SDATA "[iota ]"--=small iota, Greek--> -<!ENTITY kappa SDATA "[kappa ]"--=small kappa, Greek--> -<!ENTITY kappav SDATA "[kappav]"--/varkappa--> -<!ENTITY lambda SDATA "[lambda]"--=small lambda, Greek--> -<!ENTITY Lambda SDATA "[Lambda]"--=capital Lambda, Greek--> -<!ENTITY mu SDATA "[mu ]"--=small mu, Greek--> -<!ENTITY nu SDATA "[nu ]"--=small nu, Greek--> -<!ENTITY xi SDATA "[xi ]"--=small xi, Greek--> -<!ENTITY Xi SDATA "[Xi ]"--=capital Xi, Greek--> -<!ENTITY pi SDATA "[pi ]"--=small pi, Greek--> -<!ENTITY piv SDATA "[piv ]"--/varpi--> -<!ENTITY Pi SDATA "[Pi ]"--=capital Pi, Greek--> -<!ENTITY rho SDATA "[rho ]"--=small rho, Greek--> -<!ENTITY rhov SDATA "[rhov ]"--/varrho--> -<!ENTITY sigma SDATA "[sigma ]"--=small sigma, Greek--> -<!ENTITY Sigma SDATA "[Sigma ]"--=capital Sigma, Greek--> -<!ENTITY sigmav SDATA "[sigmav]"--/varsigma--> -<!ENTITY tau SDATA "[tau ]"--=small tau, Greek--> -<!ENTITY upsi SDATA "[upsi ]"--=small upsilon, Greek--> -<!ENTITY Upsi SDATA "[Upsi ]"--=capital Upsilon, Greek--> -<!ENTITY phis SDATA "[phis ]"--/straightphi - straight phi--> -<!ENTITY Phi SDATA "[Phi ]"--=capital Phi, Greek--> -<!ENTITY phiv SDATA "[phiv ]"--/varphi - curly or open phi--> -<!ENTITY chi SDATA "[chi ]"--=small chi, Greek--> -<!ENTITY psi SDATA "[psi ]"--=small psi, Greek--> -<!ENTITY Psi SDATA "[Psi ]"--=capital Psi, Greek--> -<!ENTITY omega SDATA "[omega ]"--=small omega, Greek--> -<!ENTITY Omega SDATA "[Omega ]"--=capital Omega, Greek-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOamsa Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,66 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsa PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Arrow Relations//EN"> - %ISOamsa; ---> -<!ENTITY cularr SDATA "[cularr]"--/curvearrowleft A: left curved arrow --> -<!ENTITY curarr SDATA "[curarr]"--/curvearrowright A: rt curved arrow --> -<!ENTITY dArr SDATA "[dArr ]"--/Downarrow A: down dbl arrow --> -<!ENTITY darr2 SDATA "[darr2 ]"--/downdownarrows A: two down arrows --> -<!ENTITY dharl SDATA "[dharl ]"--/downleftharpoon A: dn harpoon-left --> -<!ENTITY dharr SDATA "[dharr ]"--/downrightharpoon A: down harpoon-rt --> -<!ENTITY lAarr SDATA "[lAarr ]"--/Lleftarrow A: left triple arrow --> -<!ENTITY Larr SDATA "[Larr ]"--/twoheadleftarrow A:--> -<!ENTITY larr2 SDATA "[larr2 ]"--/leftleftarrows A: two left arrows --> -<!ENTITY larrhk SDATA "[larrhk]"--/hookleftarrow A: left arrow-hooked --> -<!ENTITY larrlp SDATA "[larrlp]"--/looparrowleft A: left arrow-looped --> -<!ENTITY larrtl SDATA "[larrtl]"--/leftarrowtail A: left arrow-tailed --> -<!ENTITY lhard SDATA "[lhard ]"--/leftharpoondown A: l harpoon-down --> -<!ENTITY lharu SDATA "[lharu ]"--/leftharpoonup A: left harpoon-up --> -<!ENTITY hArr SDATA "[hArr ]"--/Leftrightarrow A: l&r dbl arrow --> -<!ENTITY harr SDATA "[harr ]"--/leftrightarrow A: l&r arrow --> -<!ENTITY lrarr2 SDATA "[lrarr2]"--/leftrightarrows A: l arr over r arr --> -<!ENTITY rlarr2 SDATA "[rlarr2]"--/rightleftarrows A: r arr over l arr --> -<!ENTITY harrw SDATA "[harrw ]"--/leftrightsquigarrow A: l&r arr-wavy --> -<!ENTITY rlhar2 SDATA "[rlhar2]"--/rightleftharpoons A: r harp over l --> -<!ENTITY lrhar2 SDATA "[lrhar2]"--/leftrightharpoons A: l harp over r --> -<!ENTITY lsh SDATA "[lsh ]"--/Lsh A:--> -<!ENTITY map SDATA "[map ]"--/mapsto A:--> -<!ENTITY mumap SDATA "[mumap ]"--/multimap A:--> -<!ENTITY nearr SDATA "[nearr ]"--/nearrow A: NE pointing arrow --> -<!ENTITY nlArr SDATA "[nlArr ]"--/nLeftarrow A: not implied by --> -<!ENTITY nlarr SDATA "[nlarr ]"--/nleftarrow A: not left arrow --> -<!ENTITY nhArr SDATA "[nhArr ]"--/nLeftrightarrow A: not l&r dbl arr --> -<!ENTITY nharr SDATA "[nharr ]"--/nleftrightarrow A: not l&r arrow --> -<!ENTITY nrarr SDATA "[nrarr ]"--/nrightarrow A: not right arrow --> -<!ENTITY nrArr SDATA "[nrArr ]"--/nRightarrow A: not implies --> -<!ENTITY nwarr SDATA "[nwarr ]"--/nwarrow A: NW pointing arrow --> -<!ENTITY olarr SDATA "[olarr ]"--/circlearrowleft A: l arr in circle --> -<!ENTITY orarr SDATA "[orarr ]"--/circlearrowright A: r arr in circle --> -<!ENTITY rAarr SDATA "[rAarr ]"--/Rrightarrow A: right triple arrow --> -<!ENTITY Rarr SDATA "[Rarr ]"--/twoheadrightarrow A:--> -<!ENTITY rarr2 SDATA "[rarr2 ]"--/rightrightarrows A: two rt arrows --> -<!ENTITY rarrhk SDATA "[rarrhk]"--/hookrightarrow A: rt arrow-hooked --> -<!ENTITY rarrlp SDATA "[rarrlp]"--/looparrowright A: rt arrow-looped --> -<!ENTITY rarrtl SDATA "[rarrtl]"--/rightarrowtail A: rt arrow-tailed --> -<!ENTITY rarrw SDATA "[rarrw ]"--/squigarrowright A: rt arrow-wavy --> -<!ENTITY rhard SDATA "[rhard ]"--/rightharpoondown A: rt harpoon-down --> -<!ENTITY rharu SDATA "[rharu ]"--/rightharpoonup A: rt harpoon-up --> -<!ENTITY rsh SDATA "[rsh ]"--/Rsh A:--> -<!ENTITY drarr SDATA "[drarr ]"--/searrow A: downward rt arrow --> -<!ENTITY dlarr SDATA "[dlarr ]"--/swarrow A: downward l arrow --> -<!ENTITY uArr SDATA "[uArr ]"--/Uparrow A: up dbl arrow --> -<!ENTITY uarr2 SDATA "[uarr2 ]"--/upuparrows A: two up arrows --> -<!ENTITY vArr SDATA "[vArr ]"--/Updownarrow A: up&down dbl arrow --> -<!ENTITY varr SDATA "[varr ]"--/updownarrow A: up&down arrow --> -<!ENTITY uharl SDATA "[uharl ]"--/upleftharpoon A: up harpoon-left --> -<!ENTITY uharr SDATA "[uharr ]"--/uprightharpoon A: up harp-r--> -<!ENTITY xlArr SDATA "[xlArr ]"--/Longleftarrow A: long l dbl arrow --> -<!ENTITY xhArr SDATA "[xhArr ]"--/Longleftrightarrow A: long l&r dbl arr--> -<!ENTITY xharr SDATA "[xharr ]"--/longleftrightarrow A: long l&r arr --> -<!ENTITY xrArr SDATA "[xrArr ]"--/Longrightarrow A: long rt dbl arr -->
--- a/etc/sgml/ISO_8879=1986/entities/ISOamsb Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsb PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Binary Operators//EN"> - %ISOamsb; ---> -<!ENTITY amalg SDATA "[amalg ]"--/amalg B: amalgamation or coproduct--> -<!ENTITY Barwed SDATA "[Barwed]"--/doublebarwedge B: log and, dbl bar--> -<!ENTITY barwed SDATA "[barwed]"--/barwedge B: logical and, bar above--> -<!ENTITY Cap SDATA "[Cap ]"--/Cap /doublecap B: dbl intersection--> -<!ENTITY Cup SDATA "[Cup ]"--/Cup /doublecup B: dbl union--> -<!ENTITY cuvee SDATA "[cuvee ]"--/curlyvee B: curly logical or--> -<!ENTITY cuwed SDATA "[cuwed ]"--/curlywedge B: curly logical and--> -<!ENTITY diam SDATA "[diam ]"--/diamond B: open diamond--> -<!ENTITY divonx SDATA "[divonx]"--/divideontimes B: division on times--> -<!ENTITY intcal SDATA "[intcal]"--/intercal B: intercal--> -<!ENTITY lthree SDATA "[lthree]"--/leftthreetimes B:--> -<!ENTITY ltimes SDATA "[ltimes]"--/ltimes B: times sign, left closed--> -<!ENTITY minusb SDATA "[minusb]"--/boxminus B: minus sign in box--> -<!ENTITY oast SDATA "[oast ]"--/circledast B: asterisk in circle--> -<!ENTITY ocir SDATA "[ocir ]"--/circledcirc B: open dot in circle--> -<!ENTITY odash SDATA "[odash ]"--/circleddash B: hyphen in circle--> -<!ENTITY odot SDATA "[odot ]"--/odot B: middle dot in circle--> -<!ENTITY ominus SDATA "[ominus]"--/ominus B: minus sign in circle--> -<!ENTITY oplus SDATA "[oplus ]"--/oplus B: plus sign in circle--> -<!ENTITY osol SDATA "[osol ]"--/oslash B: solidus in circle--> -<!ENTITY otimes SDATA "[otimes]"--/otimes B: multiply sign in circle--> -<!ENTITY plusb SDATA "[plusb ]"--/boxplus B: plus sign in box--> -<!ENTITY plusdo SDATA "[plusdo]"--/dotplus B: plus sign, dot above--> -<!ENTITY rthree SDATA "[rthree]"--/rightthreetimes B:--> -<!ENTITY rtimes SDATA "[rtimes]"--/rtimes B: times sign, right closed--> -<!ENTITY sdot SDATA "[sdot ]"--/cdot B: small middle dot--> -<!ENTITY sdotb SDATA "[sdotb ]"--/dotsquare /boxdot B: small dot in box--> -<!ENTITY setmn SDATA "[setmn ]"--/setminus B: reverse solidus--> -<!ENTITY sqcap SDATA "[sqcap ]"--/sqcap B: square intersection--> -<!ENTITY sqcup SDATA "[sqcup ]"--/sqcup B: square union--> -<!ENTITY ssetmn SDATA "[ssetmn]"--/smallsetminus B: sm reverse solidus--> -<!ENTITY sstarf SDATA "[sstarf]"--/star B: small star, filled--> -<!ENTITY timesb SDATA "[timesb]"--/boxtimes B: multiply sign in box--> -<!ENTITY top SDATA "[top ]"--/top B: inverted perpendicular--> -<!ENTITY uplus SDATA "[uplus ]"--/uplus B: plus sign in union--> -<!ENTITY wreath SDATA "[wreath]"--/wr B: wreath product--> -<!ENTITY xcirc SDATA "[xcirc ]"--/bigcirc B: large circle--> -<!ENTITY xdtri SDATA "[xdtri ]"--/bigtriangledown B: big dn tri, open--> -<!ENTITY xutri SDATA "[xutri ]"--/bigtriangleup B: big up tri, open--> -<!ENTITY coprod SDATA "[coprod]"--/coprod L: coproduct operator--> -<!ENTITY prod SDATA "[prod ]"--/prod L: product operator--> -<!ENTITY sum SDATA "[sum ]"--/sum L: summation operator-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOamsc Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsc PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Delimiters//EN"> - %ISOamsc; ---> -<!ENTITY rceil SDATA "[rceil ]"--/rceil C: right ceiling--> -<!ENTITY rfloor SDATA "[rfloor]"--/rfloor C: right floor--> -<!ENTITY rpargt SDATA "[rpargt]"--/rightparengtr C: right paren, gt--> -<!ENTITY urcorn SDATA "[urcorn]"--/urcorner C: upper right corner--> -<!ENTITY drcorn SDATA "[drcorn]"--/lrcorner C: downward right corner--> -<!ENTITY lceil SDATA "[lceil ]"--/lceil O: left ceiling--> -<!ENTITY lfloor SDATA "[lfloor]"--/lfloor O: left floor--> -<!ENTITY lpargt SDATA "[lpargt]"--/leftparengtr O: left parenthesis, gt--> -<!ENTITY ulcorn SDATA "[ulcorn]"--/ulcorner O: upper left corner--> -<!ENTITY dlcorn SDATA "[dlcorn]"--/llcorner O: downward left corner-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOamsn Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsn PUBLIC - "ISO 8879:1986//ENTITIES - Added Math Symbols: Negated Relations//EN"> - %ISOamsn; ---> -<!ENTITY gnap SDATA "[gnap ]"--/gnapprox N: greater, not approximate--> -<!ENTITY gne SDATA "[gne ]"--/gneq N: greater, not equals--> -<!ENTITY gnE SDATA "[gnE ]"--/gneqq N: greater, not dbl equals--> -<!ENTITY gnsim SDATA "[gnsim ]"--/gnsim N: greater, not similar--> -<!ENTITY gvnE SDATA "[gvnE ]"--/gvertneqq N: gt, vert, not dbl eq--> -<!ENTITY lnap SDATA "[lnap ]"--/lnapprox N: less, not approximate--> -<!ENTITY lnE SDATA "[lnE ]"--/lneqq N: less, not double equals--> -<!ENTITY lne SDATA "[lne ]"--/lneq N: less, not equals--> -<!ENTITY lnsim SDATA "[lnsim ]"--/lnsim N: less, not similar--> -<!ENTITY lvnE SDATA "[lvnE ]"--/lvertneqq N: less, vert, not dbl eq--> -<!ENTITY nap SDATA "[nap ]"--/napprox N: not approximate--> -<!ENTITY ncong SDATA "[ncong ]"--/ncong N: not congruent with--> -<!ENTITY nequiv SDATA "[nequiv]"--/nequiv N: not identical with--> -<!ENTITY ngE SDATA "[ngE ]"--/ngeqq N: not greater, dbl equals--> -<!ENTITY nge SDATA "[nge ]"--/ngeq N: not greater-than-or-equal--> -<!ENTITY nges SDATA "[nges ]"--/ngeqslant N: not gt-or-eq, slanted--> -<!ENTITY ngt SDATA "[ngt ]"--/ngtr N: not greater-than--> -<!ENTITY nle SDATA "[nle ]"--/nleq N: not less-than-or-equal--> -<!ENTITY nlE SDATA "[nlE ]"--/nleqq N: not less, dbl equals--> -<!ENTITY nles SDATA "[nles ]"--/nleqslant N: not less-or-eq, slant--> -<!ENTITY nlt SDATA "[nlt ]"--/nless N: not less-than--> -<!ENTITY nltri SDATA "[nltri ]"--/ntriangleleft N: not left triangle--> -<!ENTITY nltrie SDATA "[nltrie]"--/ntrianglelefteq N: not l tri, eq--> -<!ENTITY nmid SDATA "[nmid ]"--/nmid--> -<!ENTITY npar SDATA "[npar ]"--/nparallel N: not parallel--> -<!ENTITY npr SDATA "[npr ]"--/nprec N: not precedes--> -<!ENTITY npre SDATA "[npre ]"--/npreceq N: not precedes, equals--> -<!ENTITY nrtri SDATA "[nrtri ]"--/ntriangleright N: not rt triangle--> -<!ENTITY nrtrie SDATA "[nrtrie]"--/ntrianglerighteq N: not r tri, eq--> -<!ENTITY nsc SDATA "[nsc ]"--/nsucc N: not succeeds--> -<!ENTITY nsce SDATA "[nsce ]"--/nsucceq N: not succeeds, equals--> -<!ENTITY nsim SDATA "[nsim ]"--/nsim N: not similar--> -<!ENTITY nsime SDATA "[nsime ]"--/nsimeq N: not similar, equals--> -<!ENTITY nsmid SDATA "[nsmid ]"--/nshortmid--> -<!ENTITY nspar SDATA "[nspar ]"--/nshortparallel N: not short par--> -<!ENTITY nsub SDATA "[nsub ]"--/nsubset N: not subset--> -<!ENTITY nsube SDATA "[nsube ]"--/nsubseteq N: not subset, equals--> -<!ENTITY nsubE SDATA "[nsubE ]"--/nsubseteqq N: not subset, dbl eq--> -<!ENTITY nsup SDATA "[nsup ]"--/nsupset N: not superset--> -<!ENTITY nsupE SDATA "[nsupE ]"--/nsupseteqq N: not superset, dbl eq--> -<!ENTITY nsupe SDATA "[nsupe ]"--/nsupseteq N: not superset, equals--> -<!ENTITY nvdash SDATA "[nvdash]"--/nvdash N: not vertical, dash--> -<!ENTITY nvDash SDATA "[nvDash]"--/nvDash N: not vertical, dbl dash--> -<!ENTITY nVDash SDATA "[nVDash]"--/nVDash N: not dbl vert, dbl dash--> -<!ENTITY nVdash SDATA "[nVdash]"--/nVdash N: not dbl vertical, dash--> -<!ENTITY prnap SDATA "[prnap ]"--/precnapprox N: precedes, not approx--> -<!ENTITY prnE SDATA "[prnE ]"--/precneqq N: precedes, not dbl eq--> -<!ENTITY prnsim SDATA "[prnsim]"--/precnsim N: precedes, not similar--> -<!ENTITY scnap SDATA "[scnap ]"--/succnapprox N: succeeds, not approx--> -<!ENTITY scnE SDATA "[scnE ]"--/succneqq N: succeeds, not dbl eq--> -<!ENTITY scnsim SDATA "[scnsim]"--/succnsim N: succeeds, not similar--> -<!ENTITY subne SDATA "[subne ]"--/subsetneq N: subset, not equals--> -<!ENTITY subnE SDATA "[subnE ]"--/subsetneqq N: subset, not dbl eq--> -<!ENTITY supne SDATA "[supne ]"--/supsetneq N: superset, not equals--> -<!ENTITY supnE SDATA "[supnE ]"--/supsetneqq N: superset, not dbl eq--> -<!ENTITY vsubnE SDATA "[vsubnE]"--/subsetneqq N: subset not dbl eq, var--> -<!ENTITY vsubne SDATA "[vsubne]"--/subsetneq N: subset, not eq, var--> -<!ENTITY vsupne SDATA "[vsupne]"--/supsetneq N: superset, not eq, var--> -<!ENTITY vsupnE SDATA "[vsupnE]"--/supsetneqq N: super not dbl eq, var-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOamso Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamso PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Ordinary//EN"> - %ISOamso; ---> -<!ENTITY ang SDATA "[ang ]"--/angle - angle--> -<!ENTITY angmsd SDATA "[angmsd]"--/measuredangle - angle-measured--> -<!ENTITY beth SDATA "[beth ]"--/beth - beth, Hebrew--> -<!ENTITY bprime SDATA "[bprime]"--/backprime - reverse prime--> -<!ENTITY comp SDATA "[comp ]"--/complement - complement sign--> -<!ENTITY daleth SDATA "[daleth]"--/daleth - daleth, Hebrew--> -<!ENTITY ell SDATA "[ell ]"--/ell - cursive small l--> -<!ENTITY empty SDATA "[empty ]"--/emptyset /varnothing =small o, slash--> -<!ENTITY gimel SDATA "[gimel ]"--/gimel - gimel, Hebrew--> -<!ENTITY image SDATA "[image ]"--/Im - imaginary--> -<!ENTITY inodot SDATA "[inodot]"--/imath =small i, no dot--> -<!ENTITY jnodot SDATA "[jnodot]"--/jmath - small j, no dot--> -<!ENTITY nexist SDATA "[nexist]"--/nexists - negated exists--> -<!ENTITY oS SDATA "[oS ]"--/circledS - capital S in circle--> -<!ENTITY planck SDATA "[planck]"--/hbar /hslash - Planck's over 2pi--> -<!ENTITY real SDATA "[real ]"--/Re - real--> -<!ENTITY sbsol SDATA "[sbsol ]"--/sbs - short reverse solidus--> -<!ENTITY vprime SDATA "[vprime]"--/varprime - prime, variant--> -<!ENTITY weierp SDATA "[weierp]"--/wp - Weierstrass p-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOamsr Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOamsr PUBLIC - "ISO 8879:1986//ENTITIES Added Math Symbols: Relations//EN"> - %ISOamsr; ---> -<!ENTITY ape SDATA "[ape ]"--/approxeq R: approximate, equals--> -<!ENTITY asymp SDATA "[asymp ]"--/asymp R: asymptotically equal to--> -<!ENTITY bcong SDATA "[bcong ]"--/backcong R: reverse congruent--> -<!ENTITY bepsi SDATA "[bepsi ]"--/backepsilon R: such that--> -<!ENTITY bowtie SDATA "[bowtie]"--/bowtie R:--> -<!ENTITY bsim SDATA "[bsim ]"--/backsim R: reverse similar--> -<!ENTITY bsime SDATA "[bsime ]"--/backsimeq R: reverse similar, eq--> -<!ENTITY bump SDATA "[bump ]"--/Bumpeq R: bumpy equals--> -<!ENTITY bumpe SDATA "[bumpe ]"--/bumpeq R: bumpy equals, equals--> -<!ENTITY cire SDATA "[cire ]"--/circeq R: circle, equals--> -<!ENTITY colone SDATA "[colone]"--/coloneq R: colon, equals--> -<!ENTITY cuepr SDATA "[cuepr ]"--/curlyeqprec R: curly eq, precedes--> -<!ENTITY cuesc SDATA "[cuesc ]"--/curlyeqsucc R: curly eq, succeeds--> -<!ENTITY cupre SDATA "[cupre ]"--/curlypreceq R: curly precedes, eq--> -<!ENTITY dashv SDATA "[dashv ]"--/dashv R: dash, vertical--> -<!ENTITY ecir SDATA "[ecir ]"--/eqcirc R: circle on equals sign--> -<!ENTITY ecolon SDATA "[ecolon]"--/eqcolon R: equals, colon--> -<!ENTITY eDot SDATA "[eDot ]"--/doteqdot /Doteq R: eq, even dots--> -<!ENTITY esdot SDATA "[esdot ]"--/doteq R: equals, single dot above--> -<!ENTITY efDot SDATA "[efDot ]"--/fallingdotseq R: eq, falling dots--> -<!ENTITY egs SDATA "[egs ]"--/eqslantgtr R: equal-or-gtr, slanted--> -<!ENTITY els SDATA "[els ]"--/eqslantless R: eq-or-less, slanted--> -<!ENTITY erDot SDATA "[erDot ]"--/risingdotseq R: eq, rising dots--> -<!ENTITY fork SDATA "[fork ]"--/pitchfork R: pitchfork--> -<!ENTITY frown SDATA "[frown ]"--/frown R: down curve--> -<!ENTITY gap SDATA "[gap ]"--/gtrapprox R: greater, approximate--> -<!ENTITY gsdot SDATA "[gsdot ]"--/gtrdot R: greater than, single dot--> -<!ENTITY gE SDATA "[gE ]"--/geqq R: greater, double equals--> -<!ENTITY gel SDATA "[gel ]"--/gtreqless R: greater, equals, less--> -<!ENTITY gEl SDATA "[gEl ]"--/gtreqqless R: gt, dbl equals, less--> -<!ENTITY ges SDATA "[ges ]"--/geqslant R: gt-or-equal, slanted--> -<!ENTITY Gg SDATA "[Gg ]"--/ggg /Gg /gggtr R: triple gtr-than--> -<!ENTITY gl SDATA "[gl ]"--/gtrless R: greater, less--> -<!ENTITY gsim SDATA "[gsim ]"--/gtrsim R: greater, similar--> -<!ENTITY Gt SDATA "[Gt ]"--/gg R: dbl greater-than sign--> -<!ENTITY lap SDATA "[lap ]"--/lessapprox R: less, approximate--> -<!ENTITY ldot SDATA "[ldot ]"--/lessdot R: less than, with dot--> -<!ENTITY lE SDATA "[lE ]"--/leqq R: less, double equals--> -<!ENTITY lEg SDATA "[lEg ]"--/lesseqqgtr R: less, dbl eq, greater--> -<!ENTITY leg SDATA "[leg ]"--/lesseqgtr R: less, eq, greater--> -<!ENTITY les SDATA "[les ]"--/leqslant R: less-than-or-eq, slant--> -<!ENTITY lg SDATA "[lg ]"--/lessgtr R: less, greater--> -<!ENTITY Ll SDATA "[Ll ]"--/Ll /lll /llless R: triple less-than--> -<!ENTITY lsim SDATA "[lsim ]"--/lesssim R: less, similar--> -<!ENTITY Lt SDATA "[Lt ]"--/ll R: double less-than sign--> -<!ENTITY ltrie SDATA "[ltrie ]"--/trianglelefteq R: left triangle, eq--> -<!ENTITY mid SDATA "[mid ]"--/mid R:--> -<!ENTITY models SDATA "[models]"--/models R:--> -<!ENTITY pr SDATA "[pr ]"--/prec R: precedes--> -<!ENTITY prap SDATA "[prap ]"--/precapprox R: precedes, approximate--> -<!ENTITY pre SDATA "[pre ]"--/preceq R: precedes, equals--> -<!ENTITY prsim SDATA "[prsim ]"--/precsim R: precedes, similar--> -<!ENTITY rtrie SDATA "[rtrie ]"--/trianglerighteq R: right tri, eq--> -<!ENTITY samalg SDATA "[samalg]"--/smallamalg R: small amalg--> -<!ENTITY sc SDATA "[sc ]"--/succ R: succeeds--> -<!ENTITY scap SDATA "[scap ]"--/succapprox R: succeeds, approximate--> -<!ENTITY sccue SDATA "[sccue ]"--/succcurlyeq R: succeeds, curly eq--> -<!ENTITY sce SDATA "[sce ]"--/succeq R: succeeds, equals--> -<!ENTITY scsim SDATA "[scsim ]"--/succsim R: succeeds, similar--> -<!ENTITY sfrown SDATA "[sfrown]"--/smallfrown R: small down curve--> -<!ENTITY smid SDATA "[smid ]"--/shortmid R:--> -<!ENTITY smile SDATA "[smile ]"--/smile R: up curve--> -<!ENTITY spar SDATA "[spar ]"--/shortparallel R: short parallel--> -<!ENTITY sqsub SDATA "[sqsub ]"--/sqsubset R: square subset--> -<!ENTITY sqsube SDATA "[sqsube]"--/sqsubseteq R: square subset, equals--> -<!ENTITY sqsup SDATA "[sqsup ]"--/sqsupset R: square superset--> -<!ENTITY sqsupe SDATA "[sqsupe]"--/sqsupseteq R: square superset, eq--> -<!ENTITY ssmile SDATA "[ssmile]"--/smallsmile R: small up curve--> -<!ENTITY Sub SDATA "[Sub ]"--/Subset R: double subset--> -<!ENTITY subE SDATA "[subE ]"--/subseteqq R: subset, dbl equals--> -<!ENTITY Sup SDATA "[Sup ]"--/Supset R: dbl superset--> -<!ENTITY supE SDATA "[supE ]"--/supseteqq R: superset, dbl equals--> -<!ENTITY thkap SDATA "[thkap ]"--/thickapprox R: thick approximate--> -<!ENTITY thksim SDATA "[thksim]"--/thicksim R: thick similar--> -<!ENTITY trie SDATA "[trie ]"--/triangleq R: triangle, equals--> -<!ENTITY twixt SDATA "[twixt ]"--/between R: between--> -<!ENTITY vdash SDATA "[vdash ]"--/vdash R: vertical, dash--> -<!ENTITY Vdash SDATA "[Vdash ]"--/Vdash R: dbl vertical, dash--> -<!ENTITY vDash SDATA "[vDash ]"--/vDash R: vertical, dbl dash--> -<!ENTITY veebar SDATA "[veebar]"--/veebar R: logical or, bar below--> -<!ENTITY vltri SDATA "[vltri ]"--/vartriangleleft R: l tri, open, var--> -<!ENTITY vprop SDATA "[vprop ]"--/varpropto R: proportional, variant--> -<!ENTITY vrtri SDATA "[vrtri ]"--/vartriangleright R: r tri, open, var--> -<!ENTITY Vvdash SDATA "[Vvdash]"--/Vvdash R: triple vertical, dash-->
--- a/etc/sgml/ISO_8879=1986/entities/ISObox Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISObox PUBLIC - "ISO 8879:1986//ENTITIES Box and Line Drawing//EN"> - %ISObox; ---> -<!-- All names are in the form: box1234, where: - box = constants that identify a box drawing entity. - 1&2 = v, V, u, U, d, D, Ud, or uD, as follows: - v = vertical line for full height. - u = upper half of vertical line. - d = downward (lower) half of vertical line. - 3&4 = h, H, l, L, r, R, Lr, or lR, as follows: - h = horizontal line for full width. - l = left half of horizontal line. - r = right half of horizontal line. - In all cases, an upper-case letter means a double or heavy line. ---> -<!ENTITY boxh SDATA "[boxh ]"--horizontal line --> -<!ENTITY boxv SDATA "[boxv ]"--vertical line--> -<!ENTITY boxur SDATA "[boxur ]"--upper right quadrant--> -<!ENTITY boxul SDATA "[boxul ]"--upper left quadrant--> -<!ENTITY boxdl SDATA "[boxdl ]"--lower left quadrant--> -<!ENTITY boxdr SDATA "[boxdr ]"--lower right quadrant--> -<!ENTITY boxvr SDATA "[boxvr ]"--upper and lower right quadrants--> -<!ENTITY boxhu SDATA "[boxhu ]"--upper left and right quadrants--> -<!ENTITY boxvl SDATA "[boxvl ]"--upper and lower left quadrants--> -<!ENTITY boxhd SDATA "[boxhd ]"--lower left and right quadrants--> -<!ENTITY boxvh SDATA "[boxvh ]"--all four quadrants--> -<!ENTITY boxvR SDATA "[boxvR ]"--upper and lower right quadrants--> -<!ENTITY boxhU SDATA "[boxhU ]"--upper left and right quadrants--> -<!ENTITY boxvL SDATA "[boxvL ]"--upper and lower left quadrants--> -<!ENTITY boxhD SDATA "[boxhD ]"--lower left and right quadrants--> -<!ENTITY boxvH SDATA "[boxvH ]"--all four quadrants--> -<!ENTITY boxH SDATA "[boxH ]"--horizontal line--> -<!ENTITY boxV SDATA "[boxV ]"--vertical line--> -<!ENTITY boxUR SDATA "[boxUR ]"--upper right quadrant--> -<!ENTITY boxUL SDATA "[boxUL ]"--upper left quadrant--> -<!ENTITY boxDL SDATA "[boxDL ]"--lower left quadrant--> -<!ENTITY boxDR SDATA "[boxDR ]"--lower right quadrant--> -<!ENTITY boxVR SDATA "[boxVR ]"--upper and lower right quadrants--> -<!ENTITY boxHU SDATA "[boxHU ]"--upper left and right quadrants--> -<!ENTITY boxVL SDATA "[boxVL ]"--upper and lower left quadrants--> -<!ENTITY boxHD SDATA "[boxHD ]"--lower left and right quadrants--> -<!ENTITY boxVH SDATA "[boxVH ]"--all four quadrants--> -<!ENTITY boxVr SDATA "[boxVr ]"--upper and lower right quadrants--> -<!ENTITY boxHu SDATA "[boxHu ]"--upper left and right quadrants--> -<!ENTITY boxVl SDATA "[boxVl ]"--upper and lower left quadrants--> -<!ENTITY boxHd SDATA "[boxHd ]"--lower left and right quadrants--> -<!ENTITY boxVh SDATA "[boxVh ]"--all four quadrants--> -<!ENTITY boxuR SDATA "[boxuR ]"--upper right quadrant--> -<!ENTITY boxUl SDATA "[boxUl ]"--upper left quadrant--> -<!ENTITY boxdL SDATA "[boxdL ]"--lower left quadrant--> -<!ENTITY boxDr SDATA "[boxDr ]"--lower right quadrant--> -<!ENTITY boxUr SDATA "[boxUr ]"--upper right quadrant--> -<!ENTITY boxuL SDATA "[boxuL ]"--upper left quadrant--> -<!ENTITY boxDl SDATA "[boxDl ]"--lower left quadrant--> -<!ENTITY boxdR SDATA "[boxdR ]"--lower right quadrant-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOcyr1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOcyr1 PUBLIC - "ISO 8879:1986//ENTITIES Russian Cyrillic//EN"> - %ISOcyr1; ---> -<!ENTITY acy SDATA "[acy ]"--=small a, Cyrillic--> -<!ENTITY Acy SDATA "[Acy ]"--=capital A, Cyrillic--> -<!ENTITY bcy SDATA "[bcy ]"--=small be, Cyrillic--> -<!ENTITY Bcy SDATA "[Bcy ]"--=capital BE, Cyrillic--> -<!ENTITY vcy SDATA "[vcy ]"--=small ve, Cyrillic--> -<!ENTITY Vcy SDATA "[Vcy ]"--=capital VE, Cyrillic--> -<!ENTITY gcy SDATA "[gcy ]"--=small ghe, Cyrillic--> -<!ENTITY Gcy SDATA "[Gcy ]"--=capital GHE, Cyrillic--> -<!ENTITY dcy SDATA "[dcy ]"--=small de, Cyrillic--> -<!ENTITY Dcy SDATA "[Dcy ]"--=capital DE, Cyrillic--> -<!ENTITY iecy SDATA "[iecy ]"--=small ie, Cyrillic--> -<!ENTITY IEcy SDATA "[IEcy ]"--=capital IE, Cyrillic--> -<!ENTITY iocy SDATA "[iocy ]"--=small io, Russian--> -<!ENTITY IOcy SDATA "[IOcy ]"--=capital IO, Russian--> -<!ENTITY zhcy SDATA "[zhcy ]"--=small zhe, Cyrillic--> -<!ENTITY ZHcy SDATA "[ZHcy ]"--=capital ZHE, Cyrillic--> -<!ENTITY zcy SDATA "[zcy ]"--=small ze, Cyrillic--> -<!ENTITY Zcy SDATA "[Zcy ]"--=capital ZE, Cyrillic--> -<!ENTITY icy SDATA "[icy ]"--=small i, Cyrillic--> -<!ENTITY Icy SDATA "[Icy ]"--=capital I, Cyrillic--> -<!ENTITY jcy SDATA "[jcy ]"--=small short i, Cyrillic--> -<!ENTITY Jcy SDATA "[Jcy ]"--=capital short I, Cyrillic--> -<!ENTITY kcy SDATA "[kcy ]"--=small ka, Cyrillic--> -<!ENTITY Kcy SDATA "[Kcy ]"--=capital KA, Cyrillic--> -<!ENTITY lcy SDATA "[lcy ]"--=small el, Cyrillic--> -<!ENTITY Lcy SDATA "[Lcy ]"--=capital EL, Cyrillic--> -<!ENTITY mcy SDATA "[mcy ]"--=small em, Cyrillic--> -<!ENTITY Mcy SDATA "[Mcy ]"--=capital EM, Cyrillic--> -<!ENTITY ncy SDATA "[ncy ]"--=small en, Cyrillic--> -<!ENTITY Ncy SDATA "[Ncy ]"--=capital EN, Cyrillic--> -<!ENTITY ocy SDATA "[ocy ]"--=small o, Cyrillic--> -<!ENTITY Ocy SDATA "[Ocy ]"--=capital O, Cyrillic--> -<!ENTITY pcy SDATA "[pcy ]"--=small pe, Cyrillic--> -<!ENTITY Pcy SDATA "[Pcy ]"--=capital PE, Cyrillic--> -<!ENTITY rcy SDATA "[rcy ]"--=small er, Cyrillic--> -<!ENTITY Rcy SDATA "[Rcy ]"--=capital ER, Cyrillic--> -<!ENTITY scy SDATA "[scy ]"--=small es, Cyrillic--> -<!ENTITY Scy SDATA "[Scy ]"--=capital ES, Cyrillic--> -<!ENTITY tcy SDATA "[tcy ]"--=small te, Cyrillic--> -<!ENTITY Tcy SDATA "[Tcy ]"--=capital TE, Cyrillic--> -<!ENTITY ucy SDATA "[ucy ]"--=small u, Cyrillic--> -<!ENTITY Ucy SDATA "[Ucy ]"--=capital U, Cyrillic--> -<!ENTITY fcy SDATA "[fcy ]"--=small ef, Cyrillic--> -<!ENTITY Fcy SDATA "[Fcy ]"--=capital EF, Cyrillic--> -<!ENTITY khcy SDATA "[khcy ]"--=small ha, Cyrillic--> -<!ENTITY KHcy SDATA "[KHcy ]"--=capital HA, Cyrillic--> -<!ENTITY tscy SDATA "[tscy ]"--=small tse, Cyrillic--> -<!ENTITY TScy SDATA "[TScy ]"--=capital TSE, Cyrillic--> -<!ENTITY chcy SDATA "[chcy ]"--=small che, Cyrillic--> -<!ENTITY CHcy SDATA "[CHcy ]"--=capital CHE, Cyrillic--> -<!ENTITY shcy SDATA "[shcy ]"--=small sha, Cyrillic--> -<!ENTITY SHcy SDATA "[SHcy ]"--=capital SHA, Cyrillic--> -<!ENTITY shchcy SDATA "[shchcy]"--=small shcha, Cyrillic--> -<!ENTITY SHCHcy SDATA "[SHCHcy]"--=capital SHCHA, Cyrillic--> -<!ENTITY hardcy SDATA "[hardcy]"--=small hard sign, Cyrillic--> -<!ENTITY HARDcy SDATA "[HARDcy]"--=capital HARD sign, Cyrillic--> -<!ENTITY ycy SDATA "[ycy ]"--=small yeru, Cyrillic--> -<!ENTITY Ycy SDATA "[Ycy ]"--=capital YERU, Cyrillic--> -<!ENTITY softcy SDATA "[softcy]"--=small soft sign, Cyrillic--> -<!ENTITY SOFTcy SDATA "[SOFTcy]"--=capital SOFT sign, Cyrillic--> -<!ENTITY ecy SDATA "[ecy ]"--=small e, Cyrillic--> -<!ENTITY Ecy SDATA "[Ecy ]"--=capital E, Cyrillic--> -<!ENTITY yucy SDATA "[yucy ]"--=small yu, Cyrillic--> -<!ENTITY YUcy SDATA "[YUcy ]"--=capital YU, Cyrillic--> -<!ENTITY yacy SDATA "[yacy ]"--=small ya, Cyrillic--> -<!ENTITY YAcy SDATA "[YAcy ]"--=capital YA, Cyrillic--> -<!ENTITY numero SDATA "[numero]"--=numero sign-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOcyr2 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOcyr2 PUBLIC - "ISO 8879:1986//ENTITIES Non-Russian Cyrillic//EN"> - %ISOcyr2; ---> -<!ENTITY djcy SDATA "[djcy ]"--=small dje, Serbian--> -<!ENTITY DJcy SDATA "[DJcy ]"--=capital DJE, Serbian--> -<!ENTITY gjcy SDATA "[gjcy ]"--=small gje, Macedonian--> -<!ENTITY GJcy SDATA "[GJcy ]"--=capital GJE Macedonian--> -<!ENTITY jukcy SDATA "[jukcy ]"--=small je, Ukrainian--> -<!ENTITY Jukcy SDATA "[Jukcy ]"--=capital JE, Ukrainian--> -<!ENTITY dscy SDATA "[dscy ]"--=small dse, Macedonian--> -<!ENTITY DScy SDATA "[DScy ]"--=capital DSE, Macedonian--> -<!ENTITY iukcy SDATA "[iukcy ]"--=small i, Ukrainian--> -<!ENTITY Iukcy SDATA "[Iukcy ]"--=capital I, Ukrainian--> -<!ENTITY yicy SDATA "[yicy ]"--=small yi, Ukrainian--> -<!ENTITY YIcy SDATA "[YIcy ]"--=capital YI, Ukrainian--> -<!ENTITY jsercy SDATA "[jsercy]"--=small je, Serbian--> -<!ENTITY Jsercy SDATA "[Jsercy]"--=capital JE, Serbian--> -<!ENTITY ljcy SDATA "[ljcy ]"--=small lje, Serbian--> -<!ENTITY LJcy SDATA "[LJcy ]"--=capital LJE, Serbian--> -<!ENTITY njcy SDATA "[njcy ]"--=small nje, Serbian--> -<!ENTITY NJcy SDATA "[NJcy ]"--=capital NJE, Serbian--> -<!ENTITY tshcy SDATA "[tshcy ]"--=small tshe, Serbian--> -<!ENTITY TSHcy SDATA "[TSHcy ]"--=capital TSHE, Serbian--> -<!ENTITY kjcy SDATA "[kjcy ]"--=small kje Macedonian--> -<!ENTITY KJcy SDATA "[KJcy ]"--=capital KJE, Macedonian--> -<!ENTITY ubrcy SDATA "[ubrcy ]"--=small u, Byelorussian--> -<!ENTITY Ubrcy SDATA "[Ubrcy ]"--=capital U, Byelorussian--> -<!ENTITY dzcy SDATA "[dzcy ]"--=small dze, Serbian--> -<!ENTITY DZcy SDATA "[DZcy ]"--=capital dze, Serbian-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOdia Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOdia PUBLIC - "ISO 8879:1986//ENTITIES Diacritical Marks//EN"> - %ISOdia; ---> -<!ENTITY acute SDATA "[acute ]"--=acute accent--> -<!ENTITY breve SDATA "[breve ]"--=breve--> -<!ENTITY caron SDATA "[caron ]"--=caron--> -<!ENTITY cedil SDATA "[cedil ]"--=cedilla--> -<!ENTITY circ SDATA "[circ ]"--=circumflex accent--> -<!ENTITY dblac SDATA "[dblac ]"--=double acute accent--> -<!ENTITY die SDATA "[die ]"--=dieresis--> -<!ENTITY dot SDATA "[dot ]"--=dot above--> -<!ENTITY grave SDATA "[grave ]"--=grave accent--> -<!ENTITY macr SDATA "[macr ]"--=macron--> -<!ENTITY ogon SDATA "[ogon ]"--=ogonek--> -<!ENTITY ring SDATA "[ring ]"--=ring--> -<!ENTITY tilde SDATA "[tilde ]"--=tilde--> -<!ENTITY uml SDATA "[uml ]"--=umlaut mark-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOgrk1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOgrk1 PUBLIC - "ISO 8879:1986//ENTITIES Greek Letters//EN"> - %ISOgrk1; ---> -<!ENTITY agr SDATA "[agr ]"--=small alpha, Greek--> -<!ENTITY Agr SDATA "[Agr ]"--=capital Alpha, Greek--> -<!ENTITY bgr SDATA "[bgr ]"--=small beta, Greek--> -<!ENTITY Bgr SDATA "[Bgr ]"--=capital Beta, Greek--> -<!ENTITY ggr SDATA "[ggr ]"--=small gamma, Greek--> -<!ENTITY Ggr SDATA "[Ggr ]"--=capital Gamma, Greek--> -<!ENTITY dgr SDATA "[dgr ]"--=small delta, Greek--> -<!ENTITY Dgr SDATA "[Dgr ]"--=capital Delta, Greek--> -<!ENTITY egr SDATA "[egr ]"--=small epsilon, Greek--> -<!ENTITY Egr SDATA "[Egr ]"--=capital Epsilon, Greek--> -<!ENTITY zgr SDATA "[zgr ]"--=small zeta, Greek--> -<!ENTITY Zgr SDATA "[Zgr ]"--=capital Zeta, Greek--> -<!ENTITY eegr SDATA "[eegr ]"--=small eta, Greek--> -<!ENTITY EEgr SDATA "[EEgr ]"--=capital Eta, Greek--> -<!ENTITY thgr SDATA "[thgr ]"--=small theta, Greek--> -<!ENTITY THgr SDATA "[THgr ]"--=capital Theta, Greek--> -<!ENTITY igr SDATA "[igr ]"--=small iota, Greek--> -<!ENTITY Igr SDATA "[Igr ]"--=capital Iota, Greek--> -<!ENTITY kgr SDATA "[kgr ]"--=small kappa, Greek--> -<!ENTITY Kgr SDATA "[Kgr ]"--=capital Kappa, Greek--> -<!ENTITY lgr SDATA "[lgr ]"--=small lambda, Greek--> -<!ENTITY Lgr SDATA "[Lgr ]"--=capital Lambda, Greek--> -<!ENTITY mgr SDATA "[mgr ]"--=small mu, Greek--> -<!ENTITY Mgr SDATA "[Mgr ]"--=capital Mu, Greek--> -<!ENTITY ngr SDATA "[ngr ]"--=small nu, Greek--> -<!ENTITY Ngr SDATA "[Ngr ]"--=capital Nu, Greek--> -<!ENTITY xgr SDATA "[xgr ]"--=small xi, Greek--> -<!ENTITY Xgr SDATA "[Xgr ]"--=capital Xi, Greek--> -<!ENTITY ogr SDATA "[ogr ]"--=small omicron, Greek--> -<!ENTITY Ogr SDATA "[Ogr ]"--=capital Omicron, Greek--> -<!ENTITY pgr SDATA "[pgr ]"--=small pi, Greek--> -<!ENTITY Pgr SDATA "[Pgr ]"--=capital Pi, Greek--> -<!ENTITY rgr SDATA "[rgr ]"--=small rho, Greek--> -<!ENTITY Rgr SDATA "[Rgr ]"--=capital Rho, Greek--> -<!ENTITY sgr SDATA "[sgr ]"--=small sigma, Greek--> -<!ENTITY Sgr SDATA "[Sgr ]"--=capital Sigma, Greek--> -<!ENTITY sfgr SDATA "[sfgr ]"--=final small sigma, Greek--> -<!ENTITY tgr SDATA "[tgr ]"--=small tau, Greek--> -<!ENTITY Tgr SDATA "[Tgr ]"--=capital Tau, Greek--> -<!ENTITY ugr SDATA "[ugr ]"--=small upsilon, Greek--> -<!ENTITY Ugr SDATA "[Ugr ]"--=capital Upsilon, Greek--> -<!ENTITY phgr SDATA "[phgr ]"--=small phi, Greek--> -<!ENTITY PHgr SDATA "[PHgr ]"--=capital Phi, Greek--> -<!ENTITY khgr SDATA "[khgr ]"--=small chi, Greek--> -<!ENTITY KHgr SDATA "[KHgr ]"--=capital Chi, Greek--> -<!ENTITY psgr SDATA "[psgr ]"--=small psi, Greek--> -<!ENTITY PSgr SDATA "[PSgr ]"--=capital Psi, Greek--> -<!ENTITY ohgr SDATA "[ohgr ]"--=small omega, Greek--> -<!ENTITY OHgr SDATA "[OHgr ]"--=capital Omega, Greek-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOgrk2 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOgrk2 PUBLIC - "ISO 8879:1986//ENTITIES Monotoniko Greek//EN"> - %ISOgrk2; ---> -<!ENTITY aacgr SDATA "[aacgr ]"--=small alpha, accent, Greek--> -<!ENTITY Aacgr SDATA "[Aacgr ]"--=capital Alpha, accent, Greek--> -<!ENTITY eacgr SDATA "[eacgr ]"--=small epsilon, accent, Greek--> -<!ENTITY Eacgr SDATA "[Eacgr ]"--=capital Epsilon, accent, Greek--> -<!ENTITY eeacgr SDATA "[eeacgr]"--=small eta, accent, Greek--> -<!ENTITY EEacgr SDATA "[EEacgr]"--=capital Eta, accent, Greek--> -<!ENTITY idigr SDATA "[idigr ]"--=small iota, dieresis, Greek--> -<!ENTITY Idigr SDATA "[Idigr ]"--=capital Iota, dieresis, Greek--> -<!ENTITY iacgr SDATA "[iacgr ]"--=small iota, accent, Greek--> -<!ENTITY Iacgr SDATA "[Iacgr ]"--=capital Iota, accent, Greek--> -<!ENTITY idiagr SDATA "[idiagr]"--=small iota, dieresis, accent, Greek--> -<!ENTITY oacgr SDATA "[oacgr ]"--=small omicron, accent, Greek--> -<!ENTITY Oacgr SDATA "[Oacgr ]"--=capital Omicron, accent, Greek--> -<!ENTITY udigr SDATA "[udigr ]"--=small upsilon, dieresis, Greek--> -<!ENTITY Udigr SDATA "[Udigr ]"--=capital Upsilon, dieresis, Greek--> -<!ENTITY uacgr SDATA "[uacgr ]"--=small upsilon, accent, Greek--> -<!ENTITY Uacgr SDATA "[Uacgr ]"--=capital Upsilon, accent, Greek--> -<!ENTITY udiagr SDATA "[udiagr]"--=small upsilon, dieresis, accent, Greek--> -<!ENTITY ohacgr SDATA "[ohacgr]"--=small omega, accent, Greek--> -<!ENTITY OHacgr SDATA "[OHacgr]"--=capital Omega, accent, Greek-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOgrk3 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOgrk3 PUBLIC - "ISO 8879:1986//ENTITIES Greek Symbols//EN"> - %ISOgrk3; ---> -<!ENTITY alpha SDATA "[alpha ]"--=small alpha, Greek--> -<!ENTITY beta SDATA "[beta ]"--=small beta, Greek--> -<!ENTITY gamma SDATA "[gamma ]"--=small gamma, Greek--> -<!ENTITY Gamma SDATA "[Gamma ]"--=capital Gamma, Greek--> -<!ENTITY gammad SDATA "[gammad]"--/digamma--> -<!ENTITY delta SDATA "[delta ]"--=small delta, Greek--> -<!ENTITY Delta SDATA "[Delta ]"--=capital Delta, Greek--> -<!ENTITY epsi SDATA "[epsi ]"--=small epsilon, Greek--> -<!ENTITY epsiv SDATA "[epsiv ]"--/varepsilon--> -<!ENTITY epsis SDATA "[epsis ]"--/straightepsilon--> -<!ENTITY zeta SDATA "[zeta ]"--=small zeta, Greek--> -<!ENTITY eta SDATA "[eta ]"--=small eta, Greek--> -<!ENTITY thetas SDATA "[thetas]"--straight theta--> -<!ENTITY Theta SDATA "[Theta ]"--=capital Theta, Greek--> -<!ENTITY thetav SDATA "[thetav]"--/vartheta - curly or open theta--> -<!ENTITY iota SDATA "[iota ]"--=small iota, Greek--> -<!ENTITY kappa SDATA "[kappa ]"--=small kappa, Greek--> -<!ENTITY kappav SDATA "[kappav]"--/varkappa--> -<!ENTITY lambda SDATA "[lambda]"--=small lambda, Greek--> -<!ENTITY Lambda SDATA "[Lambda]"--=capital Lambda, Greek--> -<!ENTITY mu SDATA "[mu ]"--=small mu, Greek--> -<!ENTITY nu SDATA "[nu ]"--=small nu, Greek--> -<!ENTITY xi SDATA "[xi ]"--=small xi, Greek--> -<!ENTITY Xi SDATA "[Xi ]"--=capital Xi, Greek--> -<!ENTITY pi SDATA "[pi ]"--=small pi, Greek--> -<!ENTITY piv SDATA "[piv ]"--/varpi--> -<!ENTITY Pi SDATA "[Pi ]"--=capital Pi, Greek--> -<!ENTITY rho SDATA "[rho ]"--=small rho, Greek--> -<!ENTITY rhov SDATA "[rhov ]"--/varrho--> -<!ENTITY sigma SDATA "[sigma ]"--=small sigma, Greek--> -<!ENTITY Sigma SDATA "[Sigma ]"--=capital Sigma, Greek--> -<!ENTITY sigmav SDATA "[sigmav]"--/varsigma--> -<!ENTITY tau SDATA "[tau ]"--=small tau, Greek--> -<!ENTITY upsi SDATA "[upsi ]"--=small upsilon, Greek--> -<!ENTITY Upsi SDATA "[Upsi ]"--=capital Upsilon, Greek--> -<!ENTITY phis SDATA "[phis ]"--/straightphi - straight phi--> -<!ENTITY Phi SDATA "[Phi ]"--=capital Phi, Greek--> -<!ENTITY phiv SDATA "[phiv ]"--/varphi - curly or open phi--> -<!ENTITY chi SDATA "[chi ]"--=small chi, Greek--> -<!ENTITY psi SDATA "[psi ]"--=small psi, Greek--> -<!ENTITY Psi SDATA "[Psi ]"--=capital Psi, Greek--> -<!ENTITY omega SDATA "[omega ]"--=small omega, Greek--> -<!ENTITY Omega SDATA "[Omega ]"--=capital Omega, Greek-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOgrk4 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,53 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOgrk4 PUBLIC - "ISO 8879:1986//ENTITIES Alternative Greek Symbols//EN"> - %ISOgrk4; ---> -<!ENTITY b.alpha SDATA "[b.alpha ]"--=small alpha, Greek--> -<!ENTITY b.beta SDATA "[b.beta ]"--=small beta, Greek--> -<!ENTITY b.gamma SDATA "[b.gamma ]"--=small gamma, Greek--> -<!ENTITY b.Gamma SDATA "[b.Gamma ]"--=capital Gamma, Greek--> -<!ENTITY b.gammad SDATA "[b.gammad]"--/digamma--> -<!ENTITY b.delta SDATA "[b.delta ]"--=small delta, Greek--> -<!ENTITY b.Delta SDATA "[b.Delta ]"--=capital Delta, Greek--> -<!ENTITY b.epsi SDATA "[b.epsi ]"--=small epsilon, Greek--> -<!ENTITY b.epsiv SDATA "[b.epsiv ]"--/varepsilon--> -<!ENTITY b.epsis SDATA "[b.epsis ]"--/straightepsilon--> -<!ENTITY b.zeta SDATA "[b.zeta ]"--=small zeta, Greek--> -<!ENTITY b.eta SDATA "[b.eta ]"--=small eta, Greek--> -<!ENTITY b.thetas SDATA "[b.thetas]"--straight theta--> -<!ENTITY b.Theta SDATA "[b.Theta ]"--=capital Theta, Greek--> -<!ENTITY b.thetav SDATA "[b.thetav]"--/vartheta - curly or open theta--> -<!ENTITY b.iota SDATA "[b.iota ]"--=small iota, Greek--> -<!ENTITY b.kappa SDATA "[b.kappa ]"--=small kappa, Greek--> -<!ENTITY b.kappav SDATA "[b.kappav]"--/varkappa--> -<!ENTITY b.lambda SDATA "[b.lambda]"--=small lambda, Greek--> -<!ENTITY b.Lambda SDATA "[b.Lambda]"--=capital Lambda, Greek--> -<!ENTITY b.mu SDATA "[b.mu ]"--=small mu, Greek--> -<!ENTITY b.nu SDATA "[b.nu ]"--=small nu, Greek--> -<!ENTITY b.xi SDATA "[b.xi ]"--=small xi, Greek--> -<!ENTITY b.Xi SDATA "[b.Xi ]"--=capital Xi, Greek--> -<!ENTITY b.pi SDATA "[b.pi ]"--=small pi, Greek--> -<!ENTITY b.Pi SDATA "[b.Pi ]"--=capital Pi, Greek--> -<!ENTITY b.piv SDATA "[b.piv ]"--/varpi--> -<!ENTITY b.rho SDATA "[b.rho ]"--=small rho, Greek--> -<!ENTITY b.rhov SDATA "[b.rhov ]"--/varrho--> -<!ENTITY b.sigma SDATA "[b.sigma ]"--=small sigma, Greek--> -<!ENTITY b.Sigma SDATA "[b.Sigma ]"--=capital Sigma, Greek--> -<!ENTITY b.sigmav SDATA "[b.sigmav]"--/varsigma--> -<!ENTITY b.tau SDATA "[b.tau ]"--=small tau, Greek--> -<!ENTITY b.upsi SDATA "[b.upsi ]"--=small upsilon, Greek--> -<!ENTITY b.Upsi SDATA "[b.Upsi ]"--=capital Upsilon, Greek--> -<!ENTITY b.phis SDATA "[b.phis ]"--/straightphi - straight phi--> -<!ENTITY b.Phi SDATA "[b.Phi ]"--=capital Phi, Greek--> -<!ENTITY b.phiv SDATA "[b.phiv ]"--/varphi - curly or open phi--> -<!ENTITY b.chi SDATA "[b.chi ]"--=small chi, Greek--> -<!ENTITY b.psi SDATA "[b.psi ]"--=small psi, Greek--> -<!ENTITY b.Psi SDATA "[b.Psi ]"--=capital Psi, Greek--> -<!ENTITY b.omega SDATA "[b.omega ]"--=small omega, Greek--> -<!ENTITY b.Omega SDATA "[b.Omega ]"--=capital Omega, Greek-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOlat1 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOlat1 PUBLIC - "ISO 8879:1986//ENTITIES Added Latin 1//EN"> - %ISOlat1; ---> -<!ENTITY aacute SDATA "[aacute]"--=small a, acute accent--> -<!ENTITY Aacute SDATA "[Aacute]"--=capital A, acute accent--> -<!ENTITY acirc SDATA "[acirc ]"--=small a, circumflex accent--> -<!ENTITY Acirc SDATA "[Acirc ]"--=capital A, circumflex accent--> -<!ENTITY agrave SDATA "[agrave]"--=small a, grave accent--> -<!ENTITY Agrave SDATA "[Agrave]"--=capital A, grave accent--> -<!ENTITY aring SDATA "[aring ]"--=small a, ring--> -<!ENTITY Aring SDATA "[Aring ]"--=capital A, ring--> -<!ENTITY atilde SDATA "[atilde]"--=small a, tilde--> -<!ENTITY Atilde SDATA "[Atilde]"--=capital A, tilde--> -<!ENTITY auml SDATA "[auml ]"--=small a, dieresis or umlaut mark--> -<!ENTITY Auml SDATA "[Auml ]"--=capital A, dieresis or umlaut mark--> -<!ENTITY aelig SDATA "[aelig ]"--=small ae diphthong (ligature)--> -<!ENTITY AElig SDATA "[AElig ]"--=capital AE diphthong (ligature)--> -<!ENTITY ccedil SDATA "[ccedil]"--=small c, cedilla--> -<!ENTITY Ccedil SDATA "[Ccedil]"--=capital C, cedilla--> -<!ENTITY eth SDATA "[eth ]"--=small eth, Icelandic--> -<!ENTITY ETH SDATA "[ETH ]"--=capital Eth, Icelandic--> -<!ENTITY eacute SDATA "[eacute]"--=small e, acute accent--> -<!ENTITY Eacute SDATA "[Eacute]"--=capital E, acute accent--> -<!ENTITY ecirc SDATA "[ecirc ]"--=small e, circumflex accent--> -<!ENTITY Ecirc SDATA "[Ecirc ]"--=capital E, circumflex accent--> -<!ENTITY egrave SDATA "[egrave]"--=small e, grave accent--> -<!ENTITY Egrave SDATA "[Egrave]"--=capital E, grave accent--> -<!ENTITY euml SDATA "[euml ]"--=small e, dieresis or umlaut mark--> -<!ENTITY Euml SDATA "[Euml ]"--=capital E, dieresis or umlaut mark--> -<!ENTITY iacute SDATA "[iacute]"--=small i, acute accent--> -<!ENTITY Iacute SDATA "[Iacute]"--=capital I, acute accent--> -<!ENTITY icirc SDATA "[icirc ]"--=small i, circumflex accent--> -<!ENTITY Icirc SDATA "[Icirc ]"--=capital I, circumflex accent--> -<!ENTITY igrave SDATA "[igrave]"--=small i, grave accent--> -<!ENTITY Igrave SDATA "[Igrave]"--=capital I, grave accent--> -<!ENTITY iuml SDATA "[iuml ]"--=small i, dieresis or umlaut mark--> -<!ENTITY Iuml SDATA "[Iuml ]"--=capital I, dieresis or umlaut mark--> -<!ENTITY ntilde SDATA "[ntilde]"--=small n, tilde--> -<!ENTITY Ntilde SDATA "[Ntilde]"--=capital N, tilde--> -<!ENTITY oacute SDATA "[oacute]"--=small o, acute accent--> -<!ENTITY Oacute SDATA "[Oacute]"--=capital O, acute accent--> -<!ENTITY ocirc SDATA "[ocirc ]"--=small o, circumflex accent--> -<!ENTITY Ocirc SDATA "[Ocirc ]"--=capital O, circumflex accent--> -<!ENTITY ograve SDATA "[ograve]"--=small o, grave accent--> -<!ENTITY Ograve SDATA "[Ograve]"--=capital O, grave accent--> -<!ENTITY oslash SDATA "[oslash]"--=small o, slash--> -<!ENTITY Oslash SDATA "[Oslash]"--=capital O, slash--> -<!ENTITY otilde SDATA "[otilde]"--=small o, tilde--> -<!ENTITY Otilde SDATA "[Otilde]"--=capital O, tilde--> -<!ENTITY ouml SDATA "[ouml ]"--=small o, dieresis or umlaut mark--> -<!ENTITY Ouml SDATA "[Ouml ]"--=capital O, dieresis or umlaut mark--> -<!ENTITY szlig SDATA "[szlig ]"--=small sharp s, German (sz ligature)--> -<!ENTITY thorn SDATA "[thorn ]"--=small thorn, Icelandic--> -<!ENTITY THORN SDATA "[THORN ]"--=capital THORN, Icelandic--> -<!ENTITY uacute SDATA "[uacute]"--=small u, acute accent--> -<!ENTITY Uacute SDATA "[Uacute]"--=capital U, acute accent--> -<!ENTITY ucirc SDATA "[ucirc ]"--=small u, circumflex accent--> -<!ENTITY Ucirc SDATA "[Ucirc ]"--=capital U, circumflex accent--> -<!ENTITY ugrave SDATA "[ugrave]"--=small u, grave accent--> -<!ENTITY Ugrave SDATA "[Ugrave]"--=capital U, grave accent--> -<!ENTITY uuml SDATA "[uuml ]"--=small u, dieresis or umlaut mark--> -<!ENTITY Uuml SDATA "[Uuml ]"--=capital U, dieresis or umlaut mark--> -<!ENTITY yacute SDATA "[yacute]"--=small y, acute accent--> -<!ENTITY Yacute SDATA "[Yacute]"--=capital Y, acute accent--> -<!ENTITY yuml SDATA "[yuml ]"--=small y, dieresis or umlaut mark-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOlat2 Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOlat2 PUBLIC - "ISO 8879:1986//ENTITIES Added Latin 2//EN"> - %ISOlat2; ---> -<!ENTITY abreve SDATA "[abreve]"--=small a, breve--> -<!ENTITY Abreve SDATA "[Abreve]"--=capital A, breve--> -<!ENTITY amacr SDATA "[amacr ]"--=small a, macron--> -<!ENTITY Amacr SDATA "[Amacr ]"--=capital A, macron--> -<!ENTITY aogon SDATA "[aogon ]"--=small a, ogonek--> -<!ENTITY Aogon SDATA "[Aogon ]"--=capital A, ogonek--> -<!ENTITY cacute SDATA "[cacute]"--=small c, acute accent--> -<!ENTITY Cacute SDATA "[Cacute]"--=capital C, acute accent--> -<!ENTITY ccaron SDATA "[ccaron]"--=small c, caron--> -<!ENTITY Ccaron SDATA "[Ccaron]"--=capital C, caron--> -<!ENTITY ccirc SDATA "[ccirc ]"--=small c, circumflex accent--> -<!ENTITY Ccirc SDATA "[Ccirc ]"--=capital C, circumflex accent--> -<!ENTITY cdot SDATA "[cdot ]"--=small c, dot above--> -<!ENTITY Cdot SDATA "[Cdot ]"--=capital C, dot above--> -<!ENTITY dcaron SDATA "[dcaron]"--=small d, caron--> -<!ENTITY Dcaron SDATA "[Dcaron]"--=capital D, caron--> -<!ENTITY dstrok SDATA "[dstrok]"--=small d, stroke--> -<!ENTITY Dstrok SDATA "[Dstrok]"--=capital D, stroke--> -<!ENTITY ecaron SDATA "[ecaron]"--=small e, caron--> -<!ENTITY Ecaron SDATA "[Ecaron]"--=capital E, caron--> -<!ENTITY edot SDATA "[edot ]"--=small e, dot above--> -<!ENTITY Edot SDATA "[Edot ]"--=capital E, dot above--> -<!ENTITY emacr SDATA "[emacr ]"--=small e, macron--> -<!ENTITY Emacr SDATA "[Emacr ]"--=capital E, macron--> -<!ENTITY eogon SDATA "[eogon ]"--=small e, ogonek--> -<!ENTITY Eogon SDATA "[Eogon ]"--=capital E, ogonek--> -<!ENTITY gacute SDATA "[gacute]"--=small g, acute accent--> -<!ENTITY gbreve SDATA "[gbreve]"--=small g, breve--> -<!ENTITY Gbreve SDATA "[Gbreve]"--=capital G, breve--> -<!ENTITY Gcedil SDATA "[Gcedil]"--=capital G, cedilla--> -<!ENTITY gcirc SDATA "[gcirc ]"--=small g, circumflex accent--> -<!ENTITY Gcirc SDATA "[Gcirc ]"--=capital G, circumflex accent--> -<!ENTITY gdot SDATA "[gdot ]"--=small g, dot above--> -<!ENTITY Gdot SDATA "[Gdot ]"--=capital G, dot above--> -<!ENTITY hcirc SDATA "[hcirc ]"--=small h, circumflex accent--> -<!ENTITY Hcirc SDATA "[Hcirc ]"--=capital H, circumflex accent--> -<!ENTITY hstrok SDATA "[hstrok]"--=small h, stroke--> -<!ENTITY Hstrok SDATA "[Hstrok]"--=capital H, stroke--> -<!ENTITY Idot SDATA "[Idot ]"--=capital I, dot above--> -<!ENTITY Imacr SDATA "[Imacr ]"--=capital I, macron--> -<!ENTITY imacr SDATA "[imacr ]"--=small i, macron--> -<!ENTITY ijlig SDATA "[ijlig ]"--=small ij ligature--> -<!ENTITY IJlig SDATA "[IJlig ]"--=capital IJ ligature--> -<!ENTITY inodot SDATA "[inodot]"--=small i without dot--> -<!ENTITY iogon SDATA "[iogon ]"--=small i, ogonek--> -<!ENTITY Iogon SDATA "[Iogon ]"--=capital I, ogonek--> -<!ENTITY itilde SDATA "[itilde]"--=small i, tilde--> -<!ENTITY Itilde SDATA "[Itilde]"--=capital I, tilde--> -<!ENTITY jcirc SDATA "[jcirc ]"--=small j, circumflex accent--> -<!ENTITY Jcirc SDATA "[Jcirc ]"--=capital J, circumflex accent--> -<!ENTITY kcedil SDATA "[kcedil]"--=small k, cedilla--> -<!ENTITY Kcedil SDATA "[Kcedil]"--=capital K, cedilla--> -<!ENTITY kgreen SDATA "[kgreen]"--=small k, Greenlandic--> -<!ENTITY lacute SDATA "[lacute]"--=small l, acute accent--> -<!ENTITY Lacute SDATA "[Lacute]"--=capital L, acute accent--> -<!ENTITY lcaron SDATA "[lcaron]"--=small l, caron--> -<!ENTITY Lcaron SDATA "[Lcaron]"--=capital L, caron--> -<!ENTITY lcedil SDATA "[lcedil]"--=small l, cedilla--> -<!ENTITY Lcedil SDATA "[Lcedil]"--=capital L, cedilla--> -<!ENTITY lmidot SDATA "[lmidot]"--=small l, middle dot--> -<!ENTITY Lmidot SDATA "[Lmidot]"--=capital L, middle dot--> -<!ENTITY lstrok SDATA "[lstrok]"--=small l, stroke--> -<!ENTITY Lstrok SDATA "[Lstrok]"--=capital L, stroke--> -<!ENTITY nacute SDATA "[nacute]"--=small n, acute accent--> -<!ENTITY Nacute SDATA "[Nacute]"--=capital N, acute accent--> -<!ENTITY eng SDATA "[eng ]"--=small eng, Lapp--> -<!ENTITY ENG SDATA "[ENG ]"--=capital ENG, Lapp--> -<!ENTITY napos SDATA "[napos ]"--=small n, apostrophe--> -<!ENTITY ncaron SDATA "[ncaron]"--=small n, caron--> -<!ENTITY Ncaron SDATA "[Ncaron]"--=capital N, caron--> -<!ENTITY ncedil SDATA "[ncedil]"--=small n, cedilla--> -<!ENTITY Ncedil SDATA "[Ncedil]"--=capital N, cedilla--> -<!ENTITY odblac SDATA "[odblac]"--=small o, double acute accent--> -<!ENTITY Odblac SDATA "[Odblac]"--=capital O, double acute accent--> -<!ENTITY Omacr SDATA "[Omacr ]"--=capital O, macron--> -<!ENTITY omacr SDATA "[omacr ]"--=small o, macron--> -<!ENTITY oelig SDATA "[oelig ]"--=small oe ligature--> -<!ENTITY OElig SDATA "[OElig ]"--=capital OE ligature--> -<!ENTITY racute SDATA "[racute]"--=small r, acute accent--> -<!ENTITY Racute SDATA "[Racute]"--=capital R, acute accent--> -<!ENTITY rcaron SDATA "[rcaron]"--=small r, caron--> -<!ENTITY Rcaron SDATA "[Rcaron]"--=capital R, caron--> -<!ENTITY rcedil SDATA "[rcedil]"--=small r, cedilla--> -<!ENTITY Rcedil SDATA "[Rcedil]"--=capital R, cedilla--> -<!ENTITY sacute SDATA "[sacute]"--=small s, acute accent--> -<!ENTITY Sacute SDATA "[Sacute]"--=capital S, acute accent--> -<!ENTITY scaron SDATA "[scaron]"--=small s, caron--> -<!ENTITY Scaron SDATA "[Scaron]"--=capital S, caron--> -<!ENTITY scedil SDATA "[scedil]"--=small s, cedilla--> -<!ENTITY Scedil SDATA "[Scedil]"--=capital S, cedilla--> -<!ENTITY scirc SDATA "[scirc ]"--=small s, circumflex accent--> -<!ENTITY Scirc SDATA "[Scirc ]"--=capital S, circumflex accent--> -<!ENTITY tcaron SDATA "[tcaron]"--=small t, caron--> -<!ENTITY Tcaron SDATA "[Tcaron]"--=capital T, caron--> -<!ENTITY tcedil SDATA "[tcedil]"--=small t, cedilla--> -<!ENTITY Tcedil SDATA "[Tcedil]"--=capital T, cedilla--> -<!ENTITY tstrok SDATA "[tstrok]"--=small t, stroke--> -<!ENTITY Tstrok SDATA "[Tstrok]"--=capital T, stroke--> -<!ENTITY ubreve SDATA "[ubreve]"--=small u, breve--> -<!ENTITY Ubreve SDATA "[Ubreve]"--=capital U, breve--> -<!ENTITY udblac SDATA "[udblac]"--=small u, double acute accent--> -<!ENTITY Udblac SDATA "[Udblac]"--=capital U, double acute accent--> -<!ENTITY umacr SDATA "[umacr ]"--=small u, macron--> -<!ENTITY Umacr SDATA "[Umacr ]"--=capital U, macron--> -<!ENTITY uogon SDATA "[uogon ]"--=small u, ogonek--> -<!ENTITY Uogon SDATA "[Uogon ]"--=capital U, ogonek--> -<!ENTITY uring SDATA "[uring ]"--=small u, ring--> -<!ENTITY Uring SDATA "[Uring ]"--=capital U, ring--> -<!ENTITY utilde SDATA "[utilde]"--=small u, tilde--> -<!ENTITY Utilde SDATA "[Utilde]"--=capital U, tilde--> -<!ENTITY wcirc SDATA "[wcirc ]"--=small w, circumflex accent--> -<!ENTITY Wcirc SDATA "[Wcirc ]"--=capital W, circumflex accent--> -<!ENTITY ycirc SDATA "[ycirc ]"--=small y, circumflex accent--> -<!ENTITY Ycirc SDATA "[Ycirc ]"--=capital Y, circumflex accent--> -<!ENTITY Yuml SDATA "[Yuml ]"--=capital Y, dieresis or umlaut mark--> -<!ENTITY zacute SDATA "[zacute]"--=small z, acute accent--> -<!ENTITY Zacute SDATA "[Zacute]"--=capital Z, acute accent--> -<!ENTITY zcaron SDATA "[zcaron]"--=small z, caron--> -<!ENTITY Zcaron SDATA "[Zcaron]"--=capital Z, caron--> -<!ENTITY zdot SDATA "[zdot ]"--=small z, dot above--> -<!ENTITY Zdot SDATA "[Zdot ]"--=capital Z, dot above-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOnum Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOnum PUBLIC - "ISO 8879:1986//ENTITIES Numeric and Special Graphic//EN"> - %ISOnum; ---> -<!ENTITY half SDATA "[half ]"--=fraction one-half--> -<!ENTITY frac12 SDATA "[frac12]"--=fraction one-half--> -<!ENTITY frac14 SDATA "[frac14]"--=fraction one-quarter--> -<!ENTITY frac34 SDATA "[frac34]"--=fraction three-quarters--> -<!ENTITY frac18 SDATA "[frac18]"--=fraction one-eighth--> -<!ENTITY frac38 SDATA "[frac38]"--=fraction three-eighths--> -<!ENTITY frac58 SDATA "[frac58]"--=fraction five-eighths--> -<!ENTITY frac78 SDATA "[frac78]"--=fraction seven-eighths--> - -<!ENTITY sup1 SDATA "[sup1 ]"--=superscript one--> -<!ENTITY sup2 SDATA "[sup2 ]"--=superscript two--> -<!ENTITY sup3 SDATA "[sup3 ]"--=superscript three--> - -<!ENTITY plus SDATA "[plus ]"--=plus sign B:-- > -<!ENTITY plusmn SDATA "[plusmn]"--/pm B: =plus-or-minus sign--> -<!ENTITY lt SDATA "[lt ]"--=less-than sign R:--> -<!ENTITY equals SDATA "[equals]"--=equals sign R:--> -<!ENTITY gt SDATA "[gt ]"--=greater-than sign R:--> -<!ENTITY divide SDATA "[divide]"--/div B: =divide sign--> -<!ENTITY times SDATA "[times ]"--/times B: =multiply sign--> - -<!ENTITY curren SDATA "[curren]"--=general currency sign--> -<!ENTITY pound SDATA "[pound ]"--=pound sign--> -<!ENTITY dollar SDATA "[dollar]"--=dollar sign--> -<!ENTITY cent SDATA "[cent ]"--=cent sign--> -<!ENTITY yen SDATA "[yen ]"--/yen =yen sign--> - -<!ENTITY num SDATA "[num ]"--=number sign--> -<!ENTITY percnt SDATA "[percnt]"--=percent sign--> -<!ENTITY amp SDATA "[amp ]"--=ampersand--> -<!ENTITY ast SDATA "[ast ]"--/ast B: =asterisk--> -<!ENTITY commat SDATA "[commat]"--=commercial at--> -<!ENTITY lsqb SDATA "[lsqb ]"--/lbrack O: =left square bracket--> -<!ENTITY bsol SDATA "[bsol ]"--/backslash =reverse solidus--> -<!ENTITY rsqb SDATA "[rsqb ]"--/rbrack C: =right square bracket--> -<!ENTITY lcub SDATA "[lcub ]"--/lbrace O: =left curly bracket--> -<!ENTITY horbar SDATA "[horbar]"--=horizontal bar--> -<!ENTITY verbar SDATA "[verbar]"--/vert =vertical bar--> -<!ENTITY rcub SDATA "[rcub ]"--/rbrace C: =right curly bracket--> -<!ENTITY micro SDATA "[micro ]"--=micro sign--> -<!ENTITY ohm SDATA "[ohm ]"--=ohm sign--> -<!ENTITY deg SDATA "[deg ]"--=degree sign--> -<!ENTITY ordm SDATA "[ordm ]"--=ordinal indicator, masculine--> -<!ENTITY ordf SDATA "[ordf ]"--=ordinal indicator, feminine--> -<!ENTITY sect SDATA "[sect ]"--=section sign--> -<!ENTITY para SDATA "[para ]"--=pilcrow (paragraph sign)--> -<!ENTITY middot SDATA "[middot]"--/centerdot B: =middle dot--> -<!ENTITY larr SDATA "[larr ]"--/leftarrow /gets A: =leftward arrow--> -<!ENTITY rarr SDATA "[rarr ]"--/rightarrow /to A: =rightward arrow--> -<!ENTITY uarr SDATA "[uarr ]"--/uparrow A: =upward arrow--> -<!ENTITY darr SDATA "[darr ]"--/downarrow A: =downward arrow--> -<!ENTITY copy SDATA "[copy ]"--=copyright sign--> -<!ENTITY reg SDATA "[reg ]"--/circledR =registered sign--> -<!ENTITY trade SDATA "[trade ]"--=trade mark sign--> -<!ENTITY brvbar SDATA "[brvbar]"--=broken (vertical) bar--> -<!ENTITY not SDATA "[not ]"--/neg /lnot =not sign--> -<!ENTITY sung SDATA "[sung ]"--=music note (sung text sign)--> - -<!ENTITY excl SDATA "[excl ]"--=exclamation mark--> -<!ENTITY iexcl SDATA "[iexcl ]"--=inverted exclamation mark--> -<!ENTITY quot SDATA "[quot ]"--=quotation mark--> -<!ENTITY apos SDATA "[apos ]"--=apostrophe--> -<!ENTITY lpar SDATA "[lpar ]"--O: =left parenthesis--> -<!ENTITY rpar SDATA "[rpar ]"--C: =right parenthesis--> -<!ENTITY comma SDATA "[comma ]"--P: =comma--> -<!ENTITY lowbar SDATA "[lowbar]"--=low line--> -<!ENTITY hyphen SDATA "[hyphen]"--=hyphen--> -<!ENTITY period SDATA "[period]"--=full stop, period--> -<!ENTITY sol SDATA "[sol ]"--=solidus--> -<!ENTITY colon SDATA "[colon ]"--/colon P:--> -<!ENTITY semi SDATA "[semi ]"--=semicolon P:--> -<!ENTITY quest SDATA "[quest ]"--=question mark--> -<!ENTITY iquest SDATA "[iquest]"--=inverted question mark--> -<!ENTITY laquo SDATA "[laquo ]"--=angle quotation mark, left--> -<!ENTITY raquo SDATA "[raquo ]"--=angle quotation mark, right--> -<!ENTITY lsquo SDATA "[lsquo ]"--=single quotation mark, left--> -<!ENTITY rsquo SDATA "[rsquo ]"--=single quotation mark, right--> -<!ENTITY ldquo SDATA "[ldquo ]"--=double quotation mark, left--> -<!ENTITY rdquo SDATA "[rdquo ]"--=double quotation mark, right--> -<!ENTITY nbsp SDATA "[nbsp ]"--=no break (required) space--> -<!ENTITY shy SDATA "[shy ]"--=soft hyphen-->
--- a/etc/sgml/ISO_8879=1986/entities/ISOpub Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOpub PUBLIC - "ISO 8879:1986//ENTITIES Publishing//EN"> - %ISOpub; ---> -<!ENTITY emsp SDATA "[emsp ]"--=em space--> -<!ENTITY ensp SDATA "[ensp ]"--=en space (1/2-em)--> -<!ENTITY emsp13 SDATA "[emsp3 ]"--=1/3-em space--> -<!ENTITY emsp14 SDATA "[emsp4 ]"--=1/4-em space--> -<!ENTITY numsp SDATA "[numsp ]"--=digit space (width of a number)--> -<!ENTITY puncsp SDATA "[puncsp]"--=punctuation space (width of comma)--> -<!ENTITY thinsp SDATA "[thinsp]"--=thin space (1/6-em)--> -<!ENTITY hairsp SDATA "[hairsp]"--=hair space--> -<!ENTITY mdash SDATA "[mdash ]"--=em dash--> -<!ENTITY ndash SDATA "[ndash ]"--=en dash--> -<!ENTITY dash SDATA "[dash ]"--=hyphen (true graphic)--> -<!ENTITY blank SDATA "[blank ]"--=significant blank symbol--> -<!ENTITY hellip SDATA "[hellip]"--=ellipsis (horizontal)--> -<!ENTITY nldr SDATA "[nldr ]"--=double baseline dot (en leader)--> -<!ENTITY frac13 SDATA "[frac13]"--=fraction one-third--> -<!ENTITY frac23 SDATA "[frac23]"--=fraction two-thirds--> -<!ENTITY frac15 SDATA "[frac15]"--=fraction one-fifth--> -<!ENTITY frac25 SDATA "[frac25]"--=fraction two-fifths--> -<!ENTITY frac35 SDATA "[frac35]"--=fraction three-fifths--> -<!ENTITY frac45 SDATA "[frac45]"--=fraction four-fifths--> -<!ENTITY frac16 SDATA "[frac16]"--=fraction one-sixth--> -<!ENTITY frac56 SDATA "[frac56]"--=fraction five-sixths--> -<!ENTITY incare SDATA "[incare]"--=in-care-of symbol--> -<!ENTITY block SDATA "[block ]"--=full block--> -<!ENTITY uhblk SDATA "[uhblk ]"--=upper half block--> -<!ENTITY lhblk SDATA "[lhblk ]"--=lower half block--> -<!ENTITY blk14 SDATA "[blk14 ]"--=25% shaded block--> -<!ENTITY blk12 SDATA "[blk12 ]"--=50% shaded block--> -<!ENTITY blk34 SDATA "[blk34 ]"--=75% shaded block--> -<!ENTITY marker SDATA "[marker]"--=histogram marker--> -<!ENTITY cir SDATA "[cir ]"--/circ B: =circle, open--> -<!ENTITY squ SDATA "[squ ]"--=square, open--> -<!ENTITY rect SDATA "[rect ]"--=rectangle, open--> -<!ENTITY utri SDATA "[utri ]"--/triangle =up triangle, open--> -<!ENTITY dtri SDATA "[dtri ]"--/triangledown =down triangle, open--> -<!ENTITY star SDATA "[star ]"--=star, open--> -<!ENTITY bull SDATA "[bull ]"--/bullet B: =round bullet, filled--> -<!ENTITY squf SDATA "[squf ]"--/blacksquare =sq bullet, filled--> -<!ENTITY utrif SDATA "[utrif ]"--/blacktriangle =up tri, filled--> -<!ENTITY dtrif SDATA "[dtrif ]"--/blacktriangledown =dn tri, filled--> -<!ENTITY ltrif SDATA "[ltrif ]"--/blacktriangleleft R: =l tri, filled--> -<!ENTITY rtrif SDATA "[rtrif ]"--/blacktriangleright R: =r tri, filled--> -<!ENTITY clubs SDATA "[clubs ]"--/clubsuit =club suit symbol--> -<!ENTITY diams SDATA "[diams ]"--/diamondsuit =diamond suit symbol--> -<!ENTITY hearts SDATA "[hearts]"--/heartsuit =heart suit symbol--> -<!ENTITY spades SDATA "[spades]"--/spadesuit =spades suit symbol--> -<!ENTITY malt SDATA "[malt ]"--/maltese =maltese cross--> -<!ENTITY dagger SDATA "[dagger]"--/dagger B: =dagger--> -<!ENTITY Dagger SDATA "[Dagger]"--/ddagger B: =double dagger--> -<!ENTITY check SDATA "[check ]"--/checkmark =tick, check mark--> -<!ENTITY cross SDATA "[ballot]"--=ballot cross--> -<!ENTITY sharp SDATA "[sharp ]"--/sharp =musical sharp--> -<!ENTITY flat SDATA "[flat ]"--/flat =musical flat--> -<!ENTITY male SDATA "[male ]"--=male symbol--> -<!ENTITY female SDATA "[female]"--=female symbol--> -<!ENTITY phone SDATA "[phone ]"--=telephone symbol--> -<!ENTITY telrec SDATA "[telrec]"--=telephone recorder symbol--> -<!ENTITY copysr SDATA "[copysr]"--=sound recording copyright sign--> -<!ENTITY caret SDATA "[caret ]"--=caret (insertion mark)--> -<!ENTITY lsquor SDATA "[lsquor]"--=rising single quote, left (low)--> -<!ENTITY ldquor SDATA "[ldquor]"--=rising dbl quote, left (low)--> - -<!ENTITY fflig SDATA "[fflig ]"--small ff ligature--> -<!ENTITY filig SDATA "[filig ]"--small fi ligature--> -<!ENTITY fjlig SDATA "[fjlig ]"--small fj ligature--> -<!ENTITY ffilig SDATA "[ffilig]"--small ffi ligature--> -<!ENTITY ffllig SDATA "[ffllig]"--small ffl ligature--> -<!ENTITY fllig SDATA "[fllig ]"--small fl ligature--> - -<!ENTITY mldr SDATA "[mldr ]"--em leader--> -<!ENTITY rdquor SDATA "[rdquor]"--rising dbl quote, right (high)--> -<!ENTITY rsquor SDATA "[rsquor]"--rising single quote, right (high)--> -<!ENTITY vellip SDATA "[vellip]"--vertical ellipsis--> - -<!ENTITY hybull SDATA "[hybull]"--rectangle, filled (hyphen bullet)--> -<!ENTITY loz SDATA "[loz ]"--/lozenge - lozenge or total mark--> -<!ENTITY lozf SDATA "[lozf ]"--/blacklozenge - lozenge, filled--> -<!ENTITY ltri SDATA "[ltri ]"--/triangleleft B: l triangle, open--> -<!ENTITY rtri SDATA "[rtri ]"--/triangleright B: r triangle, open--> -<!ENTITY starf SDATA "[starf ]"--/bigstar - star, filled--> - -<!ENTITY natur SDATA "[natur ]"--/natural - music natural--> -<!ENTITY rx SDATA "[rx ]"--pharmaceutical prescription (Rx)--> -<!ENTITY sext SDATA "[sext ]"--sextile (6-pointed star)--> - -<!ENTITY target SDATA "[target]"--register mark or target--> -<!ENTITY dlcrop SDATA "[dlcrop]"--downward left crop mark --> -<!ENTITY drcrop SDATA "[drcrop]"--downward right crop mark --> -<!ENTITY ulcrop SDATA "[ulcrop]"--upward left crop mark --> -<!ENTITY urcrop SDATA "[urcrop]"--upward right crop mark -->
--- a/etc/sgml/ISO_8879=1986/entities/ISOtech Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOtech PUBLIC - "ISO 8879:1986//ENTITIES General Technical//EN"> - %ISOtech; ---> -<!ENTITY aleph SDATA "[aleph ]"--/aleph =aleph, Hebrew--> -<!ENTITY and SDATA "[and ]"--/wedge /land B: =logical and--> -<!ENTITY ang90 SDATA "[ang90 ]"--=right (90 degree) angle--> -<!ENTITY angsph SDATA "[angsph]"--/sphericalangle =angle-spherical--> -<!ENTITY ap SDATA "[ap ]"--/approx R: =approximate--> -<!ENTITY becaus SDATA "[becaus]"--/because R: =because--> -<!ENTITY bottom SDATA "[bottom]"--/bot B: =perpendicular--> -<!ENTITY cap SDATA "[cap ]"--/cap B: =intersection--> -<!ENTITY cong SDATA "[cong ]"--/cong R: =congruent with--> -<!ENTITY conint SDATA "[conint]"--/oint L: =contour integral operator--> -<!ENTITY cup SDATA "[cup ]"--/cup B: =union or logical sum--> -<!ENTITY equiv SDATA "[equiv ]"--/equiv R: =identical with--> -<!ENTITY exist SDATA "[exist ]"--/exists =at least one exists--> -<!ENTITY forall SDATA "[forall]"--/forall =for all--> -<!ENTITY fnof SDATA "[fnof ]"--=function of (italic small f)--> -<!ENTITY ge SDATA "[ge ]"--/geq /ge R: =greater-than-or-equal--> -<!ENTITY iff SDATA "[iff ]"--/iff =if and only if--> -<!ENTITY infin SDATA "[infin ]"--/infty =infinity--> -<!ENTITY int SDATA "[int ]"--/int L: =integral operator--> -<!ENTITY isin SDATA "[isin ]"--/in R: =set membership--> -<!ENTITY lang SDATA "[lang ]"--/langle O: =left angle bracket--> -<!ENTITY lArr SDATA "[lArr ]"--/Leftarrow A: =is implied by--> -<!ENTITY le SDATA "[le ]"--/leq /le R: =less-than-or-equal--> -<!ENTITY minus SDATA "[minus ]"--B: =minus sign--> -<!ENTITY mnplus SDATA "[mnplus]"--/mp B: =minus-or-plus sign--> -<!ENTITY nabla SDATA "[nabla ]"--/nabla =del, Hamilton operator--> -<!ENTITY ne SDATA "[ne ]"--/ne /neq R: =not equal--> -<!ENTITY ni SDATA "[ni ]"--/ni /owns R: =contains--> -<!ENTITY or SDATA "[or ]"--/vee /lor B: =logical or--> -<!ENTITY par SDATA "[par ]"--/parallel R: =parallel--> -<!ENTITY part SDATA "[part ]"--/partial =partial differential--> -<!ENTITY permil SDATA "[permil]"--=per thousand--> -<!ENTITY perp SDATA "[perp ]"--/perp R: =perpendicular--> -<!ENTITY prime SDATA "[prime ]"--/prime =prime or minute--> -<!ENTITY Prime SDATA "[Prime ]"--=double prime or second--> -<!ENTITY prop SDATA "[prop ]"--/propto R: =is proportional to--> -<!ENTITY radic SDATA "[radic ]"--/surd =radical--> -<!ENTITY rang SDATA "[rang ]"--/rangle C: =right angle bracket--> -<!ENTITY rArr SDATA "[rArr ]"--/Rightarrow A: =implies--> -<!ENTITY sim SDATA "[sim ]"--/sim R: =similar--> -<!ENTITY sime SDATA "[sime ]"--/simeq R: =similar, equals--> -<!ENTITY square SDATA "[square]"--/square B: =square--> -<!ENTITY sub SDATA "[sub ]"--/subset R: =subset or is implied by--> -<!ENTITY sube SDATA "[sube ]"--/subseteq R: =subset, equals--> -<!ENTITY sup SDATA "[sup ]"--/supset R: =superset or implies--> -<!ENTITY supe SDATA "[supe ]"--/supseteq R: =superset, equals--> -<!ENTITY there4 SDATA "[there4]"--/therefore R: =therefore--> -<!ENTITY Verbar SDATA "[Verbar]"--/Vert =dbl vertical bar--> - -<!ENTITY angst SDATA "[angst ]"--Angstrom =capital A, ring--> -<!ENTITY bernou SDATA "[bernou]"--Bernoulli function (script capital B)--> -<!ENTITY compfn SDATA "[compfn]"--B: composite function (small circle)--> -<!ENTITY Dot SDATA "[Dot ]"--=dieresis or umlaut mark--> -<!ENTITY DotDot SDATA "[DotDot]"--four dots above--> -<!ENTITY hamilt SDATA "[hamilt]"--Hamiltonian (script capital H)--> -<!ENTITY lagran SDATA "[lagran]"--Lagrangian (script capital L)--> -<!ENTITY lowast SDATA "[lowast]"--low asterisk--> -<!ENTITY notin SDATA "[notin ]"--N: negated set membership--> -<!ENTITY order SDATA "[order ]"--order of (script small o)--> -<!ENTITY phmmat SDATA "[phmmat]"--physics M-matrix (script capital M)--> -<!ENTITY tdot SDATA "[tdot ]"--three dots above--> -<!ENTITY tprime SDATA "[tprime]"--triple prime--> -<!ENTITY wedgeq SDATA "[wedgeq]"--R: corresponds to (wedge, equals)-->
--- a/etc/sgml/ISO_8879=1986/entities/Numeric_and_Special_Graphic Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOnum PUBLIC - "ISO 8879:1986//ENTITIES Numeric and Special Graphic//EN"> - %ISOnum; ---> -<!ENTITY half SDATA "[half ]"--=fraction one-half--> -<!ENTITY frac12 SDATA "[frac12]"--=fraction one-half--> -<!ENTITY frac14 SDATA "[frac14]"--=fraction one-quarter--> -<!ENTITY frac34 SDATA "[frac34]"--=fraction three-quarters--> -<!ENTITY frac18 SDATA "[frac18]"--=fraction one-eighth--> -<!ENTITY frac38 SDATA "[frac38]"--=fraction three-eighths--> -<!ENTITY frac58 SDATA "[frac58]"--=fraction five-eighths--> -<!ENTITY frac78 SDATA "[frac78]"--=fraction seven-eighths--> - -<!ENTITY sup1 SDATA "[sup1 ]"--=superscript one--> -<!ENTITY sup2 SDATA "[sup2 ]"--=superscript two--> -<!ENTITY sup3 SDATA "[sup3 ]"--=superscript three--> - -<!ENTITY plus SDATA "[plus ]"--=plus sign B:-- > -<!ENTITY plusmn SDATA "[plusmn]"--/pm B: =plus-or-minus sign--> -<!ENTITY lt SDATA "[lt ]"--=less-than sign R:--> -<!ENTITY equals SDATA "[equals]"--=equals sign R:--> -<!ENTITY gt SDATA "[gt ]"--=greater-than sign R:--> -<!ENTITY divide SDATA "[divide]"--/div B: =divide sign--> -<!ENTITY times SDATA "[times ]"--/times B: =multiply sign--> - -<!ENTITY curren SDATA "[curren]"--=general currency sign--> -<!ENTITY pound SDATA "[pound ]"--=pound sign--> -<!ENTITY dollar SDATA "[dollar]"--=dollar sign--> -<!ENTITY cent SDATA "[cent ]"--=cent sign--> -<!ENTITY yen SDATA "[yen ]"--/yen =yen sign--> - -<!ENTITY num SDATA "[num ]"--=number sign--> -<!ENTITY percnt SDATA "[percnt]"--=percent sign--> -<!ENTITY amp SDATA "[amp ]"--=ampersand--> -<!ENTITY ast SDATA "[ast ]"--/ast B: =asterisk--> -<!ENTITY commat SDATA "[commat]"--=commercial at--> -<!ENTITY lsqb SDATA "[lsqb ]"--/lbrack O: =left square bracket--> -<!ENTITY bsol SDATA "[bsol ]"--/backslash =reverse solidus--> -<!ENTITY rsqb SDATA "[rsqb ]"--/rbrack C: =right square bracket--> -<!ENTITY lcub SDATA "[lcub ]"--/lbrace O: =left curly bracket--> -<!ENTITY horbar SDATA "[horbar]"--=horizontal bar--> -<!ENTITY verbar SDATA "[verbar]"--/vert =vertical bar--> -<!ENTITY rcub SDATA "[rcub ]"--/rbrace C: =right curly bracket--> -<!ENTITY micro SDATA "[micro ]"--=micro sign--> -<!ENTITY ohm SDATA "[ohm ]"--=ohm sign--> -<!ENTITY deg SDATA "[deg ]"--=degree sign--> -<!ENTITY ordm SDATA "[ordm ]"--=ordinal indicator, masculine--> -<!ENTITY ordf SDATA "[ordf ]"--=ordinal indicator, feminine--> -<!ENTITY sect SDATA "[sect ]"--=section sign--> -<!ENTITY para SDATA "[para ]"--=pilcrow (paragraph sign)--> -<!ENTITY middot SDATA "[middot]"--/centerdot B: =middle dot--> -<!ENTITY larr SDATA "[larr ]"--/leftarrow /gets A: =leftward arrow--> -<!ENTITY rarr SDATA "[rarr ]"--/rightarrow /to A: =rightward arrow--> -<!ENTITY uarr SDATA "[uarr ]"--/uparrow A: =upward arrow--> -<!ENTITY darr SDATA "[darr ]"--/downarrow A: =downward arrow--> -<!ENTITY copy SDATA "[copy ]"--=copyright sign--> -<!ENTITY reg SDATA "[reg ]"--/circledR =registered sign--> -<!ENTITY trade SDATA "[trade ]"--=trade mark sign--> -<!ENTITY brvbar SDATA "[brvbar]"--=broken (vertical) bar--> -<!ENTITY not SDATA "[not ]"--/neg /lnot =not sign--> -<!ENTITY sung SDATA "[sung ]"--=music note (sung text sign)--> - -<!ENTITY excl SDATA "[excl ]"--=exclamation mark--> -<!ENTITY iexcl SDATA "[iexcl ]"--=inverted exclamation mark--> -<!ENTITY quot SDATA "[quot ]"--=quotation mark--> -<!ENTITY apos SDATA "[apos ]"--=apostrophe--> -<!ENTITY lpar SDATA "[lpar ]"--O: =left parenthesis--> -<!ENTITY rpar SDATA "[rpar ]"--C: =right parenthesis--> -<!ENTITY comma SDATA "[comma ]"--P: =comma--> -<!ENTITY lowbar SDATA "[lowbar]"--=low line--> -<!ENTITY hyphen SDATA "[hyphen]"--=hyphen--> -<!ENTITY period SDATA "[period]"--=full stop, period--> -<!ENTITY sol SDATA "[sol ]"--=solidus--> -<!ENTITY colon SDATA "[colon ]"--/colon P:--> -<!ENTITY semi SDATA "[semi ]"--=semicolon P:--> -<!ENTITY quest SDATA "[quest ]"--=question mark--> -<!ENTITY iquest SDATA "[iquest]"--=inverted question mark--> -<!ENTITY laquo SDATA "[laquo ]"--=angle quotation mark, left--> -<!ENTITY raquo SDATA "[raquo ]"--=angle quotation mark, right--> -<!ENTITY lsquo SDATA "[lsquo ]"--=single quotation mark, left--> -<!ENTITY rsquo SDATA "[rsquo ]"--=single quotation mark, right--> -<!ENTITY ldquo SDATA "[ldquo ]"--=double quotation mark, left--> -<!ENTITY rdquo SDATA "[rdquo ]"--=double quotation mark, right--> -<!ENTITY nbsp SDATA "[nbsp ]"--=no break (required) space--> -<!ENTITY shy SDATA "[shy ]"--=soft hyphen-->
--- a/etc/sgml/ISOlat1.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOlat1 PUBLIC - "-//IETF//ENTITIES Added Latin 1 for HTML//EN"> - %ISOlat1; ---> -<!-- Modified for use in HTML - $Id: ISOlat1.sgml,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ --> -<!ENTITY AElig CDATA "Æ" -- capital AE diphthong (ligature) --> -<!ENTITY Aacute CDATA "Á" -- capital A, acute accent --> -<!ENTITY Acirc CDATA "Â" -- capital A, circumflex accent --> -<!ENTITY Agrave CDATA "À" -- capital A, grave accent --> -<!ENTITY Aring CDATA "Å" -- capital A, ring --> -<!ENTITY Atilde CDATA "Ã" -- capital A, tilde --> -<!ENTITY Auml CDATA "Ä" -- capital A, dieresis or umlaut mark --> -<!ENTITY Ccedil CDATA "Ç" -- capital C, cedilla --> -<!ENTITY ETH CDATA "Ð" -- capital Eth, Icelandic --> -<!ENTITY Eacute CDATA "É" -- capital E, acute accent --> -<!ENTITY Ecirc CDATA "Ê" -- capital E, circumflex accent --> -<!ENTITY Egrave CDATA "È" -- capital E, grave accent --> -<!ENTITY Euml CDATA "Ë" -- capital E, dieresis or umlaut mark --> -<!ENTITY Iacute CDATA "Í" -- capital I, acute accent --> -<!ENTITY Icirc CDATA "Î" -- capital I, circumflex accent --> -<!ENTITY Igrave CDATA "Ì" -- capital I, grave accent --> -<!ENTITY Iuml CDATA "Ï" -- capital I, dieresis or umlaut mark --> -<!ENTITY Ntilde CDATA "Ñ" -- capital N, tilde --> -<!ENTITY Oacute CDATA "Ó" -- capital O, acute accent --> -<!ENTITY Ocirc CDATA "Ô" -- capital O, circumflex accent --> -<!ENTITY Ograve CDATA "Ò" -- capital O, grave accent --> -<!ENTITY Oslash CDATA "Ø" -- capital O, slash --> -<!ENTITY Otilde CDATA "Õ" -- capital O, tilde --> -<!ENTITY Ouml CDATA "Ö" -- capital O, dieresis or umlaut mark --> -<!ENTITY THORN CDATA "Þ" -- capital THORN, Icelandic --> -<!ENTITY Uacute CDATA "Ú" -- capital U, acute accent --> -<!ENTITY Ucirc CDATA "Û" -- capital U, circumflex accent --> -<!ENTITY Ugrave CDATA "Ù" -- capital U, grave accent --> -<!ENTITY Uuml CDATA "Ü" -- capital U, dieresis or umlaut mark --> -<!ENTITY Yacute CDATA "Ý" -- capital Y, acute accent --> -<!ENTITY aacute CDATA "á" -- small a, acute accent --> -<!ENTITY acirc CDATA "â" -- small a, circumflex accent --> -<!ENTITY aelig CDATA "æ" -- small ae diphthong (ligature) --> -<!ENTITY agrave CDATA "à" -- small a, grave accent --> -<!ENTITY aring CDATA "å" -- small a, ring --> -<!ENTITY atilde CDATA "ã" -- small a, tilde --> -<!ENTITY auml CDATA "ä" -- small a, dieresis or umlaut mark --> -<!ENTITY ccedil CDATA "ç" -- small c, cedilla --> -<!ENTITY eacute CDATA "é" -- small e, acute accent --> -<!ENTITY ecirc CDATA "ê" -- small e, circumflex accent --> -<!ENTITY egrave CDATA "è" -- small e, grave accent --> -<!ENTITY eth CDATA "ð" -- small eth, Icelandic --> -<!ENTITY euml CDATA "ë" -- small e, dieresis or umlaut mark --> -<!ENTITY iacute CDATA "í" -- small i, acute accent --> -<!ENTITY icirc CDATA "î" -- small i, circumflex accent --> -<!ENTITY igrave CDATA "ì" -- small i, grave accent --> -<!ENTITY iuml CDATA "ï" -- small i, dieresis or umlaut mark --> -<!ENTITY ntilde CDATA "ñ" -- small n, tilde --> -<!ENTITY oacute CDATA "ó" -- small o, acute accent --> -<!ENTITY ocirc CDATA "ô" -- small o, circumflex accent --> -<!ENTITY ograve CDATA "ò" -- small o, grave accent --> -<!ENTITY oslash CDATA "ø" -- small o, slash --> -<!ENTITY otilde CDATA "õ" -- small o, tilde --> -<!ENTITY ouml CDATA "ö" -- small o, dieresis or umlaut mark --> -<!ENTITY szlig CDATA "ß" -- small sharp s, German (sz ligature) --> -<!ENTITY thorn CDATA "þ" -- small thorn, Icelandic --> -<!ENTITY uacute CDATA "ú" -- small u, acute accent --> -<!ENTITY ucirc CDATA "û" -- small u, circumflex accent --> -<!ENTITY ugrave CDATA "ù" -- small u, grave accent --> -<!ENTITY uuml CDATA "ü" -- small u, dieresis or umlaut mark --> -<!ENTITY yacute CDATA "ý" -- small y, acute accent --> -<!ENTITY yuml CDATA "ÿ" -- small y, dieresis or umlaut mark -->
--- a/etc/sgml/README.cdtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -The compiled dtd's are currently built by hand. Currently, something like -the following will work: - -../../src/xemacs -batch -q -l psgml-parse.elc -l psgml-dtd.elc -eval "(progn (sgml-set-global) (setq sgml-no-elements 0) (sgml-compile-dtd \"$(pwd)/html.dtd\" \"$(pwd)/cdtd/html\" []))" - -Note that the parameters are taken roughly from the ECAT file.
--- a/etc/sgml/README.htmlpro Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -Drazen Kacar <dave@public.srce.hr> writes regarding htmlpro.dtd: - -You probably want the home page URL, though. Try -<URL:http://www.arbornet.org/~silmaril/dtds/html/htmlpro.html> -The site cannot be reached sometimes. The mirror exists somewhere, but I -don't have the URL.
--- a/etc/sgml/Wing.ISOlat1.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -<!-- (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % ISOlat1 PUBLIC - "ISO 8879:1986//ENTITIES Added Latin 1//EN"> - %ISOlat1; ---> -<!-- Added (Ben Wing) 4-4-96: the most common entities were omitted ... --> -<!ENTITY quot SDATA "[quot ]" -- quotation mark --> -<!ENTITY amp SDATA "[amp ]" -- ampersand --> -<!ENTITY lt SDATA "[lt ]" -- less than --> -<!ENTITY gt SDATA "[gt ]" -- greater than --> -<!-- end added (Ben Wing) 4-4-96 --> -<!ENTITY aacute SDATA "[aacute]"--=small a, acute accent--> -<!ENTITY Aacute SDATA "[Aacute]"--=capital A, acute accent--> -<!ENTITY acirc SDATA "[acirc ]"--=small a, circumflex accent--> -<!ENTITY Acirc SDATA "[Acirc ]"--=capital A, circumflex accent--> -<!ENTITY agrave SDATA "[agrave]"--=small a, grave accent--> -<!ENTITY Agrave SDATA "[Agrave]"--=capital A, grave accent--> -<!ENTITY aring SDATA "[aring ]"--=small a, ring--> -<!ENTITY Aring SDATA "[Aring ]"--=capital A, ring--> -<!ENTITY atilde SDATA "[atilde]"--=small a, tilde--> -<!ENTITY Atilde SDATA "[Atilde]"--=capital A, tilde--> -<!ENTITY auml SDATA "[auml ]"--=small a, dieresis or umlaut mark--> -<!ENTITY Auml SDATA "[Auml ]"--=capital A, dieresis or umlaut mark--> -<!ENTITY aelig SDATA "[aelig ]"--=small ae diphthong (ligature)--> -<!ENTITY AElig SDATA "[AElig ]"--=capital AE diphthong (ligature)--> -<!ENTITY ccedil SDATA "[ccedil]"--=small c, cedilla--> -<!ENTITY Ccedil SDATA "[Ccedil]"--=capital C, cedilla--> -<!ENTITY eth SDATA "[eth ]"--=small eth, Icelandic--> -<!ENTITY ETH SDATA "[ETH ]"--=capital Eth, Icelandic--> -<!ENTITY eacute SDATA "[eacute]"--=small e, acute accent--> -<!ENTITY Eacute SDATA "[Eacute]"--=capital E, acute accent--> -<!ENTITY ecirc SDATA "[ecirc ]"--=small e, circumflex accent--> -<!ENTITY Ecirc SDATA "[Ecirc ]"--=capital E, circumflex accent--> -<!ENTITY egrave SDATA "[egrave]"--=small e, grave accent--> -<!ENTITY Egrave SDATA "[Egrave]"--=capital E, grave accent--> -<!ENTITY euml SDATA "[euml ]"--=small e, dieresis or umlaut mark--> -<!ENTITY Euml SDATA "[Euml ]"--=capital E, dieresis or umlaut mark--> -<!ENTITY iacute SDATA "[iacute]"--=small i, acute accent--> -<!ENTITY Iacute SDATA "[Iacute]"--=capital I, acute accent--> -<!ENTITY icirc SDATA "[icirc ]"--=small i, circumflex accent--> -<!ENTITY Icirc SDATA "[Icirc ]"--=capital I, circumflex accent--> -<!ENTITY igrave SDATA "[igrave]"--=small i, grave accent--> -<!ENTITY Igrave SDATA "[Igrave]"--=capital I, grave accent--> -<!ENTITY iuml SDATA "[iuml ]"--=small i, dieresis or umlaut mark--> -<!ENTITY Iuml SDATA "[Iuml ]"--=capital I, dieresis or umlaut mark--> -<!ENTITY ntilde SDATA "[ntilde]"--=small n, tilde--> -<!ENTITY Ntilde SDATA "[Ntilde]"--=capital N, tilde--> -<!ENTITY oacute SDATA "[oacute]"--=small o, acute accent--> -<!ENTITY Oacute SDATA "[Oacute]"--=capital O, acute accent--> -<!ENTITY ocirc SDATA "[ocirc ]"--=small o, circumflex accent--> -<!ENTITY Ocirc SDATA "[Ocirc ]"--=capital O, circumflex accent--> -<!ENTITY ograve SDATA "[ograve]"--=small o, grave accent--> -<!ENTITY Ograve SDATA "[Ograve]"--=capital O, grave accent--> -<!ENTITY oslash SDATA "[oslash]"--=small o, slash--> -<!ENTITY Oslash SDATA "[Oslash]"--=capital O, slash--> -<!ENTITY otilde SDATA "[otilde]"--=small o, tilde--> -<!ENTITY Otilde SDATA "[Otilde]"--=capital O, tilde--> -<!ENTITY ouml SDATA "[ouml ]"--=small o, dieresis or umlaut mark--> -<!ENTITY Ouml SDATA "[Ouml ]"--=capital O, dieresis or umlaut mark--> -<!ENTITY szlig SDATA "[szlig ]"--=small sharp s, German (sz ligature)--> -<!ENTITY thorn SDATA "[thorn ]"--=small thorn, Icelandic--> -<!ENTITY THORN SDATA "[THORN ]"--=capital THORN, Icelandic--> -<!ENTITY uacute SDATA "[uacute]"--=small u, acute accent--> -<!ENTITY Uacute SDATA "[Uacute]"--=capital U, acute accent--> -<!ENTITY ucirc SDATA "[ucirc ]"--=small u, circumflex accent--> -<!ENTITY Ucirc SDATA "[Ucirc ]"--=capital U, circumflex accent--> -<!ENTITY ugrave SDATA "[ugrave]"--=small u, grave accent--> -<!ENTITY Ugrave SDATA "[Ugrave]"--=capital U, grave accent--> -<!ENTITY uuml SDATA "[uuml ]"--=small u, dieresis or umlaut mark--> -<!ENTITY Uuml SDATA "[Uuml ]"--=capital U, dieresis or umlaut mark--> -<!ENTITY yacute SDATA "[yacute]"--=small y, acute accent--> -<!ENTITY Yacute SDATA "[Yacute]"--=capital Y, acute accent--> -<!ENTITY yuml SDATA "[yuml ]"--=small y, dieresis or umlaut mark-->
--- a/etc/sgml/html-0.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -<!-- html-0.dtd - - Document Type Definition for the HyperText Markup Language - as used by minimally conforming World Wide Web applications - (HTML Level 0 DTD). - - $Id: html-0.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@hal.com> - See Also: http://www.hal.com/%7Econnolly/html-spec/index.html - http://info.cern.ch/hypertext/WWW/MarkUp2/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML Level 0//EN//2.0" - -- public identifier for "minimal conformance" version -- - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//IETF//DTD HTML Level 0//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> - -<!ENTITY % HTML.Highlighting "IGNORE"> -<!ENTITY % HTML.Forms "IGNORE"> - -<!ENTITY % head.link " " -- no link in head at level 0 --> -<!ENTITY % linkExtraAttributes " "> -<!ENTITY % img.alt.default "#REQUIRED"> -<!ENTITY % head.link " "> - -<!ENTITY % html PUBLIC "-//IETF//DTD HTML//EN//2.0"> -%html;
--- a/etc/sgml/html-0s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -<!-- html-0P.dtd - - Document Type Definition for the HyperText Markup Language - Strict Level 0 - - $Id: html-0s.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@hal.com> - See Also: http://www.hal.com/%7Econnolly/html-spec/index.html - http://info.cern.ch/hypertext/WWW/MarkUp2/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML Strict Level 0//EN//2.0" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//IETF//DTD HTML Strict Level 0//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html-0 PUBLIC "-//IETF//DTD HTML Level 0//EN//2.0"> -%html-0;
--- a/etc/sgml/html-1.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -<!-- html-1.dtd - - Document Type Definition for the HyperText Markup Language - with Level 1 Extensions (HTML Level 1 DTD). - - $Id: html-1.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@hal.com> - See Also: http://www.hal.com/%7Econnolly/html-spec/index.html - http://info.cern.ch/hypertext/WWW/MarkUp2/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML Level 1//EN//2.0" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//IETF//DTD HTML Level 1//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Forms "IGNORE"> - -<!ENTITY % html PUBLIC "-//IETF//DTD HTML//EN//2.0"> -%html;
--- a/etc/sgml/html-1s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -<!-- html-1P.dtd - - Document Type Definition for the HyperText Markup Language - Struct Level 1 - - $Id: html-1s.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@hal.com> - See Also: http://www.hal.com/%7Econnolly/html-spec/index.html - http://info.cern.ch/hypertext/WWW/MarkUp2/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML Strict Level 1//EN//2.0" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//IETF//DTD HTML Level 1 Recommended//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html-1 PUBLIC "-//IETF//DTD HTML Level 1//EN//2.0"> -%html-1;
--- a/etc/sgml/html-2.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,599 +0,0 @@ -<!-- html.dtd - - Document Type Definition for the HyperText Markup Language - (HTML DTD) - - $Id: html-2.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@w3.org> - See Also: html.decl, html-1.dtd - http://www.w3.org/hypertext/WWW/MarkUp/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML 2.0//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> - <html> - ... - </html> - -- - > - - -<!--============ Feature Test Entities ========================--> - -<!ENTITY % HTML.Recommended "IGNORE" - -- Certain features of the language are necessary for - compatibility with widespread usage, but they may - compromise the structural integrity of a document. - This feature test entity enables a more prescriptive - document type definition that eliminates - those features. - --> - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE" - -- Certain features of the language are necessary for - compatibility with earlier versions of the specification, - but they tend to be used and implemented inconsistently, - and their use is deprecated. This feature test entity - enables a document type definition that eliminates - these features. - --> - -<!ENTITY % HTML.Highlighting "INCLUDE" - -- Use this feature test entity to validate that a - document uses no highlighting tags, which may be - ignored on minimal implementations. - --> - -<!ENTITY % HTML.Forms "INCLUDE" - -- Use this feature test entity to validate that a document - contains no forms, which may not be supported in minimal - implementations - --> - -<!--============== Imported Names ==============================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning an internet media type - (aka MIME content type, as per RFC1521) - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification, in progress - --> - -<!--========= DTD "Macros" =====================--> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list " UL | OL | DIR | MENU " > - - -<!--======= Character mnemonic entities =================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> - - -<!--========= SGML Document Access (SDA) Parameter Entities =====--> - -<!-- HTML 2.0 contains SGML Document Access (SDA) fixed attributes -in support of easy transformation to the International Committee -for Accessible Document Design (ICADD) DTD - "-//EC-USA-CDA/ICADD//DTD ICADD22//EN". -ICADD applications are designed to support usable access to -structured information by print-impaired individuals through -Braille, large print and voice synthesis. For more information on -SDA & ICADD: - - ISO 12083:1993, Annex A.8, Facilities for Braille, - large print and computer voice - - ICADD ListServ - <ICADD%ASUACAD.BITNET@ARIZVM1.ccit.arizona.edu> - - Usenet news group bit.listserv.easi - - Recording for the Blind, +1 800 221 4792 ---> - -<!ENTITY % SDAFORM "SDAFORM CDATA #FIXED" - -- one to one mapping --> -<!ENTITY % SDARULE "SDARULE CDATA #FIXED" - -- context-sensitive mapping --> -<!ENTITY % SDAPREF "SDAPREF CDATA #FIXED" - -- generated text prefix --> -<!ENTITY % SDASUFF "SDASUFF CDATA #FIXED" - -- generated text suffix --> -<!ENTITY % SDASUSP "SDASUSP NAME #FIXED" - -- suspend transform process --> - - -<!--========== Text Markup =====================--> - -<![ %HTML.Highlighting [ - -<!ENTITY % font " TT | B | I "> - -<!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE "> - -<!ENTITY % text "#PCDATA | A | IMG | BR | %phrase | %font"> - -<!ELEMENT (%font;|%phrase) - - (%text)*> -<!ATTLIST ( TT | CODE | SAMP | KBD | VAR ) - %SDAFORM; "Lit" - > -<!ATTLIST ( B | STRONG ) - %SDAFORM; "B" - > -<!ATTLIST ( I | EM | CITE ) - %SDAFORM; "It" - > - -<!-- <TT> Typewriter text --> -<!-- <B> Bold text --> -<!-- <I> Italic text --> - -<!-- <EM> Emphasized phrase --> -<!-- <STRONG> Strong emphasis --> -<!-- <CODE> Source code phrase --> -<!-- <SAMP> Sample text or characters --> -<!-- <KBD> Keyboard phrase, e.g. user input --> -<!-- <VAR> Variable phrase or substitutable --> -<!-- <CITE> Name or title of cited work --> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR | %font | %phrase"> - -]]> - -<!ENTITY % text "#PCDATA | A | IMG | BR"> - -<!ELEMENT BR - O EMPTY> -<!ATTLIST BR - %SDAPREF; "&#RE;" - > - -<!-- <BR> Line break --> - - -<!--========= Link Markup ======================--> - -<!ENTITY % linkType "NAMES"> - -<!ENTITY % linkExtraAttributes - "REL %linkType #IMPLIED - REV %linkType #IMPLIED - URN CDATA #IMPLIED - TITLE CDATA #IMPLIED - METHODS NAMES #IMPLIED - "> - -<![ %HTML.Recommended [ - <!ENTITY % A.content "(%text)*" - -- <H1><a name="xxx">Heading</a></H1> - is preferred to - <a name="xxx"><H1>Heading</H1></a> - --> -]]> - -<!ENTITY % A.content "(%heading|%text)*"> - -<!ELEMENT A - - %A.content -(A)> -<!ATTLIST A - HREF CDATA #IMPLIED - NAME CDATA #IMPLIED - %linkExtraAttributes; - %SDAPREF; "<Anchor: #AttList>" - > -<!-- <A> Anchor; source/destination of link --> -<!-- <A NAME="..."> Name of this anchor --> -<!-- <A HREF="..."> Address of link destination --> -<!-- <A URN="..."> Permanent address of destination --> -<!-- <A REL=...> Relationship to destination --> -<!-- <A REV=...> Relationship of destination to this --> -<!-- <A TITLE="..."> Title of destination (advisory) --> -<!-- <A METHODS="..."> Operations on destination (advisory) --> - - -<!--========== Images ==========================--> - -<!ELEMENT IMG - O EMPTY> -<!ATTLIST IMG - SRC CDATA #REQUIRED - ALT CDATA #IMPLIED - ALIGN (top|middle|bottom) #IMPLIED - ISMAP (ISMAP) #IMPLIED - %SDAPREF; "<Fig><?SDATrans Img: #AttList>#AttVal(Alt)</Fig>" - > - -<!-- <IMG> Image; icon, glyph or illustration --> -<!-- <IMG SRC="..."> Address of image object --> -<!-- <IMG ALT="..."> Textual alternative --> -<!-- <IMG ALIGN=...> Position relative to text --> -<!-- <IMG ISMAP> Each pixel can be a link --> - -<!--========== Paragraphs=======================--> - -<!ELEMENT P - O (%text)*> -<!ATTLIST P - %SDAFORM; "Para" - > - -<!-- <P> Paragraph --> - - -<!--========== Headings, Titles, Sections ===============--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - %SDAPREF; "&#RE;&#RE;" - > - -<!-- <HR> Horizontal rule --> - -<!ELEMENT ( %heading ) - - (%text;)*> -<!ATTLIST H1 - %SDAFORM; "H1" - > -<!ATTLIST H2 - %SDAFORM; "H2" - > -<!ATTLIST H3 - %SDAFORM; "H3" - > -<!ATTLIST H4 - %SDAFORM; "H4" - > -<!ATTLIST H5 - %SDAFORM; "H5" - > -<!ATTLIST H6 - %SDAFORM; "H6" - > - -<!-- <H1> Heading, level 1 --> -<!-- <H2> Heading, level 2 --> -<!-- <H3> Heading, level 3 --> -<!-- <H4> Heading, level 4 --> -<!-- <H5> Heading, level 5 --> -<!-- <H6> Heading, level 6 --> - - -<!--========== Text Flows ======================--> - -<![ %HTML.Forms [ - <!ENTITY % block.forms "BLOCKQUOTE | FORM | ISINDEX"> -]]> - -<!ENTITY % block.forms "BLOCKQUOTE"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<!ENTITY % block "P | %list | DL - | %preformatted - | %block.forms"> - -<!ENTITY % flow "(%text|%block)*"> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR"> -<!ELEMENT PRE - - (%pre.content)*> -<!ATTLIST PRE - WIDTH NUMBER #implied - %SDAFORM; "Lit" - > - -<!-- <PRE> Preformatted text --> -<!-- <PRE WIDTH=...> Maximum characters per line --> - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ATTLIST XMP - %SDAFORM; "Lit" - %SDAPREF; "Example:&#RE;" - > -<!ATTLIST LISTING - %SDAFORM; "Lit" - %SDAPREF; "Listing:&#RE;" - > - -<!-- <XMP> Example section --> -<!-- <LISTING> Computer listing --> - -<!ELEMENT PLAINTEXT - O %literal> -<!-- <PLAINTEXT> Plain text passage --> - -<!ATTLIST PLAINTEXT - %SDAFORM; "Lit" - > -]]> - - -<!--========== Lists ==================--> - -<!ELEMENT DL - - (DT | DD)+> -<!ATTLIST DL - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "Definition List:" - > - -<!ELEMENT DT - O (%text)*> -<!ATTLIST DT - %SDAFORM; "Term" - > - -<!ELEMENT DD - O %flow> -<!ATTLIST DD - %SDAFORM; "LItem" - > - -<!-- <DL> Definition list, or glossary --> -<!-- <DL COMPACT> Compact style list --> -<!-- <DT> Term in definition list --> -<!-- <DD> Definition of term --> - -<!ELEMENT (OL|UL) - - (LI)+> -<!ATTLIST OL - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - > -<!ATTLIST UL - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - > -<!-- <UL> Unordered list --> -<!-- <UL COMPACT> Compact list style --> -<!-- <OL> Ordered, or numbered list --> -<!-- <OL COMPACT> Compact list style --> - - -<!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> -<!ATTLIST DIR - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "<LHead>Directory</LHead>" - > -<!ATTLIST MENU - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "<LHead>Menu</LHead>" - > - -<!-- <DIR> Directory list --> -<!-- <DIR COMPACT> Compact list style --> -<!-- <MENU> Menu list --> -<!-- <MENU COMPACT> Compact list style --> - -<!ELEMENT LI - O %flow> -<!ATTLIST LI - %SDAFORM; "LItem" - > - -<!-- <LI> List item --> - -<!--========== Document Body ===================--> - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(%heading|%block|HR|ADDRESS|IMG)*" - -- <h1>Heading</h1> - <p>Text ... - is preferred to - <h1>Heading</h1> - Text ... - --> -]]> - -<!ENTITY % body.content "(%heading | %text | %block | - HR | ADDRESS)*"> - -<!ELEMENT BODY O O %body.content> - -<!-- <BODY> Document body --> - -<!ELEMENT BLOCKQUOTE - - %body.content> -<!ATTLIST BLOCKQUOTE - %SDAFORM; "BQ" - > - -<!-- <BLOCKQUOTE> Quoted passage --> - -<!ELEMENT ADDRESS - - (%text|P)*> -<!ATTLIST ADDRESS - %SDAFORM; "Lit" - %SDAPREF; "Address:&#RE;" - > - -<!-- <ADDRESS> Address, signature, or byline --> - - -<!--======= Forms ====================--> - -<![ %HTML.Forms [ - -<!ELEMENT FORM - - %body.content -(FORM) +(INPUT|SELECT|TEXTAREA)> -<!ATTLIST FORM - ACTION CDATA #IMPLIED - METHOD (%HTTP-Method) GET - ENCTYPE %Content-Type; "application/x-www-form-urlencoded" - %SDAPREF; "<Para>Form:</Para>" - %SDASUFF; "<Para>Form End.</Para>" - > - -<!-- <FORM> Fill-out or data-entry form --> -<!-- <FORM ACTION="..."> Address for completed form --> -<!-- <FORM METHOD=...> Method of submitting form --> -<!-- <FORM ENCTYPE="..."> Representation of form data --> - -<!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | - RADIO | SUBMIT | RESET | - IMAGE | HIDDEN )"> -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - TYPE %InputType TEXT - NAME CDATA #IMPLIED - VALUE CDATA #IMPLIED - SRC CDATA #IMPLIED - CHECKED (CHECKED) #IMPLIED - SIZE CDATA #IMPLIED - MAXLENGTH NUMBER #IMPLIED - ALIGN (top|middle|bottom) #IMPLIED - %SDAPREF; "Input: " - > - -<!-- <INPUT> Form input datum --> -<!-- <INPUT TYPE=...> Type of input interaction --> -<!-- <INPUT NAME=...> Name of form datum --> -<!-- <INPUT VALUE="..."> Default/initial/selected value --> -<!-- <INPUT SRC="..."> Address of image --> -<!-- <INPUT CHECKED> Initial state is "on" --> -<!-- <INPUT SIZE=...> Field size hint --> -<!-- <INPUT MAXLENGTH=...> Data length maximum --> -<!-- <INPUT ALIGN=...> Image alignment --> - -<!ELEMENT SELECT - - (OPTION+) -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST SELECT - NAME CDATA #REQUIRED - SIZE NUMBER #IMPLIED - MULTIPLE (MULTIPLE) #IMPLIED - %SDAFORM; "List" - %SDAPREF; - "<LHead>Select #AttVal(Multiple)</LHead>" - > - -<!-- <SELECT> Selection of option(s) --> -<!-- <SELECT NAME=...> Name of form datum --> -<!-- <SELECT SIZE=...> Options displayed at a time --> -<!-- <SELECT MULTIPLE> Multiple selections allowed --> - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - SELECTED (SELECTED) #IMPLIED - VALUE CDATA #IMPLIED - %SDAFORM; "LItem" - %SDAPREF; - "Option: #AttVal(Value) #AttVal(Selected)" - > - -<!-- <OPTION> A selection option --> -<!-- <OPTION SELECTED> Initial state --> -<!-- <OPTION VALUE="..."> Form datum value for this option--> - -<!ELEMENT TEXTAREA - - (#PCDATA)* -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST TEXTAREA - NAME CDATA #REQUIRED - ROWS NUMBER #REQUIRED - COLS NUMBER #REQUIRED - %SDAFORM; "Para" - %SDAPREF; "Input Text -- #AttVal(Name): " - > - -<!-- <TEXTAREA> An area for text input --> -<!-- <TEXTAREA NAME=...> Name of form datum --> -<!-- <TEXTAREA ROWS=...> Height of area --> -<!-- <TEXTAREA COLS=...> Width of area --> - -]]> - - -<!--======= Document Head ======================--> - -<![ %HTML.Recommended [ - <!ENTITY % head.extra ""> -]]> -<!ENTITY % head.extra "& NEXTID?"> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE? %head.extra"> - -<!ELEMENT HEAD O O (%head.content) +(META|LINK)> - -<!-- <HEAD> Document head --> - -<!ELEMENT TITLE - - (#PCDATA)* -(META|LINK)> -<!ATTLIST TITLE - %SDAFORM; "Ti" > - -<!-- <TITLE> Title of document --> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - HREF CDATA #REQUIRED - %linkExtraAttributes; - %SDAPREF; "Linked to : #AttVal (TITLE) (URN) (HREF)>" > - -<!-- <LINK> Link from this document --> -<!-- <LINK HREF="..."> Address of link destination --> -<!-- <LINK URN="..."> Lasting name of destination --> -<!-- <LINK REL=...> Relationship to destination --> -<!-- <LINK REV=...> Relationship of destination to this --> -<!-- <LINK TITLE="..."> Title of destination (advisory) --> -<!-- <LINK METHODS="..."> Operations allowed (advisory) --> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - %SDAPREF; - "<Para>[Document is indexed/searchable.]</Para>"> - -<!-- <ISINDEX> Document is a searchable index --> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - HREF CDATA #REQUIRED > - -<!-- <BASE> Base context document --> -<!-- <BASE HREF="..."> Address for this document --> - -<!ELEMENT NEXTID - O EMPTY> -<!ATTLIST NEXTID - N CDATA #REQUIRED > - -<!-- <NEXTID> Next ID to use for link name --> -<!-- <NEXTID N=...> Next ID to use for link name --> - -<!ELEMENT META - O EMPTY> -<!ATTLIST META - HTTP-EQUIV NAME #IMPLIED - NAME NAME #IMPLIED - CONTENT CDATA #REQUIRED > - -<!-- <META> Generic Meta-information --> -<!-- <META HTTP-EQUIV=...> HTTP response header name --> -<!-- <META NAME=...> Meta-information name --> -<!-- <META CONTENT="..."> Associated information --> - -<!--======= Document Structure =================--> - -<![ %HTML.Deprecated [ - <!ENTITY % html.content "HEAD, BODY, PLAINTEXT?"> -]]> -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<!ATTLIST HTML - %version.attr; - %SDAFORM; "Book" - > - -<!-- <HTML> HTML Document -->
--- a/etc/sgml/html-3.2.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,599 +0,0 @@ -<!-- - W3C Document Type Definition for the HyperText Markup Language - This version is code named Wilbur, and also as "HTML 3.2". - - Draft: Tuesday 21-May-96 - - Author: Dave Raggett <dsr@w3.org> - - This is subject to change, pending final approval by the W3C - member companies. - - HTML 3.2 aims to capture recommended practice as of early '96 - and as such to be used as a replacement for HTML 2.0 (RFC 1866). - Widely deployed rendering attributes are included where they - have been shown to be interoperable. SCRIPT and STYLE are - included to smooth the introduction of client-side scripts - and style sheets. Browsers must avoid showing the contents - of these element Otherwise support for them is not required. - ID, CLASS and STYLE attributes are not included in this version - of HTML. - - The next version of HTML after Wilbur is code named Cougar and - will add support for <OBJECT>, client-side scripting, style - sheets, and extensions to fill-out forms. ---> - -<!ENTITY % HTML.Version - "-//W3C//DTD HTML 3.2//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> - <html> - ... - </html> - -- - > - -<!--================== Deprecated Features Switch =========================--> - -<!ENTITY % HTML.Deprecated "INCLUDE"> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URL "CDATA" - -- The term URL means a CDATA attribute - whose value is a Uniform Resource Locator, - See RFC1808 (June 95) and RFC1738 (Dec 94). - --> - -<!-- Parameter Entities --> - -<!ENTITY % head.misc "SCRIPT|STYLE|META|LINK" -- repeatable head elements --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list "UL | OL | DIR | MENU"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<!--================ Character mnemonic entities ==========================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!--================ Entities for special symbols =========================--> -<!-- &trade ­ and &cbsp are not widely deployed and so not included here --> - -<!ENTITY copy CDATA "©" -- copyright sign --> -<!ENTITY reg CDATA "®" -- registered sign --> -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> -<!ENTITY nbsp CDATA " " -- non breaking space --> - -<!--=================== Text Markup =======================================--> - -<!ENTITY % font "TT | I | B | STRIKE | BIG | SMALL | SUB | SUP"> - -<!ENTITY % phrase "EM | STRONG | DFN | CODE | SAMP | KBD | VAR | CITE"> - -<!ENTITY % special "A | IMG | APPLET | FONT | BR | SCRIPT | MAP"> - -<!ENTITY % form "INPUT | SELECT | TEXTAREA"> - -<!ENTITY % text "#PCDATA | %font | %phrase | %special | %form"> - -<!ELEMENT (%font|%phrase) - - (%text)*> - -<!-- there are also 16 widely known color names although - the resulting colors are implementation dependent: - - aqua, black, blue, fuchsia, gray, green, lime, maroon, - navy, olive, purple, red, silver, teal, white, and yellow - - These colors were originally picked as being the standard - 16 colors supported with the Windows VGA palette. - --> - -<!ELEMENT FONT - - (%text)* -- local change to font --> -<!ATTLIST FONT - size CDATA #IMPLIED -- [+]nn e.g. size="+1", size=4 -- - color CDATA #IMPLIED -- #RRGGBB in hex, e.g. red: color="#FF0000" -- - > - -<!ELEMENT BR - O EMPTY -- forced line break --> -<!ATTLIST BR - clear (left|all|right|none) none -- control of text flow -- - > - -<!--================== HTML content models ================================--> -<!-- - HTML has three basic content models: - - %text character level elements and text strings - %flow block-like elements e.g. paragraphs and lists - %bodytext as (b) plus headers and ADDRESS ---> - -<!ENTITY % block - "P | %list | %preformatted | DL | DIV | CENTER | - BLOCKQUOTE | FORM | ISINDEX | HR | TABLE"> - -<!-- %flow is used for DD and LI --> - -<!ENTITY % flow "(%text | %block)*"> - -<!--=================== Document Body =====================================--> - -<!ENTITY % body.content "(%heading | %text | %block | ADDRESS)*"> - -<!ENTITY % color "CDATA" -- a color specification: #HHHHHH @@ details? --> - -<!ENTITY % body-color-attrs " - bgcolor %color #IMPLIED - text %color #IMPLIED - link %color #IMPLIED - vlink %color #IMPLIED - alink %color #IMPLIED - "> - -<!ELEMENT BODY O O %body.content> -<!ATTLIST BODY - background %URL #IMPLIED -- texture tile for document background -- - %body-color-attrs; -- bgcolor, text, link, vlink, alink -- - > - -<!ENTITY % address.content "((%text;) | P)*"> - -<!ELEMENT ADDRESS - - %address.content> - -<!ELEMENT DIV - - %body.content> -<!ATTLIST DIV - align (left|center|right) left -- alignment of following text -- - > - -<!-- CENTER is a shorthand for DIV with ALIGN=CENTER --> -<!ELEMENT center - - %body.content> - -<!--================== The Anchor Element =================================--> - -<!ELEMENT A - - (%text)* -(A)> -<!ATTLIST A - name CDATA #IMPLIED -- named link end -- - href %URL #IMPLIED -- URL for linked resource -- - rel CDATA #IMPLIED -- forward link types -- - rev CDATA #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - > - -<!--================== Client-side image maps ============================--> - -<!-- These can be placed in the same document or grouped in a - separate document although this isn't yet widely supported --> - -<!ENTITY % SHAPE "(rect|circle|poly|default)"> -<!ENTITY % COORDS "CDATA" -- comma separated list of numbers --> - -<!ELEMENT MAP - - (AREA)*> -<!ATTLIST MAP - name CDATA #IMPLIED - > - -<!ELEMENT AREA - O EMPTY> -<!ATTLIST AREA - shape %SHAPE rect - coords %COORDS #IMPLIED -- always needed except for shape=default -- - href %URL #IMPLIED -- this region acts as hypertext link -- - nohref (nohref) #IMPLIED -- this region has no action -- - alt CDATA #REQUIRED - > - -<!--================== The LINK Element ==================================--> - -<!ENTITY % Types "CDATA" - -- See Internet Draft: draft-ietf-html-relrev-00.txt - LINK has been part of HTML since the early days - although few browsers as yet take advantage of it. - - Relationship values can be used in principle: - - a) for document specific toolbars/menus when used - with the LINK element in document head: - b) to link to a separate style sheet (rel=stylesheet) - c) to make a link to a script (rel=script) - d) by stylesheets to control how collections of - html nodes are rendered into printed documents - e) to make a link to a printable version of this document - e.g. a postscript or pdf version (rel=print) ---> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - id ID #IMPLIED -- SGML ID attribute -- - href %URL #IMPLIED -- URL for linked resource -- - rel %Types #IMPLIED -- forward link types -- - rev %Types #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - > - -<!--=================== Images ============================================--> - -<!ENTITY % Length "CDATA" -- nn for pixels or nn% for percentage length --> -<!ENTITY % Pixels "CDATA" -- integer representing length in pixels --> - -<!-- Suggested widths are used for negotiating image size - with the module responsible for painting the image. - align=left or right cause image to float to margin - and for subsequent text to wrap around image --> - -<!ENTITY % IAlign "(top|middle|bottom|left|right)"> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - src %URL #REQUIRED -- URL of image to embed -- - alt CDATA #IMPLIED -- for display in place of image -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #IMPLIED -- suggested height in pixels -- - width %Pixels #IMPLIED -- suggested width in pixels -- - border %Pixels #IMPLIED -- suggested link border width -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - usemap %URL #IMPLIED -- use client-side image map -- - ismap (ismap) #IMPLIED -- use server image map -- - > - -<!-- USEMAP points to a MAP element which may be in this document - or an external document, although the latter is not widely supported --> - -<!--=================== Java APPLET tag ===================================--> -<!-- - This tag is supported by all java enabled browsers. Applet resources - (including their classes) are normally loaded relative to the document - URL (or <BASE> element if it is defined). The CODEBASE attribute is used - to change this default behavior. If the CODEBASE attribute is defined then - it specifies a different location to find applet resources. The value - can be an absolute URL or a relative URL. The absolute URL is used as is - without modification and is not effected by the documents <BASE> element. - When the codebase attribute is relative, then it is relative to the - document URL (or <BASE> tag if defined). <TEXTFLOW> avoids the problems - with SGML mixed content. It can always be omitted *except* when the APPLET - element hasn't any content. White space, comments and PARAM elements - don't count as content for this purpose. TEXTFLOW was introduced into - the DTD to satisfy SGML parsers, but is ignored by current Web browsers. ---> -<!ELEMENT APPLET - - (PARAM*, TEXTFLOW)> -<!ATTLIST APPLET - codebase %URL #IMPLIED -- code base -- - code CDATA #REQUIRED -- class file -- - name CDATA #IMPLIED -- applet name -- - alt CDATA #IMPLIED -- for display in place of applet -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #REQUIRED -- suggested height in pixels -- - width %Pixels #REQUIRED -- suggested width in pixels -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - > - -<!ELEMENT PARAM - O EMPTY> -<!ATTLIST PARAM - name NAME #REQUIRED -- The name of the parameter -- - value CDATA #IMPLIED -- The value of the parameter -- - > -<!ELEMENT TEXTFLOW O O (%text)* -- needed to bypass mixed content model --> - -<!-- -Here is an example: - - <applet codebase="applets/NervousText" - code=NervousText.class - width=300 - height=50> - <param name=text value="Java is Cool!"> - <img src=sorry.gif alt="This looks better with Java support"> - </applet> ---> - -<!--=================== Horizontal Rule ===================================--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - align (left|right|center) #IMPLIED - noshade (noshade) #IMPLIED - size %Pixels #IMPLIED - width %Length #IMPLIED - > -<!--=================== Paragraphs=========================================--> - -<!ELEMENT P - O (%text)*> -<!ATTLIST P - align (left|center|right) #IMPLIED - > - -<!--=================== Headings ==========================================--> - -<!-- - There are six levels of headers from H1 (the most important) - to H6 (the least important). ---> - -<!ELEMENT ( %heading ) - - (%text;)*> -<!ATTLIST ( %heading ) - align (left|center|right) #IMPLIED - > - -<!--=================== Preformatted Text =================================--> - -<!-- excludes images and changes in font size --> - -<!ENTITY % pre.exclusion "IMG|BIG|SMALL|SUB|SUP|FONT"> - -<!ELEMENT PRE - - (%text)* -(%pre.exclusion)> -<!ATTLIST PRE - width NUMBER #implied -- is this widely supported? -- - > - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -]]> - -<!--=================== Block-like Quotes =================================--> - -<!ELEMENT BLOCKQUOTE - - %body.content> - -<!--=================== Lists =============================================--> - -<!-- - HTML 3.2 allows you to control the sequence number for ordered lists. - You can set the sequence number with the START and VALUE attributes. - The TYPE attribute may be used to specify the rendering of ordered - and unordered lists. ---> - -<!-- definition lists - DT for term, DD for its definition --> - -<!ELEMENT DL - - (DT|DD)*> -<!ATTLIST DL - compact (compact) #IMPLIED -- more compact style -- - > - -<!ELEMENT DT - O (%text)*> -<!ELEMENT DD - O %flow;> - -<!-- Ordered lists OL, and unordered lists UL --> -<!ELEMENT (OL|UL) - - (LI)*> - -<!-- - Numbering style - 1 arablic numbers 1, 2, 3, ... - a lower alpha a, b, c, ... - A upper alpha A, B, C, ... - i lower roman i, ii, iii, ... - I upper roman I, II, III, ... - - The style is applied to the sequence number which by default - is reset to 1 for the first list item in an ordered list. - - This can't be expressed directly in SGML due to case folding. ---> - -<!ENTITY % OLStyle "CDATA" -- constrained to: [1|a|A|i|I] --> - -<!ATTLIST OL -- ordered lists -- - type %OLStyle #IMPLIED -- numbering style -- - start NUMBER #IMPLIED -- starting sequence number -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!-- bullet styles --> - -<!ENTITY % ULStyle "disc|square|circle"> - -<!ATTLIST UL -- unordered lists -- - type (%ULStyle) #IMPLIED -- bullet style -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!ELEMENT (DIR|MENU) - - (LI)* -(%block)> -<!ATTLIST DIR - compact (compact) #IMPLIED - > -<!ATTLIST MENU - compact (compact) #IMPLIED - > - -<!-- <DIR> Directory list --> -<!-- <DIR COMPACT> Compact list style --> -<!-- <MENU> Menu list --> -<!-- <MENU COMPACT> Compact list style --> - -<!-- The type attribute can be used to change the bullet style - in unordered lists and the numbering style in ordered lists --> - -<!ENTITY % LIStyle "CDATA" -- constrained to: "(%ULStyle|%OLStyle)" --> - -<!ELEMENT LI - O %flow -- list item --> -<!ATTLIST LI - type %LIStyle #IMPLIED -- list item style -- - value NUMBER #IMPLIED -- reset sequence number -- - > - -<!--================ Forms ===============================================--> - -<!ELEMENT FORM - - %body.content -(FORM)> -<!ATTLIST FORM - action %URL #REQUIRED -- server-side form handler -- - method (%HTTP-Method) GET -- see HTTP specification -- - enctype %Content-Type; "application/x-www-form-urlencoded" - > - -<!ENTITY % InputType - "(TEXT | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | FILE | HIDDEN | IMAGE)"> - -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - type %InputType TEXT -- what kind of widget is needed -- - name CDATA #IMPLIED -- required for all but submit and reset -- - value CDATA #IMPLIED -- required for radio and checkboxes -- - checked (checked) #IMPLIED -- for radio buttons and check boxes -- - size CDATA #IMPLIED -- specific to each type of field -- - maxlength NUMBER #IMPLIED - src %URL #IMPLIED -- for fields with background images -- - align (top|middle|bottom|left|right) top -- image alignment -- - > - -<!ELEMENT SELECT - - (OPTION+)> -<!ATTLIST SELECT - name CDATA #REQUIRED - size NUMBER #IMPLIED - multiple (multiple) #IMPLIED - > - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - selected (selected) #IMPLIED - value CDATA #IMPLIED -- defaults to element content -- - > - -<!-- Multi-line text input field. --> - -<!ELEMENT TEXTAREA - - (#PCDATA)*> -<!ATTLIST TEXTAREA - name CDATA #REQUIRED - rows NUMBER #REQUIRED - cols NUMBER #REQUIRED - > - -<!--======================= Tables ========================================--> - -<!-- Widely deployed subset of the full table standard, see RFC XXXX --> - -<!-- horizontal placement of table relative to window --> -<!ENTITY % Where "(left|center|right)"> - -<!-- horizontal alignment attributes for cell contents --> -<!ENTITY % cell.halign - "align (left|center|right) #IMPLIED" - > - -<!-- vertical alignment attributes for cell contents --> -<!ENTITY % cell.valign - "valign (top|middle|bottom|baseline) #IMPLIED" - > - -<!ELEMENT table - - (caption?, tr+)> -<!ELEMENT tr - O (th|td)*> -<!ELEMENT (th|td) - O %body.content> - -<!ATTLIST table -- table element -- - align %Where; #IMPLIED -- table position relative to window -- - width %Length #IMPLIED -- table width relative to window -- - border %Pixels #IMPLIED -- controls frame width around table -- - cellspacing %Pixels #IMPLIED -- spacing between cells -- - cellpadding %Pixels #IMPLIED -- spacing within cells -- - > - -<!ELEMENT CAPTION - - (%text;)* -- table or figure caption --> -<!ATTLIST CAPTION - align (top|bottom) #IMPLIED - > - -<!ATTLIST tr -- table row -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!ATTLIST (th|td) -- header or data cell -- - nowrap (nowrap) #IMPLIED -- suppress word wrap -- - rowspan NUMBER 1 -- number of rows spanned by cell -- - colspan NUMBER 1 -- number of cols spanned by cell -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!--================ Document Head ========================================--> - -<!-- %head.misc defined earlier on as "SCRIPT|STYLE|META|LINK" --> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE?"> - -<!ELEMENT HEAD O O (%head.content) +(%head.misc)> - -<!ELEMENT TITLE - - (#PCDATA)* -(%head.misc) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - prompt CDATA #IMPLIED -- prompt message --> - -<!-- - The BASE element gives an absolute URL for dereferencing relative - URLs, e.g. - - <BASE href="http://foo.com/index.html"> - ... - <IMG SRC="images/bar.gif"> - - The image is deferenced to - - http://foo.com/images/bar.gif - - In the absence of a BASE element the document URL should be used. - Note that this is not necessarily the same as the URL used to - request the document, as the base URL may be overridden by an HTTP - header accompanying the document. ---> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - href %URL #REQUIRED - > - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - http-equiv NAME #IMPLIED -- HTTP response header name -- - name NAME #IMPLIED -- metainformation name -- - content CDATA #REQUIRED -- associated information -- - > - -<!-- SCRIPT/STYLE are place holders for transition to next version of HTML --> - -<!ELEMENT STYLE - - (#PCDATA)* -(%head.misc) -- style info --> -<!ELEMENT SCRIPT - - (#PCDATA)* -(%head.misc) -- script statements --> - -<!--================ Document Structure ===================================--> - -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<!ELEMENT HTML O O (HEAD, BODY)> -<!ATTLIST HTML - %version.attr; - >
--- a/etc/sgml/html-3.2f.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,598 +0,0 @@ -<!-- - W3C Document Type Definition for the HyperText Markup Language - version 3.2 as ratified by a vote of W3C member companies. - For more information on W3C look at URL http://www.w3.org/ - - Date: Tuesday January 14th 1996 - - Author: Dave Raggett <dsr@w3.org> - - HTML 3.2 aims to capture recommended practice as of early '96 - and as such to be used as a replacement for HTML 2.0 (RFC 1866). - Widely deployed rendering attributes are included where they - have been shown to be interoperable. SCRIPT and STYLE are - included to smooth the introduction of client-side scripts - and style sheets. Browsers must avoid showing the contents - of these element Otherwise support for them is not required. - ID, CLASS and STYLE attributes are not included in this version - of HTML. ---> - -<!ENTITY % HTML.Version - "-//W3C//DTD HTML 3.2 Final//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN"> - <html> - ... - </html> - -- - > - -<!--================== Deprecated Features Switch =========================--> - -<!ENTITY % HTML.Deprecated "INCLUDE"> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URL "CDATA" - -- The term URL means a CDATA attribute - whose value is a Uniform Resource Locator, - See RFC1808 (June 95) and RFC1738 (Dec 94). - --> - -<!-- Parameter Entities --> - -<!ENTITY % head.misc "SCRIPT|STYLE|META|LINK" -- repeatable head elements --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list "UL | OL | DIR | MENU"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<!--================ Character mnemonic entities ==========================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!--================ Entities for special symbols =========================--> -<!-- &trade and &cbsp are not widely deployed and so not included here --> - -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> - -<!--=================== Text Markup =======================================--> - -<!ENTITY % font "TT | I | B | U | STRIKE | BIG | SMALL | SUB | SUP"> - -<!ENTITY % phrase "EM | STRONG | DFN | CODE | SAMP | KBD | VAR | CITE"> - -<!ENTITY % special "A | IMG | APPLET | FONT | BASEFONT | BR | SCRIPT | MAP"> - -<!ENTITY % form "INPUT | SELECT | TEXTAREA"> - -<!ENTITY % text "#PCDATA | %font | %phrase | %special | %form"> - -<!ELEMENT (%font|%phrase) - - (%text)*> - -<!-- there are also 16 widely known color names although - the resulting colors are implementation dependent: - - aqua, black, blue, fuchsia, gray, green, lime, maroon, - navy, olive, purple, red, silver, teal, white, and yellow - - These colors were originally picked as being the standard - 16 colors supported with the Windows VGA palette. - --> - -<!ELEMENT FONT - - (%text)* -- local change to font --> -<!ATTLIST FONT - size CDATA #IMPLIED -- [+]nn e.g. size="+1", size=4 -- - color CDATA #IMPLIED -- #RRGGBB in hex, e.g. red: color="#FF0000" -- - > - -<!ELEMENT BASEFONT - O EMPTY -- base font size (1 to 7)--> -<!ATTLIST BASEFONT - size CDATA #IMPLIED -- e.g. size=3 -- - > - -<!ELEMENT BR - O EMPTY -- forced line break --> -<!ATTLIST BR - clear (left|all|right|none) none -- control of text flow -- - > - -<!--================== HTML content models ================================--> -<!-- - HTML has three basic content models: - - %text character level elements and text strings - %flow block-like elements e.g. paragraphs and lists - %bodytext as %flow plus headers H1-H6 and ADDRESS ---> - -<!ENTITY % block - "P | %list | %preformatted | DL | DIV | CENTER | - BLOCKQUOTE | FORM | ISINDEX | HR | TABLE"> - -<!-- %flow is used for DD and LI --> - -<!ENTITY % flow "(%text | %block)*"> - -<!--=================== Document Body =====================================--> - -<!ENTITY % body.content "(%heading | %text | %block | ADDRESS)*"> - -<!ENTITY % color "CDATA" -- a color specification: #HHHHHH @@ details? --> - -<!ENTITY % body-color-attrs " - bgcolor %color #IMPLIED - text %color #IMPLIED - link %color #IMPLIED - vlink %color #IMPLIED - alink %color #IMPLIED - "> - -<!ELEMENT BODY O O %body.content> -<!ATTLIST BODY - background %URL #IMPLIED -- texture tile for document background -- - %body-color-attrs; -- bgcolor, text, link, vlink, alink -- - > - -<!ENTITY % address.content "((%text;) | P)*"> - -<!ELEMENT ADDRESS - - %address.content> - -<!ELEMENT DIV - - %body.content> -<!ATTLIST DIV - align (left|center|right) #IMPLIED -- alignment of following text -- - > - -<!-- CENTER is a shorthand for DIV with ALIGN=CENTER --> -<!ELEMENT center - - %body.content> - -<!--================== The Anchor Element =================================--> - -<!ELEMENT A - - (%text)* -(A)> -<!ATTLIST A - name CDATA #IMPLIED -- named link end -- - href %URL #IMPLIED -- URL for linked resource -- - rel CDATA #IMPLIED -- forward link types -- - rev CDATA #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - > - -<!--================== Client-side image maps ============================--> - -<!-- These can be placed in the same document or grouped in a - separate document although this isn't yet widely supported --> - -<!ENTITY % SHAPE "(rect|circle|poly)"> -<!ENTITY % COORDS "CDATA" -- comma separated list of numbers --> - -<!ELEMENT MAP - - (AREA)*> -<!ATTLIST MAP - name CDATA #IMPLIED - > - -<!ELEMENT AREA - O EMPTY> -<!ATTLIST AREA - shape %SHAPE rect - coords %COORDS #IMPLIED -- defines coordinates for shape -- - href %URL #IMPLIED -- this region acts as hypertext link -- - nohref (nohref) #IMPLIED -- this region has no action -- - alt CDATA #REQUIRED -- needed for non-graphical user agents -- - > - -<!--================== The LINK Element ==================================--> - -<!ENTITY % Types "CDATA" - -- See Internet Draft: draft-ietf-html-relrev-00.txt - LINK has been part of HTML since the early days - although few browsers as yet take advantage of it. - - Relationship values can be used in principle: - - a) for document specific toolbars/menus when used - with the LINK element in the document head: - b) to link to a separate style sheet - c) to make a link to a script - d) by stylesheets to control how collections of - html nodes are rendered into printed documents - e) to make a link to a printable version of this document - e.g. a postscript or pdf version ---> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - href %URL #IMPLIED -- URL for linked resource -- - rel %Types #IMPLIED -- forward link types -- - rev %Types #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - > - -<!--=================== Images ============================================--> - -<!ENTITY % Length "CDATA" -- nn for pixels or nn% for percentage length --> -<!ENTITY % Pixels "CDATA" -- integer representing length in pixels --> - -<!-- Suggested widths are used for negotiating image size - with the module responsible for painting the image. - align=left or right cause image to float to margin - and for subsequent text to wrap around image --> - -<!ENTITY % IAlign "(top|middle|bottom|left|right)"> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - src %URL #REQUIRED -- URL of image to embed -- - alt CDATA #IMPLIED -- for display in place of image -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #IMPLIED -- suggested height in pixels -- - width %Pixels #IMPLIED -- suggested width in pixels -- - border %Pixels #IMPLIED -- suggested link border width -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - usemap %URL #IMPLIED -- use client-side image map -- - ismap (ismap) #IMPLIED -- use server image map -- - > - -<!-- USEMAP points to a MAP element which may be in this document - or an external document, although the latter is not widely supported --> - -<!--=================== Java APPLET tag ===================================--> -<!-- - This tag is supported by all Java enabled browsers. Applet resources - (including their classes) are normally loaded relative to the document - URL (or <BASE> element if it is defined). The CODEBASE attribute is used - to change this default behavior. If the CODEBASE attribute is defined then - it specifies a different location to find applet resources. The value - can be an absolute URL or a relative URL. The absolute URL is used as is - without modification and is not effected by the documents <BASE> element. - When the codebase attribute is relative, then it is relative to the - document URL (or <BASE> tag if defined). ---> -<!ELEMENT APPLET - - (PARAM | %text)*> -<!ATTLIST APPLET - codebase %URL #IMPLIED -- code base -- - code CDATA #REQUIRED -- class file -- - alt CDATA #IMPLIED -- for display in place of applet -- - name CDATA #IMPLIED -- applet name -- - width %Pixels #REQUIRED -- suggested width in pixels -- - height %Pixels #REQUIRED -- suggested height in pixels -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - > - -<!ELEMENT PARAM - O EMPTY> -<!ATTLIST PARAM - name NMTOKEN #REQUIRED -- The name of the parameter -- - value CDATA #IMPLIED -- The value of the parameter -- - > - -<!-- -Here is an example: - - <applet codebase="applets/NervousText" - code=NervousText.class - width=300 - height=50> - <param name=text value="Java is Cool!"> - <img src=sorry.gif alt="This looks better with Java support"> - </applet> ---> - -<!--=================== Horizontal Rule ===================================--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - align (left|right|center) #IMPLIED - noshade (noshade) #IMPLIED - size %Pixels #IMPLIED - width %Length #IMPLIED - > -<!--=================== Paragraphs=========================================--> - -<!ELEMENT P - O (%text)*> -<!ATTLIST P - align (left|center|right) #IMPLIED - > - -<!--=================== Headings ==========================================--> - -<!-- - There are six levels of headers from H1 (the most important) - to H6 (the least important). ---> - -<!ELEMENT ( %heading ) - - (%text;)*> -<!ATTLIST ( %heading ) - align (left|center|right) #IMPLIED - > - -<!--=================== Preformatted Text =================================--> - -<!-- excludes images and changes in font size --> - -<!ENTITY % pre.exclusion "IMG|BIG|SMALL|SUB|SUP|FONT"> - -<!ELEMENT PRE - - (%text)* -(%pre.exclusion)> -<!ATTLIST PRE - width NUMBER #implied -- is this widely supported? -- - > - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -]]> - -<!--=================== Block-like Quotes =================================--> - -<!ELEMENT BLOCKQUOTE - - %body.content> - -<!--=================== Lists =============================================--> - -<!-- - HTML 3.2 allows you to control the sequence number for ordered lists. - You can set the sequence number with the START and VALUE attributes. - The TYPE attribute may be used to specify the rendering of ordered - and unordered lists. ---> - -<!-- definition lists - DT for term, DD for its definition --> - -<!ELEMENT DL - - (DT|DD)+> -<!ATTLIST DL - compact (compact) #IMPLIED -- more compact style -- - > - -<!ELEMENT DT - O (%text)*> -<!ELEMENT DD - O %flow;> - -<!-- Ordered lists OL, and unordered lists UL --> -<!ELEMENT (OL|UL) - - (LI)+> - -<!-- - Numbering style - 1 arablic numbers 1, 2, 3, ... - a lower alpha a, b, c, ... - A upper alpha A, B, C, ... - i lower roman i, ii, iii, ... - I upper roman I, II, III, ... - - The style is applied to the sequence number which by default - is reset to 1 for the first list item in an ordered list. - - This can't be expressed directly in SGML due to case folding. ---> - -<!ENTITY % OLStyle "CDATA" -- constrained to: [1|a|A|i|I] --> - -<!ATTLIST OL -- ordered lists -- - type %OLStyle #IMPLIED -- numbering style -- - start NUMBER #IMPLIED -- starting sequence number -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!-- bullet styles --> - -<!ENTITY % ULStyle "disc|square|circle"> - -<!ATTLIST UL -- unordered lists -- - type (%ULStyle) #IMPLIED -- bullet style -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> -<!ATTLIST DIR - compact (compact) #IMPLIED - > -<!ATTLIST MENU - compact (compact) #IMPLIED - > - -<!-- <DIR> Directory list --> -<!-- <DIR COMPACT> Compact list style --> -<!-- <MENU> Menu list --> -<!-- <MENU COMPACT> Compact list style --> - -<!-- The type attribute can be used to change the bullet style - in unordered lists and the numbering style in ordered lists --> - -<!ENTITY % LIStyle "CDATA" -- constrained to: "(%ULStyle|%OLStyle)" --> - -<!ELEMENT LI - O %flow -- list item --> -<!ATTLIST LI - type %LIStyle #IMPLIED -- list item style -- - value NUMBER #IMPLIED -- reset sequence number -- - > - -<!--================ Forms ===============================================--> - -<!ELEMENT FORM - - %body.content -(FORM)> -<!ATTLIST FORM - action %URL #IMPLIED -- server-side form handler -- - method (%HTTP-Method) GET -- see HTTP specification -- - enctype %Content-Type; "application/x-www-form-urlencoded" - > - -<!ENTITY % InputType - "(TEXT | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | FILE | HIDDEN | IMAGE)"> - -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - type %InputType TEXT -- what kind of widget is needed -- - name CDATA #IMPLIED -- required for all but submit and reset -- - value CDATA #IMPLIED -- required for radio and checkboxes -- - checked (checked) #IMPLIED -- for radio buttons and check boxes -- - size CDATA #IMPLIED -- specific to each type of field -- - maxlength NUMBER #IMPLIED - src %URL #IMPLIED -- for fields with background images -- - align (top|middle|bottom|left|right) top -- image alignment -- - > - -<!ELEMENT SELECT - - (OPTION+)> -<!ATTLIST SELECT - name CDATA #REQUIRED - size NUMBER #IMPLIED - multiple (multiple) #IMPLIED - > - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - selected (selected) #IMPLIED - value CDATA #IMPLIED -- defaults to element content -- - > - -<!-- Multi-line text input field. --> - -<!ELEMENT TEXTAREA - - (#PCDATA)*> -<!ATTLIST TEXTAREA - name CDATA #REQUIRED - rows NUMBER #REQUIRED - cols NUMBER #REQUIRED - > - -<!--======================= Tables ========================================--> - -<!-- Widely deployed subset of the full table standard, see RFC 1942 - e.g. at http://www.ics.uci.edu/pub/ietf/html/rfc1942.txt --> - -<!-- horizontal placement of table relative to window --> -<!ENTITY % Where "(left|center|right)"> - -<!-- horizontal alignment attributes for cell contents --> -<!ENTITY % cell.halign - "align (left|center|right) #IMPLIED" - > - -<!-- vertical alignment attributes for cell contents --> -<!ENTITY % cell.valign - "valign (top|middle|bottom) #IMPLIED" - > - -<!ELEMENT table - - (caption?, tr+)> -<!ELEMENT tr - O (th|td)*> -<!ELEMENT (th|td) - O %body.content> - -<!ATTLIST table -- table element -- - align %Where; #IMPLIED -- table position relative to window -- - width %Length #IMPLIED -- table width relative to window -- - border %Pixels #IMPLIED -- controls frame width around table -- - cellspacing %Pixels #IMPLIED -- spacing between cells -- - cellpadding %Pixels #IMPLIED -- spacing within cells -- - > - -<!ELEMENT CAPTION - - (%text;)* -- table or figure caption --> -<!ATTLIST CAPTION - align (top|bottom) #IMPLIED - > - -<!ATTLIST tr -- table row -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!ATTLIST (th|td) -- header or data cell -- - nowrap (nowrap) #IMPLIED -- suppress word wrap -- - rowspan NUMBER 1 -- number of rows spanned by cell -- - colspan NUMBER 1 -- number of cols spanned by cell -- - %cell.halign; -- horizontal alignment in cell -- - %cell.valign; -- vertical alignment in cell -- - width %Pixels #IMPLIED -- suggested width for cell -- - height %Pixels #IMPLIED -- suggested height for cell -- - > - -<!--================ Document Head ========================================--> - -<!-- %head.misc defined earlier on as "SCRIPT|STYLE|META|LINK" --> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE?"> - -<!ELEMENT HEAD O O (%head.content) +(%head.misc)> - -<!ELEMENT TITLE - - (#PCDATA)* -(%head.misc) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - prompt CDATA #IMPLIED -- prompt message --> - -<!-- - The BASE element gives an absolute URL for dereferencing relative - URLs, e.g. - - <BASE href="http://foo.com/index.html"> - ... - <IMG SRC="images/bar.gif"> - - The image is deferenced to - - http://foo.com/images/bar.gif - - In the absence of a BASE element the document URL should be used. - Note that this is not necessarily the same as the URL used to - request the document, as the base URL may be overridden by an HTTP - header accompanying the document. ---> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - href %URL #REQUIRED - > - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - http-equiv NAME #IMPLIED -- HTTP response header name -- - name NAME #IMPLIED -- metainformation name -- - content CDATA #REQUIRED -- associated information -- - > - -<!-- SCRIPT/STYLE are place holders for transition to next version of HTML --> - -<!ELEMENT STYLE - - (#PCDATA)* -(%head.misc) -- style info --> -<!ELEMENT SCRIPT - - (#PCDATA)* -(%head.misc) -- script statements --> - -<!--================ Document Structure ===================================--> - -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<![ %HTML.Deprecated [ - <!ENTITY % html.content "HEAD, BODY, PLAINTEXT?"> -]]> - -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ATTLIST HTML - %version.attr; - > -
--- a/etc/sgml/html-3.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1447 +0,0 @@ -<!-- - html3.dtd - - Document Type Definition for the HyperText Markup Language (HTML DTD) - - Draft: Fri 24-Mar-95 09:46:33 - - Author: Dave Raggett <dsr@hplb.hpl.hp.com> - - W3O is developing a testbed browser to provide practical - experience with HTML 3.0 before it becomes a standard. - See: http://www.w3.org/hypertext/WWW/Arena/ - - This is an open process and comments are welcomed on the - www-html mailing list. - - Please use the following MIME content type: - - Content-Type: text/html; version=3.0 - - This will allow clients to distinguish HTML 3.0 from current - HTML documents. This is most easily achieved by saving - files with the extension ".html3" or ".ht3" so that servers - can easily distinguish these files from HTML 2.0 files. - - The entity HTML.Recommended can be used to give a more rigorous - version of the DTD suitable for use with SGML authoring tools. - The default version of the DTD offers a laxer interpretation, - e.g. allowing authors to omit leading <P> elements. You can - switch on the more rigorous version of the DTD by including - the following at the start of your HTML document. - - <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.0//EN//" - [ <!ENTITY % HTML.Recommended "INCLUDE"> ] > - - - Design Objectives: - - o Backwards compatibility with 2.0 - - o Tightening up HTML.Recommended and - moving more things to HTML.Deprecated - - o Keep HTML - simple don't compete with CALS - - o Make it practical for people to edit HTML 3.0 - documents directly, i.e. avoid long names. - - o Tables, figures and math from HTML+ - with tweaks based on recent experience - - o Client-side event handling for figures - and graphical form selection menus - - o Add limited presentational controls with - a view to use of linked style sheets - (style overrides are supported) - - o Compatibility with ICADD as per Yuri's suggestions - - HTML 3.0 relies on linked style info to give authors - control over the appearence of documents. Such info is - placed in a linked style sheet, or as overrides in the - HTML document head, using the STYLE element. The generic - CLASS attribute can be used to subclass elements when - you want to use a different style from normal, e.g. you - might use <h2 class=bigcaps> for headers with enlarged - capital letters. Note that the class attribute has a - wider scope than just style changes, e.g. browsers could - provide the means for searching through documents, - restricting search according to element class values. - - The DTD contains a small number of attributes for direct - control of basic alignment parameters; column widths for - tables; support for custom bullets, sequence numbering for - lists and headers; and text flow. These attributes offer - control over appearence which would be inconvenient to - express exclusively via associated style sheets. - - The MD attribute for each hypertext or inline link specifies a - message digest such as MD5 for the linked object and is needed - to ensure someone hasn't tampered with a linked document. - - History: - - 24th March '95 - - Changed ROLE->CLASS for HTML element - Added dummy elements to fix problem with mixed - content models for BODY, BLOCKQUOTE/BQ and FIG - Dropped audio fields from FORMs - Reinstated MIN/MAX for range fields - Reinstated DISABLED and ERROR attributes for fields - - 22nd March '95 - - Changed from em to en units. The latter - is a typographical unit = half point size - Merged NEEDS into CLEAR for control of textflow - - 21st March '95 - - Added REL=Banner to LINK element - Added BANNER element in place of <DIV CLASS=BANNER> - Added RANGE and SPOT elements - Added FN in place of <NOTE ROLE=FOOTNOTE> - Changed ROLE->CLASS for NOTE element - - 17th March '95 - - Fixed bug in PRE content model - Changed external references to omit trailling // - Dropped <!DOCTYPE HTML [ ... ]> wrapper to avoid problems - with "real" sgml parsers - Added NOFLOW attribute to FIG and TABLE - Fixed typo in IMG ALIGN attribute - Made SELECT match IMG for graphic attributes - Added decimal alignment for tabs and table cells - Added ALIGN attribute to TEXTAREA for parity - with IMG and INPUT, including ALIGN=LEFT etc. - - 13th March '95 - - Dropped MARK tag on advice from SGML Open - Allowed spaces in table colspec attribute - Changed ARRAY element - Added CHOOSE tag to BOX element - Cleaned up PRE content model - Obsoleted tags incompatible with SGML - - 6th March '95 - - Added several tags to MATH: %mathface, %mathvec - and improved ROOT, with new SQRT convience tag - - 1st March '95 - - Dropped align attribute from BR element - Added indent attribute to TAB - Added optional CREDIT to end of BQ - Changed FIG to %body.content to allow headers - - 22nd February '95 - - Added align attribute, and dropped before, after, center and right - attributes to clean up TAB element - Added INS and DEL for legal documents - Added CREDIT to end of FIG element - Dropped FN in favor of <NOTE ROLE=FootNote> - - 9th Feburuary '95 - - Dropped base attribute mechanism for scoping relative URLs - Dropped nofold attribute for disabling whitespace folding - Dropped border width attributes for FIG (-> style sheet) - Dropped delims attribute from math BOX element - Dropped stylistic attributes from OL such as inherit (-> stylesheet) - Added baseline to list of valign attribute values for tables. - Added DIV element for generic container class and static banners - Added MARK element for marked range class - Added closed set of LINK REL values for toolbars - Added numbering attributes to headers - Added bullet attributes to headers - Added TERM element to math for style sheet control of term rendering - Changed to imagemap=URI for server-side event handling for FIG/OVERLAY - Changed delimiter attributes for math arrays - Changed ROOT element for maths to allow an arbitrary radix - Simplified numbering attributes for ordered lists - Simplified STYLE element to leave binding to style language ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML 3.0//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.0//EN"> - <html> - ... - </html> - -- - > - -<!--================== Flags for Marked Sections ==========================--> - -<!ENTITY % HTML.Recommended "IGNORE" - -- Certain features of the language are necessary for compatibility - with widespread usage, but they may compromise the structural - integrity of a document. This feature test entity enables - a more prescriptive document type definition that eliminates - the above features. - --> - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE" - -- Certain features of the language are necessary for compatibility - with earlier versions of the specification, but they tend - to be used an implemented inconsistently, and their use is - deprecated. This feature test entity enables a document type - definition that eliminates these features. - --> - -<!ENTITY % HTML.Obsoleted "IGNORE" - -- The XMP, LISTING and PLAINTEXT tags are incompatible with SGML - and derive from very early versions of HTML. They require non- - standard parsers and will cause problems for processing - documents with standard SGML tools. - --> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URI "CDATA" - -- The term URI means a CDATA attribute - whose value is a Uniform Resource Identifier, - as defined by - "Uniform Resource Identifiers" by Tim Berners-Lee - aka http://info.cern.ch/hypertext/WWW/Addressing/URL/URI_Overview.html - aka RFC 1630 - - Note that CDATA attributes are limited by the LITLEN - capacity (1024 in the current version of html.decl), - so that URIs in HTML have a bounded length. - - --> - -<!ENTITY % REAL "CDATA" -- real numbers (not in SGML) --> - -<!ENTITY % SHAPE "CDATA" - -- Shape of hotzone in image. - - All coordinates are assumed to be numbers in the range 0 to 1 - and interpreted as fractional width/height and measured from - the top left corner of the associated image. - - The attribute value is a string taking one of the following forms: - - "default" - - Used to define a default link for the figure background. - - "circle x, y, r" - - (x, y) define the center and r the radius. - - "rect x, y, w, h" - - (x, y) defines upper left, and w and h the width and height. - - "polygon x1, y1, x2, y2, ..." - - Given n pairs of x, y coordinates, the polygon is closed by a - line linking the n'th point to the first. Intersecting polygons - use the non-zero winding number rule to determine if a point lies - inside the polygon.I - -- -> - -<!-- 3.0 Parameter Entities --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<![ %HTML.Obsoleted [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - - -<![ %HTML.Deprecated [ - <!ENTITY % list "UL | OL | DIR | MENU"> - <!ENTITY % blockquote "BLOCKQUOTE | BQ"> -]]> - -<!ENTITY % list "UL | OL"> - -<!ENTITY % blockquote "BQ"> - -<!ENTITY % preformatted "PRE"> - - -<!-- The CLASS attribute is used to subclass HTML elements for - rendering purposes, when used with style sheets, e.g. DSSSL lite --> - -<!ENTITY % attrs -- common attributes for elements -- - 'id ID #IMPLIED -- as target for hrefs (link ends) -- - lang CDATA "en.us" -- ISO language, country code -- - class NAMES #IMPLIED -- for subclassing elements --'> - -<!-- SGML standard forces different NAMES for all attribute values - in the same element, regardless of the attribute name! As a result - CDATA is used for CLEAR attribute to avoid clash with ALIGN attribute.--> - -<!-- -When text flows around a figure or table in the margin, you sometimes want -to start an element like a header, paragraph or list below the figure rather -than alongside it. The CLEAR attribute allows you to move down unconditionally: - - clear=left move down until left margin is clear - clear=right move down until right margin is clear - clear=all move down until both margins are clear - -Alternatively, you can decide to place the element alongside the figure just -so long as there is enough room. The minimum width needed is specified as: - - clear="40 en" move down until there is at least 40 en units free - clear="100 pixels" move down until there is at least 100 pixels free - -The style sheet (or browser defaults) may provide default minimum widths for -each class of block-like elements. ---> - -<!ENTITY % needs -- Attributes for controlling text flow. Used in headers - and other elements to guarantee sufficient room -- - 'clear CDATA #IMPLIED'> - -<!-- - The following attribute may be included where ever a URL can be given: - - md message digest e.g. md="md5:jV2OfH+nnXHU8bnkPAad/mSQlTDZ" - where the digest is base64 encoded and preceded by a prefix - denoting the algorithm (in this case MD5). ---> - -<!ENTITY % url.link -- Attributes associated with URL based links -- - "md CDATA #IMPLIED -- message digest for linked object --"> - -<!--================ Character mnemonic entities ==========================--> - -<!-- The HTML list of Latin-1 entities includes the full range - of characters in widely available Latin-1 fonts, and as such - is a mixture of ISOlat1 and other ISO publishing symbols --> - -<!ENTITY % HTMLlat1 PUBLIC - "-//IETF//ENTITIES Added Latin 1 for HTML//EN"> -%HTMLlat1; - -<!--================ Entities for special symbols =========================--> - -<!ENTITY emsp SDATA "[emsp ]" -- em space --> -<!ENTITY ensp SDATA "[ensp ]" -- en space (1/2-em) --> -<!ENTITY mdash SDATA "[ndash ]" -- em dash --> -<!ENTITY ndash SDATA "[ndash ]" -- en dash (1/2-em) --> -<!ENTITY nbsp SDATA "[nbsp ]" -- non breaking space --> -<!ENTITY shy SDATA "[shy ]" -- soft hyphen --> -<!ENTITY copy SDATA "[copy ]" -- copyright sign --> -<!ENTITY trade SDATA "[trade ]" -- trade mark sign --> -<!ENTITY reg SDATA "[reg ]" -- registered sign --> - -<!--================ Entities for standard icons ==========================--> - -<!-- a range of standard icons such as &folder; for use - in speeding up display of directory listings etc. --> - -<!ENTITY % HTMLicons PUBLIC - "-//IETF//ENTITIES icons for HTML//EN"> -%HTMLicons; - -<!--================ Entities for math symbols ============================--> - -<!-- ISO subset chosen for use with the widely available Adobe math font --> - -<!ENTITY % HTMLmath PUBLIC - "-//IETF//ENTITIES Math and Greek for HTML//EN"> -%HTMLmath; - -<!--=================== Text Markup =======================================--> - -<!ENTITY % font " U | S | TT | I | BIG | SMALL"> - -<!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE"> - -<!ENTITY % misc "Q | LANG | AU | DFN | PERSON | ACRONYM | ABBREV | INS | DEL"> - -<!ENTITY % special "TAB | MATH | A | IMG | BR"> - -<!ENTITY % notmath "%font | %phrase | %special | %misc"> - -<!ENTITY % text "#PCDATA | SUB | SUP | B | %notmath"> - - -<!ENTITY % pre.exclusion "TAB|MATH|IMG|BIG|SMALL|SUB|SUP"> - -<!ELEMENT (%font|B|%phrase|%misc) - - (%text)+> -<!ATTLIST (%font|B|%phrase|%misc) %attrs;> - -<!-- Subscripts and superscripts. The ALIGN attribute is only used for math --> - -<!ELEMENT (SUB|SUP) - - (%text)+> -<!ATTLIST (SUB|SUP) - %attrs; - align (left|center|right) #IMPLIED - > - -<!-- Forced line break --> - -<!ELEMENT BR - O EMPTY> -<!ATTLIST BR - %attrs; - %needs; -- for control of text flow -- - > - -<!-- Named left, center and right tab stops (independent of '\t' char) --> - -<!ELEMENT TAB - O EMPTY> -<!ATTLIST TAB - id ID #IMPLIED -- defines named tab stop -- - indent NUMBER 0 -- en units before new tab stop -- - to IDREF #IMPLIED -- jump to named tab stop -- - align (left|center|right|decimal) left - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - > - -<!--================== Link Markup ========================================--> - -<!-- - With HTML 3.0 you can use ID attributes on most elements for named - link ends. The use of the NAME attribute on anchors is deprecated. - - Do we want to support arbitrary elements for link starts? This would - involve adding HREF and related attributes to most elements. ---> - -<![ %HTML.Deprecated [ - <!ENTITY % linkName "name CDATA #IMPLIED -- named link end --"> -]]> - -<!ENTITY % linkName ""> - - -<!ENTITY % ToolBar "home|toc|index|glossary|copyright| - up|previous|next|help|bookmark" - - -- LINK RELationship values which are used to create toolbar - buttons or menu items for navigation, where toc stands - for table of contents and bookmark provides for an open - ended set of links, i.e. you can use multiple bookmarks - for key entry points. Use the optional TITLE attribute - to override default names. - --> - -<!ENTITY % linkType "NAME" - -- A definitive list will be specified at a later date. - - They are used - - a) by stylesheets to control how collections of - html nodes are rendered into printed documents - - b) for document specific toolbars/menus when used - with the LINK element in document head: - - "home|toc|index|glossary|copyright| - up|previous|next|help|bookmark" - - where toc stands for table of contents and - bookmark provides for an open ended set of links, - i.e. you can use several bookmarks for key entry - points. Use the optional TITLE attribute to - override default names. - - c) for hypertext paths or guided tours, - with REL=NODE and REL=PATH. - - d) to make a link to a style sheet, e.g. rel=stylesheet - (used only with the LINK element). - - e) to make a link to a separate banner, e.g. rel=banner - (used only with the LINK element). - --> - - -<!ENTITY % linkExtraAttributes -- URN moved to %url.link -- - "rel %linkType #IMPLIED -- forward relationship type -- - rev %linkType #IMPLIED -- reversed relationship type - to referent data -- - title CDATA #IMPLIED -- advisory only -- - methods NAMES #IMPLIED -- supported public methods of the object: - TEXTSEARCH, GET, HEAD, ... -- - "> - -<![ %HTML.Deprecated [ - <!ENTITY % A.content "(%heading|%text)+"> -]]> - -<!ENTITY % A.content "(%text)+"> - -<!ELEMENT A - - %A.content -(A)> - -<!ATTLIST A - %attrs; - href %URI; #IMPLIED - %url.link; -- standard link attributes -- - %linkName; -- name attribute is deprecated; use ID instead -- - shape %SHAPE; #IMPLIED -- for shaped hotzones in FIGs -- - %linkExtraAttributes; - > - -<!--=================== Images ============================================--> - -<!-- Desired widths are used for negotiating image size - with the module responsible for painting the image. - align=left or right cause image to float to margin - and for subsequent text to wrap around image --> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - %attrs; - src %URI; #REQUIRED -- URI of image to embed -- - %url.link; -- standard link attributes -- - alt CDATA #IMPLIED -- for display in place of image -- - align (top|middle|bottom|left|right) top -- relative to baseline - -- width NUMBER #IMPLIED -- desired width in en's or pixels -- - height NUMBER #IMPLIED -- desired height in en's or pixels -- - units (en|pixels) pixels -- units for width and height -- - ismap (ismap) #IMPLIED -- pass clicks to server -- - > - -<!--=================== Paragraphs=========================================--> - -<!ELEMENT P - O (%text)+> -<!ATTLIST P - %attrs; - align (left|center|right|justify) #IMPLIED - %needs; -- for control of text flow -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!--=================== Headings, Titles, Sections ========================--> - -<!ELEMENT HR - O EMPTY -- customizable horizontal rule --> -<!ATTLIST HR - %attrs; - src %URI; #IMPLIED -- URI of custom rule graphic -- - %url.link; -- standard link attributes -- - %needs; -- for control of text flow -- - > - -<!-- - Headers can be numbered, although this is a matter for style sheets. - The style sheet controls the numbering style: - - a) whether the parent numbering is inherited, e.g. 5.i.c - where 5 is the current sequence number for H1 headers, and - 1 is the number for H2 headers and 3 for H3 headers. - - b) what style is used for current sequence number - e.g. arabic, upperalpha, loweralpha, upperroman, lowerroman - or a numbering scheme appropriate for the current language - - The skip attribute is used to skip over sequence numbers for items - which have been left out of the list, e.g. skip=3 advances the - sequence number past 3 omitted items. The seqnum sets the sequence - number to a specified value. Note that the style sheet may take - advantage of the sequence number for higher level headers. - - The dingbat or src attributes may be used to specify a bullet like - image to be placed adjacent to the header. Defining this in the - header element simplifies the document markup and avoids the need - to use the clear or needs attribute in the following element to - prevent it flowing around this image. ---> - -<!ELEMENT ( %heading ) - - (%text;)+> -<!ATTLIST ( %heading ) - %attrs; - align (left|center|right|justify) #IMPLIED - %needs; -- for control of text flow -- - seqnum NUMBER #IMPLIED -- starting sequence number -- - skip NUMBER 0 -- skip seq nums for missing items -- - dingbat ENTITY #IMPLIED -- dingbat entity from HTMLicons -- - src %URI; #IMPLIED -- bullet defined by graphic -- - %url.link; -- standard link attributes -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!ELEMENT TITLE - - (#PCDATA) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> - -<!--=================== Text Flows ========================================--> - -<!ENTITY % block - "P | %list | DL - | %preformatted - | %blockquote - | FORM | ISINDEX | FN - | TABLE | FIG | NOTE"> - -<!-- - ((%block)* | (%text)*) would be much nicer as it would avoid the need - for a <P> tag when all you want is a few words of text. The problem - is that it also prevents: "<LI> <P>some text" since it forbids PCDATA - and hence the white space between the <LI> and the <P>. ---> - -<![ %HTML.Recommended [ - <!ENTITY % flow "(%block)*"> -]]> - -<!ENTITY % flow "(%text | %block)*"> - -<!ELEMENT PRE - - (%text)* -(%pre.exclusion)> - -<!ATTLIST PRE - %attrs; - width NUMBER #implied - %needs; -- for control of text flow -- - > - -<![ %HTML.Obsoleted [ - -<!ENTITY % literal "CDATA" - -- special non-conforming parsing mode where - the only markup signal is the end tag - in full. This will cause problems for - standard SGML tools! - --> - -<!ELEMENT XMP - - %literal> -<!ELEMENT LISTING - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -]]> - -<!--=================== Lists =============================================--> - -<!ELEMENT DL - - (LH?, (DT|DD)+) -- this is perhaps too lax? --> -<!ATTLIST DL - %attrs; - %needs; -- for control of text flow -- - compact (compact) #IMPLIED -- more compact style -- - > - -<!ELEMENT DT - O (%text)+> -<!ELEMENT DD - O %flow;> -<!ATTLIST (DT|DD) - %attrs; - %needs; -- for control of text flow -- - > - - -<!ELEMENT (OL|UL) - - (LH?, LI+) -- should we allow a list header ? --> - -<!-- style sheet controls numbering style - a) whether the parent numbering is inherited, e.g. 5.1.c - b) what style is used for current sequence number - e.g. arabic, upperalpha, loweralpha, upperroman, lowerroman - or a numbering scheme for the current language ---> -<!ATTLIST OL - %attrs; - %needs; -- for control of text flow -- - continue (continue) #IMPLIED -- don't restart sequence number -- - seqnum NUMBER #IMPLIED -- starting sequence number -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!-- Unordered lists: - - o single or multicolumn with - horizontal or vertical wrapping - - o plain or bulletted list items - - o bullets can be customised via: - - entities (dingbats in HTMLicons) - - external graphic via URL - - individual attributes on LI tags ---> -<!ATTLIST UL - %attrs; - %needs; -- for control of text flow -- - wrap (vert|horiz|none) none -- multicolumn list style -- - plain (plain) #IMPLIED -- suppress bullets -- - dingbat ENTITY #IMPLIED -- dingbat entity from HTMLicons -- - src %URI; #IMPLIED -- bullet defined by graphic -- - %url.link; -- standard link attributes -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!ELEMENT LH - O (%text;)+ -- list header --> -<!ATTLIST LH %attrs;> - -<!-- - For unordered lists, you can override the standard bullet with - a custom graphic specified via a URI e.g. src="splash.gif" or - a reference to one of the HTMLicons graphics e.g. dingbat=folder - - The skip attribute is used with ordered lists to skip over sequence - numbers for items which have been left out of the list, e.g. skip=3 - advances the sequence number past 3 omitted items. ---> - -<!ELEMENT LI - O %flow; -- list item --> -<!ATTLIST LI - %attrs; - %needs; -- for control of text flow -- - dingbat ENTITY #IMPLIED -- dingbat entity from HTMLicons -- - src %URI; #IMPLIED -- custom bullet graphic -- - %url.link; -- standard link attributes -- - skip NUMBER 0 -- skip seq nums for missing items -- - > - -<!-- DIR and MENU are now subsumed by UL with type=plain. Use the - wrap attribute to control wrapping style for multicolumn lists --> - -<![ %HTML.Deprecated [ - <!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> - <!ATTLIST (DIR|MENU) - compact (compact) #IMPLIED> -]]> - -<!--=================== Document Body =====================================--> - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(DIV|%heading|%block|HR|ADDRESS)*" - -- <h1>Heading</h1> - <p>Text ... - is preferred to - <h1>Heading</h1> - Text ... - --> -]]> - -<!ENTITY % body.content "(DIV | %heading | %text | %block | HR | ADDRESS)*"> - -<!ELEMENT BODY O O (BANNER?, BODYTEXT) +(SPOT)> -<!ATTLIST BODY - %attrs; - background %URI; #IMPLIED -- texture tile for document background -- - > - -<!ELEMENT BODYTEXT O O %body.content -- dummy element --> - -<!-- - The BANNER element is used for a banner section which appears at - the top of the window and doesn't scroll with window contents. - This can be used for corporate logos, copyright statements and - disclaimers, as well as customized navigation/search controls. ---> -<!ELEMENT BANNER - - %body.content> -<!ATTLIST BANNER %attrs; > - -<!-- SPOT is used to insert IDs at arbitrary places - e.g. for end points of a marked range (see RANGE) --> -<!ELEMENT SPOT - O EMPTY> -<!ATTLIST SPOT id ID #REQUIRED> - -<!ELEMENT (%blockquote) - - (BODYTEXT, CREDIT?)> -<!ATTLIST (%blockquote) - %attrs; - %needs; -- for control of text flow -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!ENTITY % address.content "((%text;)* | P*)"> - -<!ELEMENT ADDRESS - - %address.content> -<!ATTLIST ADDRESS - %attrs; - %needs; -- for control of text flow -- - > - -<!-- - DIV can be used with the CLASS attribute to represent different - kinds of container, e.g. chapter, section, abstract, appendix. ---> - -<!ELEMENT DIV - - %body.content> -<!ATTLIST DIV - %attrs; - %needs; -- for control of text flow -- - align (left|center|right) left -- alignment of following text -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!--================ Forms ===============================================--> - -<!-- - As HTML 2.0 plus a few extensions: - - a) A RANGE control which varies between pair of values - specified with the size attribute, e.g. SIZE="1, 10" - - b) FILE widget for uploading one or more files to a server - - c) SCRIBBLE on image widget that sends the "ink" to the server - - d) SUBMIT/RESET buttons can now be customised with an image. - This subsumes the IMAGE type which is now deprecated. - - e) Graphical SELECTion menus are now supported, using - the new SHAPE attribute on OPTION elements. - - Further extensions are in the pipeline (e.g. table entry, - multiple data formats for textarea fields and client-side - scripts with custom widgets) but will have to wait until - the backlog of implementation work diminishes. ---> - -<!ELEMENT FORM - - %body.content -(FORM) +(INPUT|SELECT|TEXTAREA)> -<!ATTLIST FORM - action %URI #REQUIRED -- server-side form handler -- - method (%HTTP-Method) GET -- see HTTP specification -- - enctype %Content-Type; "application/x-www-form-urlencoded" - script %URI #IMPLIED -- link to client-side script -- - > - -<![ %HTML.Deprecated [ - <!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | RANGE | FILE | SCRIBBLE | HIDDEN | IMAGE)"> -]]> - -<!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | RANGE | FILE | SCRIBBLE | HIDDEN)"> - -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - %attrs; - type %InputType TEXT - name NAME #IMPLIED -- required for all but submit and reset -- - value CDATA #IMPLIED -- required for radio buttons & checkboxes -- - disabled (disabled) #IMPLIED -- read-only fields -- - error CDATA #IMPLIED -- why field is in error -- - checked (checked) #IMPLIED -- for radio buttons and check boxes -- - size NUMBER #IMPLIED -- visible width of TEXT fields -- - maxlength NUMBER #IMPLIED -- max number of chars for TEXT fields -- - min %REAL #IMPLIED -- lower limit for RANGE fields -- - max %REAL #IMPLIED -- upper limit for RANGE fields -- - accept CDATA #IMPLIED -- list of MIME types for file fields -- - src %URI #IMPLIED -- for fields with background images -- - %url.link; -- standard link attributes -- - align (top|middle|bottom|left|right) top - > - -<!-- - SRC attribute added for graphical selection menus - The WIDTH, HEIGHT and UNITS attributes apply to the - image specified by the SRC attribute. - --> - -<!ELEMENT SELECT - - (OPTION+) -(INPUT|TEXTAREA|SELECT)> -<!ATTLIST SELECT - %attrs; - name CDATA #REQUIRED - multiple (multiple) #IMPLIED - disabled (disabled) #IMPLIED -- read-only menu -- - error CDATA #IMPLIED -- why selections are in error -- - src %URI #IMPLIED -- for graphical selection menus -- - %url.link; -- standard link attributes -- - width NUMBER #IMPLIED -- desired width of in en's or pixels -- - height NUMBER #IMPLIED -- desired height in en's or pixels -- - units (en|pixels) pixels -- units for width and height -- - align (top|middle|bottom|left|right) top - > - -<!ELEMENT OPTION - O (#PCDATA)> -<!ATTLIST OPTION - %attrs; - selected (selected) #IMPLIED - value CDATA #IMPLIED -- default to element content -- - shape %SHAPE; #IMPLIED -- for graphical selection menus -- - disabled (disabled) #IMPLIED -- unselectable option -- - error CDATA #IMPLIED -- why this choice is in error -- - > - -<!-- - Multi-line text input field. align=left or right - causes the field to float to margin and for - subsequent text to wrap around the field. ---> - -<!ELEMENT TEXTAREA - - (#PCDATA) -(INPUT|TEXTAREA|SELECT)> -<!ATTLIST TEXTAREA - %attrs; - name CDATA #REQUIRED - rows NUMBER #REQUIRED - cols NUMBER #REQUIRED - disabled (disabled) #IMPLIED -- read-only field -- - error CDATA #IMPLIED -- why field is in error -- - align (top|middle|bottom|left|right) top - > - -<!--======================= Captions ======================================--> - -<!ELEMENT CAPTION - - (%text;)+ -- table or figure caption --> -<!ATTLIST CAPTION - %attrs; - align (top|bottom|left|right) #IMPLIED - > -<!--======================= Tables ========================================--> - -<!-- - Tables and figures can be aligned in several ways: - - bleedleft flush left with the left (window) border - left flush left with the left text margin - center centered (text flow is disabled for this mode) - right flush right with the right text margin - bleedright flush right with the right (window) border - justify when applicable the table/figure should stretch - to fill space between the text margins - - Note: text will flow around the table or figure if the browser - judges there is enough room and the alignment is not centered - or justified. The table or figure may itself be part of the - text flow around some earlier figure. You can in this case use - the clear or needs attributes to move the new table or figure - down the page beyond the obstructing earlier figure. Similarly, - you can use the clear or needs attributes with other elements - such as headers and lists to move them further down the page. ---> - -<!ENTITY % block.align - "align (bleedleft|left|center|right|bleedright|justify) center"> - -<!-- - The HTML 3.0 table model has been chosen for its simplicity - and the ease in writing filters from common DTP packages. - - By default the table is automatically sized according to the - cell contents and the current window size. Specifying the columns - widths using the colspec attribute allows browsers to start - displaying the table without having to wait for last row. - - The colspec attribute is a list of column widths and alignment - specifications. The columns are listed from left to right with - a capital letter followed by a number, e.g. COLSPEC="L20 C8 L40". - The letter is L for left, C for center, R for right alignment of - cell contents. J is for justification, when feasible, otherwise - this is treated in the same way as L for left alignment. - Column entries are delimited by one or more space characters. - - The number specifies the width in en's, pixels or as a - fractional value of the table width, as according to the - associated units attribute. This approach is more compact - than used with most SGML table models and chosen to simplify - hand entry. The width attribute allows you to specify the - width of the table in pixels, en units or as a percentage - of the space between the current left and right margins. - - To assist with rendering to speech, row and column headers - can be given short names using the AXIS attribute. The AXES - attribute is used to explicitly specify the row and column - names for use with each cell. Otherwise browsers can follow - up columns and left along rows (right for some languages) - to find the corresponding header cells. - - Table content model: Braille limits the width of tables, - placing severe limits on column widths. User agents need - to render big cells by moving the content to a note placed - before the table. The cell is then rendered as a link to - the corresponding note. - - To assist with formatting tables to paged media, authors - can differentiate leading and trailing rows that are to - be duplicated when splitting tables across page boundaries. - The recommended way is to subclass rows with the CLASS attribute - For example: <TR CLASS=Header>, <TR CLASS=Footer> are used for - header and footer rows. Paged browsers insert footer rows at - the bottom of the current page and header rows at the top of - the new page, followed by the remaining body rows. ---> - -<!ELEMENT TABLE - - (CAPTION?, TR*) -- mixed headers and data --> -<!ATTLIST TABLE - %attrs; - %needs; -- for control of text flow -- - border (border) #IMPLIED -- draw borders -- - colspec CDATA #IMPLIED -- column widths and alignment -- - units (en|pixels|relative) en -- units for column widths -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - width NUMBER #IMPLIED -- absolute or percentage width -- - %block.align; -- horizontal alignment -- - noflow (noflow) #IMPLIED -- noflow around table -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - > - -<!ENTITY % cell "TH | TD"> -<!ENTITY % horiz.align "left|center|right|justify"> -<!ENTITY % vert.align "top|middle|bottom|baseline"> - -<!-- - Browsers should tolerate an omission of the first <TR> - tag as it is implied by the context. Missing trailing - <TR>s implied by rowspans should be ignored. - - The alignment attributes act as defaults for rows - overriding the colspec attribute and being in turn - overridden by alignment attributes on cell elements. - Use valign=baseline when you want to ensure that text - in different cells on the same row is aligned on the - same baseline regardless of fonts. It only applies - when the cells contain a single line of text. ---> - -<!ELEMENT TR - O (%cell)* -- row container --> -<!ATTLIST TR - %attrs; - align (%horiz.align) #IMPLIED -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - > - -<!-- - Note that table cells can include nested tables. - Missing cells are considered to be empty, while - missing rows should be ignored, i.e. if a cell - spans a row and there are no further TR elements - then the implied row should be ignored. ---> - -<!ELEMENT (%cell) - O %body.content> -<!ATTLIST (%cell) - %attrs; - colspan NUMBER 1 -- columns spanned -- - rowspan NUMBER 1 -- rows spanned -- - align (%horiz.align) #IMPLIED -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - axis CDATA #IMPLIED -- axis name, defaults to element content -- - axes CDATA #IMPLIED -- comma separated list of axis names -- - > - -<!--====================== Figures ========================================--> - -<!-- - The element contains text for use in non-graphical displays. Note that - you can use the shape attribute in anchors to specify hotzones on images. - This provides for local processing of pointer clicks and a unified method - for dealing with graphical and non-graphical displays. - - Text is flowed around figures when the figure is left or right aligned. - You can request the browser to move down until there is enough room for - the next element, see the CLEAR and NEED attributes (in %needs) - - Figures offer a path towards embedding arbitrary information formats - via some kind of OLE/OpenDoc mechanism. ---> - -<!ELEMENT FIG - - (OVERLAY*, CAPTION?, FIGTEXT, CREDIT?) -(FIG|IMG)> -<!ATTLIST FIG - %attrs; - %needs; -- for control of text flow -- - src %URI; #REQUIRED -- URI of document to embed -- - %url.link; -- standard link attributes -- - %block.align; -- horizontal alignment -- - noflow (noflow) #IMPLIED -- noflow around figure -- - width NUMBER #IMPLIED -- desired width in units -- - height NUMBER #IMPLIED -- desired height in units -- - units (en|pixels) pixels -- specifies units as en's or pixels -- - imagemap %URI; #IMPLIED -- pass background clicks to server -- - > - -<!ELEMENT FIGTEXT O O %body.content -- dummy element --> - -<!-- - Figure overlays. When combined with local caching, overlays - provide a cheap way of modifying a larger base image sent as - part of a previous page. ---> - -<!ELEMENT OVERLAY - O EMPTY -- image overlay --> -<!ATTLIST OVERLAY - src %URI; #REQUIRED -- URI of image overlay -- - %url.link; -- standard link attributes -- - units (en|pixels) pixels -- specifies units as en's or pixels -- - x NUMBER 0 -- offset from left in units -- - y NUMBER 0 -- offset from top in units -- - width NUMBER #IMPLIED -- desired width in units -- - height NUMBER #IMPLIED -- desired height in units -- - imagemap %URI; #IMPLIED -- pass background clicks to server -- - > - -<!ELEMENT CREDIT - - (%text;)* -- source of image --> -<!ATTLIST CREDIT - %attrs; - > - -<!--======================== Notes ========================================--> - -<!-- -The NOTE element is used for admonishments. The CLASS attribute -is used to differentiate NOTE's, e.g. Note, Caution or Warning. ---> - -<!ELEMENT NOTE - - %body.content; -- admonishment --> -<!ATTLIST NOTE - %attrs; - src %URI; #IMPLIED -- URI of custom graphic -- - %url.link; -- standard link attributes -- - %needs; -- for control of text flow -- - > - -<!--======================== Footnotes ====================================--> - -<!-- -Typically rendered as popup note. These elements are referenced -by hypertext links specified with the anchor element. ---> -<!ELEMENT FN - - %body.content;> -<!ATTLIST FN %attrs;> - -<!--======================== Math ========================================--> - -<!-- Use     etc for greater control of spacing. --> - -<!-- Subscripts and Superscripts - - <SUB> and <SUP> are used for subscripts and superscripts. - - i j - X <SUP>i</SUP>Y<SUP>j</SUP> is X Y - - i.e. the space following the X disambiguates the binding. - The align attribute can be used for horizontal alignment, - e.g. to explicitly place an index above an element: - i - X<sup align=center>i</sup> produces X - -Short references are defined for superscripts, subscripts and boxes -to save typing when manually editing HTML math, e.g. - - x^2^ is mapped to x<sup>2</sup> - y_z_ is mapped to y<sub>z</sub> - {a+b} is mapped to <box>a + b</box> - -Note that these only apply within the MATH element and can't be -used in normal text! ---> -<!ENTITY REF1 STARTTAG "SUP"> -<!ENTITY REF2 ENDTAG "SUP"> -<!ENTITY REF3 STARTTAG "SUB"> -<!ENTITY REF4 ENDTAG "SUB"> -<!ENTITY REF5 STARTTAG "BOX"> -<!ENTITY REF6 ENDTAG "BOX"> - -<!USEMAP MAP1 MATH> -<!USEMAP MAP2 SUP> -<!USEMAP MAP3 SUB> -<!USEMAP MAP4 BOX> - -<!SHORTREF MAP1 "^" REF1 - "_" REF3 - "{" REF5 > - -<!SHORTREF MAP2 "^" REF2 - "_" REF3 - "{" REF5 > - -<!SHORTREF MAP3 "_" REF4 - "^" REF1 - "{" REF5 > - -<!SHORTREF MAP4 "}" REF6 - "^" REF1 - "_" REF3 - "{" REF5 > - -<!-- - The inclusion of %math and exclusion of %notmath is used here - to alter the content model for the B, SUB and SUP elements, - to limit them to formulae rather than general text elements. ---> - -<!ENTITY % mathvec "VEC|BAR|DOT|DDOT|HAT|TILDE" -- common accents --> -<!ENTITY % mathface "B|T|BT" -- control of font face --> -<!ENTITY % math "BOX|ABOVE|BELOW|%mathvec|ROOT|SQRT|ARRAY|SUB|SUP|%mathface"> -<!ENTITY % formula "#PCDATA|%math"> - -<!ELEMENT MATH - - (#PCDATA)* -(%notmath) +(%math)> -<!ATTLIST MATH - id ID #IMPLIED - class NAMES #IMPLIED -- e.g. class=chem --> - -<!-- The BOX element acts as brackets. Delimiters are optional and - stretch to match the height of the box. The OVER element is used - when you want a line between numerator and denominator. This line - is suppressed with the alternative ATOP element. CHOOSE acts like - ATOP but adds enclosing round brackets as a convenience for binomial - coefficients. Note the use of { and } as shorthand for <BOX> and - </BOX> respectively: - - 1 + X - {1 + X<OVER>Y} is _______ - Y - - a + b - {a + b<ATOP>c - d} is - c - d - - The delimiters are represented using the LEFT and RIGHT - elements as in: - - {[<LEFT>x + y<RIGHT>]} is [ x + y ] - {(<LEFT>a<RIGHT>]} is (a] - {||<LEFT>a<RIGHT>||} is || a || - - Use { and } for "{" and "}" respectively as - these symbols are used as shorthand for BOX, e.g. - - {{<LEFT>a+b<RIGHT>}} is {a+b} - - You can stretch definite integrals to match the integrand, e.g. - - {∫<SUB>a</SUB><SUP>b</SUP><LEFT>{f(x)<over>1+x} dx} - - b - / f(x) - | ----- dx - / 1 + x - a - - Note the complex content model for BOX is a work around - for the absence of support for infix operators in SGML. - - You can get oversize delimiters with the SIZE attribute, - for example <BOX SIZE=large>(<LEFT>...<RIGHT>)</BOX> - - Note that the names of common functions are recognized - by the parser without the need to use "&" and ";" around - them, e.g. int, sum, sin, cos, tan, ... ---> - -<!ELEMENT BOX - - ((%formula)*, (LEFT, (%formula)*)?, - ((OVER|ATOP|CHOOSE), (%formula)*)?, - (RIGHT, (%formula)*)?)> -<!ATTLIST BOX - size (normal|medium|large|huge) normal -- oversize delims --> - -<!ELEMENT (OVER|ATOP|CHOOSE|LEFT|RIGHT) - O EMPTY> - -<!-- Horizontal line drawn ABOVE contents - The symbol attribute allows authors to supply - an entity name for an accent, arrow symbol etc. - Generalisation of LaTeX's overline command. - - e.g. <above sym=ssmile>x</above> - places an upwardly turning curve above the "x" - --> - -<!ELEMENT ABOVE - - (%formula)+> -<!ATTLIST ABOVE sym ENTITY #IMPLIED> - -<!-- Horizontal line drawn BELOW contents - The symbol attribute allows authors to - supply an entity name for an arrow symbol etc. - Generalisation of LaTeX's underline command. - --> - -<!ELEMENT BELOW - - (%formula)+> -<!ATTLIST BELOW sym ENTITY #IMPLIED> - -<!-- Convenience tags for common accents: - vec, bar, dot, ddot, hat and tilde ---> - -<!ELEMENT (%mathvec) - - (%formula)+> - -<!-- - T and BT are used to designate terms which should - be rendered in an upright font (& bold face for BT) ---> - -<!ELEMENT (T|BT) - - (%formula)+> -<!ATTLIST (T|BT) class NAMES #IMPLIED> - -<!-- Roots e.g. <ROOT>3<OF>1+x</ROOT> --> - -<!ELEMENT ROOT - - ((%formula)+, OF, (%formula)+)> -<!ELEMENT OF - O (%formula)* -- what the root applies to --> - -<!ELEMENT SQRT - - (%formula)* -- square root convenience tag --> - -<!-- LaTeX like arrays. The COLDEF attribute specifies - a single capital letter for each column determining - how the column should be aligned, e.g. coldef="CCC" - - "L" left - "C" center - "R" right - - An optional separator letter can occur between columns - and should be one of + - or =, e.g. "C+C+C+C=C". - Whitespace within coldef is ignored. By default, the - columns are all centered. - - The ALIGN attribute alters the vertical position of the - array as compared with preceding and following expressions. - - Use LDELIM and RDELIM attributes for delimiter entities. - When the LABELS attribute is present, the array is - displayed with the first row and the first column as - labels displaced from the other elements. In this case, - the first element of the first row should normally be - left blank. - - Use &vdots; &cdots; and &ddots; for vertical, horizontal - and diagonal ellipsis dots. Use &dotfill; to fill an array - cell with horizontal dots (e.g. for a full row). - Note &ldots; places the dots on the baseline, while &cdots; - places them higher up. ---> - -<!ELEMENT ARRAY - - (ROW)+> -<!ATTLIST ARRAY - align (top|middle|bottom) middle -- vertical alignment -- - coldef CDATA #IMPLIED -- column alignment and separator -- - ldelim CDATA #IMPLIED -- stretchy left delimiter -- - rdelim CDATA #IMPLIED -- stretchy right delimiter -- - labels (labels) #IMPLIED -- TeX's \bordermatrix style --> - -<!ELEMENT ROW - O (ITEM)*> -<!ELEMENT ITEM - O (%formula)*> -<!ATTLIST ITEM - align CDATA #IMPLIED -- override coldef alignment -- - colspan NUMBER 1 -- merge columns as per TABLE -- - rowspan NUMBER 1 -- merge rows as per TABLE --> - -<!--================ Document Head ========================================--> - -<![ %HTML.Deprecated [ - <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? - & META* & LINK* & RANGE* & NEXTID?"> -]]> - -<!ENTITY % head.nextid ""> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? - & META* & LINK* & RANGE*"> - -<!ELEMENT HEAD O O (%head.content)> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - href %URI #REQUIRED - %linkExtraAttributes; > - -<!ELEMENT RANGE - O EMPTY> -<!ATTLIST RANGE - id ID #IMPLIED -- for naming marked range -- - class NAMES #IMPLIED -- for subclassing -- - from IDREF #REQUIRED -- start of marked range -- - until IDREF #REQUIRED -- end of marked range -- - > - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - href %URI #IMPLIED -- server handling queries -- - prompt CDATA #IMPLIED -- prompt message --> - -<!-- - The BASE element gives the base URL for - dereferencing relative URLs, e.g. - - <BASE href="http://foo.com/images"> - ... - <IMG SRC="bar.gif"> - - The image is deferenced to - - http://foo.com/images/bar.gif ---> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - id ID #IMPLIED - href %URI; #REQUIRED - > - -<![ %HTML.Deprecated [ - <!ELEMENT NEXTID - O EMPTY> - <!ATTLIST NEXTID N CDATA #REQUIRED> -]]> - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - http-equiv NAME #IMPLIED -- HTTP response header name -- - name NAME #IMPLIED -- metainformation name -- - content CDATA #REQUIRED -- associated information -- - > - -<!-- - A style sheet can be associated with the document using the - LINK element, e.g. <LINK rel=style href="housestyle.dsssl">. - Style overrides can be placed in the document head using the - STYLE element, e.g. - - <style notation=dsssl-lite> - dsss-lite stuff - </style> - - Later on in the document you can use: - - <h2 class=bigcaps>Header with bigger than normal capitals</h2> - <p class=abstract>A paragraph with a unique style of its own - ... - - Statements in the given style notation - - The tag names, class and id attributes are used in the style sheet - notation to describe how to render matching elements. ---> - -<!ENTITY % style-notations "dsssl-lite | w3c-style"> - -<!-- -<!NOTATION dsssl-lite PUBLIC - "ISO/IEC 10179:1995//NOTATION DSSSL Style Language//EN"> - -<!NOTATION w3c-style PUBLIC "IETF/RFC nnn/W3C Style Language//EN"> ---> - -<!ELEMENT STYLE - O (#PCDATA)> -<!ATTLIST STYLE - notation NOTATION (%style-notations;) #REQUIRED -> - -<!--================ Document Structure ===================================--> - -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ENTITY % version.attr 'VERSION CDATA #FIXED "%HTML.Version;"'> - -<!-- suggested roles are: TOC, DOC, DOCPART, HITLIST, DIALOG --> - -<!ATTLIST HTML - %version.attr; -- report DTD version to application -- - urn CDATA #IMPLIED -- universal resource name for this document -- - class NAMES #IMPLIED -- role of this document, eg table of contents -- - > - -<!-- The END -->
--- a/etc/sgml/html-3s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -<!-- - html3s.dtd - - Document Type Definition for the HyperText Markup Language (HTML DTD) - with strict validation. - -<!ENTITY % HTML.Version - "-//W3O//DTD W3 HTML Strict 3.0//EN//" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//W3O//DTD W3 HTML Strict 3.0//EN//"> - <html> - ... - </html> - -- - > - -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html PUBLIC "-//W3O//DTD W3 HTML 3.0//EN//"> -%html;
--- a/etc/sgml/html-cougar.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,873 +0,0 @@ -<!-- - This is an EXPERIMENTAL version of HTML (code named Cougar) that - extends HTML 3.2 to add support for work by the HTML ERB, including - style sheets, scripting, the object tag, internationalization and - some extensions to forms. The frame tags will probably be added - once we have an agreed definition for them. - - Draft: Wednesday 12-July-96 - - Author: Dave Raggett <dsr@w3.org> - - This is SUBJECT TO CHANGE, pending final approval by member - organizations of the World Wide Web Consortium. ---> - -<!ENTITY % HTML.Version - "-//W3C//DTD HTML Experimental 19960712//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML Experimental 19960712//EN"> - <html> - ... - </html> - -- - > - -<!--================== Deprecated Features Switch =========================--> - -<!ENTITY % HTML.Deprecated "INCLUDE"> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URL "CDATA" - -- The term URL means a CDATA attribute - whose value is a Uniform Resource Locator, - See RFC1808 (June 95) and RFC1738 (Dec 94). - --> - -<!ENTITY % script "CDATA" -- scriptlet --> - -<!-- Parameter Entities --> - -<!ENTITY % head.misc "SCRIPT|STYLE|META|LINK" -- repeatable head elements --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list "UL | OL | DIR | MENU"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<!--================ Character mnemonic entities ==========================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!--================ Entities for special symbols =========================--> - -<!ENTITY copy CDATA "©" -- copyright sign --> -<!ENTITY reg CDATA "®" -- registered sign --> -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> -<!ENTITY nbsp CDATA " " -- non breaking space --> -<!ENTITY trade CDATA "™" -- trade mark symbol --> -<!ENTITY shy CDATA "­" -- soft hyphen --> -<!ENTITY thinsp CDATA " " -- thin space (1/6 em) --> -<!ENTITY emsp CDATA " " -- em space --> -<!ENTITY ensp CDATA " " -- en space (1/2 em) --> -<!ENTITY mdash CDATA "—" -- em dash --> -<!ENTITY ndash CDATA "–" -- en dash --> - -<!-- Language-dependent BIDI and contextual analysis --> -<!ENTITY zwnj CDATA "‌" -- zero width non-joiner --> -<!ENTITY zwj CDATA "‍" -- zero width joiner --> -<!ENTITY lrm CDATA "‎" -- left-to-right mark --> -<!ENTITY rlm CDATA "‏" -- right-to-left mark --> - -<!--=================== Generic Attributes ================================--> - -<!ENTITY % style - "id ID #IMPLIED -- document wide unique id -- - class CDATA #IMPLIED -- comma list of class values -- - style CDATA #IMPLIED -- associated style info --" - > - -<!ENTITY % i18n - "lang NAME #IMPLIED -- RFC 1766 language value -- - dir (ltr|rtl) #IMPLIED -- default directionality --" - > - -<!ENTITY % attrs "%style %i18n"> - -<!ENTITY % just - "align (left|center|right|justify) #IMPLIED" - -- default is left for ltr paragraphs, right for rtl -- - > - -<!--=================== Text Markup =======================================--> - -<!ENTITY % font "TT | I | B | U | S | BIG | SMALL | SUB | SUP"> - -<!ENTITY % phrase "EM | STRONG | DFN | CODE | SAMP | KBD | VAR | CITE | Q"> - -<!ENTITY % special - "A|IMG|APPLET|OBJECT|FONT|BASEFONT|BR|SCRIPT|STYLE|MAP|SPAN|BDO"> - -<!ENTITY % form "INPUT | SELECT | TEXTAREA | LABEL"> - -<!ENTITY % text "#PCDATA | %font | %phrase | %special | %form"> - -<!ELEMENT (%font|%phrase) - - (%text)*> -<!ATTLIST (%font|%phrase) %attrs> - -<!-- There are also 16 widely known color names: - - Black = #000000 Green = #008000 - Silver = #C0C0C0 Lime = #00FF00 - Gray = #808080 Olive = #808000 - White = #FFFFFF Yellow = #FFFF00 - Maroon = #800000 Navy = #000080 - Red = #FF0000 Blue = #0000FF - Purple = #800080 Teal = #008080 - Fuchsia= #FF00FF Aqua = #00FFFF - - These colors were originally picked as being the standard - 16 colors supported with the Windows VGA palette. The above - gives the sRGB values in hex (#RRGGBB). - --> - -<!ELEMENT SPAN - - (%text)* -- generic language/style container --> -<!ATTLIST SPAN %attrs> - -<!ELEMENT BDO - - (%text)* -- I18N BiDi over-ride --> -<!ATTLIST BDO - lang NAME #IMPLIED -- RFC 1766 language value -- - dir (ltr|rtl) #REQUIRED -- directionality -- - > - -<!ELEMENT BASEFONT - O EMPTY> -<!ATTLIST BASEFONT - size CDATA #REQUIRED -- base font size for FONT elements -- - > - -<!ELEMENT FONT - - (%text)* -- local change to font --> -<!ATTLIST FONT - size CDATA #IMPLIED -- [+]nn e.g. size="+1", size=4 -- - color CDATA #IMPLIED -- #RRGGBB in hex, e.g. red: color="#FF0000" -- - face CDATA #IMPLIED -- comma separated list of font names -- - > - -<!ELEMENT BR - O EMPTY -- forced line break --> -<!ATTLIST BR - %attrs; -- id, class, style, lang, dir -- - clear (left|all|right|none) none -- control of text flow -- - > - -<!--================== HTML content models ================================--> -<!-- - HTML has three basic content models: - - %text character level elements and text strings - %flow block-like elements e.g. paragraphs and lists - %bodytext as (b) plus headers and ADDRESS ---> - -<!ENTITY % block - "P | %list | %preformatted | DL | DIV | CENTER | - BLOCKQUOTE | FORM | ISINDEX | HR | TABLE | FIELDSET"> - -<!-- %flow is used for DD and LI --> - -<!ENTITY % flow "(%text | %block)*"> - -<!--=================== Document Body =====================================--> - -<!ENTITY % body.content "(%heading | %text | %block | ADDRESS)*"> - -<!ENTITY % color "CDATA" -- a color specification: #HHHHHH @@ details? --> - -<!ENTITY % body-color-attrs " - bgcolor %color #IMPLIED - text %color #IMPLIED - link %color #IMPLIED - vlink %color #IMPLIED - alink %color #IMPLIED - "> - -<!ELEMENT BODY O O %body.content> -<!ATTLIST BODY - %attrs; -- id, class, style, lang, dir -- - background %URL #IMPLIED -- texture tile for document background -- - %body-color-attrs; -- bgcolor, text, link, vlink, alink -- - onLoad %script #IMPLIED -- intrinsic event -- - onUnload %script #IMPLIED -- intrinsic event -- - > - -<!ENTITY % address.content "((%text;) | P)*"> - -<!ELEMENT ADDRESS - - %address.content> - -<!ELEMENT DIV - - %body.content> -<!ATTLIST DIV - %attrs; -- id, class, style, lang, dir -- - %just; -- alignment of following text -- - > - -<!-- CENTER is a shorthand for DIV with ALIGN=CENTER --> -<!ELEMENT center - - %body.content> - -<!--================== The Anchor Element =================================--> -<!-- see WD-object draft for OBJECT client-side imagemap extensions --> - -<!ENTITY % SHAPE "(rect|circle|poly|default)"> -<!ENTITY % COORDS "CDATA" -- comma separated list of numbers --> - -<!ELEMENT A - - (%text)* -(A)> -<!ATTLIST A - %attrs; -- id, class, style, lang, dir -- - name CDATA #IMPLIED -- named link end -- - href %URL #IMPLIED -- URL for linked resource -- - rel CDATA #IMPLIED -- forward link types -- - rev CDATA #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - accesskey CDATA #IMPLIED -- accessibility key character -- - shape %SHAPE rect -- for use with OBJECT SHAPES -- - coords %COORDS #IMPLIED -- for use with OBJECT SHAPES -- - tabindex NUMBER #IMPLIED -- position in tabbing order -- - notab (notab) #IMPLIED -- exclude from tabbing order -- - onClick %script #IMPLIED -- intrinsic event -- - onMouseOver %script #IMPLIED -- intrinsic event -- - onMouseOut %script #IMPLIED -- intrinsic event -- - > - -<!--================== Client-side image maps ============================--> - -<!-- These can be placed in the same document or grouped in a - separate document although this isn't yet widely supported --> - -<!ELEMENT MAP - - (AREA)*> -<!ATTLIST MAP - name CDATA #IMPLIED - > - -<!ELEMENT AREA - O EMPTY> -<!ATTLIST AREA - shape %SHAPE rect - coords %COORDS #IMPLIED -- always needed except for shape=default -- - href %URL #IMPLIED -- this region acts as hypertext link -- - nohref (nohref) #IMPLIED -- this region has no action -- - title CDATA #IMPLIED -- advisory title string for balloon help -- - alt CDATA #REQUIRED -- description for text only browsers -- - tabindex NUMBER #IMPLIED -- position in tabbing order -- - notab (notab) #IMPLIED -- exclude from tabbing order -- - onClick %script #IMPLIED -- intrinsic event -- - onMouseOver %script #IMPLIED -- intrinsic event -- - onMouseOut %script #IMPLIED -- intrinsic event -- - > - -<!--================== The LINK Element ==================================--> - -<!ENTITY % Types "CDATA" - -- See Internet Draft: draft-ietf-html-relrev-00.txt - LINK has been part of HTML since the early days - although few browsers as yet take advantage of it. - - Relationship values can be used in principle: - - a) for document specific toolbars/menus when used - with the LINK element in document head: - b) to link to a separate style sheet (rel=stylesheet) - c) to make a link to a script (rel=script) - d) by stylesheets to control how collections of - html nodes are rendered into printed documents - e) to make a link to a printable version of this document - e.g. a postscript or pdf version (rel=print) ---> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - %style; -- id, class, style -- - href %URL #IMPLIED -- URL for linked resource -- - rel %Types #IMPLIED -- forward link types -- - rev %Types #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - type CDATA #IMPLIED -- advisory Internet media type -- - > - -<!--=================== Images ============================================--> - -<!ENTITY % Length "CDATA" -- nn for pixels or nn% for percentage length --> -<!ENTITY % Pixels "CDATA" -- integer representing length in pixels --> - -<!-- Suggested widths are used for negotiating image size - with the module responsible for painting the image. - align=left or right cause image to float to margin - and for subsequent text to wrap around image --> - -<!ENTITY % IAlign "(top|middle|bottom|left|right)" -- center? --> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - %style; -- id, class, style -- - src %URL #REQUIRED -- URL of image to embed -- - alt CDATA #IMPLIED -- for display in place of image -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #IMPLIED -- suggested height in pixels -- - width %Pixels #IMPLIED -- suggested width in pixels -- - border %Pixels #IMPLIED -- suggested link border width -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - usemap %URL #IMPLIED -- use client-side image map -- - ismap (ismap) #IMPLIED -- use server image map -- - title CDATA #IMPLIED -- advisory title string -- - > - -<!-- USEMAP points to a MAP element which may be in this document - or an external document, although the latter is not widely supported --> - -<!--=================== OBJECT tag ===================================--> -<!-- OBJECT is a character-like element for inserting objects, see - W3C working draft: http://www.w3.org/pub/WWW/TR/WD-object.html --> - -<!ENTITY % OAlign "(texttop|middle|textmiddle|baseline| - textbottom|left|center|right)"> - -<!ELEMENT OBJECT - - (param | %body.content)*> -<!ATTLIST OBJECT - %attrs -- id, class, style, lang, dir -- - declare (declare) #IMPLIED -- declare but don't instantiate flag -- - classid %URL #IMPLIED -- identifies an implementation -- - codebase %URL #IMPLIED -- some systems need an additional URL -- - data %URL #IMPLIED -- reference to object's data -- - type CDATA #IMPLIED -- Internet media type for data -- - codetype CDATA #IMPLIED -- Internet media type for code -- - standby CDATA #IMPLIED -- message to show while loading -- - align %OAlign #IMPLIED -- positioning inside document -- - height %Length #IMPLIED -- suggested height -- - width %Length #IMPLIED -- suggested width -- - border %Length #IMPLIED -- suggested link border width -- - hspace %Length #IMPLIED -- suggested horizontal gutter -- - vspace %Length #IMPLIED -- suggested vertical gutter -- - usemap %URL #IMPLIED -- reference to image map -- - shapes (shapes) #IMPLIED -- object has shaped hypertext links -- - name %URL #IMPLIED -- submit as part of form -- - title CDATA #IMPLIED -- advisory title string -- - tabindex NUMBER #IMPLIED -- position in tabbing order -- - notab (notab) #IMPLIED -- exclude from tabbing order -- - > - -<!ELEMENT param - O EMPTY -- named property value --> -<!ATTLIST param - name CDATA #REQUIRED -- property name -- - value CDATA #IMPLIED -- property value -- - valuetype (DATA|REF|OBJECT) DATA -- How to interpret value -- - type CDATA #IMPLIED -- Internet media type -- - > - -<!--=================== Java APPLET tag ===================================--> -<!-- - This tag is supported by all java enabled browsers. Applet resources - (including their classes) are normally loaded relative to the document - URL (or <BASE> element if it is defined). The CODEBASE attribute is used - to change this default behavior. If the CODEBASE attribute is defined then - it specifies a different location to find applet resources. The value - can be an absolute URL or a relative URL. The absolute URL is used as is - without modification and is not effected by the documents <BASE> element. - When the codebase attribute is relative, then it is relative to the - document URL (or <BASE> tag if defined). <TEXTFLOW> avoids the problems - with SGML mixed content. It can always be omitted *except* when the APPLET - element hasn't any content. White space, comments and PARAM elements - don't count as content for this purpose. TEXTFLOW was introduced into - the DTD to satisfy SGML parsers, but is ignored by current Web browsers. ---> -<!ELEMENT APPLET - - (PARAM*, TEXTFLOW)> -<!ATTLIST APPLET - %style; -- id, class, style -- - codebase %URL #IMPLIED -- code base -- - code CDATA #REQUIRED -- class file -- - name CDATA #IMPLIED -- applet name -- - alt CDATA #IMPLIED -- for display in place of applet -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #REQUIRED -- suggested height in pixels -- - width %Pixels #REQUIRED -- suggested width in pixels -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - title CDATA #IMPLIED -- advisory title string -- - download NUMBER #IMPLIED -- image download order -- - > - -<!ELEMENT TEXTFLOW O O (%text)* -- needed to bypass mixed content model --> - -<!-- -Here is an example: - - <applet codebase="applets/NervousText" - code=NervousText.class - width=300 - height=50> - <param name=text value="Java is Cool!"> - <img src=sorry.gif alt="This looks better with Java support"> - </applet> ---> - -<!--=================== Horizontal Rule ===================================--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - %style; -- id, class, style -- - align (left|right|center) #IMPLIED - noshade (noshade) #IMPLIED - size %Pixels #IMPLIED - width %Length #IMPLIED - > -<!--=================== Paragraphs =========================================--> - -<!ELEMENT P - O (%text)*> -<!ATTLIST P - %attrs; -- id, class, style, lang, dir -- - %just; -- text alignment -- - > - -<!--=================== Headings ==========================================--> - -<!-- - There are six levels of headers from H1 (the most important) - to H6 (the least important). ---> - -<!ELEMENT ( %heading ) - - (%text;)*> -<!ATTLIST ( %heading ) - %attrs; -- id, class, style, lang, dir -- - %just; -- text alignment -- - > - -<!--=================== Preformatted Text =================================--> - -<!-- excludes images and changes in font size --> - -<!ENTITY % pre.exclusion "IMG|BIG|SMALL|SUB|SUP|FONT"> - -<!ELEMENT PRE - - (%text)* -(%pre.exclusion)> -<!ATTLIST PRE - %attrs; -- id, class, style, lang, dir -- - width NUMBER #implied -- is this widely supported? -- - > - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -]]> - -<!--=================== Block-like Quotes =================================--> - -<!ELEMENT BLOCKQUOTE - - %body.content> -<!ATTLIST BLOCKQUOTE %attrs> - -<!--=================== Lists =============================================--> - -<!-- - HTML 3.2 allows you to control the sequence number for ordered lists. - You can set the sequence number with the START and VALUE attributes. - The TYPE attribute may be used to specify the rendering of ordered - and unordered lists. ---> - -<!-- definition lists - DT for term, DD for its definition --> - -<!ELEMENT DL - - (DT|DD)*> -<!ATTLIST DL - %attrs; -- id, class, style, lang, dir -- - compact (compact) #IMPLIED -- more compact style -- - > - -<!ELEMENT DT - O (%text)*> -<!ELEMENT DD - O %flow;> -<!ATTLIST (DT|DD) %attrs> - -<!-- Ordered lists OL, and unordered lists UL --> -<!ELEMENT (OL|UL) - - (LI)*> - -<!-- - Numbering style - 1 arablic numbers 1, 2, 3, ... - a lower alpha a, b, c, ... - A upper alpha A, B, C, ... - i lower roman i, ii, iii, ... - I upper roman I, II, III, ... - - The style is applied to the sequence number which by default - is reset to 1 for the first list item in an ordered list. - - This can't be expressed directly in SGML due to case folding. ---> - -<!ENTITY % OLStyle "CDATA" -- constrained to: [1|a|A|i|I] --> - -<!ATTLIST OL -- ordered lists -- - %attrs; -- id, class, style, lang, dir -- - type %OLStyle #IMPLIED -- numbering style -- - start NUMBER #IMPLIED -- starting sequence number -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!-- bullet styles --> - -<!ENTITY % ULStyle "disc|square|circle"> - -<!ATTLIST UL -- unordered lists -- - %attrs; -- id, class, style, lang, dir -- - type (%ULStyle) #IMPLIED -- bullet style -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!ELEMENT (DIR|MENU) - - (LI)* -(%block)> -<!ATTLIST DIR - compact (compact) #IMPLIED - > -<!ATTLIST MENU - compact (compact) #IMPLIED - > - -<!-- <DIR> Directory list --> -<!-- <DIR COMPACT> Compact list style --> -<!-- <MENU> Menu list --> -<!-- <MENU COMPACT> Compact list style --> - -<!-- The type attribute can be used to change the bullet style - in unordered lists and the numbering style in ordered lists --> - -<!ENTITY % LIStyle "CDATA" -- constrained to: "(%ULStyle|%OLStyle)" --> - -<!ELEMENT LI - O %flow -- list item --> -<!ATTLIST LI - %attrs; -- id, class, style, lang, dir -- - type %LIStyle #IMPLIED -- list item style -- - value NUMBER #IMPLIED -- reset sequence number -- - > - -<!--================ Forms ===============================================--> - -<!ELEMENT FORM - - %body.content -(FORM)> -<!ATTLIST FORM - action %URL #REQUIRED -- server-side form handler -- - method (%HTTP-Method) GET -- see HTTP specification -- - enctype %Content-Type; "application/x-www-form-urlencoded" - onSubmit %script #IMPLIED -- intrinsic event -- - > - -<!ELEMENT LABEL - - (%text)* -(LABEL) -- field label text --> -<!ATTLIST LABEL - %attrs; -- id, class, style, lang, dir -- - for IDREF #IMPLIED -- matches field ID value -- - accesskey CDATA #IMPLIED -- accessibility key character -- - title CDATA #IMPLIED -- advisory title string -- - onClick %script #IMPLIED -- intrinsic event -- - > -<!ENTITY % InputType - "(TEXT | PASSWORD | CHECKBOX | - RADIO | SUBMIT | RESET | - FILE | HIDDEN | IMAGE | BUTTON)" - > - -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - %attrs; -- id, class, style, lang, dir -- - type %InputType TEXT -- what kind of widget is needed -- - name CDATA #IMPLIED -- required for all but submit and reset -- - value CDATA #IMPLIED -- required for radio and checkboxes -- - checked (checked) #IMPLIED -- for radio buttons and check boxes -- - title CDATA #IMPLIED -- advisory title string -- - size CDATA #IMPLIED -- specific to each type of field -- - maxlength NUMBER #IMPLIED - src %URL #IMPLIED -- for fields with background images -- - align (top|middle|bottom|left|right) top -- image alignment -- - tabindex NUMBER #IMPLIED -- position in tabbing order -- - notab (notab) #IMPLIED -- exclude from tabbing order -- - onClick %script #IMPLIED -- intrinsic event -- - onFocus %script #IMPLIED -- intrinsic event -- - onBlur %script #IMPLIED -- intrinsic event -- - onSelect %script #IMPLIED -- intrinsic event -- - onChange %script #IMPLIED -- intrinsic event -- - > - -<!ELEMENT SELECT - - (OPTION+)> -<!ATTLIST SELECT - %attrs; -- id, class, style, lang, dir -- - name CDATA #REQUIRED - size NUMBER #IMPLIED - multiple (multiple) #IMPLIED - title CDATA #IMPLIED -- advisory title string -- - tabindex NUMBER #IMPLIED -- position in tabbing order -- - notab (notab) #IMPLIED -- exclude from tabbing order -- - onFocus %script #IMPLIED -- intrinsic event -- - onBlur %script #IMPLIED -- intrinsic event -- - onChange %script #IMPLIED -- intrinsic event -- - > - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - %attrs; -- id, class, style, lang, dir -- - selected (selected) #IMPLIED - value CDATA #IMPLIED -- defaults to element content -- - > - -<!-- Multi-line text input field. --> - -<!ELEMENT TEXTAREA - - (#PCDATA)*> -<!ATTLIST TEXTAREA - %attrs; -- id, class, style, lang, dir -- - name CDATA #REQUIRED - rows NUMBER #REQUIRED - cols NUMBER #REQUIRED - title CDATA #IMPLIED -- advisory title string -- - tabindex NUMBER #IMPLIED -- position in tabbing order -- - notab (notab) #IMPLIED -- exclude from tabbing order -- - onFocus %script #IMPLIED -- intrinsic event -- - onBlur %script #IMPLIED -- intrinsic event -- - onSelect %script #IMPLIED -- intrinsic event -- - onChange %script #IMPLIED -- intrinsic event -- - > - -<!-- captioned set of related form fields --> - -<!ELEMENT FIELDSET - - (CAPTION?, %body.content)> -<!ATTLIST FIELDSET - %attrs; -- id, class, style, lang, dir -- - title CDATA #IMPLIED -- advisory title string --> - -<!--======================= Tables ========================================--> - -<!-- IETF HTML table standard, see RFC 1942 e.g. at - http://www.ics.uci.edu/pub/ietf/html/rfc1942.txt --> - -<!-- - The BORDER attribute sets the thickness of the frame around the - table. The default units are screen pixels. - - The FRAME attribute specifies which parts of the frame around - the table should be rendered. The values are not the same as - CALS to avoid a name clash with the VALIGN attribute. - - The value "border" is included for backwards compatibility with - <TABLE BORDER> which yields frame=border and border=implied - For <TABLE BORDER=1> you get border=1 and frame=implied. In this - case, its appropriate to treat this as frame=border for backwards - compatibility with deployed browsers. ---> - -<!ENTITY % Frame "(void|above|below|hsides|lhs|rhs|vsides|box|border)"> - -<!-- - The RULES attribute defines which rules to draw between cells: - - If RULES is absent then assume: - "none" if BORDER is absent or BORDER=0 otherwise "all" ---> - -<!ENTITY % Rules "(none | groups | rows | cols | all)"> - -<!-- horizontal placement of table relative to window --> -<!ENTITY % Where "(left|center|right)"> - -<!-- horizontal alignment attributes for cell contents --> -<!ENTITY % cell.halign - "align (left|center|right|justify|char) #IMPLIED - char CDATA #IMPLIED -- alignment char, e.g. char=':' -- - charoff CDATA #IMPLIED -- offset for alignment char --" - > - -<!-- vertical alignment attributes for cell contents --> -<!ENTITY % cell.valign - "valign (top|middle|bottom|baseline) #IMPLIED" - > - -<!ELEMENT table - - (caption?, (col*|colgroup*), thead?, tfoot?, tbody+)> -<!ELEMENT caption - - (%text;)+> -<!ELEMENT thead - O (tr+)> -<!ELEMENT tfoot - O (tr+)> -<!ELEMENT tbody O O (tr+)> -<!ELEMENT colgroup - O (col*)> -<!ELEMENT col - O EMPTY> -<!ELEMENT tr - O (th|td)+> -<!ELEMENT (th|td) - O %body.content> - -<!ATTLIST table -- table element -- - %attrs; -- id, lang, style, dir and class -- - align %Where; #IMPLIED -- table position relative to window -- - width CDATA #IMPLIED -- table width relative to window -- - cols NUMBER #IMPLIED -- used for immediate display mode -- - border CDATA #IMPLIED -- controls frame width around table -- - frame %Frame; #IMPLIED -- which parts of table frame to include -- - rules %Rules; #IMPLIED -- rulings between rows and cols -- - cellspacing CDATA #IMPLIED -- spacing between cells -- - cellpadding CDATA #IMPLIED -- spacing within cells -- - > - -<!-- ALIGN is used here for compatibility with deployed browsers --> -<!ENTITY % Caption "(top|bottom|left|right)"> - -<!ATTLIST caption -- table caption -- - %attrs; -- id, lang, style, dir and class -- - align %Caption; #IMPLIED -- relative to table -- - accesskey CDATA #IMPLIED -- accessibility key character -- - > - -<!-- -COLGROUP groups a set of COL elements. It allows you to group -several columns together. ---> - -<!ATTLIST colgroup - %attrs; -- id, lang, style, dir and class -- - span NUMBER 1 -- default number of columns in group -- - width CDATA #IMPLIED -- default width for enclosed COLs -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!-- - COL elements define the alignment properties for cells in a given - column or spanned columns. The WIDTH attribute specifies the - width of the columns, e.g. - - width=64 width in screen pixels - width=0.5* relative width of 0.5 ---> - -<!ATTLIST col -- column groups and properties -- - %attrs; -- id, lang, style, dir and class -- - span NUMBER 1 -- number of columns spanned by group -- - width CDATA #IMPLIED -- column width specification -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!-- - Use THEAD to duplicate headers when breaking table - across page boundaries, or for static headers when - body sections are rendered in scrolling panel. - - Use TFOOT to duplicate footers when breaking table - across page boundaries, or for static footers when - body sections are rendered in scrolling panel. - - Use multiple TBODY sections when rules are needed - between groups of table rows. ---> -<!ATTLIST (thead|tbody|tfoot) -- table section -- - %attrs; -- id, lang, style, dir and class -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!ATTLIST tr -- table row -- - %attrs; -- id, lang, style, dir and class -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!ATTLIST (th|td) -- header or data cell -- - %attrs; -- id, lang, style, dir and class -- - axis CDATA #IMPLIED -- defaults to cell content -- - axes CDATA #IMPLIED -- list of axis names -- - nowrap (nowrap) #IMPLIED -- suppress word wrap -- - bgcolor %color #IMPLIED -- cell background color -- - rowspan NUMBER 1 -- number of rows spanned by cell -- - colspan NUMBER 1 -- number of cols spanned by cell -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > -<!--================ Document Head ========================================--> - -<!-- %head.misc defined earlier on as "SCRIPT|STYLE|META|LINK" --> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE?"> - -<!ELEMENT HEAD O O (%head.content) +(%head.misc)> - -<!ELEMENT TITLE - - (#PCDATA)* -(%head.misc) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> -<!ATTLIST TITLE %i18n> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - %i18n; -- lang, dir -- - prompt CDATA #IMPLIED -- prompt message --> - -<!-- - The BASE element gives an absolute URL for dereferencing relative - URLs, e.g. - - <BASE href="http://foo.com/index.html"> - ... - <IMG SRC="images/bar.gif"> - - The image is deferenced to - - http://foo.com/images/bar.gif - - In the absence of a BASE element the document URL should be used. - Note that this is not necessarily the same as the URL used to - request the document, as the base URL may be overridden by an HTTP - header accompanying the document. ---> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - href %URL #REQUIRED - > - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - http-equiv NAME #IMPLIED -- HTTP response header name -- - name NAME #IMPLIED -- metainformation name -- - content CDATA #REQUIRED -- associated information -- - > - -<!-- SCRIPT/STYLE are place holders for transition to next version of HTML --> - -<!ELEMENT STYLE - - CDATA -- style info --> -<!ATTLIST STYLE - %i18n; -- lang, dir for use with title string -- - type CDATA #REQUIRED -- Internet media type for style notation -- - title CDATA #IMPLIED -- advisory title for this style -- - > - -<!ELEMENT SCRIPT - - CDATA -- script statements --> -<!ATTLIST SCRIPT - type CDATA #IMPLIED -- Internet media type for style notation -- - language CDATA #IMPLIED -- predefined script language name -- - src %URL #IMPLIED -- URL for an external script -- - > - -<!--================ Document Structure ===================================--> - -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<![ %HTML.Deprecated [ - <!ENTITY % html.content "HEAD, BODY, PLAINTEXT?"> -]]> - -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ATTLIST HTML - %version.attr; - >
--- a/etc/sgml/html-hj.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1302 +0,0 @@ -<!-- - html-hj.dtd - - Document Type Definition for the HyperText Markup Language (HTML - DTD) for Sun Microsystems Corp. HotJava environment - - - Date: 24 Jul 95 - - Revisions made by: Mark Gaither (markg@hal.com) - Original Author: Dave Raggett <dsr@hplb.hpl.hp.com> - - I have taken the HTML 3.0 DTD dated 16 Mar 95 and added the APP - element introduced by Sun Microsystems Corp. to accomodate their - Java/HotJava WWW application environment. ---> - -<!ENTITY % HTML.Version - "-//Sun Micorsystems Corp.//DTD HotJava HTML//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//Sun Micorsystems Corp.//DTD HotJava HTML//EN"> - <html> - ... - </html> - -- - > - -<!--================== Flags for Marked Sections ==========================--> - -<!ENTITY % HTML.Recommended "IGNORE" - -- Certain features of the language are necessary for compatibility - with widespread usage, but they may compromise the structural - integrity of a document. This feature test entity enables - a more prescriptive document type definition that eliminates - the above features. - --> - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE" - -- Certain features of the language are necessary for compatibility - with earlier versions of the specification, but they tend - to be used an implemented inconsistently, and their use is - deprecated. This feature test entity enables a document type - definition that eliminates these features. - --> - -<!ENTITY % HTML.Obsoleted "IGNORE" - -- The XMP, LISTING and PLAINTEXT tags are incompatible with SGML - and derive from very early versions of HTML. They require non- - standard parsers and will cause problems for processing - documents with standard SGML tools. - --> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URI "CDATA" - -- The term URI means a CDATA attribute - whose value is a Uniform Resource Identifier, - as defined by - "Uniform Resource Identifiers" by Tim Berners-Lee - aka http://info.cern.ch/hypertext/WWW/Addressing/URL/URI_Overview.html - aka RFC 1630 - - Note that CDATA attributes are limited by the LITLEN - capacity (1024 in the current version of html.decl), - so that URIs in HTML have a bounded length. - - --> - -<!ENTITY % REAL "CDATA" -- real numbers (not in SGML) --> - -<!ENTITY % SHAPE "CDATA" - -- Shape of hotzone in image. - - All coordinates are assumed to be numbers in the range 0 to 1 - and interpreted as fractional width/height and measured from - the top left corner of the associated image. - - The attribute value is a string taking one of the following forms: - - "default" - - Used to define a default link for the figure background. - - "circle x, y, r" - - (x, y) define the center and r the radius. - - "rect x, y, w, h" - - (x, y) defines upper left, and w and h the width and height. - - "polygon x1, y1, x2, y2, ..." - - Given n pairs of x, y coordinates, the polygon is closed by a - line linking the n'th point to the first. Intersecting polygons - use the non-zero winding number rule to determine if a point lies - inside the polygon.I - -- -> - -<!-- 3.0 Parameter Entities --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<![ %HTML.Obsoleted [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - - -<![ %HTML.Deprecated [ - <!ENTITY % list "UL | OL | DIR | MENU"> - <!ENTITY % blockquote "BLOCKQUOTE | BQ"> -]]> - -<!ENTITY % list "UL | OL"> - -<!ENTITY % blockquote "BQ"> - -<!ENTITY % preformatted "PRE"> - - -<!-- The CLASS attribute is used to subclass HTML elements for - rendering purposes, when used with style sheets, e.g. DSSSL lite --> - -<!ENTITY % attrs -- common attributes for elements -- - 'id ID #IMPLIED -- as target for hrefs (link ends) -- - lang CDATA "en.us" -- ISO language, country code -- - class NAMES #IMPLIED -- for subclassing elements --'> - -<!-- SGML standard forces different NAMES for all attribute values - in the same element, regardless of the attribute name! As a result - CDATA is used for CLEAR attribute to avoid clash with ALIGN attribute.--> - -<!-- -When text flows around a figure or table in the margin, you sometimes want -to start an element like a header, paragraph or list below the figure rather -than alongside it. The CLEAR attribute allows you to move down unconditionally: - - clear=left move down until left margin is clear - clear=right move down until right margin is clear - clear=all move down until both margins are clear - -Alternatively, you can decide to place the element alongside the figure just -so long as there is enough room. The minimum width needed is specified as: - - clear="40 en" move down until there is at least 40 en units free - clear="100 pixels" move down until there is at least 100 pixels free - -The style sheet (or browser defaults) may provide default minimum widths for -each class of block-like elements. ---> - -<!ENTITY % needs -- Attributes for controlling text flow. Used in headers - and other elements to guarantee sufficient room -- - 'clear CDATA #IMPLIED'> - -<!-- - The following attribute may be included where ever a URL can be given: - - md message digest e.g. md="md5:jV2OfH+nnXHU8bnkPAad/mSQlTDZ" - where the digest is base64 encoded and preceded by a prefix - denoting the algorithm (in this case MD5). ---> - -<!ENTITY % url.link -- Attributes associated with URL based links -- - "md CDATA #IMPLIED -- message digest for linked object --"> - -<!--================ Character mnemonic entities ==========================--> - -<!-- The HTML list of Latin-1 entities includes the full range - of characters in widely available Latin-1 fonts, and as such - is a mixture of ISOlat1 and other ISO publishing symbols --> - -<!ENTITY % HTMLlat1 PUBLIC - "-//IETF//ENTITIES Added Latin 1 for HTML//EN"> -%HTMLlat1; - -<!--================ Entities for special symbols =========================--> - -<!ENTITY emsp SDATA "[emsp ]" -- em space --> -<!ENTITY ensp SDATA "[ensp ]" -- en space (1/2-em) --> -<!ENTITY mdash SDATA "[ndash ]" -- em dash --> -<!ENTITY ndash SDATA "[ndash ]" -- en dash (1/2-em) --> -<!ENTITY nbsp SDATA "[nbsp ]" -- non breaking space --> -<!ENTITY shy SDATA "[shy ]" -- soft hyphen --> -<!ENTITY copy SDATA "[copy ]" -- copyright sign --> -<!ENTITY trade SDATA "[trade ]" -- trade mark sign --> -<!ENTITY reg SDATA "[reg ]" -- registered sign --> - -<!--================ Entities for standard icons ==========================--> - -<!-- a range of standard icons such as &folder; for use - in speeding up display of directory listings etc. --> - -<!ENTITY % HTMLicons PUBLIC - "-//IETF//ENTITIES icons for HTML//EN"> -%HTMLicons; - -<!--================ Entities for math symbols ============================--> - -<!-- ISO subset chosen for use with the widely available Adobe math font --> - -<!ENTITY % HTMLmath PUBLIC - "-//IETF//ENTITIES Math and Greek for HTML//EN"> -%HTMLmath; - -<!--=================== Text Markup =======================================--> - -<!ENTITY % font " U | S | TT | I | BIG | SMALL"> - -<!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE"> - -<!ENTITY % misc "Q | LANG | AU | DFN | PERSON | ACRONYM | ABBREV | INS | DEL"> - -<!ENTITY % special "TAB | MATH | A | IMG | BR"> - -<!ENTITY % notmath "%font | %phrase | %special | %misc"> - -<!ENTITY % text "#PCDATA | SUB | SUP | B | %notmath"> - - -<!ENTITY % pre.exclusion "TAB|MATH|IMG|BIG|SMALL|SUB|SUP"> - -<!ELEMENT (%font|B|%phrase|%misc) - - (%text)+> -<!ATTLIST (%font|B|%phrase|%misc) %attrs;> - -<!-- Subscripts and superscripts. The ALIGN attribute is only used for math --> - -<!ELEMENT (SUB|SUP) - - (%text)+> -<!ATTLIST (SUB|SUP) - %attrs; - align (left|center|right) #IMPLIED - > - -<!-- Forced line break --> - -<!ELEMENT BR - O EMPTY> -<!ATTLIST BR - %attrs; - %needs; -- for control of text flow -- - > - -<!-- Named left, center and right tab stops (independent of '\t' char) --> - -<!ELEMENT TAB - O EMPTY> -<!ATTLIST TAB - id ID #IMPLIED -- defines named tab stop -- - indent NUMBER 0 -- en units before new tab stop -- - to IDREF #IMPLIED -- jump to named tab stop -- - align (left|center|right|decimal) left - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - > - -<!--================== Link Markup ========================================--> - -<!-- - With HTML 3.0 you can use ID attributes on most elements for named - link ends. The use of the NAME attribute on anchors is deprecated. - - Do we want to support arbitrary elements for link starts? This would - involve adding HREF and related attributes to most elements. ---> - -<![ %HTML.Deprecated [ - <!ENTITY % linkName "name CDATA #IMPLIED -- named link end --"> -]]> - -<!ENTITY % linkName ""> - - -<!ENTITY % ToolBar "home|toc|index|glossary|copyright| - up|previous|next|help|bookmark" - - -- LINK RELationship values which are used to create toolbar - buttons or menu items for navigation, where toc stands - for table of contents and bookmark provides for an open - ended set of links, i.e. you can use multiple bookmarks - for key entry points. Use the optional TITLE attribute - to override default names. - --> - -<!ENTITY % linkType "NAME" - -- A definitive list will be specified at a later date. - - They are used - - a) by stylesheets to control how collections of - html nodes are rendered into printed documents - - b) for document specific toolbars/menus when used - with the LINK element in document head: - - "home|toc|index|glossary|copyright| - up|previous|next|help|bookmark" - - where toc stands for table of contents and - bookmark provides for an open ended set of links, - i.e. you can use several bookmarks for key entry - points. Use the optional TITLE attribute to - override default names. - - c) for hypertext paths or guided tours, - with REL=NODE and REL=PATH. - - d) to make a link to a style sheet, e.g. rel=stylesheet - (used only with the LINK element). - - e) to make a link to a separate banner, e.g. rel=banner - (used only with the LINK element). - --> - - -<!ENTITY % linkExtraAttributes -- URN moved to %url.link -- - "rel %linkType #IMPLIED -- forward relationship type -- - rev %linkType #IMPLIED -- reversed relationship type - to referent data -- - title CDATA #IMPLIED -- advisory only -- - methods NAMES #IMPLIED -- supported public methods of the object: - TEXTSEARCH, GET, HEAD, ... -- - "> - -<![ %HTML.Deprecated [ - <!ENTITY % A.content "(%heading|%text)+"> -]]> - -<!ENTITY % A.content "(%text)+"> - -<!ELEMENT A - - %A.content -(A)> - -<!ATTLIST A - %attrs; - href %URI; #IMPLIED - %url.link; -- standard link attributes -- - %linkName; -- name attribute is deprecated; use ID instead -- - shape %SHAPE; #IMPLIED -- for shaped hotzones in FIGs -- - %linkExtraAttributes; - > - -<!--=================== Images ============================================--> - -<!-- Desired widths are used for negotiating image size - with the module responsible for painting the image. - align=left or right cause image to float to margin - and for subsequent text to wrap around image --> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - %attrs; - src %URI; #REQUIRED -- URI of image to embed -- - %url.link; -- standard link attributes -- - alt CDATA #IMPLIED -- for display in place of image -- - align (top|middle|bottom|left|right) top -- relative to baseline - -- width NUMBER #IMPLIED -- desired width in en's or pixels -- - height NUMBER #IMPLIED -- desired height in en's or pixels -- - units (en|pixels) pixels -- units for width and height -- - ismap (ismap) #IMPLIED -- pass clicks to server -- - > - -<!--=================== Paragraphs=========================================--> - -<!ELEMENT P - O (%text)+> -<!ATTLIST P - %attrs; - align (left|center|right|justify) #IMPLIED - %needs; -- for control of text flow -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!--=================== Headings, Titles, Sections ========================--> - -<!ELEMENT HR - O EMPTY -- customizable horizontal rule --> -<!ATTLIST HR - %attrs; - src %URI; #IMPLIED -- URI of custom rule graphic -- - %url.link; -- standard link attributes -- - %needs; -- for control of text flow -- - > - -<!-- - Headers can be numbered, although this is a matter for style sheets. - The style sheet controls the numbering style: - - a) whether the parent numbering is inherited, e.g. 5.i.c - where 5 is the current sequence number for H1 headers, and - 1 is the number for H2 headers and 3 for H3 headers. - - b) what style is used for current sequence number - e.g. arabic, upperalpha, loweralpha, upperroman, lowerroman - or a numbering scheme appropriate for the current language - - The skip attribute is used to skip over sequence numbers for items - which have been left out of the list, e.g. skip=3 advances the - sequence number past 3 omitted items. The seqnum sets the sequence - number to a specified value. Note that the style sheet may take - advantage of the sequence number for higher level headers. - - The dingbat or src attributes may be used to specify a bullet like - image to be placed adjacent to the header. Defining this in the - header element simplifies the document markup and avoids the need - to use the clear or needs attribute in the following element to - prevent it flowing around this image. ---> - -<!ELEMENT ( %heading ) - - (%text;)+> -<!ATTLIST ( %heading ) - %attrs; - align (left|center|right|justify) #IMPLIED - %needs; -- for control of text flow -- - seqnum NUMBER #IMPLIED -- starting sequence number -- - skip NUMBER 0 -- skip seq nums for missing items -- - dingbat ENTITY #IMPLIED -- dingbat entity from HTMLicons -- - src (%URI;) #IMPLIED -- bullet defined by graphic -- - %url.link; -- standard link attributes -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!ELEMENT TITLE - - (#PCDATA) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> - -<!--=================== Text Flows ========================================--> - -<!ENTITY % block - "P | %list | DL - | %preformatted - | %blockquote - | FORM | ISINDEX | FN - | TABLE | FIG | NOTE"> - -<!-- - ((%block)* | (%text)*) would be much nicer as it would avoid the need - for a <P> tag when all you want is a few words of text. The problem - is that it also prevents: "<LI> <P>some text" since it forbids PCDATA - and hence the white space between the <LI> and the <P>. ---> - -<![ %HTML.Recommended [ - <!ENTITY % flow "(%block)*"> -]]> - -<!ENTITY % flow "(%text | %block)*"> - -<!ELEMENT PRE - - (%text)* -(%pre.exclusion)> - -<!ATTLIST PRE - %attrs; - width NUMBER #implied - %needs; -- for control of text flow -- - > - -<![ %HTML.Obsoleted [ - -<!ENTITY % literal "CDATA" - -- special non-conforming parsing mode where - the only markup signal is the end tag - in full. This will cause problems for - standard SGML tools! - --> - -<!ELEMENT XMP - - %literal> -<!ELEMENT LISTING - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -]]> - -<!--=================== Lists =============================================--> - -<!ELEMENT DL - - (LH?, (DT|DD)+) -- this is perhaps too lax? --> -<!ATTLIST DL - %attrs; - %needs; -- for control of text flow -- - compact (compact) #IMPLIED -- more compact style -- - > - -<!ELEMENT DT - O (%text)+> -<!ELEMENT DD - O %flow;> -<!ATTLIST (DT|DD) - %attrs; - %needs; -- for control of text flow -- - > - - -<!ELEMENT (OL|UL) - - (LH?, LI+) -- should we allow a list header ? --> - -<!-- style sheet controls numbering style - a) whether the parent numbering is inherited, e.g. 5.1.c - b) what style is used for current sequence number - e.g. arabic, upperalpha, loweralpha, upperroman, lowerroman - or a numbering scheme for the current language ---> -<!ATTLIST OL - %attrs; - %needs; -- for control of text flow -- - continue (continue) #IMPLIED -- don't restart sequence number -- - seqnum NUMBER #IMPLIED -- starting sequence number -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!-- Unordered lists: - - o single or multicolumn with - horizontal or vertical wrapping - - o plain or bulletted list items - - o bullets can be customised via: - - entities (dingbats in HTMLicons) - - external graphic via URL - - individual attributes on LI tags ---> -<!ATTLIST UL - %attrs; - %needs; -- for control of text flow -- - wrap (vert|horiz|none) none -- multicolumn list style -- - plain (plain) #IMPLIED -- suppress bullets -- - dingbat ENTITY #IMPLIED -- dingbat entity from HTMLicons -- - src (%URI;) #IMPLIED -- bullet defined by graphic -- - %url.link; -- standard link attributes -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!ELEMENT LH - O (%text;)+ -- list header --> -<!ATTLIST LH %attrs;> - -<!-- - For unordered lists, you can override the standard bullet with - a custom graphic specified via a URI e.g. src="splash.gif" or - a reference to one of the HTMLicons graphics e.g. dingbat=folder - - The skip attribute is used with ordered lists to skip over sequence - numbers for items which have been left out of the list, e.g. skip=3 - advances the sequence number past 3 omitted items. ---> - -<!ELEMENT LI - O %flow; -- list item --> -<!ATTLIST LI - %attrs; - %needs; -- for control of text flow -- - dingbat ENTITY #IMPLIED -- dingbat entity from HTMLicons -- - src (%URI;) #IMPLIED -- custom bullet graphic -- - %url.link; -- standard link attributes -- - skip NUMBER 0 -- skip seq nums for missing items -- - > - -<!-- DIR and MENU are now subsumed by UL with type=plain. Use the - wrap attribute to control wrapping style for multicolumn lists --> - -<![ %HTML.Deprecated [ - <!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> - <!ATTLIST (DIR|MENU) - compact (compact) #IMPLIED> -]]> - -<!--=================== Document Body =====================================--> - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(DIV|%heading|%block|HR|ADDRESS|APP)*" - -- <h1>Heading</h1> - <p>Text ... - is preferred to - <h1>Heading</h1> - Text ... - --> -]]> - -<!ENTITY % body.content "(DIV | %heading | %text | %block | HR | ADDRESS | APP)*"> - -<!ELEMENT BODY O O (BANNER?, BODYTEXT) +(SPOT)> -<!ATTLIST BODY - %attrs; - background %URI; #IMPLIED -- texture tile for document background -- - > - -<!ELEMENT BODYTEXT O O %body.content -- dummy element --> - -<!-- - The BANNER element is used for a banner section which appears at - the top of the window and doesn't scroll with window contents. - This can be used for corporate logos, copyright statements and - disclaimers, as well as customized navigation/search controls. ---> -<!ELEMENT BANNER - - %body.content> -<!ATTLIST BANNER %attrs; > - -<!-- SPOT is used to insert IDs at arbitrary places - e.g. for end points of a marked range (see RANGE) --> -<!ELEMENT SPOT - O EMPTY> -<!ATTLIST SPOT id ID #REQUIRED> - -<!ELEMENT (%blockquote) - - (BODYTEXT, CREDIT?)> -<!ATTLIST (%blockquote) - %attrs; - %needs; -- for control of text flow -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!ENTITY % address.content "((%text;)* | P*)"> - -<!ELEMENT ADDRESS - - %address.content> -<!ATTLIST ADDRESS - %attrs; - %needs; -- for control of text flow -- - > - -<!ELEMENT APP - O EMPTY> -<!ATTLIST APP - class CDATA #REQUIRED - src %URI; #IMPLIED - align (bottom|top|middle) #IMPLIED - width NUMBER #IMPLIED - height NUMBER #IMPLIED - > - -<!-- - DIV can be used with the CLASS attribute to represent different - kinds of container, e.g. chapter, section, abstract, appendix. ---> - -<!ELEMENT DIV - - %body.content> -<!ATTLIST DIV - %attrs; - %needs; -- for control of text flow -- - align (left|center|right) left -- alignment of following text -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!--================ Forms ===============================================--> - -<!-- - As HTML 2.0 plus a few extensions: - - a) A RANGE control which varies between pair of values - specified with the size attribute, e.g. SIZE="1, 10" - - b) FILE widget for uploading one or more files to a server - - c) SCRIBBLE on image widget that sends the "ink" to the server - - d) SUBMIT/RESET buttons can now be customised with an image. - This subsumes the IMAGE type which is now deprecated. - - e) Graphical SELECTion menus are now supported, using - the new SHAPE attribute on OPTION elements. - - Further extensions are in the pipeline (e.g. table entry, - multiple data formats for textarea fields and client-side - scripts with custom widgets) but will have to wait until - the backlog of implementation work diminishes. ---> - -<!ELEMENT FORM - - %body.content -(FORM) +(INPUT|SELECT|TEXTAREA)> -<!ATTLIST FORM - action %URI #REQUIRED -- server-side form handler -- - method (%HTTP-Method) GET -- see HTTP specification -- - enctype %Content-Type; "application/x-www-form-urlencoded" - script %URI #IMPLIED -- link to client-side script -- - > - -<![ %HTML.Deprecated [ - <!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | RANGE | FILE | SCRIBBLE | HIDDEN | IMAGE)"> -]]> - -<!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | RANGE | FILE | SCRIBBLE | HIDDEN)"> - -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - %attrs; - type %InputType TEXT - name NAME #IMPLIED -- required for all but submit and reset -- - value CDATA #IMPLIED -- required for radio buttons & checkboxes -- - disabled (disabled) #IMPLIED -- read-only fields -- - error CDATA #IMPLIED -- why field is in error -- - checked (checked) #IMPLIED -- for radio buttons and check boxes -- - size NUMBER #IMPLIED -- visible width of TEXT fields -- - maxlength NUMBER #IMPLIED -- max number of chars for TEXT fields -- - min %REAL #IMPLIED -- lower limit for RANGE fields -- - max %REAL #IMPLIED -- upper limit for RANGE fields -- - accept CDATA #IMPLIED -- list of MIME types for file fields -- - src %URI #IMPLIED -- for fields with background images -- - %url.link; -- standard link attributes -- - align (top|middle|bottom|left|right) top - > - -<!-- - SRC attribute added for graphical selection menus - The WIDTH, HEIGHT and UNITS attributes apply to the - image specified by the SRC attribute. - --> - -<!ELEMENT SELECT - - (OPTION+) -(INPUT|TEXTAREA|SELECT)> -<!ATTLIST SELECT - %attrs; - name CDATA #REQUIRED - multiple (multiple) #IMPLIED - disabled (disabled) #IMPLIED -- read-only menu -- - error CDATA #IMPLIED -- why selections are in error -- - src %URI #IMPLIED -- for graphical selection menus -- - %url.link; -- standard link attributes -- - width NUMBER #IMPLIED -- desired width of in en's or pixels -- - height NUMBER #IMPLIED -- desired height in en's or pixels -- - units (en|pixels) pixels -- units for width and height -- - align (top|middle|bottom|left|right) top - > - -<!ELEMENT OPTION - O (#PCDATA)> -<!ATTLIST OPTION - %attrs; - selected (selected) #IMPLIED - value CDATA #IMPLIED -- default to element content -- - shape %SHAPE; #IMPLIED -- for graphical selection menus -- - disabled (disabled) #IMPLIED -- unselectable option -- - error CDATA #IMPLIED -- why this choice is in error -- - > - -<!-- - Multi-line text input field. align=left or right - causes the field to float to margin and for - subsequent text to wrap around the field. ---> - -<!ELEMENT TEXTAREA - - (#PCDATA) -(INPUT|TEXTAREA|SELECT)> -<!ATTLIST TEXTAREA - %attrs; - name CDATA #REQUIRED - rows NUMBER #REQUIRED - cols NUMBER #REQUIRED - disabled (disabled) #IMPLIED -- read-only field -- - error CDATA #IMPLIED -- why field is in error -- - align (top|middle|bottom|left|right) top - > - -<!--======================= Captions ======================================--> - -<!ELEMENT CAPTION - - (%text;)+ -- table or figure caption --> -<!ATTLIST CAPTION - %attrs; - align (top|bottom|left|right) #IMPLIED - > -<!--======================= Tables ========================================--> - -<!-- - Tables and figures can be aligned in several ways: - - bleedleft flush left with the left (window) border - left flush left with the left text margin - center centered (text flow is disabled for this mode) - right flush right with the right text margin - bleedright flush right with the right (window) border - justify when applicable the table/figure should stretch - to fill space between the text margins - - Note: text will flow around the table or figure if the browser - judges there is enough room and the alignment is not centered - or justified. The table or figure may itself be part of the - text flow around some earlier figure. You can in this case use - the clear or needs attributes to move the new table or figure - down the page beyond the obstructing earlier figure. Similarly, - you can use the clear or needs attributes with other elements - such as headers and lists to move them further down the page. ---> - -<!ENTITY % block.align - "align (bleedleft|left|center|right|bleedright|justify) center"> - -<!-- - The HTML 3.0 table model has been chosen for its simplicity - and the ease in writing filters from common DTP packages. - - By default the table is automatically sized according to the - cell contents and the current window size. Specifying the columns - widths using the colspec attribute allows browsers to start - displaying the table without having to wait for last row. - - The colspec attribute is a list of column widths and alignment - specifications. The columns are listed from left to right with - a capital letter followed by a number, e.g. COLSPEC="L20 C8 L40". - The letter is L for left, C for center, R for right alignment of - cell contents. J is for justification, when feasible, otherwise - this is treated in the same way as L for left alignment. - Column entries are delimited by one or more space characters. - - The number specifies the width in en's, pixels or as a - fractional value of the table width, as according to the - associated units attribute. This approach is more compact - than used with most SGML table models and chosen to simplify - hand entry. The width attribute allows you to specify the - width of the table in pixels, en units or as a percentage - of the space between the current left and right margins. - - To assist with rendering to speech, row and column headers - can be given short names using the AXIS attribute. The AXES - attribute is used to explicitly specify the row and column - names for use with each cell. Otherwise browsers can follow - up columns and left along rows (right for some languages) - to find the corresponding header cells. - - Table content model: Braille limits the width of tables, - placing severe limits on column widths. User agents need - to render big cells by moving the content to a note placed - before the table. The cell is then rendered as a link to - the corresponding note. - - To assist with formatting tables to paged media, authors - can differentiate leading and trailing rows that are to - be duplicated when splitting tables across page boundaries. - The recommended way is to subclass rows with the CLASS attribute - For example: <TR CLASS=Header>, <TR CLASS=Footer> are used for - header and footer rows. Paged browsers insert footer rows at - the bottom of the current page and header rows at the top of - the new page, followed by the remaining body rows. ---> - -<!ELEMENT TABLE - - (CAPTION?, TR*) -- mixed headers and data --> -<!ATTLIST TABLE - %attrs; - %needs; -- for control of text flow -- - border (border) #IMPLIED -- draw borders -- - colspec CDATA #IMPLIED -- column widths and alignment -- - units (en|pixels|relative) en -- units for column widths -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - width NUMBER #IMPLIED -- absolute or percentage width -- - %block.align; -- horizontal alignment -- - noflow (noflow) #IMPLIED -- noflow around table -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - > - -<!ENTITY % cell "TH | TD"> -<!ENTITY % horiz.align "left|center|right|justify"> -<!ENTITY % vert.align "top|middle|bottom|baseline"> - -<!-- - Browsers should tolerate an omission of the first <TR> - tag as it is implied by the context. Missing trailing - <TR>s implied by rowspans should be ignored. - - The alignment attributes act as defaults for rows - overriding the colspec attribute and being in turn - overridden by alignment attributes on cell elements. - Use valign=baseline when you want to ensure that text - in different cells on the same row is aligned on the - same baseline regardless of fonts. It only applies - when the cells contain a single line of text. ---> - -<!ELEMENT TR - O (%cell)* -- row container --> -<!ATTLIST TR - %attrs; - align (%horiz.align) #IMPLIED -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - > - -<!-- - Note that table cells can include nested tables. - Missing cells are considered to be empty, while - missing rows should be ignored, i.e. if a cell - spans a row and there are no further TR elements - then the implied row should be ignored. ---> - -<!ELEMENT (%cell) - O %body.content> -<!ATTLIST (%cell) - %attrs; - colspan NUMBER 1 -- columns spanned -- - rowspan NUMBER 1 -- rows spanned -- - align (%horiz.align) #IMPLIED -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - axis CDATA #IMPLIED -- axis name, defaults to element content -- - axes CDATA #IMPLIED -- comma separated list of axis names -- - > - -<!--====================== Figures ========================================--> - -<!-- - The element contains text for use in non-graphical displays. Note that - you can use the shape attribute in anchors to specify hotzones on images. - This provides for local processing of pointer clicks and a unified method - for dealing with graphical and non-graphical displays. - - Text is flowed around figures when the figure is left or right aligned. - You can request the browser to move down until there is enough room for - the next element, see the CLEAR and NEED attributes (in %needs) - - Figures offer a path towards embedding arbitrary information formats - via some kind of OLE/OpenDoc mechanism. ---> - -<!ELEMENT FIG - - (OVERLAY*, CAPTION?, FIGTEXT, CREDIT?) -(FIG|IMG)> -<!ATTLIST FIG - %attrs; - %needs; -- for control of text flow -- - src %URI; #REQUIRED -- URI of document to embed -- - %url.link; -- standard link attributes -- - %block.align; -- horizontal alignment -- - noflow (noflow) #IMPLIED -- noflow around figure -- - width NUMBER #IMPLIED -- desired width in units -- - height NUMBER #IMPLIED -- desired height in units -- - units (en|pixels) pixels -- specifies units as en's or pixels -- - imagemap (%URI) #IMPLIED -- pass background clicks to server -- - > - -<!ELEMENT FIGTEXT O O %body.content -- dummy element --> - -<!-- - Figure overlays. When combined with local caching, overlays - provide a cheap way of modifying a larger base image sent as - part of a previous page. ---> - -<!ELEMENT OVERLAY - O EMPTY -- image overlay --> -<!ATTLIST OVERLAY - src %URI; #REQUIRED -- URI of image overlay -- - %url.link; -- standard link attributes -- - units (en|pixels) pixels -- specifies units as en's or pixels -- - x NUMBER 0 -- offset from left in units -- - y NUMBER 0 -- offset from top in units -- - width NUMBER #IMPLIED -- desired width in units -- - height NUMBER #IMPLIED -- desired height in units -- - imagemap (%URI) #IMPLIED -- pass background clicks to server -- - > - -<!ELEMENT CREDIT - - (%text;)* -- source of image --> -<!ATTLIST CREDIT - %attrs; - > - -<!--======================== Notes ========================================--> - -<!-- -The NOTE element is used for admonishments. The CLASS attribute -is used to differentiate NOTE's, e.g. Note, Caution or Warning. ---> - -<!ELEMENT NOTE - - %body.content; -- admonishment --> -<!ATTLIST NOTE - %attrs; - src %URI; #IMPLIED -- URI of custom graphic -- - %url.link; -- standard link attributes -- - %needs; -- for control of text flow -- - > - -<!--======================== Footnotes ====================================--> - -<!-- -Typically rendered as popup note. These elements are referenced -by hypertext links specified with the anchor element. ---> -<!ELEMENT FN - - %body.content;> -<!ATTLIST FN %attrs;> - -<!--======================== Math ========================================--> - -<!-- Use     etc for greater control of spacing. --> - -<!-- Subscripts and Superscripts - - <SUB> and <SUP> are used for subscripts and superscripts. - - i j - X <SUP>i</SUP>Y<SUP>j</SUP> is X Y - - i.e. the space following the X disambiguates the binding. - The align attribute can be used for horizontal alignment, - e.g. to explicitly place an index above an element: - i - X<sup align=center>i</sup> produces X - -Short references are defined for superscripts, subscripts and boxes -to save typing when manually editing HTML math, e.g. - - x^2^ is mapped to x<sup>2</sup> - y_z_ is mapped to y<sub>z</sub> - {a+b} is mapped to <box>a + b</box> - -Note that these only apply within the MATH element and can't be -used in normal text! ---> -<!ENTITY REF1 STARTTAG "SUP"> -<!ENTITY REF2 ENDTAG "SUP"> -<!ENTITY REF3 STARTTAG "SUB"> -<!ENTITY REF4 ENDTAG "SUB"> -<!ENTITY REF5 STARTTAG "BOX"> -<!ENTITY REF6 ENDTAG "BOX"> - -<!USEMAP MAP1 MATH> -<!USEMAP MAP2 SUP> -<!USEMAP MAP3 SUB> -<!USEMAP MAP4 BOX> - -<!SHORTREF MAP1 "^" REF1 - "_" REF3 - "{" REF5 > - -<!SHORTREF MAP2 "^" REF2 - "_" REF3 - "{" REF5 > - -<!SHORTREF MAP3 "_" REF4 - "^" REF1 - "{" REF5 > - -<!SHORTREF MAP4 "}" REF6 - "^" REF1 - "_" REF3 - "{" REF5 > - -<!-- - The inclusion of %math and exclusion of %notmath is used here - to alter the content model for the B, SUB and SUP elements, - to limit them to formulae rather than general text elements. ---> - -<!ENTITY % mathvec "VEC|BAR|DOT|DDOT|HAT|TILDE" -- common accents --> -<!ENTITY % mathface "B|T|BT" -- control of font face --> -<!ENTITY % math "BOX|ABOVE|BELOW|%mathvec|ROOT|SQRT|ARRAY|SUB|SUP|%mathface"> -<!ENTITY % formula "#PCDATA|%math"> - -<!ELEMENT MATH - - (#PCDATA)* -(%notmath) +(%math)> -<!ATTLIST MATH - id ID #IMPLIED - class NAMES #IMPLIED -- e.g. class=chem --> - -<!-- The BOX element acts as brackets. Delimiters are optional and - stretch to match the height of the box. The OVER element is used - when you want a line between numerator and denominator. This line - is suppressed with the alternative ATOP element. CHOOSE acts like - ATOP but adds enclosing round brackets as a convenience for binomial - coefficients. Note the use of { and } as shorthand for <BOX> and - </BOX> respectively: - - 1 + X - {1 + X<OVER>Y} is _______ - Y - - a + b - {a + b<ATOP>c - d} is - c - d - - The delimiters are represented using the LEFT and RIGHT - elements as in: - - {[<LEFT>x + y<RIGHT>]} is [ x + y ] - {(<LEFT>a<RIGHT>]} is (a] - {||<LEFT>a<RIGHT>||} is || a || - - Use { and } for "{" and "}" respectively as - these symbols are used as shorthand for BOX, e.g. - - {{<LEFT>a+b<RIGHT>}} is {a+b} - - You can stretch definite integrals to match the integrand, e.g. - - {∫<SUB>a</SUB><SUP>b</SUP><LEFT>{f(x)<over>1+x} dx} - - b - / f(x) - | ----- dx - / 1 + x - a - - Note the complex content model for BOX is a work around - for the absence of support for infix operators in SGML. - - You can get oversize delimiters with the SIZE attribute, - for example <BOX SIZE=large>(<LEFT>...<RIGHT>)</BOX> - - Note that the names of common functions are recognized - by the parser without the need to use "&" and ";" around - them, e.g. int, sum, sin, cos, tan, ... ---> - -<!ELEMENT BOX - - ((%formula)*, (LEFT, (%formula)*)?, - ((OVER|ATOP|CHOOSE), (%formula)*)?, - (RIGHT, (%formula)*)?)> -<!ATTLIST BOX - size (normal|medium|large|huge) normal -- oversize delims --> - -<!ELEMENT (OVER|ATOP|CHOOSE|LEFT|RIGHT) - O EMPTY> - -<!-- Horizontal line drawn ABOVE contents - The symbol attribute allows authors to supply - an entity name for an accent, arrow symbol etc. - Generalisation of LaTeX's overline command. - - e.g. <above sym=ssmile>x</above> - places an upwardly turning curve above the "x" - --> - -<!ELEMENT ABOVE - - (%formula)+> -<!ATTLIST ABOVE sym ENTITY #IMPLIED> - -<!-- Horizontal line drawn BELOW contents - The symbol attribute allows authors to - supply an entity name for an arrow symbol etc. - Generalisation of LaTeX's underline command. - --> - -<!ELEMENT BELOW - - (%formula)+> -<!ATTLIST BELOW sym ENTITY #IMPLIED> - -<!-- Convenience tags for common accents: - vec, bar, dot, ddot, hat and tilde ---> - -<!ELEMENT (%mathvec) - - (%formula)+> - -<!-- - T and BT are used to designate terms which should - be rendered in an upright font (& bold face for BT) ---> - -<!ELEMENT (T|BT) - - (%formula)+> -<!ATTLIST (T|BT) class NAMES #IMPLIED> - -<!-- Roots e.g. <ROOT>3<OF>1+x</ROOT> --> - -<!ELEMENT ROOT - - ((%formula)+, OF, (%formula)+)> -<!ELEMENT OF - O (%formula)* -- what the root applies to --> - -<!ELEMENT SQRT - - (%formula)* -- square root convenience tag --> - -<!-- LaTeX like arrays. The COLDEF attribute specifies - a single capital letter for each column determining - how the column should be aligned, e.g. coldef="CCC" - - "L" left - "C" center - "R" right - - An optional separator letter can occur between columns - and should be one of + - or =, e.g. "C+C+C+C=C". - Whitespace within coldef is ignored. By default, the - columns are all centered. - - The ALIGN attribute alters the vertical position of the - array as compared with preceding and following expressions. - - Use LDELIM and RDELIM attributes for delimiter entities. - When the LABELS attribute is present, the array is - displayed with the first row and the first column as - labels displaced from the other elements. In this case, - the first element of the first row should normally be - left blank. - - Use &vdots; &cdots; and &ddots; for vertical, horizontal - and diagonal ellipsis dots. Use &dotfill; to fill an array - cell with horizontal dots (e.g. for a full row). - Note &ldots; places the dots on the baseline, while &cdots; - places them higher up. ---> - -<!ELEMENT ARRAY - - (ROW)+> -<!ATTLIST ARRAY - align (top|middle|bottom) middle -- vertical alignment -- - coldef CDATA #IMPLIED -- column alignment and separator -- - ldelim CDATA #IMPLIED -- stretchy left delimiter -- - rdelim CDATA #IMPLIED -- stretchy right delimiter -- - labels (labels) #IMPLIED -- TeX's \bordermatrix style --> - -<!ELEMENT ROW - O (ITEM)*> -<!ELEMENT ITEM - O (%formula)*> -<!ATTLIST ITEM - align CDATA #IMPLIED -- override coldef alignment -- - colspan NUMBER 1 -- merge columns as per TABLE -- - rowspan NUMBER 1 -- merge rows as per TABLE --> - -<!--================ Document Head ========================================--> - -<![ %HTML.Deprecated [ - <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? - & META* & LINK* & RANGE* & NEXTID?"> -]]> - -<!ENTITY % head.nextid ""> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? - & META* & LINK* & RANGE*"> - -<!ELEMENT HEAD O O (%head.content)> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - href %URI #REQUIRED - %linkExtraAttributes; > - -<!ELEMENT RANGE - O EMPTY> -<!ATTLIST RANGE - id ID #IMPLIED -- for naming marked range -- - class NAMES #IMPLIED -- for subclassing -- - from IDREF #REQUIRED -- start of marked range -- - until IDREF #REQUIRED -- end of marked range -- - > - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - href %URI #IMPLIED -- server handling queries -- - prompt CDATA #IMPLIED -- prompt message --> - -<!-- - The BASE element gives the base URL for - dereferencing relative URLs, e.g. - - <BASE href="http://foo.com/images"> - ... - <IMG SRC="bar.gif"> - - The image is deferenced to - - http://foo.com/images/bar.gif ---> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - id ID #IMPLIED - href %URI; #REQUIRED - > - -<![ %HTML.Deprecated [ - <!ELEMENT NEXTID - O EMPTY> - <!ATTLIST NEXTID N CDATA #REQUIRED> -]]> - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - http-equiv NAME #IMPLIED -- HTTP response header name -- - name NAME #IMPLIED -- metainformation name -- - content CDATA #REQUIRED -- associated information -- - > - -<!-- - A style sheet can be associated with the document using the - LINK element, e.g. <LINK rel=style href="housestyle.dsssl">. - Style overrides can be placed in the document head using the - STYLE element, e.g. - - <style notation=dsssl-lite> - dsss-lite stuff - </style> - - Later on in the document you can use: - - <h2 class=bigcaps>Header with bigger than normal capitals</h2> - <p class=abstract>A paragraph with a unique style of its own - ... - - Statements in the given style notation - - The tag names, class and id attributes are used in the style sheet - notation to describe how to render matching elements. ---> - -<!ENTITY % style-notations "dsssl-lite | w3c-style"> - -<!-- -<!NOTATION dsssl-lite PUBLIC - "ISO/IEC 10179:1995//NOTATION DSSSL Style Language//EN"> - -<!NOTATION w3c-style PUBLIC "IETF/RFC nnn/W3C Style Language//EN"> ---> - -<!ELEMENT STYLE - O (#PCDATA)> -<!ATTLIST STYLE - notation NOTATION (%style-notations;) #REQUIRED -> - -<!--================ Document Structure ===================================--> - -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ENTITY % version.attr 'VERSION CDATA #FIXED "%HTML.Version;"'> - -<!-- suggested roles are: TOC, DOC, DOCPART, HITLIST, DIALOG --> - -<!ATTLIST HTML - %version.attr; -- report DTD version to application -- - urn CDATA #IMPLIED -- universal resource name for this document -- - class NAMES #IMPLIED -- role of this document, eg table of contents -- - > - -<!-- The END -->
--- a/etc/sgml/html-hjs.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -<!-- html-hjs.dtd - - Document Type Definition for the HyperText Markup Language - with strict validation of the HotJava DTD. - - Author: Daniel W. Connolly <connolly@w3.org> - Applet additions by: Mark Gaither (markg@hal.com) 24 Jul 95 - ---> - -<!ENTITY % HTML.Version - "-//Sun Microsystems Corp.//DTD HotJava Strict HTML//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//Sun Microsystems Corp.//DTD HotJava HTML//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html PUBLIC "-//Sun Microsystems Corp.//DTD HotJava HTML//EN"> -%html;
--- a/etc/sgml/html-icons.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ - -<!-- - HTMLicons fake entity declarations to get the html-3.dtd to work ---> - -<!ENTITY folder SDATA "[folder ]" -- folder icon --> -<!-- should have a bunch more icons, like the internal icons = - - in Mosaic and Netscape --> -
--- a/etc/sgml/html-latin.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,161 +0,0 @@ -<!-- Portions of this text are copyright ISO: - - (C) International Organization for Standardization 1986 - Permission to copy in any form is granted for use with - conforming SGML systems and applications as defined in - ISO 8879, provided this notice is included in all copies. ---> -<!-- Character entity set. Typical invocation: - <!ENTITY % HTMLlat1 PUBLIC - "-//W3O//ENTITIES W3 Latin 1 for HTML//EN"> - %HTMLlat1; ---> -<!-- Modified for use in HTML - $Id: html-latin.sgml,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ = - ---> -<!-- Modified to add characters in the range &161; to &191; in - the ISO Latin-1 character set, which could only be referred = - - to by numeric references. Entity names based on relevant entities in - ISO 8879-1986//ENTITIES Numeric and Special Graphic//EN" - Also added the standard lt gt amp entities from HTML 2.0 - Chris Lilley, 13 March 1995 - = - - This covers all of Latin 1, but we are still unable to display a = - - Trade Mark (TM) ---> - -<!ENTITY AElig CDATA "Æ" -- capital AE diphthong (ligature) --> -<!ENTITY Aacute CDATA "Á" -- capital A, acute accent --> -<!ENTITY Acirc CDATA "Â" -- capital A, circumflex accent --> -<!ENTITY Agrave CDATA "À" -- capital A, grave accent --> -<!ENTITY Aring CDATA "Å" -- capital A, ring --> -<!ENTITY Atilde CDATA "Ã" -- capital A, tilde --> -<!ENTITY Auml CDATA "Ä" -- capital A, dieresis or umlaut mark --> -<!ENTITY Ccedil CDATA "Ç" -- capital C, cedilla --> -<!ENTITY ETH CDATA "Ð" -- capital Eth, Icelandic --> -<!ENTITY Eacute CDATA "É" -- capital E, acute accent --> -<!ENTITY Ecirc CDATA "Ê" -- capital E, circumflex accent --> -<!ENTITY Egrave CDATA "È" -- capital E, grave accent --> -<!ENTITY Euml CDATA "Ë" -- capital E, dieresis or umlaut mark --> -<!ENTITY Iacute CDATA "Í" -- capital I, acute accent --> -<!ENTITY Icirc CDATA "Î" -- capital I, circumflex accent --> -<!ENTITY Igrave CDATA "Ì" -- capital I, grave accent --> -<!ENTITY Iuml CDATA "Ï" -- capital I, dieresis or umlaut mark --> -<!ENTITY Ntilde CDATA "Ñ" -- capital N, tilde --> -<!ENTITY Oacute CDATA "Ó" -- capital O, acute accent --> -<!ENTITY Ocirc CDATA "Ô" -- capital O, circumflex accent --> -<!ENTITY Ograve CDATA "Ò" -- capital O, grave accent --> -<!ENTITY Oslash CDATA "Ø" -- capital O, slash --> -<!ENTITY Otilde CDATA "Õ" -- capital O, tilde --> -<!ENTITY Ouml CDATA "Ö" -- capital O, dieresis or umlaut mark --> -<!ENTITY THORN CDATA "Þ" -- capital THORN, Icelandic --> -<!ENTITY Uacute CDATA "Ú" -- capital U, acute accent --> -<!ENTITY Ucirc CDATA "Û" -- capital U, circumflex accent --> -<!ENTITY Ugrave CDATA "Ù" -- capital U, grave accent --> -<!ENTITY Uuml CDATA "Ü" -- capital U, dieresis or umlaut mark --> -<!ENTITY Yacute CDATA "Ý" -- capital Y, acute accent --> -<!ENTITY aacute CDATA "á" -- small a, acute accent --> -<!ENTITY acirc CDATA "â" -- small a, circumflex accent --> -<!ENTITY aelig CDATA "æ" -- small ae diphthong (ligature) --> -<!ENTITY agrave CDATA "à" -- small a, grave accent --> -<!ENTITY aring CDATA "å" -- small a, ring --> -<!ENTITY atilde CDATA "ã" -- small a, tilde --> -<!ENTITY auml CDATA "ä" -- small a, dieresis or umlaut mark --> -<!ENTITY ccedil CDATA "ç" -- small c, cedilla --> -<!ENTITY eacute CDATA "é" -- small e, acute accent --> -<!ENTITY ecirc CDATA "ê" -- small e, circumflex accent --> -<!ENTITY egrave CDATA "è" -- small e, grave accent --> -<!ENTITY eth CDATA "ð" -- small eth, Icelandic --> -<!ENTITY euml CDATA "ë" -- small e, dieresis or umlaut mark --> -<!ENTITY iacute CDATA "í" -- small i, acute accent --> -<!ENTITY icirc CDATA "î" -- small i, circumflex accent --> -<!ENTITY igrave CDATA "ì" -- small i, grave accent --> -<!ENTITY iuml CDATA "ï" -- small i, dieresis or umlaut mark --> -<!ENTITY ntilde CDATA "ñ" -- small n, tilde --> -<!ENTITY oacute CDATA "ó" -- small o, acute accent --> -<!ENTITY ocirc CDATA "ô" -- small o, circumflex accent --> -<!ENTITY ograve CDATA "ò" -- small o, grave accent --> -<!ENTITY oslash CDATA "ø" -- small o, slash --> -<!ENTITY otilde CDATA "õ" -- small o, tilde --> -<!ENTITY ouml CDATA "ö" -- small o, dieresis or umlaut mark --> -<!ENTITY szlig CDATA "ß" -- small sharp s, German (sz ligature) --> -<!ENTITY thorn CDATA "þ" -- small thorn, Icelandic --> -<!ENTITY uacute CDATA "ú" -- small u, acute accent --> -<!ENTITY ucirc CDATA "û" -- small u, circumflex accent --> -<!ENTITY ugrave CDATA "ù" -- small u, grave accent --> -<!ENTITY uuml CDATA "ü" -- small u, dieresis or umlaut mark --> -<!ENTITY yacute CDATA "ý" -- small y, acute accent --> -<!ENTITY yuml CDATA "ÿ" -- small y, dieresis or umlaut mark --> -<!-- = - - Ones that aren't accented characters, and so not in ISO Added Latin = -1. - - umlaut. macron, acute, cedilla - were not in ISO Numeric and Special Graphic - either; I took their names from the numeric entity list in - http://www.hpl.hp.co.uk/people/dsr/html/latin1.html = - - Chris Lilley, 13 March 1995 = - ---> - -<!ENTITY iexcl SDATA "=A1" --=3D inverted exclamation mark &161; --> -<!ENTITY cent SDATA "=A2" --=3D cent sign &162; --> -<!ENTITY pound SDATA "=A3" --=3D pound sterling sign &163; --> -<!ENTITY curren SDATA "=A4" --=3D general currency sign &164; --> -<!ENTITY yen SDATA "=A5" --=3D yen sign &165; --> -<!ENTITY brvbar SDATA "=A6" --=3D broken (vertical) bar &166; --> -<!ENTITY sect SDATA "=A7" --=3D section sign &167; --> -<!ENTITY umlaut SDATA "=A8" --=3D umlaut (dieresis) &168; --> -<!ENTITY copy SDATA "=A9" --=3D copyright sign &169; --> -<!ENTITY ordf SDATA "=AA" --=3D ordinal indicator, feminine &170; --> -<!ENTITY laquo SDATA "=AB" --=3D angle quotation mark, left &171; --> -<!ENTITY not SDATA "=AC" --=3D not sign &172; --> -<!ENTITY shy SDATA "=AD" --=3D soft hyphen &173;--> -<!ENTITY reg SDATA "=AE" --=3D registered trademark &174; --> -<!ENTITY macron SDATA "=AF" --=3D macron &175; --> -<!ENTITY deg SDATA "=B0" --=3D degree sign &176; --> -<!ENTITY plusmn SDATA "=B1" --=3D plus-or-minus sign &177; --> -<!ENTITY sup2 SDATA "=B2" --=3D superscript two &178; --> -<!ENTITY sup3 SDATA "=B3" --=3D superscript three &179; --> -<!ENTITY acute SDATA "=B4" --=3D acute accent &180; --> -<!ENTITY micro SDATA "=B5" --=3D micro sign &181; --> -<!ENTITY para SDATA "=B6" --=3D pilcrow (paragraph sign) &182; --> -<!ENTITY middot SDATA "=B7" --=3D middle dot (centred decimal point) &183; --> -<!ENTITY cedilla SDATA "=B8" --=3D cedilla accent &184; --> -<!ENTITY sup1 SDATA "=B9" --=3D superscript one --> -<!ENTITY ordm SDATA "=BA" --=3D ordinal indicator, masculine --> -<!ENTITY raquo SDATA "=BB" --=3D angle quotation mark, right --> -<!ENTITY frac14 SDATA "=BC" --=3D fraction one-quarter --> -<!ENTITY frac12 SDATA "=BD" --=3D fraction one-half --> -<!ENTITY frac34 SDATA "=BE" --=3D fraction three-quarters --> -<!ENTITY iquest SDATA "=BF" --=3D inverted question mark --> -<!-- the odd ones tucked in amongs the accented letters --> -<!ENTITY times SDATA "=D7" --=3D multiply sign --> -<!ENTITY divide SDATA "=F7" --=3D divide sign --> - -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> - -<!-- - Should the dollar sign and such like also be given entity names? - There are suitable ones around. For example, people using = - - internationalised keyboards in various countries might not be = - - readily able to access some of these characters. - = - - On such grounds, I suggest entity names for these: - ! " # $ % ' ( ) * + , - . / : ; =3D ? [ \ ] ^ _ ` { | } ~ - Lastly, what about &tab; for those whose editors convert all - tabs to spaces? - --->
--- a/etc/sgml/html-math.sgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ - -<!-- all these entities copied from = - - ftp://ifi.uio.no/pub/SGML/ENTITIES/ISOgrk1 --> - -<!ENTITY agr SDATA "[agr ]"--small alpha, Greek--> -<!ENTITY Agr SDATA "[Agr ]"--capital Alpha, Greek--> -<!ENTITY bgr SDATA "[bgr ]"--small beta, Greek--> -<!ENTITY Bgr SDATA "[Bgr ]"--capital Beta, Greek--> -<!ENTITY ggr SDATA "[ggr ]"--small gamma, Greek--> -<!ENTITY Ggr SDATA "[Ggr ]"--capital Gamma, Greek--> -<!ENTITY dgr SDATA "[dgr ]"--small delta, Greek--> -<!ENTITY Dgr SDATA "[Dgr ]"--capital Delta, Greek--> -<!ENTITY egr SDATA "[egr ]"--small epsilon, Greek--> -<!ENTITY Egr SDATA "[Egr ]"--capital Epsilon, Greek--> -<!ENTITY zgr SDATA "[zgr ]"--small zeta, Greek--> -<!ENTITY Zgr SDATA "[Zgr ]"--capital Zeta, Greek--> -<!ENTITY eegr SDATA "[eegr ]"--small eta, Greek--> -<!ENTITY EEgr SDATA "[EEgr ]"--capital Eta, Greek--> -<!ENTITY thgr SDATA "[thgr ]"--small theta, Greek--> -<!ENTITY THgr SDATA "[THgr ]"--capital Theta, Greek--> -<!ENTITY igr SDATA "[igr ]"--small iota, Greek--> -<!ENTITY Igr SDATA "[Igr ]"--capital Iota, Greek--> -<!ENTITY kgr SDATA "[kgr ]"--small kappa, Greek--> -<!ENTITY Kgr SDATA "[Kgr ]"--capital Kappa, Greek--> -<!ENTITY lgr SDATA "[lgr ]"--small lambda, Greek--> -<!ENTITY Lgr SDATA "[Lgr ]"--capital Lambda, Greek--> -<!ENTITY mgr SDATA "[mgr ]"--small mu, Greek--> -<!ENTITY Mgr SDATA "[Mgr ]"--capital Mu, Greek--> -<!ENTITY ngr SDATA "[ngr ]"--small nu, Greek--> -<!ENTITY Ngr SDATA "[Ngr ]"--capital Nu, Greek--> -<!ENTITY xgr SDATA "[xgr ]"--small xi, Greek--> -<!ENTITY Xgr SDATA "[Xgr ]"--capital Xi, Greek--> -<!ENTITY ogr SDATA "[ogr ]"--small omicron, Greek--> -<!ENTITY Ogr SDATA "[Ogr ]"--capital Omicron, Greek--> -<!ENTITY pgr SDATA "[pgr ]"--small pi, Greek--> -<!ENTITY Pgr SDATA "[Pgr ]"--capital Pi, Greek--> -<!ENTITY rgr SDATA "[rgr ]"--small rho, Greek--> -<!ENTITY Rgr SDATA "[Rgr ]"--capital Rho, Greek--> -<!ENTITY sgr SDATA "[sgr ]"--small sigma, Greek--> -<!ENTITY Sgr SDATA "[Sgr ]"--capital Sigma, Greek--> -<!ENTITY sfgr SDATA "[sfgr ]"--final small sigma, Greek--> -<!ENTITY tgr SDATA "[tgr ]"--small tau, Greek--> -<!ENTITY Tgr SDATA "[Tgr ]"--capital Tau, Greek--> -<!ENTITY ugr SDATA "[ugr ]"--small upsilon, Greek--> -<!ENTITY Ugr SDATA "[Ugr ]"--capital Upsilon, Greek--> -<!ENTITY phgr SDATA "[phgr ]"--small phi, Greek--> -<!ENTITY PHgr SDATA "[PHgr ]"--capital Phi, Greek--> -<!ENTITY khgr SDATA "[khgr ]"--small chi, Greek--> -<!ENTITY KHgr SDATA "[KHgr ]"--capital Chi, Greek--> -<!ENTITY psgr SDATA "[psgr ]"--small psi, Greek--> -<!ENTITY PSgr SDATA "[PSgr ]"--capital Psi, Greek--> -<!ENTITY ohgr SDATA "[ohgr ]"--small omega, Greek--> -<!ENTITY OHgr SDATA "[OHgr ]"--capital Omega, Greek--> -
--- a/etc/sgml/html-mcom.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,494 +0,0 @@ -<!-- html-mcom.dtd - - Document Type Definition for the HyperText Markup Language (HTML DTD) - with Netscape Communications Corp Extensions - - $Id: html-mcom.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@w3.org> - See Also: html.decl, ISOlat1.sgml - http://home.netscape.com/assist/net_sites/html_extensions.html - http://www.halsoft.com/sgml/Mozilla/DTD-HOME.html - http://www.hpl.hp.co.uk/people/dsr/html3/Contents.html - - Table addtions by: Mark Gaither (markg@hal.com) 26 Jun 95 ---> - -<!ENTITY % HTML.Version - "-//Netscape Comm. Corp.//DTD HTML//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//Netscape Comm. Corp.//DTD HTML//EN"> - <html> - ... - </html> - -- - > - - -<!--================== Feature Test Entities ==============================--> - -<!ENTITY % HTML.Recommended "IGNORE" - -- Certain features of the language are necessary for compatibility - with widespread usage, but they may compromise the structural - integrity of a document. This feature test entity enables - a more prescriptive document type definition that eliminates - the above features. - --> - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE" - -- Certain features of the language are necessary for compatibility - with earlier versions of the specification, but they tend - to be used an implemented inconsistently, and their use is - deprecated. This feature test entity enables a document type - definition that eliminates these features. - --> - -<!ENTITY % HTML.Highlighting "INCLUDE"> -<!ENTITY % HTML.Forms "INCLUDE"> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URI "CDATA" - -- The term URI means a CDATA attribute - whose value is a Uniform Resource Identifier, - as defined by - "Universal Resource Identifiers" by Tim Berners-Lee - aka http://info.cern.ch/hypertext/WWW/Addressing/URL/URI_Overview.html - aka RFC 1630 - - Note that CDATA attributes are limited by the LITLEN - capacity (1024 in the current version of html.decl), - so that URIs in HTML have a bounded length. - - --> - - -<!-- DTD "macros" --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list " UL | OL | DIR | MENU " > - - -<!--================ Character mnemonic entities ==========================--> - -<!ENTITY % ISOlat1 PUBLIC - "-//IETF//ENTITIES Added Latin 1 for HTML//EN"> -%ISOlat1; - -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> - -<!ENTITY reg CDATA "®" -- registered trademark --> -<!ENTITY copy CDATA "©" -- copyright --> - -<!--=================== Text Markup =======================================--> - -<![ %HTML.Highlighting [ - -<!ENTITY % font " TT | B | I | FONT"> - -<!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE | BLINK"> - -<!ENTITY % text "#PCDATA | A | IMG | BR | WBR | NOBR | BASEFONT - | %phrase | %font"> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR | %font | %phrase"> - -<!ELEMENT (%font;|%phrase) - - (%text)+> - -<!ELEMENT basefont - - ANY> - -<!ATTLIST (font|basefont) - SIZE CDATA #REQUIRED -- should be NUTOKEN, using size=plus3, --> -]]> - -<!ENTITY % text "#PCDATA | A | IMG | BR | WBR | NOBR | CENTER"> - -<!ELEMENT BR - O EMPTY> -<!ATTLIST BR - CLEAR (left|right|all) #IMPLIED> - -<!ELEMENT NOBR - - (%text)+> -<!ELEMENT WBR - O EMPTY> - -<!--================== Link Markup ========================================--> - -<![ %HTML.Recommended [ - <!ENTITY % linkName "ID"> -]]> - -<!ENTITY % linkName "CDATA"> - -<!ENTITY % linkType "NAME" - -- a list of these will be specified at a later date --> - -<!ENTITY % linkExtraAttributes - "REL %linkType #IMPLIED -- forward relationship type -- - REV %linkType #IMPLIED -- reversed relationship type - to referent data -- - URN CDATA #IMPLIED -- universal resource number -- - - TITLE CDATA #IMPLIED -- advisory only -- - METHODS NAMES #IMPLIED -- supported public methods of the object: - TEXTSEARCH, GET, HEAD, ... -- - "> - -<![ %HTML.Recommended [ - <!ENTITY % A.content "(%text)+" - -- <H1><a name="xxx">Heading</a></H1> - is preferred to - <a name="xxx"><H1>Heading</H1></a> - --> -]]> - -<!ENTITY % A.content "(%heading|%text)+"> - -<!ELEMENT A - - %A.content -(A)> - -<!ATTLIST A - HREF %URI #IMPLIED - NAME %linkName #IMPLIED - %linkExtraAttributes; - > - -<!--=================== Images ============================================--> - -<!ENTITY % img.alt.default "#IMPLIED" - -- ALT attribute required in Level 0 docs --> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - SRC %URI; #REQUIRED -- URI of document to embed -- - LOWSRC %URI; #IMPLIED -- low resolution images spec -- - ALT CDATA %img.alt.default; - ALIGN (left|right|center|top|texttop|middle| - absmiddle|baseline|bottom|absbottom) baseline - WIDTH CDATA #IMPLIED - HEIGHT NUMBER #IMPLIED - BORDER NUMBER #IMPLIED - VSPACE NUMBER #IMPLIED - HSPACE NUMBER #IMPLIED - ISMAP (ISMAP) #IMPLIED - > - - -<!--=================== Paragraphs=========================================--> - -<!ENTITY % attrs -- common attributes for elements -- - 'id ID #IMPLIED -- as target for hrefs (link ends) -- - lang CDATA "en.us" -- ISO language, country code -- - class NAMES #IMPLIED -- for subclassing elements --'> - -<!ENTITY % needs -- Attributes for controlling text flow. Used in headers - and other elements to guarantee sufficient room -- - 'clear CDATA "no" -- (left|right|all|no) move down past figures -- - needs CDATA #IMPLIED -- minimum width needed in em"s or pixels -- - -- e.g. "40 em" or "100 pixels" --'> - -<!ELEMENT P - O (%text)+> -<!ATTLIST P - %attrs; - align (left|center|right|justify) #IMPLIED - %needs; -- for control of text flow -- - nowrap (nowrap) #IMPLIED -- disable wordwrap -- - > - -<!--=================== Headings, Titles, Sections ========================--> - -<!ELEMENT HR - O EMPTY -- horizontal rule --> -<!ATTLIST HR - SIZE NUMBER #IMPLIED - WIDTH CDATA #IMPLIED - ALIGN (left|right|center) #IMPLIED - NOSHADE (NOSHADE) #IMPLIED> - -<!ELEMENT ( %heading ) - - (%text;)+> -<!ATTLIST ( %heading ) - %attrs; - align (left|center|right|justify) #IMPLIED - %needs; -- for control of text flow -- - > - - -<!ELEMENT TITLE - - (#PCDATA) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> - - -<!--=================== Text Flows ========================================--> - -<![ %HTML.Forms [ - <!ENTITY % block.forms "FORM | TABLE | ISINDEX"> -]]> - -<!ENTITY % block.forms ""> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<!ENTITY % block "P | %list | DL - | %preformatted - | BLOCKQUOTE | CENTER | %block.forms"> - -<!ENTITY % flow "(%text|%block)*"> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR"> -<!ELEMENT PRE - - (%pre.content)+> - -<!ATTLIST PRE - WIDTH NUMBER #implied - > - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- special non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT XMP - - %literal> -<!ELEMENT LISTING - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -]]> - - -<!--=================== Lists =============================================--> - -<!ELEMENT DL - - (DT*, DD?)+> -<!ATTLIST DL - COMPACT (COMPACT) #IMPLIED> - -<!ELEMENT DT - O (%text)+> -<!ELEMENT DD - O %flow> - -<!ELEMENT (OL|UL) - - (LI)+> -<!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> -<!ATTLIST (UL) - COMPACT (COMPACT) #IMPLIED - TYPE CDATA #IMPLIED - > -<!ATTLIST (OL) - START NUMBER #IMPLIED - COMPACT (COMPACT) #IMPLIED - TYPE CDATA "1" - > - -<!ELEMENT LI - O %flow> -<!ATTLIST LI - TYPE CDATA #IMPLIED - VALUE CDATA #implied> - -<!--=================== Document Body =====================================--> - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(%heading|%block|HR|ADDRESS)*" - -- <h1>Heading</h1> - <p>Text ... - is preferred to - <h1>Heading</h1> - Text ... - --> -]]> - -<!ENTITY % body.content "(%heading | %text | %block | HR | ADDRESS)*"> - -<!ELEMENT BODY O O %body.content> -<!ATTLIST BODY - BACKGROUND %URI; #IMPLIED - BGCOLOR CDATA #IMPLIED - TEXT CDATA #IMPLIED - LINK CDATA #IMPLIED - VLINK CDATA #IMPLIED - ALINK CDATA #IMPLIED - > - -<!ELEMENT BLOCKQUOTE - - %body.content> - -<!ELEMENT CENTER - - %body.content> - -<![ %HTML.Recommended [ - <!ENTITY % address.content "(%text)*"> -]]> -<!ENTITY % address.content "(%text|P)*"> -<!ELEMENT ADDRESS - - %address.content> - - -<!--================ Forms ===============================================--> - -<![ %HTML.Forms [ - -<!ELEMENT FORM - - %body.content -(FORM) +(INPUT|SELECT|TEXTAREA)> -<!ATTLIST FORM - ACTION %URI #REQUIRED - METHOD (%HTTP-Method) GET - ENCTYPE %Content-Type; "application/x-www-form-urlencoded" - > - -<!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | - RADIO | SUBMIT | RESET | - IMAGE | HIDDEN )"> -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - TYPE %InputType TEXT - NAME CDATA #IMPLIED -- required for all but submit and reset -- - VALUE CDATA #IMPLIED - SRC %URI #IMPLIED -- for image inputs -- - CHECKED (CHECKED) #IMPLIED - SIZE CDATA #IMPLIED -- like NUMBERS, - but delimited with comma, not space -- - MAXLENGTH NUMBER #IMPLIED - ALIGN (top|middle|bottom) #IMPLIED - > - -<!ELEMENT SELECT - - (OPTION+)> -<!ATTLIST SELECT - NAME CDATA #REQUIRED - SIZE NUMBER #IMPLIED - MULTIPLE (MULTIPLE) #IMPLIED - > - -<!ELEMENT OPTION - O (#PCDATA)> -<!ATTLIST OPTION - SELECTED (SELECTED) #IMPLIED - VALUE CDATA #IMPLIED - > - -<!ELEMENT TEXTAREA - - (#PCDATA)> -<!ATTLIST TEXTAREA - NAME CDATA #REQUIRED - ROWS NUMBER #REQUIRED - COLS NUMBER #REQUIRED - > - -]]> - - -<!--================ Document Head ========================================--> - -<!ENTITY % head.link "& LINK*"> - -<![ %HTML.Recommended [ - <!ENTITY % head.nextid ""> -]]> -<!ENTITY % head.nextid "& NEXTID?"> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE? & META* - %head.nextid - %head.link"> - -<!ELEMENT HEAD O O (%head.content)> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - HREF %URI #REQUIRED - %linkExtraAttributes; > - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - PROMPT CDATA "This is a searchable index. Enter search keywords:"> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - HREF %URI; #REQUIRED - > - -<!ELEMENT NEXTID - O EMPTY> -<!ATTLIST NEXTID N %linkName #REQUIRED> - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - HTTP-EQUIV NAME #IMPLIED -- HTTP response header name -- - NAME NAME #IMPLIED -- metainformation name -- - CONTENT CDATA #REQUIRED -- associated information -- - > - -<!--================ Tables ===================================--> - - -<!ENTITY % block.align - "align (bleedleft|left|center|right|bleedright|justify) center"> - -<!ELEMENT CAPTION - - (%text;)+ -- table or figure caption --> -<!ATTLIST CAPTION - %attrs; - align (top|bottom|left|right) #IMPLIED - > - -<!ELEMENT TABLE - - (CAPTION?, TR*) -- mixed headers and data --> -<!ATTLIST TABLE - %attrs; - %needs; -- for control of text flow -- - border NUMBER #IMPLIED -- draw borders -- - colspec CDATA #IMPLIED -- column widths and alignment -- - units (em|pixels|relative) em -- units for column widths -- - width CDATA #IMPLIED -- absolute or percentage width -- - %block.align; -- horizontal alignment -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - cellspacing NUMBER 2 -- insert space between cells -- - cellpadding NUMBER 1 -- pad between cell border and content -- - > - -<!ENTITY % cell "TH | TD"> -<!ENTITY % vertical.align "top|middle|bottom|baseline"> - -<!ELEMENT TR - O (%cell)* -- row container --> -<!ATTLIST TR - %attrs; - align (left|center|right|justify) #IMPLIED - valign (%vertical.align) top -- vertical alignment -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - > - -<!ELEMENT (%cell) - O %body.content> -<!ATTLIST (%cell) - %attrs; - colspan NUMBER 1 -- columns spanned -- - rowspan NUMBER 1 -- rows spanned -- - align (left|center|right|justify) #IMPLIED - valign (%vertical.align) top -- vertical alignment -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - width CDATA #IMPLIED -- allow width for cells -- - axis CDATA #IMPLIED -- axis name, defaults to element content -- - axes CDATA #IMPLIED -- comma separated list of axis names -- - > - - -<!--================ Document Structure ===================================--> - -<![ %HTML.Deprecated [ - <!ENTITY % html.content "HEAD, BODY, PLAINTEXT?"> -]]> -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ENTITY % version.attr "VERSION CDATA #FIXED "%HTML.Version;""> - -<!ATTLIST HTML - %version.attr;-- report DTD version to application -- - > - -
--- a/etc/sgml/html-mcoms.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -<!-- html-mcom.dtd - - Document Type Definition for the HyperText Markup Language (HTML DTD) - with Mosaic Communications Copr Extensions and with strict - validation (HTML Strict DTD). - - $Id: html-mcoms.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@w3.org> - See Also: html.decl, ISOlat1.sgml - http://home.netscape.com/assist/net_sites/html_extensions.html - http://www.halsoft.com/sgml/Mozilla/DTD-HOME.html - http://www.hpl.hp.co.uk/people/dsr/html3/Contents.html - - Table addtions by: Mark Gaither (markg@hal.com) 26 Jun 95 ---> - -<!ENTITY % HTML.Version - "-//Netscape Comm. Corp. Strict//DTD HTML//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//Netscape Comm. Corp. Strict//DTD HTML//EN"> - <html> - ... - </html> - -- - > - - -<!--================== Feature Test Entities ==============================--> - -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html PUBLIC "-//Netscape Comm. Corp.//DTD HTML//EN"> -%html;
--- a/etc/sgml/html-s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -<!-- html-P.dtd - - Document Type Definition for the HyperText Markup Language - with strict validation (HTML Strict DTD). - - $Id: html-s.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@hal.com> - See Also: http://www.hal.com/%7Econnolly/html-spec/index.html - http://info.cern.ch/hypertext/WWW/MarkUp2/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML Strict Level 2//EN//2.0" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//IETF//DTD HTML Strict//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html PUBLIC "-//IETF//DTD HTML Level 2//EN//2.0"> -%html;
--- a/etc/sgml/html.decl Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -<!SGML "ISO 8879:1986" --- - SGML Declaration for HyperText Markup Language (HTML) - as used by the World-Wide Web (WWW) application. - --- - -CHARSET - BASESET "ISO 646:1983//CHARSET - International Reference Version (IRV)//ESC 2/5 4/0" - DESCSET 0 9 UNUSED - 9 2 9 - 11 2 UNUSED - 13 1 13 - 14 18 UNUSED - 32 95 32 - 127 1 UNUSED - BASESET "ISO Registration Number 100//CHARSET - ECMA-94 Right Part of Latin Alphabet Nr. 1//ESC 2/13 4/1" - DESCSET 128 32 UNUSED - 160 96 UNUSED - -CAPACITY SGMLREF - TOTALCAP 150000 - GRPCAP 150000 - -SCOPE DOCUMENT -SYNTAX - SHUNCHAR CONTROLS 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 - 19 20 21 22 23 24 25 26 27 28 29 30 31 127 - BASESET "ISO 646:1983//CHARSET - International Reference Version (IRV)//ESC 2/5 4/0" - DESCSET 0 128 0 - FUNCTION - -- SPACE 32 - TAB SEPCHAR 9 - LF SEPCHAR 10 - FF SEPCHAR 12 - CR SEPCHAR 13 -- - - -- The above is an accurate description of the usage of FUNCTION -- - -- characters in HTML implementations; that is, there is no -- - -- Record Start or Record End character, and no occurences of -- - -- character 10 or 13 are "ignored" by the parser. -- - -- But because few SGML implementations support this concrete -- - -- sytax, we include the one below. -- - - -- Note that in order to get correct behaviour w.r.t. newline -- - -- processing, you will have to play some tricks in construcing -- - -- the document entity for parsing in order to keep the parser -- - -- from ignoring newlines in surpirsing ways -- - - RE 13 - RS 10 - SPACE 32 - TAB SEPCHAR 9 - - - NAMING LCNMSTRT "" - UCNMSTRT "" - LCNMCHAR ".-" - UCNMCHAR ".-" - NAMECASE GENERAL YES - ENTITY NO - DELIM GENERAL SGMLREF - SHORTREF SGMLREF - NAMES SGMLREF - QUANTITY SGMLREF - NAMELEN 72 -- somewhat arbitrary; taken from - internet line length conventions -- - TAGLVL 100 - LITLEN 1024 - GRPGTCNT 150 - GRPCNT 64 - -FEATURES - MINIMIZE - DATATAG NO - OMITTAG YES - RANK NO - SHORTTAG YES - LINK - SIMPLE NO - IMPLICIT NO - EXPLICIT NO - OTHER - CONCUR NO - SUBDOC NO - FORMAL YES - APPINFO NONE -> -<!-- - $Id: html.decl,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@hal.com> - - See also: http://www.hal.com/%7Econnolly/html-spec - http://info.cern.ch/hypertext/WWW/MarkUp/MarkUp.html - -->
--- a/etc/sgml/html.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,616 +0,0 @@ -<!-- html.dtd - - Document Type Definition for the HyperText Markup Language - (HTML DTD) - - $Id: html.dtd,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ - - Author: Daniel W. Connolly <connolly@w3.org> - See Also: html.decl, html-1.dtd - http://www.w3.org/hypertext/WWW/MarkUp/MarkUp.html -- --> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML 2.0//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> - <html> - ... - </html> - -- - > - - -<!--============ Feature Test Entities ========================--> - -<!ENTITY % HTML.Recommended "IGNORE" - -- Certain features of the language are necessary for - compatibility with widespread usage, but they may - compromise the structural integrity of a document. - This feature test entity enables a more prescriptive - document type definition that eliminates - those features. - --> - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE" - -- Certain features of the language are necessary for - compatibility with earlier versions of the specification, - but they tend to be used an implemented inconsistently, - and their use is deprecated. This feature test entity - enables a document type definition that eliminates - these features. - --> - -<!ENTITY % HTML.Highlighting "INCLUDE" - -- Use this feature test entity to validate that a - document uses no highlighting tags, which may be - ignored on minimal implementations. - --> - -<!ENTITY % HTML.Forms "INCLUDE" - -- Use this feature test entity to validate that a document - contains no forms, which may not be supported in minimal - implementations - --> - -<!--============== Imported Names ==============================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning an internet media type - (aka MIME content type, as per RFC1521) - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification, in progress - --> - -<!ENTITY % URI "CDATA" - -- The term URI means a CDATA attribute - whose value is a Uniform Resource Identifier, - as defined by - "Universal Resource Identifiers" by Tim Berners-Lee - aka RFC 1630 - - Note that CDATA attributes are limited by the LITLEN - capacity (1024 in the current version of html.decl), - so that URIs in HTML have a bounded length. - - --> - - -<!--========= DTD "Macros" =====================--> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list "UL|OL|DIR|MENU" > - - -<!--======= Character mnemonic entities =================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> - - -<!--========= SGML Document Access (SDA) Parameter Entities =====--> - -<!-- HTML 2.0 contains SGML Document Access (SDA) fixed attributes -in support of easy transformation to the International Committee -for Accessible Document Design (ICADD) DTD - "-//EC-USA-CDA/ICADD//DTD ICADD22//EN". -ICADD applications are designed to support usable access to -structured information by print-impaired individuals through -Braille, large print and voice synthesis. For more information on -SDA & ICADD: - - ISO 12083:1993, Annex A.8, Facilities for Braille, - large print and computer voice - - ICADD ListServ - <ICADD%ASUACAD.BITNET@ARIZVM1.ccit.arizona.edu> - - Usenet news group bit.listserv.easi - - Recording for the Blind, +1 800 221 4792 -- --> - -<!ENTITY % SDAFORM "SDAFORM CDATA #FIXED" - -- one to one mapping --> -<!ENTITY % SDARULE "SDARULE CDATA #FIXED" - -- context-sensitive mapping --> -<!ENTITY % SDAPREF "SDAPREF CDATA #FIXED" - -- generated text prefix --> -<!ENTITY % SDASUFF "SDASUFF CDATA #FIXED" - -- generated text suffix --> -<!ENTITY % SDASUSP "SDASUSP NAME #FIXED" - -- suspend transform process --> - - -<!--========== Text Markup =====================--> - -<![ %HTML.Highlighting [ - -<!ENTITY % font " TT | B | I "> - -<!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE "> - -<!ENTITY % text "#PCDATA | A | IMG | BR | %phrase | %font"> - -<!ELEMENT (%font;|%phrase) - - (%text)*> -<!ATTLIST ( TT | CODE | SAMP | KBD | VAR ) - %SDAFORM; "Lit" - > -<!ATTLIST ( B | STRONG ) - %SDAFORM; "B" - > -<!ATTLIST ( I | EM | CITE ) - %SDAFORM; "It" - > - -<!-- <TT> Typewriter text --> -<!-- <B> Bold text --> -<!-- <I> Italic text --> - -<!-- <EM> Emphasized phrase --> -<!-- <STRONG> Strong emphais --> -<!-- <CODE> Source code phrase --> -<!-- <SAMP> Sample text or characters --> -<!-- <KBD> Keyboard phrase, e.g. user input --> -<!-- <VAR> Variable phrase or substituable --> -<!-- <CITE> Name or title of cited work --> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR | %font | %phrase"> - -]]> - -<!ENTITY % text "#PCDATA | A | IMG | BR"> - -<!ELEMENT BR - O EMPTY> -<!ATTLIST BR - %SDAPREF; "&#RE;" - > - -<!-- <BR> Line break --> - - -<!--========= Link Markup ======================--> - -<!ENTITY % linkType "NAME"> - -<!ENTITY % linkExtraAttributes - "REL %linkType #IMPLIED - REV %linkType #IMPLIED - URN CDATA #IMPLIED - TITLE CDATA #IMPLIED - METHODS NAMES #IMPLIED - "> - -<![ %HTML.Recommended [ - <!ENTITY % A.content "(%text)*" - - -- <H1><a name="xxx">Heading</a></H1> - is preferred to - <a name="xxx"><H1>Heading</H1></a> - --> -]]> - -<!ENTITY % A.content "(%heading|%text)*"> - -<!ELEMENT A - - %A.content -(A)> -<!ATTLIST A - HREF %URI #IMPLIED - NAME CDATA #IMPLIED - %linkExtraAttributes; - %SDAPREF; "<Anchor: #AttList>" - > -<!-- <A> Anchor; source/destination of link --> -<!-- <A NAME="..."> Name of this anchor --> -<!-- <A HREF="..."> Address of link destination --> -<!-- <A URN="..."> Permanent address of destination --> -<!-- <A REL=...> Relationship to destination --> -<!-- <A REV=...> Relationship of destination to this --> -<!-- <A TITLE="..."> Title of destination (advisory) --> -<!-- <A METHODS="..."> Operations on destination (advisory) --> - - -<!--========== Images ==========================--> - -<!ELEMENT IMG - O EMPTY> -<!ATTLIST IMG - SRC %URI; #REQUIRED - ALT CDATA #IMPLIED - ALIGN (top|middle|bottom) #IMPLIED - ISMAP (ISMAP) #IMPLIED - %SDAPREF; "<Fig><?SDATrans Img: #AttList>#AttVal(Alt)</Fig>" - > - -<!-- <IMG> Image; icon, glyph or illustration --> -<!-- <IMG SRC="..."> Address of image object --> -<!-- <IMG ALT="..."> Textual alternative --> -<!-- <IMG ALIGN=...> Position relative to text --> -<!-- <IMG ISMAP> Each pixel can be a link --> - -<!--========== Paragraphs=======================--> - -<!ELEMENT P - O (%text)*> -<!ATTLIST P - %SDAFORM; "Para" - > - -<!-- <P> Paragraph --> - - -<!--========== Headings, Titles, Sections ===============--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - %SDAPREF; "&#RE;&#RE;" - > - -<!-- <HR> Horizontal rule --> - -<!ELEMENT ( %heading ) - - (%text;)*> -<!ATTLIST H1 - %SDAFORM; "H1" - > -<!ATTLIST H2 - %SDAFORM; "H2" - > -<!ATTLIST H3 - %SDAFORM; "H3" - > -<!ATTLIST H4 - %SDAFORM; "H4" - > -<!ATTLIST H5 - %SDAFORM; "H5" - > -<!ATTLIST H6 - %SDAFORM; "H6" - > - -<!-- <H1> Heading, level 1 --> -<!-- <H2> Heading, level 2 --> -<!-- <H3> Heading, level 3 --> -<!-- <H4> Heading, level 4 --> -<!-- <H5> Heading, level 5 --> -<!-- <H6> Heading, level 6 --> - - -<!--========== Text Flows ======================--> - -<![ %HTML.Forms [ - <!ENTITY % block.forms "BLOCKQUOTE | FORM | ISINDEX"> -]]> - -<!ENTITY % block.forms "BLOCKQUOTE"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<!ENTITY % block "P | %list | DL - | %preformatted - | %block.forms"> - -<!ENTITY % flow "(%text|%block)*"> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR"> - -<!ELEMENT PRE - - (%pre.content)*> -<!ATTLIST PRE - WIDTH NUMBER #implied - %SDAFORM; "Lit" - > - -<!-- <PRE> Preformatted text --> -<!-- <PRE WIDTH=...> Maximum characters per line --> - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ATTLIST XMP - %SDAFORM; "Lit" - %SDAPREF; "Example:&#RE;" - > -<!ATTLIST LISTING - %SDAFORM; "Lit" - %SDAPREF; "Listing:&#RE;" - > - -<!-- <XMP> Example section --> -<!-- <LISTING> Computer listing --> - -<!ELEMENT PLAINTEXT - O %literal> -<!-- <PLAINTEXT> Plain text passage --> - -<!ATTLIST PLAINTEXT - %SDAFORM; "Lit" - > -]]> - - -<!--========== Lists ==================--> - -<!ELEMENT DL - - (DT | DD)+> -<!ATTLIST DL - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "Definition List:" - > - -<!ELEMENT DT - O (%text)*> -<!ATTLIST DT - %SDAFORM; "Term" - > - -<!ELEMENT DD - O %flow> -<!ATTLIST DD - %SDAFORM; "LItem" - > - -<!-- <DL> Definition list, or glossary --> -<!-- <DL COMPACT> Compact style list --> -<!-- <DT> Term in definition list --> -<!-- <DD> Definition of term --> - -<!ELEMENT (OL|UL) - - (LI)+> -<!ATTLIST OL - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - > -<!ATTLIST UL - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - > -<!-- <UL> Unordered list --> -<!-- <UL COMPACT> Compact list style --> -<!-- <OL> Ordered, or numbered list --> -<!-- <OL COMPACT> Compact list style --> - - -<!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> -<!ATTLIST DIR - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "<LHead>Directory</LHead>" - > -<!ATTLIST MENU - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "<LHead>Menu</LHead>" - > - -<!-- <DIR> Directory list --> -<!-- <DIR COMPACT> Compact list style --> -<!-- <MENU> Menu list --> -<!-- <MENU COMPACT> Compact list style --> - -<!ELEMENT LI - O %flow> -<!ATTLIST LI - %SDAFORM; "LItem" - > - -<!-- <LI> List item --> - -<!--========== Document Body ===================--> - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(%heading|%block|HR|ADDRESS|IMG)*" - - -- <h1>Heading</h1> - <p>Text ... - is preferred to - <h1>Heading</h1> - Text ... - --> -]]> - -<!ENTITY % body.content "(%heading | %text | %block | - HR | ADDRESS)*"> - -<!ELEMENT BODY O O %body.content> - -<!-- <BODY> Document body --> - -<!ELEMENT BLOCKQUOTE - - %body.content> -<!ATTLIST BLOCKQUOTE - %SDAFORM; "BQ" - > - -<!-- <BLOCKQUOTE> Quoted passage --> - -<!ELEMENT ADDRESS - - (%text|P)*> -<!ATTLIST ADDRESS - %SDAFORM; "Lit" - %SDAPREF; "Address:&#RE;" - > - -<!-- <ADDRESS> Address, signature, or byline --> - - -<!--======= Forms ====================--> - -<![ %HTML.Forms [ - -<!ELEMENT FORM - - %body.content -(FORM) +(INPUT|SELECT|TEXTAREA)> -<!ATTLIST FORM - ACTION %URI #IMPLIED - METHOD (%HTTP-Method) GET - ENCTYPE %Content-Type; "application/x-www-form-urlencoded" - %SDAPREF; "<Para>Form:</Para>" - %SDASUFF; "<Para>Form End.</Para>" - > - -<!-- <FORM> Fill-out or data-entry form --> -<!-- <FORM ACTION="..."> Address for completed form --> -<!-- <FORM METHOD=...> Method of submitting form --> -<!-- <FORM ENCTYPE="..."> Representation of form data --> - -<!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | - RADIO | SUBMIT | RESET | - IMAGE | HIDDEN )"> -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - TYPE %InputType TEXT - NAME CDATA #IMPLIED - VALUE CDATA #IMPLIED - SRC %URI #IMPLIED - CHECKED (CHECKED) #IMPLIED - SIZE CDATA #IMPLIED - MAXLENGTH NUMBER #IMPLIED - ALIGN (top|middle|bottom) #IMPLIED - %SDAPREF; "Input: " - > - -<!-- <INPUT> Form input datum --> -<!-- <INPUT TYPE=...> Type of input interaction --> -<!-- <INPUT NAME=...> Name of form datum --> -<!-- <INPUT VALUE="..."> Default/initial/selected value --> -<!-- <INPUT SRC="..."> Address of image --> -<!-- <INPUT CHECKED> Initial state is "on" --> -<!-- <INPUT SIZE=...> Field size hint --> -<!-- <INPUT MAXLENGTH=...> Data length maximum --> -<!-- <INPUT ALIGN=...> Image alignment --> - -<!ELEMENT SELECT - - (OPTION+) -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST SELECT - NAME CDATA #REQUIRED - SIZE NUMBER #IMPLIED - MULTIPLE (MULTIPLE) #IMPLIED - %SDAFORM; "List" - %SDAPREF; - "<LHead>Select #AttVal(Multiple)</LHead>" - > - -<!-- <SELECT> Selection of option(s) --> -<!-- <SELECT NAME=...> Name of form datum --> -<!-- <SELECT SIZE=...> Options displayed at a time --> -<!-- <SELECT MULTIPLE> Multiple selections allowed --> - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - SELECTED (SELECTED) #IMPLIED - VALUE CDATA #IMPLIED - %SDAFORM; "LItem" - %SDAPREF; - "Option: #AttVal(Value) #AttVal(Selected)" - > - -<!-- <OPTION> A selection option --> -<!-- <OPTION SELECTED> Initial state --> -<!-- <OPTION VALUE="..."> Form datum value for this option--> - -<!ELEMENT TEXTAREA - - (#PCDATA)* -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST TEXTAREA - NAME CDATA #REQUIRED - ROWS NUMBER #REQUIRED - COLS NUMBER #REQUIRED - %SDAFORM; "Para" - %SDAPREF; "Input Text -- #AttVal(Name): " - > - -<!-- <TEXTAREA> An area for text input --> -<!-- <TEXTAREA NAME=...> Name of form datum --> -<!-- <TEXTAREA ROWS=...> Height of area --> -<!-- <TEXTAREA COLS=...> Width of area --> - -]]> - - -<!--======= Document Head ======================--> - -<![ %HTML.Recommended [ - <!ENTITY % head.extra ""> -]]> -<!ENTITY % head.extra "& NEXTID?"> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE? %head.extra"> - -<!ELEMENT HEAD O O (%head.content) +(META|LINK)> - -<!-- <HEAD> Document head --> - -<!ELEMENT TITLE - - (#PCDATA)*> -<!ATTLIST TITLE - %SDAFORM; "Ti" > - -<!-- <TITLE> Title of document --> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - HREF %URI #REQUIRED - %linkExtraAttributes; - %SDAPREF; "Linked to : #AttVal (TITLE) (URN) (HREF)>" > - -<!-- <LINK> Link from this document --> -<!-- <LINK HREF="..."> Address of link destination --> -<!-- <LINK URN="..."> Lasting name of destination --> -<!-- <LINK REL=...> Relationship to destination --> -<!-- <LINK REV=...> Relationship of destination to this --> -<!-- <LINK TITLE="..."> Title of destination (advisory) --> -<!-- <LINK METHODS="..."> Operations allowed (advisory) --> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - %SDAPREF; - "<Para>[Document is indexed/searchable.]</Para>"> - -<!-- <ISINDEX> Document is a searchable index --> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - HREF %URI; #REQUIRED > - -<!-- <BASE> Base context document --> -<!-- <BASE HREF="..."> Address for this document --> - -<!ELEMENT NEXTID - O EMPTY> -<!ATTLIST NEXTID - N CDATA #REQUIRED > - -<!-- <NEXTID> Next ID to use for link name --> -<!-- <NEXTID N=...> Next ID to use for link name --> - -<!ELEMENT META - O EMPTY> -<!ATTLIST META - HTTP-EQUIV NAME #IMPLIED - NAME NAME #IMPLIED - CONTENT CDATA #REQUIRED > - -<!-- <META> Generic Metainformation --> -<!-- <META HTTP-EQUIV=...> HTTP response header name --> -<!-- <META NAME=...> Metainformation name --> -<!-- <META CONTENT="..."> Associated information --> - -<!--======= Document Structure =================--> - -<![ %HTML.Deprecated [ - <!ENTITY % html.content "HEAD, BODY, PLAINTEXT?"> -]]> -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<!ATTLIST HTML - %version.attr; - %SDAFORM; "Book" - > - -<!-- <HTML> HTML Document -->
--- a/etc/sgml/htmlpro.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6093 +0,0 @@ -<!--<Title>htmlpro-- ---This is the HTML Professional Document Type Description (DTD)-- - > -<!ENTITY % head.any "(META | LINK | SCRIPT | STYLE | RANGE)*" - --<Title>Repeatable HEAD elements-- - > - -<!ENTITY % text "((#PCDATA) | TT | I | B | U | S | BIG | SMALL | SUB | - SUP | EM | STRONG | DFN | CODE | SAMP | KBD | VAR | CITE | - Q | A | LANG | AU | AUTHOR | FONT | PERSON | ACRONYM | - ABBREV | INS | DEL | STYLE | SPAN | ENTITY | ELEMENT | - ATTRIB | STRIKE | COMMENT | BLINK | MATH | BLACKFACE | - LIMITTEXT | NOSMARTQUOTES | SHADOW)*" - --<Title>textual, descriptive, or analytical elements-- - > - -<!ENTITY % insertions "(BASEFONT | APP | APPLET | OBJECT | EMBED | - SCRIPT | MARQUEE | HR | ISINDEX | BGSOUND | TAB | IMG | - IMAGE | BR | NOEMBED | MAP | SERVER | SPACER | AUDIOSCOPE | - SIDEBAR)*" - --<Title>things which are not part of the running text-- - > - -<!ENTITY % structure "(DIV | CENTER | H1 | H2 | H3 | H4 | H5 | H6 | P | - UL | OL | DL | DIR | MENU | PRE | XMP | LISTING | BQ | - MULTICOL | NOBR | BLOCKQUOTE | FORM | TABLE | ADDRESS | - FIG | BDO | NOTE | FN)+" --<Title>structural elements-- > - -<!ENTITY % formula "((#PCDATA) | BOX | ABOVE | BELOW | VEC | BAR | DOT | - DDOT | HAT | TILDE | ROOT | SQRT | ARRAY | SUB | SUP | B | - I | T | BT)+" --<Title>mathematical formulae-- > - -<!ELEMENT XTML O O (HTML*) - --<Title>(P)EXPERIMENTAL Container used only for database (corpus) storage when there needs to be more than one HTML document in the file-- - > - -<!ELEMENT HTML - O ((HEAD , (BODY | (FRAMESET+ , NOFRAMES))) | - PLAINTEXT) - --<Title>(H1)COMPULSORY The HTML overall container-- - > - -<!ELEMENT HEAD - - ((%head.any;) , ((TITLE , (%head.any;)) & (BASE , - (%head.any;))? & (ISINDEX , (%head.any;))? & (NEXTID , - (%head.any;))? & (NOSCRIPT , (%head.any;))? & (BGSOUND , - (%head.any;))?)) - --<Title>(H1)COMPULSORY Documentation header-- - > - -<!ELEMENT TITLE - - (#PCDATA) - --<Title>(H1)COMPULSORY document title-- - > - -<!ELEMENT ISINDEX - O EMPTY - --<Title>(H1)This file is a script which accepts a single input-- - > - -<!ELEMENT BASE - O EMPTY - --<Title>(H2)Specifies home base URL-- - > - -<!ELEMENT META - O EMPTY - --<Title>(H2)Generic metainformation-- - > - -<!ELEMENT LINK - O EMPTY - --<Title>(H2)Link to another resource on the network-- - > - -<!ELEMENT NEXTID - O EMPTY - --<Title>(H1)OBSOLETE editor control value-- - > - -<!ELEMENT BGSOUND - O (#PCDATA) - --<Title>(M)SOLITAIRE Background sound-- - > - -<!ELEMENT SCRIPT - - CDATA - --<Title>(N)Script language statements-- - > - -<!ELEMENT NOSCRIPT - - (%text;)+ - --<Title>(N)Text to display when SCRIPTs are disabled or unimplemented-- - > - -<!ELEMENT STYLE - - CDATA - --<Title>(H3)Stylesheet information-- - > - -<!ELEMENT RANGE - O EMPTY - --<Title>(H3)Identifies arbitrary range of text from SPOT to SPOT-- - > - -<!ELEMENT FRAMESET - - (FRAME* | FRAMESET+) - --<Title>(N)Set of FRAME elements-- - > - -<!ELEMENT FRAME - O EMPTY - --<Title>(N)Display external HTML object in separate frame-- - > - -<!ELEMENT NOFRAMES - - (BODY) - --<Title>(N)Alternative body for non-FRAMEing browsers-- - > - -<!ELEMENT BODY O O (BANNER? , BODYTEXT) +(SPOT) - --<Title>(H1)Text body of the document-- - > - -<!ELEMENT BANNER - - ((%structure;) | (%insertions;) | (%text;))+ - --<Title>(H3)Static (non-scrolling) banner-- - > - -<!ELEMENT BODYTEXT O O ((%structure;) | (%insertions;))+ - --<Title>(H3)Used only when distinguishing BANNER from remainder of BODY-- - > - -<!ELEMENT BDO - - ((%text;)+ | (%insertions;)*)+ - --<Title>(I) BiDirectional Override-- - > - -<!ELEMENT DIV - - ((%structure;)+ | (%insertions;)* | (%text;)*)+ - --<Title>(H3)Unspecified structural division-- - > - -<!ELEMENT H1 - - ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Heading level 1-- > - -<!ELEMENT H2 - - ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Heading level 2-- > - -<!ELEMENT H3 - - ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Heading level 3-- > - -<!ELEMENT H4 - - ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Heading level 4-- > - -<!ELEMENT H5 - - ((%text;)+ | (%insertions;)*)+ --<Title>(H5)Heading level 5-- > - -<!ELEMENT H6 - - ((%text;)+ | (%insertions;)*)+ --<Title>(H6)Heading level 6-- > - -<!ELEMENT P - O ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Paragraph-- > - -<!ELEMENT MULTICOL - - (%structure;)+ - --<Title>(N)Enclose multicolumn material-- - > - -<!ELEMENT NOBR - - (%text;)+ +(WBR , APPLET , EMBED , OBJECT , IMG , - IMAGE) - --<Title>(N)Prohibit break within this line-- - > - -<!ELEMENT WBR - O EMPTY - --<Title>(N)Discretionary linebreak between words within NOBR-- - > - -<!ELEMENT PRE - - (%text;)+ -(BR , TT) +(HR , APPLET , EMBED , OBJECT , - IMG , IMAGE) - --<Title>(H3)Preformatted text for fixed-width display-- - > - -<!ELEMENT BLOCKQUOTE - - (BODYTEXT , CREDIT?) --<Title>(H1)Block quotation-- > - -<!ELEMENT BQ - - (BODYTEXT , CREDIT?) - --<Title>(H3)Alternative block quotation-- - > - -<!ELEMENT DL - - (DT | DD | HR)* --<Title>(H1)Definition list-- > - -<!ELEMENT DT - O ((%text;)+ | (%insertions;)*)+ - --<Title>(H1)Definition term in a DL-- - > - -<!ELEMENT DD - O ((%structure;)+ | (%insertions;)* | (%text;)+)? - --<Title>(H1)Definition description in a DL-- - > - -<!ELEMENT OL - - (LI* | HR? | LH?)+ --<Title>(H1)Ordered list-- > - -<!ELEMENT UL - - (LI* | HR? | LH?)+ --<Title>(H1)Unordered list-- > - -<!ELEMENT DIR - - ((#PCDATA) | (LH? , LI*)+) -(P , UL , OL , DIR , MENU , - PRE , XMP , LISTING , DL , DIV , CENTER , BQ , FORM , - TABLE , FIELDSET) - --<Title>(H1)Directory listing, (T) also allows #pcdata-- - > - -<!ELEMENT MENU - - (LH? , LI*) -(P , UL , OL , DIR , MENU , PRE , XMP , - LISTING , DL , DIV , CENTER , BQ , FORM , TABLE , - FIELDSET) --<Title>(H1)Menu listing-- > - -<!ELEMENT LH - - ((%text;)+ | (%insertions;)*)+ --<Title>(H3)List header-- > - -<!ELEMENT LI - O ((%insertions;)* | (%text;)+ | P | UL | OL | DL | DIR | - MENU | PRE | XMP | LISTING | BLOCKQUOTE | BQ | FORM | - TABLE | ADDRESS)+ --<Title>(H1)Item in a list-- > - -<!ELEMENT ADDRESS - - ((%text;)+ | (%insertions;)*)+ +(P) --<Title>(H1)Address blocks-- > - -<!ELEMENT FN - - ((%structure;)+ | (%insertions;)* | (%text;)+)? - --<Title>(H3)Footnotes (T)WARNING: idiosyncratic implementation-- - > - -<!ELEMENT NOTE - - ((%structure;)+ | (%insertions;)* | (%text;)+)? --<Title>(H3)Notes-- > - -<!ELEMENT SIDEBAR - - ((%structure;)+ | (%insertions;)* | (%text;)+)? - --<Title>(T) non-scrolling sidebar on-screen-- - > - -<!ELEMENT BLINK - - ((%text;)+ | (%insertions;)*)+ - --<Title>(N)DEPRECATED Flashing text, deprecated for medical reasons-- - > - -<!ELEMENT CENTER - - ((%structure;)+ | (%insertions;)* | (%text;)*)+ - --<Title>(N)SUPERFLUOUS Centered material, use DIV with ALIGN="CENTER"-- - > - -<!ELEMENT HR - O EMPTY --<Title>(H1)Horizontal rule-- > - -<!ELEMENT BR - O EMPTY --<Title>(H2)Forced line break-- > - -<!ELEMENT BASEFONT - O EMPTY - --<Title>(M)Change (specify) the base font from here on-- - > - -<!ELEMENT MARQUEE - O (%text;)+ - --<Title>(M)Marching display text-- - > - -<!ELEMENT SERVER - - CDATA - --<Title>(N)Contains a LiveWire script-- - > - -<!ELEMENT SPACER - O EMPTY - --<Title>(N)Governs concrete spacing-- - > - -<!ELEMENT IMG - O (#PCDATA) - --<Title>(A)Inline image (IMAGE is a Netscapism, and STRONGLY deprecated)-- - > - -<!ELEMENT IMAGE - O (#PCDATA) --<Title>IMAGE-- > - -<!ELEMENT AUDIOSCOPE - O EMPTY - --<Title>(T)Displays realtime animated image of a playing sound-- - > - -<!ELEMENT MAP - - (AREA*) - --<Title>(N)Mapping spec for clientside imagemaps-- - > - -<!ELEMENT AREA - O EMPTY - --<Title>(N)Mapping area within a MAP-- - > - -<!ELEMENT OBJECT - - (param+ | (%structure;)+ | (%insertions;)* | - (%text;)*)* - --<Title>(W?)External object for insertion-- - > - -<!ELEMENT EMBED - - (param* , CAPTION? , EMBED.BODY , CREDIT?) - --<Title>(N)Embedded plugin applet-- - > - -<!ELEMENT EMBED.BODY O O ((%insertions;)* | (%text;)*)+ -(A) --<Title>(O) Object-- > - -<!ELEMENT NOEMBED - - ((%text;)+ | (%insertions;)*)+ - --<Title>(N)Alternative text for EMBED-unable browsers-- - > - -<!ELEMENT APP - - (param* , TEXTFLOW) - --<Title>(S)Embedded application-- - > - -<!ELEMENT APPLET - - (param* , TEXTFLOW) --<Title>APPLET-- > - -<!ELEMENT param - O EMPTY - --<Title>(S)Named property value to pass to OBJECT or APPLET-- - > - -<!ELEMENT FORM - - ((%structure;)+ | (%insertions;)* | (%text;)*)+ -( - FORM) +(INPUT , SELECT , TEXTAREA , LABEL , FIELDSET , - KEYGEN) --<Title>(H2)Fill-in form-- > - -<!ELEMENT LABEL - - ((%text;)+ | (%insertions;)*)+ -(LABEL) --<Title>(?)Field label text-- > - -<!ELEMENT FIELDSET - - (CAPTION? , ((%structure;)+ | (%insertions;)*)?) -( - FIELDSET) - --<Title>(?)Encloses a set of form fields-- - > - -<!ELEMENT INPUT - O CDATA --<Title>(H2)Single-line input-- > - -<!ELEMENT SELECT - - (OPTION+) - --<Title>(H2)Encloses multi-option form menu-- - > - -<!ELEMENT OPTION - O (#PCDATA) - --<Title>(H2)Options in a form menu-- - > - -<!ELEMENT TEXTAREA - - (#PCDATA) - --<Title>(H2)Freetext input area-- - > - -<!ELEMENT KEYGEN - O EMPTY - --<Title>(N)Generates and submits PublicKey encryption-- - > - -<!ELEMENT TABLE - - (CAPTION? , (col* | colgroup*) , thead? , tfoot? , ( - tbody | tr*)+) --<Title>(H3)Table-- > - -<!ELEMENT CAPTION - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Caption to a TABLE or FIGURE-- - > - -<!ELEMENT colgroup - O (col*) - --<Title>(H3)Group of column specifications-- - > - -<!ELEMENT col - O EMPTY - --<Title>(H3)Column specification in a COLGROUP-- - > - -<!ELEMENT thead - O (tr+) --<Title>(H3)Table header-- > - -<!ELEMENT tfoot - O (tr+) - --<Title>(H3)Table footer: if used, must precede table body-- - > - -<!ELEMENT tbody O O (tr+) - --<Title>(H3)Table body, implied for all tables but optional-- - > - -<!ELEMENT tr - O (th* | td*)+ --<Title>(H3)Table row-- > - -<!ELEMENT th - O ((%structure;)+ | (%insertions;)* | (%text;)+)+ - --<Title>(H3)Table headings and data (cells)-- - > - -<!ELEMENT td - O ((%structure;)+ | (%insertions;)* | (%text;)+)+ --<Title>td-- > - -<!ELEMENT FIG - - (CAPTION? , CREDIT? , OVERLAY* , (IMG | IMAGE | - FIGTEXT)+ , CAPTION? , CREDIT?) -(FIG) --<Title>(H3)Floating figure-- > - -<!ELEMENT OVERLAY - O (#PCDATA) --<Title>(H3)Image overlay-- > - -<!ELEMENT CREDIT - - ((%text;)+ | (%insertions;)*)+ --<Title>(H3)source of image-- > - -<!ELEMENT FIGTEXT - O ((%structure;) | (%insertions;))+ - --<Title>(H3)Container for textual figures-- - > - -<!ELEMENT A - - ((%insertions;)* | (%text;)*)+ -(A) - --<Title>(H1)Hypertext anchor (link)-- - > - -<!ELEMENT AUTHOR - - ((%text;)+ | (%insertions;)*)+ - --<Title>(L)Author of a CITEd document-- - > - -<!ELEMENT CITE - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H1)Citation (book title, product name, etc)-- - > - -<!ELEMENT DFN - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Definition (index term)-- - > - -<!ELEMENT U - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H2)Underlining where possible; WebTV wrongly does a UL here-- - > - -<!ELEMENT S - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Stricken text, reason unspecified-- - > - -<!ELEMENT STRIKE - - ((%text;)+ | (%insertions;)*)+ - --<Title>(N)Alternative form of S-- - > - -<!ELEMENT BIG - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Larger type than the current size-- - > - -<!ELEMENT SMALL - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Smaller type than the current size-- - > - -<!ELEMENT SUB - - (%text;)+ +(VEC , BAR , DOT , DDOT , HAT , TILDE , T , - BT , BOX , ABOVE , ROOT , SQRT , ARRAY) --<Title>(H3)Subscript-- > - -<!ELEMENT SUP - - (%text;)+ +(VEC , BAR , DOT , DDOT , HAT , TILDE , T , - BT , BOX , ABOVE , ROOT , SQRT , ARRAY) --<Title>(H3)Superscript-- > - -<!ELEMENT Q - - ((%text;)+ | (%insertions;)*)+ - --<Title>(3I)Direct speech: browsers should display `quotes' appropriately-- - > - -<!ELEMENT SPAN - - ((%text;)+ | (%insertions;)*)+ -(SPAN) - --<Title>(H3)Marks a text fragment for analytical reasons-- - > - -<!ELEMENT AU - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Author of a CITEd document-- - > - -<!ELEMENT PERSON - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Personal name for indexing-- - > - -<!ELEMENT ACRONYM - - ((%text;)+ | (%insertions;)*)+ --<Title>(H3)Acronym-- > - -<!ELEMENT ABBREV - - ((%text;)+ | (%insertions;)*)+ --<Title>(H3)Abbreviation-- > - -<!ELEMENT ENTITY - - CDATA - --<Title>(P)EXPERIMENTAL SGML entity-- - > - -<!ELEMENT ELEMENT - - CDATA - --<Title>(P)EXPERIMENTAL SGML element-- - > - -<!ELEMENT ATTRIB - - CDATA - --<Title>(P)EXPERIMENTAL SGML attribute-- - > - -<!ELEMENT EM - - ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Emphasis-- > - -<!ELEMENT I - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H2)Unspecified italics-- - > - -<!ELEMENT VAR - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H1)Program variable name, filename, etc-- - > - -<!ELEMENT LANG - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Language other than the base language of the document (eg eg :-)-- - > - -<!ELEMENT INS - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Text inserted at the last edit, or text inserted in the opinion of an editor-- - > - -<!ELEMENT DEL - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Text marked for deletion at the last edit, or text deleted by an editor but left on display for review-- - > - -<!ELEMENT CODE - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H1)Program or code fragment-- - > - -<!ELEMENT KBD - - CDATA - --<Title>(H1)Single keyboard character, keycap, or button-- - > - -<!ELEMENT SAMP - - ((%text;)+ | (%insertions;)*)+ - --<Title>(H1)Inline sample of computer input or response-- - > - -<!ELEMENT TT - - ((%text;)+ | (%insertions;)*)+ --<Title>(H2)Fixed-width type-- > - -<!ELEMENT B - - ((%text;)+ | (%insertions;)*)+ --<Title>(H2)Unspecified bold-- > - -<!ELEMENT STRONG - - ((%text;)+ | (%insertions;)*)+ --<Title>(H1)Strong emphasis-- > - -<!ELEMENT BLACKFACE - - ((%text;)+ | (%insertions;)*)+ - --<Title>(T)Unspecified extra-bold-- - > - -<!ELEMENT LIMITTEXT - O EMPTY - --<Title>(T) holds fixed-width text-- - > - -<!ELEMENT NOSMARTQUOTES - - ((%text;)+ | (%insertions;)*)+ - --<Title>(T) defeats "smart" quotes-- - > - -<!ELEMENT SHADOW - - ((%text;)+ | (%insertions;)*)+ - --<Title>(T) lights up shadow down and right of content text-- - > - -<!ELEMENT FONT - - ((%text;)+ | (%insertions;)*)+ - --<Title>(M)Make local change to font-- - > - -<!ELEMENT SPOT - O EMPTY - --<Title>(H3)Start or finish point of a RANGE-- - > - -<!ELEMENT TAB - O EMPTY - --<Title>(H3)Tab set and tab jump-to-- --was (#PCDATA)-- - > - -<!ELEMENT MATH - - (%text;)+ -(EM , STRONG , Q , BLINK) +(VEC , BAR , - DOT , DDOT , HAT , TILDE , T , BT , BOX , ABOVE , BELOW , - ROOT , SQRT , ARRAY , SUB , SUP , FONT) --<Title>(H3)Mathematics-- > - -<!ELEMENT BOX - - ((%formula;) , (LEFT , (%formula;))? , ((OVER | ATOP | - CHOOSE) , (%formula;))? , (RIGHT , (%formula;))?) - --<Title>(H3)Boxes for building fractions-- - > - -<!ELEMENT ABOVE - - (%formula;) --<Title>(H3)Numerator-- > - -<!ELEMENT BELOW - - (%formula;) --<Title>(H3)Denominator-- > - -<!ELEMENT OVER - O EMPTY - --<Title>(H3)Separates num from denom in fractions-- - > - -<!ELEMENT RIGHT - O EMPTY --<Title>(H3)Math RH barrier-- > - -<!ELEMENT CHOOSE - O EMPTY --<Title>(H3)Math choose array-- > - -<!ELEMENT ATOP - O EMPTY - --<Title>(H3)Separates top from bottom in unlined overposition-- - > - -<!ELEMENT LEFT - O EMPTY --<Title>(H3)Math LH barrier-- > - -<!ELEMENT ARRAY - - (ROW+) --<Title>(h3)LaTeX-like ARRAY-- > - -<!ELEMENT ROW - O (ITEM*) - --<Title>(H3)Row in a math array-- - > - -<!ELEMENT ITEM - O (%formula;) - --<Title>(H3)Math array row item-- - > - -<!ELEMENT T - - (%formula;) --<Title>(H3)Math typewriter-- > - -<!ELEMENT BT - - (%formula;) - --<Title>(H3)Math bold typewriter-- - > - -<!ELEMENT ROOT - - ((%formula;) , OF , (%formula;)) --<Title>(H3)Math root-- > - -<!ELEMENT OF - O EMPTY - --<Title>(H3)Dummy separator in ROOT-- - > - -<!ELEMENT SQRT - - (%formula;) - --<Title>(H3)Square root (convenience)-- - > - -<!ELEMENT TILDE - - (%formula;) - --<Title>(H3)Math accents: see TeX-- - > - -<!ELEMENT HAT - - (%formula;) --<Title>HAT-- > - -<!ELEMENT DOT - - (%formula;) --<Title>DOT-- > - -<!ELEMENT DDOT - - (%formula;) --<Title>DDOT-- > - -<!ELEMENT BAR - - (%formula;) --<Title>BAR-- > - -<!ELEMENT VEC - - (%formula;) --<Title>VEC-- > - -<!ELEMENT TEXTFLOW - O ((%text;)+ | (%insertions;)*)+ - --<Title>(H3)Dummy: accomodates mixed content model in APPLET caused by REs between PARAMs-- - > - -<!ELEMENT XMP - - CDATA - --<Title>(H1)OBSOLETE: example (of display code), superseded by PRE-- - > - -<!ELEMENT LISTING - - CDATA - --<Title>(H1)OBSOLETE: listing (lineprinter style), superseded by PRE-- - > - -<!ELEMENT PLAINTEXT - O ANY - --<Title>(H1)OBSOLETE: no further markup permitted, superseded by PRE-- - > - -<!ELEMENT COMMENT - - (#PCDATA) - --<Title>(M)SUPERFLUOUS: comment, use normal comment markup instead-- - > - -<!ATTLIST XTML - --<Title>html_p~1 - Attribute List-000-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST HTML - --<Title>html_p~1 - Attribute List-001-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - VERSION CDATA #FIXED - "+//Silmaril//DTD HTML Pro v0r11 19970101//EN" - - --<Title>DTD version-- - - VER CDATA #IMPLIED - --<Title>(?)Added by dumb editors which don't grok the DOCTYPE-- - - SDAFORM CDATA #FIXED "Book" - --<Title>SDAFORM-- - > - -<!ATTLIST HEAD - --<Title>html_p~1 - Attribute List-002-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST TITLE - --<Title>html_p~1 - Attribute List-003-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - SDAFORM CDATA #FIXED "Ti" - --<Title>SDAFORM-002-- - > - -<!ATTLIST ISINDEX - --<Title>html_p~1 - Attribute List-004-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - href CDATA #REQUIRED - --<Title>URL for a linked resource. Note some browsers have faulty syntax in omitting HREF-- - - action CDATA #REQUIRED - --<Title>URL for a server-side handler script-- - - prompt CDATA #IMPLIED - --<Title>Prompt message-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAPREF CDATA #FIXED - "<Para>[Document is a script accepting input.]</Para>" - - --<Title>SDAPREF-- - > - -<!ATTLIST BASE - --<Title>html_p~1 - Attribute List-005-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - href CDATA #REQUIRED - --<Title>URL of the document's home base-- - - target CDATA #IMPLIED - --<Title>(N) target window in framing environment-- - > - -<!ATTLIST META - --<Title>html_p~1 - Attribute List-006-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - http-equiv NAME #IMPLIED - --<Title>HTTP response header name (RFC1945)-- - - name NAME #IMPLIED - --<Title>Metainformation name (eg Dublin Core)-- - - content CDATA #REQUIRED - --<Title>Metainformation itself-- - > - -<!ATTLIST LINK - --<Title>html_p~1 - Attribute List-007-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - href CDATA #REQUIRED - --<Title>URL for linked resource-- - - target CDATA #IMPLIED - --<Title>(N) target window in framing environment-- - - rel CDATA #IMPLIED - --<Title>Forward link types (the HREF'd doc is these to this doc)-- - - rev CDATA #IMPLIED - --<Title>Reverse link types (this doc is these to the HREF'd doc)-- - - type CDATA #IMPLIED - --<Title>Advisory Internet media type-- - - urn CDATA #IMPLIED - --<Title>URN when available-- - - SDAPREF CDATA #FIXED - "Linked to: #AttVal (TITLE) (URN) (HREF)>" - - --<Title>SDAPREF-002-- - > - -<!ATTLIST NEXTID - --<Title>html_p~1 - Attribute List-008-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - N CDATA #REQUIRED - --<Title>Number to pass to editor-- - > - -<!ATTLIST BGSOUND - --<Title>html_p~1 - Attribute List-009-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - alt CDATA #IMPLIED - --<Title>For display in place of noise-- - - SRC CDATA #REQUIRED - --<Title>URL for sound file-- - - fileformat NOTATION (AU , WAV , SND) #IMPLIED - --<Title>Format of sound file if not implicit-- - - LOOP (loop) #IMPLIED - --<Title>Loop control information (was NMTOKEN #IMPLIED)-- - > - -<!ATTLIST SCRIPT - --<Title>html_p~1 - Attribute List-010-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - type CDATA #IMPLIED - --<Title>Internet media type for script language-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - event CDATA #IMPLIED - --<Title>(L) Undefined-- - - for CDATA #IMPLIED - --<Title>for-- - - name CDATA #IMPLIED - --<Title>name-- - - scriptengine CDATA #IMPLIED - --<Title>scriptengine-- - - language CDATA #IMPLIED - --<Title>Predefined script language name-- - - src CDATA #IMPLIED - --<Title>URL for an external script-- - > - -<!ATTLIST NOSCRIPT - --<Title>html_p~1 - Attribute List-011-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST STYLE - --<Title>html_p~1 - Attribute List-012-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - type CDATA #REQUIRED - --<Title>Internet media type for style notation-- - - notation NOTATION (CSS , DSSSL) #IMPLIED - --<Title>(L)Undefined in Lynx but must be one of these so far-- - > - -<!ATTLIST RANGE - --<Title>html_p~1 - Attribute List-013-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - from IDREF #REQUIRED - --<Title>SPOT indicating start of marked range-- - - until IDREF #REQUIRED - --<Title>SPOT indicating end of marked range-- - > - -<!ATTLIST FRAMESET - --<Title>html_p~1 - Attribute List-014-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - cols CDATA #IMPLIED - --<Title>Comma-sep column specs in pixels or %, *=equalize remainder-- - - rows CDATA #IMPLIED - --<Title>Comma-sep row specs in pixels or %, *=equalize remainder-- - - border NUMBER #IMPLIED - --<Title>(N) border width in pixels-- - - bordercolor CDATA #IMPLIED - --<Title>(N) Hex-encoded or Windows colorname-- - - frameborder (YES , NO) "NO" - --<Title>(N) has the frame a border or not: rules are complex, see Netscape-- - - onLoad CDATA #IMPLIED - --<Title>Module to execute on loading-- - - onUnload CDATA #IMPLIED - --<Title>Module to execute on unloading (exiting)-- - - onFocus CDATA #IMPLIED - --<Title>Module to execute when window gains focus-- - - onBlur CDATA #IMPLIED - --<Title>Module to execute when window loses focus-- - > - -<!ATTLIST FRAME - --<Title>html_p~1 - Attribute List-015-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - marginheight CDATA #IMPLIED - --<Title>(N) Margin above and below-- - - marginwidth CDATA #IMPLIED - --<Title>(N) Margin either side-- - - bordercolor CDATA #IMPLIED - --<Title>(N) Hex-encoded or Windows colorname-- - - frameborder CDATA "NO" - --<Title>frameborder-- - - name CDATA #IMPLIED - --<Title>(N) Name to refer to this frame by from <a> links-- - - noresize (noresize) #IMPLIED - --<Title>(N) Frame cannot be size-dragged-- - - scrolling (yes , no , auto) "auto" - --<Title>(N) Frame scrolling control-- - - src CDATA #REQUIRED - --<Title>(N) URL for the document to display-- - > - -<!ATTLIST NOFRAMES - --<Title>html_p~1 - Attribute List-016-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST BODY - --<Title>html_p~1 - Attribute List-017-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - background CDATA #IMPLIED - --<Title>Image to tile for document background-- - - bgcolor CDATA #IMPLIED - --<Title>#rrggbb color code for document background-- - - text CDATA #IMPLIED - --<Title>#rrggbb color code for body text-- - - link CDATA #IMPLIED - --<Title>#rrggbb color code for unvisited <a> links-- - - vlink CDATA #IMPLIED - --<Title>#rrggbb color code for visited <a> links-- - - alink CDATA #IMPLIED - --<Title>#rrggbb color code for active <a> link-- - - onLoad CDATA #IMPLIED - --<Title>Module to execute on loading-- - - onUnload CDATA #IMPLIED - --<Title>Module to execute on unloading (exiting)-- - - onFocus CDATA #IMPLIED - --<Title>Module to execute when window gains focus-- - - onBlur CDATA #IMPLIED - --<Title>Module to execute when window loses focus-- - - topmargin NUMBER #IMPLIED - --<Title>(?)Forces body to top of screen?-- - - tile (vertical , horizontal , both) "both" - - --<Title>(P)Controls direction of tiling BACKGROUND image-- - - credits CDATA #IMPLIED - --<Title>(T) URL of authors, contributors, etc-- - - fontsize (small , medium , large) "medium" - - --<Title>(T) overrides user-specified body font size-- - - hspace NUMBER "8" - --<Title>(T) specifies outer LH and RH margins of BODY in pixels-- - - instructions CDATA #IMPLIED - --<Title>(T) URL for user instructions related to current page-- - - logo CDATA #IMPLIED - --<Title>(T) URL for thumbnail for index entries of current page-- - - nohtilebg (nohtilebg) #IMPLIED - --<Title>(T) defeats horizontal tiling of background image-- - - novtilebg (novtilebg) #IMPLIED - --<Title>(T) defeats vertical tiling of background image-- - - vspace NUMBER "6" - --<Title>(T) specifies top and bottom margins of BODY in pixels-- - - xspeed NUMBER "0" - --<Title>(T) horizontal scroll speed for scrolled background image-- - - yspeed NUMBER "0" - --<Title>(T) vertical scroll speed for scrolled background image-- - > - -<!ATTLIST BANNER - --<Title>html_p~1 - Attribute List-018-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - > - -<!ATTLIST BODYTEXT - --<Title>html_p~1 - Attribute List-019-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - data CDATA #IMPLIED - --<Title>(L) reference to object's data-- - - name CDATA #IMPLIED - --<Title>(L) name for image-- - - ref CDATA #IMPLIED - --<Title>(L) Undocumented-- - - object CDATA #IMPLIED - --<Title>object-- - - value CDATA #IMPLIED - --<Title>property value-- - - valuetype (DATA , REF , OBJECT) "DATA" - - --<Title>How to interpret value-- - - type CDATA #IMPLIED - --<Title>Internet media type-- - > - -<!ATTLIST BDO - --<Title>html_p~1 - Attribute List-020-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(I) control of text flow-- - > - -<!ATTLIST DIV - --<Title>html_p~1 - Attribute List-021-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3)control of text flow-- - > - -<!ATTLIST H1 - --<Title>html_p~1 - Attribute List-022-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - SDAFORM CDATA #FIXED "H1" - --<Title>SDAFORM-003-- - > - -<!ATTLIST H2 - --<Title>html_p~1 - Attribute List-023-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - SDAFORM CDATA #FIXED "H2" - --<Title>SDAFORM-004-- - > - -<!ATTLIST H3 - --<Title>html_p~1 - Attribute List-024-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - SDAFORM CDATA #FIXED "H3" - --<Title>SDAFORM-005-- - > - -<!ATTLIST H4 - --<Title>html_p~1 - Attribute List-025-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - SDAFORM CDATA #FIXED "H4" - --<Title>SDAFORM-006-- - > - -<!ATTLIST H5 - --<Title>html_p~1 - Attribute List-026-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - SDAFORM CDATA #FIXED "H5" - --<Title>SDAFORM-007-- - > - -<!ATTLIST H6 - --<Title>html_p~1 - Attribute List-027-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - SDAFORM CDATA #FIXED "H6" - --<Title>SDAFORM-008-- - > - -<!ATTLIST P - --<Title>html_p~1 - Attribute List-028-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - SDAFORM CDATA #FIXED "Para" - --<Title>SDAFORM-009-- - > - -<!ATTLIST MULTICOL - --<Title>html_p~1 - Attribute List-029-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - cols NUMBER #REQUIRED - --<Title>Number of columns-- - - width NUMBER #IMPLIED - --<Title>Column width in pixels, default calculated-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - gutter NUMBER #IMPLIED - --<Title>Space between columns in pixels, default 10-- - > - -<!ATTLIST NOBR - --<Title>html_p~1 - Attribute List-030-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - > - -<!ATTLIST WBR - --<Title>html_p~1 - Attribute List-031-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST PRE - --<Title>html_p~1 - Attribute List-032-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - width NUMBER #IMPLIED - --<Title>Recommended maximum width in fixed-width characters-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAFORM CDATA #FIXED "Lit" - --<Title>SDAFORM-010-- - > - -<!ATTLIST BLOCKQUOTE - --<Title>html_p~1 - Attribute List-033-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - SDAFORM CDATA #FIXED "BQ" - --<Title>SDAFORM-011-- - > - -<!ATTLIST BQ - --<Title>html_p~1 - Attribute List-034-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - SDAFORM CDATA #FIXED "BQ" - --<Title>SDAFORM-012-- - > - -<!ATTLIST DL - --<Title>html_p~1 - Attribute List-035-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - compact (compact) #IMPLIED - --<Title>Reduced interitem spacing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAFORM CDATA #FIXED "List" - --<Title>SDAFORM-013-- - - SDAPREF CDATA #FIXED "Definition List:" - - --<Title>SDAPREF-003-- - > - -<!ATTLIST DT - --<Title>html_p~1 - Attribute List-036-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAFORM CDATA #FIXED "Term" - --<Title>SDAFORM-014-- - > - -<!ATTLIST DD - --<Title>html_p~1 - Attribute List-037-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAFORM CDATA #FIXED "LItem" - --<Title>SDAFORM-015-- - > - -<!ATTLIST OL - --<Title>html_p~1 - Attribute List-038-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - seqnum NUMBER #IMPLIED - --<Title>Starting sequence number-- - - type CDATA #IMPLIED - --<Title>Numbering/lettering style constrained to [1aAiI]-- - - start NUMBER #IMPLIED - --<Title>start-- - - continue NUMBER #IMPLIED - --<Title>Continuation sequence number-- - - compact (compact) #IMPLIED - --<Title>Reduced interitem spacing-- - - wrap (ON , OFF , HARD , SOFT , HORIZ) "ON" - - --<Title>(N) how to handle line-wrapping-- - - SDAFORM CDATA #FIXED "List" - --<Title>SDAFORM-016-- - > - -<!ATTLIST UL - --<Title>html_p~1 - Attribute List-039-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - type (disc , square , circle , plain , A , I , 1) - #IMPLIED - --<Title>Bulleting style, [AaIi1] interpreted by browser-- - - compact (compact) #IMPLIED - --<Title>Reduced interitem spacing-- - - plain CDATA #IMPLIED - --<Title>Unbulleted, ought to be the nametoken "PLAIN" but it's already bee used above for TYPE-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - wrap (ON , OFF , HARD , SOFT , HORIZ) "ON" - - --<Title>(N) how to handle line-wrapping-- - - fileformat NOTATION (GIF , JPG , DVI , BMP , EPS , PNG , - PICT , TIFF , XBM , XPM) #IMPLIED - --<Title>Format of image if not implicit-- - - SDAFORM CDATA #FIXED "List" - --<Title>SDAFORM-017-- - > - -<!ATTLIST DIR - --<Title>html_p~1 - Attribute List-040-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - compact (compact) #IMPLIED - --<Title>Reduced interitem spacing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - type CDATA #IMPLIED - --<Title>Numbering/lettering style constrained to [1aAiI]-- - - plain CDATA #IMPLIED - --<Title>Unbulleted, ought to be the nametoken "PLAIN" but it's already bee used above for TYPE-- - - wrap (ON , OFF , HARD , SOFT , HORIZ) "ON" - - --<Title>(N) how to handle line-wrapping-- - - SDAFORM CDATA #FIXED "List" - --<Title>SDAFORM-018-- - - SDAPREF CDATA #FIXED "<LHead>Directory</LHead>" - - --<Title>SDAPREF-004-- - > - -<!ATTLIST MENU - --<Title>html_p~1 - Attribute List-041-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - compact (compact) #IMPLIED - --<Title>Reduced interitem spacing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - type CDATA #IMPLIED - --<Title>Numbering/lettering style constrained to [1aAiI]-- - - plain CDATA #IMPLIED - --<Title>Unbulleted, ought to be the nametoken "PLAIN" but it's already bee used above for TYPE-- - - wrap (ON , OFF , HARD , SOFT , HORIZ) "ON" - - --<Title>(N) how to handle line-wrapping-- - - SDAFORM CDATA #FIXED "List" - --<Title>SDAFORM-019-- - - SDAPREF CDATA #FIXED "<LHead>Menu</LHead>" - - --<Title>SDAPREF-005-- - > - -<!ATTLIST LH - --<Title>html_p~1 - Attribute List-042-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - > - -<!ATTLIST LI - --<Title>html_p~1 - Attribute List-043-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - type CDATA #IMPLIED - --<Title>List item style, see TYPE for OL and UL-- - - value NUMBER #IMPLIED - --<Title>Reset sequence number-- - - skip NUMBER "0" - --<Title>skip seq nums for missing items-- - - dingbat ENTITY #IMPLIED - --<Title>dingbat entity from obsolete HTMLicons collection-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - src CDATA #IMPLIED - --<Title>URI for bullet icon-- - - fileformat NOTATION (GIF , JPG , DVI , BMP , EPS , PNG , - PICT , TIFF , XBM , XPM) #IMPLIED - --<Title>Format of icon if not implicit-- - - SDAFORM CDATA #FIXED "LItem" - --<Title>SDAFORM-020-- - > - -<!ATTLIST ADDRESS - --<Title>html_p~1 - Attribute List-044-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - SDAFORM CDATA #FIXED "Lit" - --<Title>SDAFORM-021-- - - SDAPREF CDATA #FIXED "Address: " - --<Title>SDAPREF-006-- - > - -<!ATTLIST FN - --<Title>html_p~1 - Attribute List-045-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - flow (vertical , columnar , para) "vertical" - - --<Title>Arrangement-- - - series CDATA #IMPLIED - --<Title>Multiseries like A, B, C etc-- - - src CDATA #IMPLIED - --<Title>URI of image to embed-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - num NUMBER #IMPLIED - --<Title>Sequence number if needed-- - - href CDATA #IMPLIED - --<Title>(T) #ID fragmentary URL for an <fn id="..."> in current document-- - > - -<!ATTLIST NOTE - --<Title>html_p~1 - Attribute List-046-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - flow (vertical , columnar , para) "vertical" - - --<Title>Arrangement-- - - series CDATA #IMPLIED - --<Title>Multiseries like A, B, C etc-- - - src CDATA #IMPLIED - --<Title>URI of image to embed-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - num NUMBER #IMPLIED - --<Title>Sequence number if needed-- - > - -<!ATTLIST SIDEBAR - --<Title>html_p~1 - Attribute List-047-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - width CDATA #IMPLIED - --<Title>(T) width of the sidebar in pixels or as a percent-- - > - -<!ATTLIST BLINK - --<Title>html_p~1 - Attribute List-048-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - speed NUMBER #IMPLIED - --<Title>Blinks per minutes-- - > - -<!ATTLIST CENTER - --<Title>html_p~1 - Attribute List-049-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - > - -<!ATTLIST HR - --<Title>html_p~1 - Attribute List-050-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - src CDATA #IMPLIED - --<Title>URI of image to embed-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - noshade (noshade) #IMPLIED - --<Title>(N) non-shaded rule-- - - size CDATA #IMPLIED - --<Title>(N) [+]nn e.g. size="+1", size="4"-- - - width CDATA #IMPLIED - --<Title>(N) suggested width in pixels-- - - invertborder (invertborder) #IMPLIED - --<Title>(T) produces 3D-style raised rule-- - - SDAPREF CDATA #FIXED " " - --<Title>SDAPREF-007-- - > - -<!ATTLIST BR - --<Title>html_p~1 - Attribute List-051-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAPREF CDATA #FIXED " " - --<Title>SDAPREF-008-- - > - -<!ATTLIST BASEFONT - --<Title>html_p~1 - Attribute List-052-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - size CDATA #REQUIRED - --<Title>base font size for FONT elements-- - - end CDATA #IMPLIED - --<Title>end-- - - color CDATA #IMPLIED - --<Title>#RRGGBB in hex, e.g. red: color="#FF0000"-- - - face CDATA #IMPLIED - --<Title>typeface if available-- - > - -<!ATTLIST MARQUEE - --<Title>html_p~1 - Attribute List-053-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , top , absmiddle , absbottom , - texttop , middle , baseline , bottom) "bottom" - - --<Title>Relationship to adjacent text (type=block only)-- - - DIRECTION CDATA #IMPLIED - --<Title>Direction of scroll, should be (LEFT,RIGHT) but they've already been used-- - - BEHAVIOR (SCROLL , SLIDE , ALTERNATE) "SCROLL" - - --<Title>Type of movement-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SCROLLAMOUNT NUMBER #IMPLIED - --<Title>Quantity of scroll-- - - SCROLLDELAY NUMBER #IMPLIED - --<Title>Delay time-- - - LOOP CDATA "INFINITE" - --<Title>How long to scroll for-- - - bgcolor CDATA #IMPLIED - --<Title>Background color-- - - BORDER NUMBER #IMPLIED - --<Title>Border width-- - - HEIGHT CDATA #IMPLIED - --<Title>Height-- - - WIDTH CDATA #IMPLIED - --<Title>Width-- - - HSPACE NUMBER #IMPLIED - --<Title>Horizontal spacing-- - - VSPACE NUMBER #IMPLIED - --<Title>Vertical spacing-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - > - -<!ATTLIST SERVER - --<Title>html_p~1 - Attribute List-054-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - > - -<!ATTLIST SPACER - --<Title>html_p~1 - Attribute List-055-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , top , absmiddle , absbottom , - texttop , middle , baseline , bottom) "bottom" - - --<Title>Relationship to adjacent text (type=block only)-- - - height NUMBER #IMPLIED - --<Title>Height in pixels (type=block only)-- - - size NUMBER #IMPLIED - --<Title>Width or height in pixels, depending on TYPE-- - - type (horizontal , vertical , block) "block" - - --<Title>Functional type-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - width NUMBER #IMPLIED - --<Title>Width in pixels (type=block only)-- - > - -<!ATTLIST (IMG , IMAGE) - --<Title>html_p~1 - Attribute List-056-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - isobject (isobject) #IMPLIED - --<Title>(L) Figure is an object-- - - units (en , pixels) "pixels" - --<Title>specifies units as en's or pixels-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - src CDATA #REQUIRED - --<Title>URL of image to embed-- - - lowsrc CDATA #IMPLIED - --<Title>(N) source for lo-res image-- - - name CDATA #IMPLIED - --<Title>(N) name for image-- - - onLoad CDATA #IMPLIED - --<Title>Module to execute on loading-- - - onAbort CDATA #IMPLIED - --<Title>Module to execute when user cancels load-- - - onError CDATA #IMPLIED - --<Title>Module to execute when script encounters error-- - - alt CDATA #REQUIRED - --<Title>For display in place of image-- - - align (left , right , top , absmiddle , absbottom , - texttop , middle , baseline , bottom) "bottom" - - --<Title>Relationship to adjacent text (type=block only)-- - - height NUMBER #IMPLIED - --<Title>Suggested height in pixels-- - - width NUMBER #IMPLIED - --<Title>Suggested width in pixels-- - - border NUMBER #IMPLIED - --<Title>(N) border width in pixels-- - - hspace NUMBER #IMPLIED - --<Title>Suggested horizontal gutter-- - - vspace CDATA #IMPLIED - --<Title>Suggested vertical gutter-- - - usemap CDATA #IMPLIED - --<Title>Use client-side image map-- - - ismap (ismap) #IMPLIED - --<Title>Use server image map-- - - fileformat NOTATION (GIF , JPG , DVI , BMP , EPS , PNG , - PICT , TIFF , XBM , XPM) #IMPLIED - --<Title>(P)Format of image file if not implicit-- - - naturalsizeflag NUMBER #IMPLIED - --<Title>(M) Indicates if scaling has been used-- - - ani CDATA #IMPLIED - --<Title>(T) URL of alternate WebTV-specific animation to replace SRC-- - - animateonselect (animateonselect) #IMPLIED - --<Title>(T) ANI animation only runs when user selects it-- - - anistartx NUMBER #IMPLIED - --<Title>(T) ANI TLC location in pixels relative to page or table cell-- - - anistarty NUMBER #IMPLIED - --<Title>anistarty-- - - loop (loop) #IMPLIED - --<Title>(MT) recycle an animated image?-- - - reload NUMBER #IMPLIED - --<Title>(T) frequency of reload-- - - selected CDATA #IMPLIED - --<Title>(T) wrests focus to "x,y" of imagemap relative to TLC-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - - dynsrc CDATA #IMPLIED - --<Title>(?) Undocumented-- - - SDAPREF CDATA #FIXED - "<Fig><?SDATrans Img: #AttList>#AttVal(Alt)</Fig>" - - --<Title>SDAPREF-009-- - > - -<!ATTLIST AUDIOSCOPE - --<Title>html_p~1 - Attribute List-057-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , top , absmiddle , absbottom , - texttop , middle , baseline , bottom) "bottom" - - --<Title>Relationship to adjacent text (type=block only)-- - - border NUMBER "1" - --<Title>width of border in pixels-- - - gain NUMBER "1" - --<Title>multiplier for amplitude display-- - - height NUMBER "80" - --<Title>height of image in pixels-- - - leftcolor CDATA "#8ECE10" - --<Title>color of left channel trace-- - - leftoffset NUMBER "0" - --<Title>positions the left channel baseline + or - -- - - maxlevel CDATA "false" - --<Title>specifies clip level for gain-- - - rightcolor CDATA "#8ECE10" - --<Title>color of right channel trace-- - - rightoffset NUMBER "0" - --<Title>positions the right channel baseline + or - -- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - width NUMBER "100" - --<Title>width of image in pixels-- - > - -<!ATTLIST MAP - --<Title>html_p~1 - Attribute List-058-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - name CDATA #IMPLIED - --<Title>Named link end-- - > - -<!ATTLIST AREA - --<Title>html_p~1 - Attribute List-059-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - shape (rect , circle , poly , default) "rect" - - --<Title>For use with OBJECT SHAPES-- - - coords CDATA #IMPLIED - --<Title>Coord pairs, always needed except for shape=default-- - - href CDATA #IMPLIED - --<Title>Hypertext link to apply-- - - nohref (nohref) #IMPLIED - --<Title>This region has no action-- - - name CDATA #IMPLIED - --<Title>Named link end-- - - target CDATA #IMPLIED - --<Title>(N) target window in framing environment-- - - rel CDATA #IMPLIED - --<Title>forward link types-- - - rev CDATA #IMPLIED - --<Title>reverse link types-- - - alt CDATA #REQUIRED - --<Title>Description for text-only browsers-- - - tabindex NUMBER #IMPLIED - --<Title>Position in tabbing order-- - - notab (notab) #IMPLIED - --<Title>Exclude from tabbing order-- - - onClick CDATA #IMPLIED - --<Title>What to do on click-- - - onMouseOver CDATA #IMPLIED - --<Title>What to do when mouse is moved over area-- - - onMouseOut CDATA #IMPLIED - --<Title>What to do when mouse is moved off area-- - > - -<!ATTLIST OBJECT - --<Title>html_p~1 - Attribute List-060-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - declare (declare) #IMPLIED - --<Title>declare but don't instantiate flag-- - - classid CDATA #IMPLIED - --<Title>identifies an implementation-- - - codebase CDATA #IMPLIED - --<Title>some systems need an additional URL-- - - data CDATA #IMPLIED - --<Title>reference to object's data-- - - alt CDATA #IMPLIED - --<Title>for display in place of object-- - - type CDATA #IMPLIED - --<Title>Internet media type for data-- - - codetype CDATA #IMPLIED - --<Title>Internet media type for code-- - - standby CDATA #IMPLIED - --<Title>message to show while loading-- - - align (texttop , middle , textmiddle , baseline , - textbottom , left , center , right) #IMPLIED - --<Title>positioning inside document-- - - height CDATA #IMPLIED - --<Title>suggested height-- - - width CDATA #IMPLIED - --<Title>suggested width-- - - border CDATA #IMPLIED - --<Title>suggested link border width-- - - hspace CDATA #IMPLIED - --<Title>hspace-- - - vspace CDATA #IMPLIED - --<Title>Suggested vertical gutter-- - - ismap (ismap) #IMPLIED - --<Title>Use server image map-- - - usemap CDATA #IMPLIED - --<Title>reference to image map-- - - shapes (shapes) #IMPLIED - --<Title>object has shaped hypertext links-- - - name CDATA #IMPLIED - --<Title>submit as part of form-- - - tabindex NUMBER #IMPLIED - --<Title>Position in tabbing order-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - notab (notab) #IMPLIED - --<Title>Exclude from tabbing order-- - > - -<!ATTLIST EMBED - --<Title>html_p~1 - Attribute List-061-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - ALIGN (top , middle , bottom , left , center , right) - #IMPLIED - --<Title>(O) more specific alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - border NUMBER #IMPLIED - --<Title>(N) thickness of border in pixels-- - - frameborder (YES , NO) "NO" - --<Title>(N) has the frame a border or not-- - - hidden (TRUE , FALSE) "FALSE" - --<Title>(N) is the plugin visible-- - - hspace NUMBER #IMPLIED - --<Title>(N) LR margin in pixels-- - - vspace NUMBER #IMPLIED - --<Title>(N) TB margin in pixels-- - - FLOWTO NAME #IMPLIED - --<Title>(O) flow text around block until this ID-- - - name CDATA #IMPLIED - --<Title>(N) name of the applet-- - - controls CDATA "FALSE" - --<Title>(N) should the controls be on display-- - - palette (FOREGROUND , BACKGROUND) "FOREGROUND" - - --<Title>(N) where the applet's palette applies (MS-Win only)-- - - pluginspace CDATA #IMPLIED - --<Title>(N) URL of instructions if applet's MIME-type plugin not found-- - - type CDATA #IMPLIED - --<Title>(N) MIME content-type-- - - src CDATA #REQUIRED - --<Title>location of object source-- - - height CDATA #IMPLIED - --<Title>suggested height-- - - width CDATA #IMPLIED - --<Title>suggested width-- - - imagemap (imagemap) #IMPLIED - --<Title>pass background clicks to server-- - - ismap (ismap) #IMPLIED - --<Title>Use server image map-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - noflow (noflow) #IMPLIED - --<Title>noflow around table-- - - params CDATA #IMPLIED - --<Title>(O) parameters to pass-- - - units (en , px , relative) "en" - --<Title>units for column widths-- - - usemap CDATA #IMPLIED - --<Title>reference to image map-- - - alt CDATA #IMPLIED - --<Title>for display in place of embedded object-- - - URN CDATA #IMPLIED - --<Title>(O) global entity name-- - - REL NAME #IMPLIED - --<Title>(O) link relationship-- - - REV NAME #IMPLIED - --<Title>(O) reverse relationship-- - - ACCEPT CDATA "text/plain" - --<Title>(O) applicable media type(s)-- - - ACCEPT-CHARSET CDATA "ISO-8859-1" - --<Title>(O) applicable character encoding(s)-- - - ACCEPT-ENCODING CDATA "ISO-8859-1" - --<Title>(O) applicable transfer encoding(s)-- - - SDAPREF CDATA #FIXED - '<Fig><Xref IDRef="#AttVal(SRC)"><?SDATrans Embed: #AttList>' - - --<Title>(O)SDAPREF-- - - SDASUFF CDATA #FIXED "</Fig>" - --<Title>(O)SDASUFF-- - > - -<!ATTLIST EMBED.BODY - --<Title>html_p~1 - Attribute List-062-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST NOEMBED - --<Title>html_p~1 - Attribute List-063-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - > - -<!ATTLIST APP - --<Title>html_p~1 - Attribute List-064-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - codebase CDATA #IMPLIED - --<Title>code base-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - mayscript (mayscript) #IMPLIED - --<Title>(N) allows applet access to JavaScript or similar-- - - archive CDATA #IMPLIED - --<Title>(N) URL of code archive (.zip, but not a compressed file)-- - - code CDATA #REQUIRED - --<Title>class file-- - - name CDATA #IMPLIED - --<Title>applet name-- - - alt CDATA #IMPLIED - --<Title>for display in place of applet-- - - align (top , middle , bottom , left , right) #IMPLIED - --<Title>vertical or horizontal alignment-- - - height CDATA #REQUIRED - --<Title>height-002-- - - width CDATA #REQUIRED - --<Title>width-002-- - - hspace CDATA #IMPLIED - --<Title>hspace-002-- - - vspace CDATA #IMPLIED - --<Title>Suggested vertical gutter-- - - download NUMBER #IMPLIED - --<Title>image download order-- - > - -<!ATTLIST APPLET - --<Title>html_p~1 - Attribute List-065-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - codebase CDATA #IMPLIED - --<Title>code base-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - mayscript (mayscript) #IMPLIED - --<Title>(N) allows applet access to JavaScript or similar-- - - archive CDATA #IMPLIED - --<Title>(N) URL of code archive (.zip, but not a compressed file)-- - - code CDATA #REQUIRED - --<Title>class file-- - - name CDATA #IMPLIED - --<Title>applet name-- - - alt CDATA #IMPLIED - --<Title>for display in place of applet-- - - align (top , middle , bottom , left , right) #IMPLIED - --<Title>vertical or horizontal alignment-- - - height CDATA #REQUIRED - --<Title>height-003-- - - width CDATA #REQUIRED - --<Title>width-003-- - - hspace CDATA #IMPLIED - --<Title>hspace-003-- - - vspace CDATA #IMPLIED - --<Title>Suggested vertical gutter-- - - download NUMBER #IMPLIED - --<Title>image download order-- - > - -<!ATTLIST param - --<Title>html_p~1 - Attribute List-066-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - name CDATA #REQUIRED - --<Title>property name-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - value CDATA #IMPLIED - --<Title>property value-- - - valuetype (DATA , REF , OBJECT) "DATA" - - --<Title>How to interpret value-- - - ref CDATA #IMPLIED - --<Title>(L) Undocumented-- - - valueref CDATA #IMPLIED - --<Title>valueref-- - - data CDATA #IMPLIED - --<Title>reference to object's data-- - - object CDATA #IMPLIED - --<Title>object-002-- - - accept CDATA #IMPLIED - --<Title>accept-- - - accept-charset CDATA #IMPLIED - --<Title>accept-charset-- - - accept-encoding CDATA #IMPLIED - --<Title>accept-encoding-- - - type CDATA #IMPLIED - --<Title>Internet media type-- - - SDAPREF CDATA #FIXED "<?SDATrans Param: #AttList>" - - --<Title>SDAPREF-010-- - > - -<!ATTLIST FORM - --<Title>html_p~1 - Attribute List-067-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - script CDATA #IMPLIED - --<Title>script-- - - subject CDATA #IMPLIED - --<Title>subject-- - - action CDATA #REQUIRED - --<Title>(H2) server-side form handler (script)-- - - method (GET , POST , PGET) "GET" - --<Title>(H2) see HTTP specification: PGET added for Foteos' testing-- - - name CDATA #IMPLIED - --<Title>(N) name for the form-- - - target CDATA #IMPLIED - --<Title>(N) name for the target window-- - - enctype CDATA "application/x-www-form-urlencoded" - - --<Title>(H2) Encoding type, may also be "multipart/form-data"-- - - onReset CDATA #IMPLIED - --<Title>(N) module to execute when form is reset-- - - onSubmit CDATA #IMPLIED - --<Title>(N) module to execute when form is submitted-- - - SDAPREF CDATA #FIXED "<Para>Form:</Para>" - - --<Title>SDAPREF-011-- - - SDASUFF CDATA #FIXED "<Para>Form End.</Para>" - - --<Title>SDASUFF-- - > - -<!ATTLIST LABEL - --<Title>html_p~1 - Attribute List-068-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - for IDREF #IMPLIED - --<Title>matches a field ID value-- - - accesskey CDATA #IMPLIED - --<Title>accessibility key character-- - - onClick CDATA #IMPLIED - --<Title>intrinsic event-- - > - -<!ATTLIST FIELDSET - --<Title>html_p~1 - Attribute List-069-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - checked (checked) #IMPLIED - --<Title>marks this set of fields by default as CHECKED-- - > - -<!ATTLIST INPUT - --<Title>html_p~1 - Attribute List-070-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - type (TEXT , PASSWORD , CHECKBOX , RADIO , SUBMIT , RESET , - FILE , HIDDEN , IMAGE , BUTTON) "TEXT" - - --<Title>what kind of widget is needed-- - - name CDATA #IMPLIED - --<Title>required for all but submit and reset-- - - value CDATA #IMPLIED - --<Title>required for radio and checkboxes, also for file uploads-- - - checked (checked) #IMPLIED - --<Title>marks this field by default as CHECKED-- - - disabled (disabled) #IMPLIED - --<Title>turns off this field-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - error CDATA #IMPLIED - --<Title>error-- - - height NUMBER #IMPLIED - --<Title>height-004-- - - width NUMBER #IMPLIED - --<Title>width-004-- - - max NUMBER #IMPLIED - --<Title>max-- - - min NUMBER #IMPLIED - --<Title>min-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - size CDATA #IMPLIED - --<Title>specific to each type of field-- - - maxlength NUMBER #IMPLIED - --<Title>maxlength-- - - src CDATA #IMPLIED - --<Title>for fields with background images-- - - alt CDATA #IMPLIED - --<Title>for display in place of applet-- - - fileformat NOTATION (GIF , JPG , DVI , BMP , EPS , PNG , - PICT , TIFF , XBM , XPM) #IMPLIED - --<Title>Format of icon file if not implicit-- - - accept CDATA #IMPLIED - --<Title>Form-based file upload accepted types (RFC1867)-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - tabindex NUMBER #IMPLIED - --<Title>Position in tabbing order-- - - notab (notab) #IMPLIED - --<Title>Exclude from tabbing order-- - - onClick CDATA #IMPLIED - --<Title>(N) script to execute when button is clicked; (T) animation-- - - onFocus CDATA #IMPLIED - --<Title>onFocus-- - - onBlur CDATA #IMPLIED - --<Title>onBlur-- - - onSelect CDATA #IMPLIED - --<Title>onSelect-- - - onChange CDATA #IMPLIED - --<Title>onChange-- - - action CDATA #IMPLIED - --<Title>(T) URL to send single field value to when field is clicked-- - - submitform (submitform) #IMPLIED - --<Title>(T) with ACTION, sends whole form instead of single value-- - - noargs (noargs) #IMPLIED - --<Title>(T) with ACTION, defeats sending of field data-- - - nohighlight (nohighlight) #IMPLIED - --<Title>(T) disables auto-highlighting-- - - usestyle (usestyle) #IMPLIED - --<Title>(T) use body font for content-- - - autosubmit (autosubmit) #IMPLIED - --<Title>(T) in HIDDEN fields, submits form when user transcludes-- - - loop (loop) #IMPLIED - --<Title>(T) forces an ONCLICK animation to loop-- - - nocursor (nocursor) #IMPLIED - --<Title>(T) in IMAGE fields, disable cursor on image-- - - borderimage CDATA #IMPLIED - --<Title>(T) in TEXT, RESET and SUBMIT, specifies alternate button images-- - - useform IDREF #IMPLIED - --<Title>(T) in SUBMIT, send the form ID="id" rather than the current form-- - - allcaps (allcaps) #IMPLIED - --<Title>(T) forces keyboard to CAPS LOCK for data in this field-- - - autocaps (autocaps) #IMPLIED - --<Title>(T) forces keyboard to initial capitalization for this field-- - - autoactivate (autoactivate) #IMPLIED - --<Title>(T) in TEXT fields, activates focus automatically-- - - bgcolor CDATA #IMPLIED - --<Title>(T) background color-- - - cursor CDATA #IMPLIED - --<Title>(T) cursor color-- - - executeurl CDATA #IMPLIED - --<Title>(T) in TEXT, interpret data as URL and transclude on RETURN-- - - nosubmit (nosubmit) #IMPLIED - --<Title>(T) defeats submission when RETURN is pressed-- - - numbers (numbers) #IMPLIED - --<Title>(T) forces use of numeric keypad-- - - SDAPREF CDATA #FIXED "Input: " - --<Title>SDAPREF-012-- - > - -<!ATTLIST SELECT - --<Title>html_p~1 - Attribute List-071-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - name CDATA #REQUIRED - --<Title>property name-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - disabled (disabled) #IMPLIED - --<Title>marks this field by default as disabled-- - - error CDATA #IMPLIED - --<Title>error-002-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - width NUMBER #IMPLIED - --<Title>desired width in units-- - - height NUMBER #IMPLIED - --<Title>desired height in units-- - - units (en , pixels) "pixels" - --<Title>specifies units as en's or pixels-- - - size NUMBER #IMPLIED - --<Title>number of items in the list to be visible at once-- - - multiple (multiple) #IMPLIED - --<Title>multiple-- - - checked (checked) #IMPLIED - --<Title>marks this field by default as CHECKED-- - - tabindex NUMBER #IMPLIED - --<Title>Position in tabbing order-- - - notab (notab) #IMPLIED - --<Title>Exclude from tabbing order-- - - onFocus CDATA #IMPLIED - --<Title>onFocus-002-- - - onBlur CDATA #IMPLIED - --<Title>onBlur-002-- - - onChange CDATA #IMPLIED - --<Title>onChange-002-- - - onClick CDATA #IMPLIED - --<Title>(N) script to execute when button is clicked-- - - autoactivate (autoactivate) #IMPLIED - --<Title>(T) in TEXT fields, activates focus automatically-- - - bgcolor CDATA #IMPLIED - --<Title>(T) background color-- - - exclusive (exclusive) #IMPLIED - --<Title>(T) detect and purge duplicate OPTION entries-- - - selcolor CDATA "#EAEAEA" - --<Title>(T) sets color for background of selected options-- - - showempty (showempty) #IMPLIED - --<Title>(T) displays empty lists with string "empty"-- - - text CDATA #IMPLIED - --<Title>(T) sets color for text of OPTIONs-- - - usestyle (usestyle) #IMPLIED - --<Title>(T) use body font for content-- - - SDAFORM CDATA #FIXED "List" - --<Title>SDAFORM-022-- - - SDAPREF CDATA #FIXED - "<LHead>Select #AttVal(Multiple)</LHead>" - - --<Title>SDAPREF-013-- - > - -<!ATTLIST OPTION - --<Title>html_p~1 - Attribute List-072-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - disabled (disabled) #IMPLIED - --<Title>marks this field by default as disabled-- - - selected (selected) #IMPLIED - --<Title>marks this field by default as selected-- - - error CDATA #IMPLIED - --<Title>error-003-- - - shape CDATA #IMPLIED - --<Title>(L) Instantiation-- - - value CDATA #IMPLIED - --<Title>defaults to element content-- - - SDAFORM CDATA #FIXED "LItem" - --<Title>SDAFORM-023-- - - SDAPREF CDATA #FIXED - "Option: #AttVal(Value) #AttVal(Selected)" - - --<Title>SDAPREF-014-- - > - -<!ATTLIST TEXTAREA - --<Title>html_p~1 - Attribute List-073-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - name CDATA #REQUIRED - --<Title>property name-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - disabled (disabled) #IMPLIED - --<Title>marks this field by default as disabled-- - - error CDATA #IMPLIED - --<Title>error-004-- - - wrap (ON , OFF , HARD , SOFT , PHYSICAL , VIRTUAL) "OFF" - - --<Title>(N) how to handle line-wrapping and inserted newlines-- - - rows NUMBER #REQUIRED - --<Title>rows-- - - cols NUMBER #REQUIRED - --<Title>cols-- - - checked (checked) #IMPLIED - --<Title>marks this field by default as CHECKED-- - - tabindex NUMBER #IMPLIED - --<Title>Position in tabbing order-- - - notab (notab) #IMPLIED - --<Title>Exclude from tabbing order-- - - onFocus CDATA #IMPLIED - --<Title>onFocus-003-- - - onBlur CDATA #IMPLIED - --<Title>onBlur-003-- - - onSelect CDATA #IMPLIED - --<Title>onSelect-002-- - - onChange CDATA #IMPLIED - --<Title>onChange-003-- - - allcaps (allcaps) #IMPLIED - --<Title>(T) forces keyboard to CAPS LOCK for data in this field-- - - autocaps (autocaps) #IMPLIED - --<Title>(T) forces keyboard to initial capitalization for this field-- - - autoactivate (autoactivate) #IMPLIED - --<Title>(T) in TEXT fields, activates focus automatically-- - - bgcolor CDATA #IMPLIED - --<Title>(T) background color-- - - cursor CDATA #IMPLIED - --<Title>(T) cursor color-- - - growable (growable) #IMPLIED - --<Title>(T) area grows when full instead of scrolling-- - - nohardbreaks (nohardbreaks) #IMPLIED - --<Title>(T) RETURN moves to next field instead of entering a newline-- - - nosoftbreaks (nosoftbreaks) #IMPLIED - --<Title>(T) soft breaks in wrapping will not be sent to server-- - - numbers (numbers) #IMPLIED - --<Title>(T) forces use of numeric keypad-- - - showkeyboard (showkeyboard) #IMPLIED - --<Title>(T) keyboard pops up automatically when area selected-- - - usestyle (usestyle) #IMPLIED - --<Title>(T) use body font for content-- - - SDAFORM CDATA #FIXED "Para" - --<Title>SDAFORM-024-- - - SDAPREF CDATA #FIXED "Input Text -- #AttVal(Name): " - - --<Title>SDAPREF-015-- - > - -<!ATTLIST KEYGEN - --<Title>html_p~1 - Attribute List-074-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - name CDATA #REQUIRED - --<Title>Name for the name-value pair-- - - challenge CDATA #IMPLIED - --<Title>Challenge string (default is null IA5STRING)-- - > - -<!ATTLIST TABLE - --<Title>html_p~1 - Attribute List-075-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA "no" - --<Title>(left|right|all|no) move down past figures-- - - needs CDATA #IMPLIED - --<Title>minimum width needed in ems or pixels, eg "40 em" or "100 pixels"-- - - align (left , center , right , bleedleft , bleedright , - justify) #IMPLIED - --<Title>table position relative to window-- - - width CDATA #IMPLIED - --<Title>table width relative to window-- - - cols NUMBER #IMPLIED - --<Title>used for immediate display mode-- - - border CDATA #IMPLIED - --<Title>controls frame width around table-- - - frame (void , above , below , hsides , lhs , rhs , vsides , - box , border) #IMPLIED - --<Title>which parts of table frame to include-- - - rules (none , groups , rows , cols , all) #IMPLIED - --<Title>rulings between rows and cols-- - - cellspacing CDATA #IMPLIED - --<Title>spacing between cells-- - - cellpadding CDATA #IMPLIED - --<Title>spacing within cells-- - - colspec CDATA #IMPLIED - --<Title>column widths and alignment-- - - units (en , px , relative) "en" - --<Title>units for column widths-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - valign (top , middle , bottom , baseline) "top" - - --<Title>vertical alignment-- - - noflow (noflow) #IMPLIED - --<Title>noflow around table-- - - nowrap (nowrap) #IMPLIED - --<Title>(N) don't wrap words-- - - bgcolor CDATA #IMPLIED - --<Title>Table background color-- - - bordercolor CDATA #IMPLIED - --<Title>table border color-- - - bordercolorlight CDATA #IMPLIED - --<Title>3D table border color-- - - bordercolordark CDATA #IMPLIED - --<Title>bordercolordark-- - - background CDATA #IMPLIED - --<Title>(T) Image to tile for table background-- - - cellborder NUMBER #IMPLIED - --<Title>(T) set cell border width in pixels-- - - href CDATA #IMPLIED - --<Title>(T) Hypertext link to apply to whole table-- - - name CDATA #IMPLIED - --<Title>(T) Name instead of ID-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - - stubcols NUMBER #IMPLIED - --<Title>(D) so user agent can progressive render-- - - hdrrows NUMBER #IMPLIED - --<Title>(D) for symmetry, tho less important-- - - TblWd CDATA #IMPLIED - --<Title>(AE) Table width-- - - TblHt CDATA #IMPLIED - --<Title>(AE) Table height-- - - TblUnits (percent , pixels , points , picas , mm , cm , - inches) #IMPLIED - --<Title>(AE) Table units-- - --Not known if this is needed: SQTABLE CDATA #FIXED 'TBLBODY'-- - > - -<!ATTLIST CAPTION - --<Title>html_p~1 - Attribute List-076-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (top , bottom) #IMPLIED - --<Title>(H3) location of caption wrt table|figure|etc-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - accesskey CDATA #IMPLIED - --<Title>accessibility key character-- - - SDAPREF CDATA #FIXED "Caption: " - --<Title>SDAPREF-016-- - > - -<!ATTLIST colgroup - --<Title>html_p~1 - Attribute List-077-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - span NUMBER "1" - --<Title>default number of columns in group-- - - width CDATA #IMPLIED - --<Title>default width for enclosed COLs-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for alignment char-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - ColSep (VSingle , VDouble , VTriple , VDash , VDot , - VBold , VBlank , VNone) #IMPLIED - --<Title>(AE) column separation pattern-- - - AlignChr CDATA #IMPLIED - --<Title>(AE) alignment character-- - - CharPos CDATA #IMPLIED - --<Title>(AE) character position-- - - ColWd CDATA #IMPLIED - --<Title>(AE) default width for all cells in all columns-- - - TblUnits (percent , pixels , points , picas , mm , cm , - inches) #IMPLIED - --<Title>(AE) Table units-- - --Not known if this is needed: SQTABLE CDATA #FIXED 'TBLBODY'-- - - TopSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) "HSingle" - --<Title>(AE) default top border for all cells in row 1-- - --unused: SQTABLE CDATA #FIXED 'TBLCDEFS'-- - > - -<!ATTLIST col - --<Title>html_p~1 - Attribute List-078-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - span NUMBER "1" - --<Title>number of columns spanned by group-- - - width CDATA #IMPLIED - --<Title>column width specification-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>alignment-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for alignment char-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - ColSep (VSingle , VDouble , VTriple , VDash , VDot , - VBold , VBlank , VNone) #IMPLIED - --<Title>(AE) column separation pattern-- - - AlignChr CDATA #IMPLIED - --<Title>(AE) alignment character-- - - CharPos CDATA #IMPLIED - --<Title>(AE) character position-- - - ColWd CDATA #IMPLIED - --<Title>(AE) default width for all cells in all columns-- - - TblUnits (percent , pixels , points , picas , mm , cm , - inches) #IMPLIED - --<Title>(AE) Table units-- - --Not known if this is needed: SQTABLE CDATA #FIXED 'TBLBODY'-- - - TopSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) "HSingle" - --<Title>(AE) default top border for all cells in row 1-- - --unused: SQTABLE CDATA #FIXED 'TBLCDEFS'-- - > - -<!ATTLIST thead - --<Title>html_p~1 - Attribute List-079-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for alignment char-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - nowrap (nowrap) #IMPLIED - --<Title>don't wrap words-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - RowSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) #IMPLIED - --<Title>(AE) Inter-row border-- - > - -<!ATTLIST tfoot - --<Title>html_p~1 - Attribute List-080-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for alignment char-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - nowrap (nowrap) #IMPLIED - --<Title>don't wrap words-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - RowSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) #IMPLIED - --<Title>(AE) Inter-row border-- - > - -<!ATTLIST tbody - --<Title>html_p~1 - Attribute List-081-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for alignment char-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - nowrap (nowrap) #IMPLIED - --<Title>don't wrap words-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - RowSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) #IMPLIED - --<Title>(AE) Inter-row border-- - > - -<!ATTLIST tr - --<Title>html_p~1 - Attribute List-082-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for horizontal alignment in cells-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - nowrap (nowrap) #IMPLIED - --<Title>don't wrap words-- - - bgcolor CDATA #IMPLIED - --<Title>background color for cell-- - - bordercolor CDATA #IMPLIED - --<Title>cell border color-- - - bordercolorlight CDATA #IMPLIED - --<Title>3D cell border color-- - - bordercolordark CDATA #IMPLIED - --<Title>bordercolordark-002-- - - width CDATA #IMPLIED - --<Title>cell width-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - - rowaxes CDATA #IMPLIED - --<Title>(D) to indicate the distinguishing row part of td axes value-- - - ColSep (VSingle , VDouble , VTriple , VDash , VDot , - VBold , VBlank , VNone) #IMPLIED - --<Title>(AE) column separation pattern-- - - RowSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) #IMPLIED - --<Title>(AE) Inter-row border-- - > - -<!ATTLIST th - --<Title>html_p~1 - Attribute List-083-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - axis CDATA #IMPLIED - --<Title>defaults to cell content-- - - axes CDATA #IMPLIED - --<Title>list of axis names-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - nowrap (nowrap) #IMPLIED - --<Title>suppress word wrap-- - - bgcolor CDATA #IMPLIED - --<Title>cell background color-- - - rowspan NUMBER "1" - --<Title>number of rows spanned by cell-- - - colspan NUMBER "1" - --<Title>number of cols spanned by cell-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for horizontal alignment in cells-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - rowstart NUMBER #IMPLIED - --<Title>(AE) edit control-- - - colstart NUMBER #IMPLIED - --<Title>colstart-- - - bordercolor CDATA #IMPLIED - --<Title>cell border color-- - - bordercolorlight CDATA #IMPLIED - --<Title>3D cell border color-- - - bordercolordark CDATA #IMPLIED - --<Title>bordercolordark-003-- - - width CDATA #IMPLIED - --<Title>cell width-- - - absheight NUMBER #IMPLIED - --<Title>(T) height of cell, presumably in pixels-- - - abswidth NUMBER #IMPLIED - --<Title>(T) width of cell, presumably in pixels-- - - maxlines NUMBER #IMPLIED - --<Title>(T) max lines to display in cell-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - - ColSep (VSingle , VDouble , VTriple , VDash , VDot , - VBold , VBlank , VNone) #IMPLIED - --<Title>(AE) column separation pattern-- - - RowSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) #IMPLIED - --<Title>(AE) Inter-row border-- - - AlignChr CDATA #IMPLIED - --<Title>(AE) alignment character-- - - CharPos CDATA #IMPLIED - --<Title>(AE) character position-- - - ColWd CDATA #IMPLIED - --<Title>(AE) default width for all cells in all columns-- - - TblUnits (percent , pixels , points , picas , mm , cm , - inches) #IMPLIED - --<Title>(AE) Table units-- - --Not known if this is needed: SQTABLE CDATA #FIXED 'TBLBODY'-- - > - -<!ATTLIST td - --<Title>html_p~1 - Attribute List-084-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - axis CDATA #IMPLIED - --<Title>defaults to cell content-- - - axes CDATA #IMPLIED - --<Title>list of axis names-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - nowrap (nowrap) #IMPLIED - --<Title>suppress word wrap-- - - bgcolor CDATA #IMPLIED - --<Title>cell background color-- - - rowspan NUMBER "1" - --<Title>number of rows spanned by cell-- - - colspan NUMBER "1" - --<Title>number of cols spanned by cell-- - - align (left , center , right , justify , char) - #IMPLIED - --<Title>align-- - - char CDATA #IMPLIED - --<Title>alignment char, e.g. char=':'-- - - charoff CDATA #IMPLIED - --<Title>offset for horizontal alignment in cells-- - - valign (top , middle , bottom , baseline) #IMPLIED - --<Title>vertical alignment in cells-- - - dp CDATA #IMPLIED - --<Title>decimal point e.g. dp=","-- - - rowstart NUMBER #IMPLIED - --<Title>(AE) edit control-- - - colstart NUMBER #IMPLIED - --<Title>colstart-002-- - - bordercolor CDATA #IMPLIED - --<Title>cell border color-- - - bordercolorlight CDATA #IMPLIED - --<Title>3D cell border color-- - - bordercolordark CDATA #IMPLIED - --<Title>bordercolordark-004-- - - width CDATA #IMPLIED - --<Title>cell width-- - - absheight NUMBER #IMPLIED - --<Title>(T) height of cell, presumably in pixels-- - - abswidth NUMBER #IMPLIED - --<Title>(T) width of cell, presumably in pixels-- - - background CDATA #IMPLIED - --<Title>(T) Image to tile for table background-- - - maxlines NUMBER #IMPLIED - --<Title>(T) max lines to display in cell-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - - ColSep (VSingle , VDouble , VTriple , VDash , VDot , - VBold , VBlank , VNone) #IMPLIED - --<Title>(AE) column separation pattern-- - - RowSep (HSingle , HDouble , HTriple , HDash , HDot , - HBold , HBlank , HNone) #IMPLIED - --<Title>(AE) Inter-row border-- - - AlignChr CDATA #IMPLIED - --<Title>(AE) alignment character-- - - CharPos CDATA #IMPLIED - --<Title>(AE) character position-- - - ColWd CDATA #IMPLIED - --<Title>(AE) default width for all cells in all columns-- - - TblUnits (percent , pixels , points , picas , mm , cm , - inches) #IMPLIED - --<Title>(AE) Table units-- - --Not known if this is needed: SQTABLE CDATA #FIXED 'TBLBODY'-- - > - -<!ATTLIST FIG - --<Title>html_p~1 - Attribute List-085-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - border CDATA #IMPLIED - --<Title>controls frame width around figure-- - - clear CDATA #IMPLIED - --<Title>for control of text flow-- - - src CDATA #IMPLIED - --<Title>URI of image to embed-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - isobject (isobject) #IMPLIED - --<Title>(L) Figure is an object-- - - width NUMBER #IMPLIED - --<Title>desired width in units-- - - height NUMBER #IMPLIED - --<Title>desired height in units-- - - units (en , pixels) "pixels" - --<Title>specifies units as en's or pixels-- - - align (bleedleft , left , center , right , bleedright , - justify) "center" - --<Title>align-002-- - - noflow (noflow) #IMPLIED - --<Title>noflow around figure-- - - imagemap (CDATA) #IMPLIED - --<Title>imagemap-- - - fileformat NOTATION (GIF , JPG , DVI , BMP , EPS , PNG , - PICT , TIFF , XBM , XPM) #IMPLIED - --<Title>Format of figure if not implicit-- - > - -<!ATTLIST OVERLAY - --<Title>html_p~1 - Attribute List-086-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - src CDATA #REQUIRED - --<Title>URI of image overlay-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - units (en , pixels) "pixels" - --<Title>specifies units as en's or pixels-- - - x NUMBER "0" - --<Title>offset from left in units-- - - y NUMBER "0" - --<Title>offset from top in units-- - - width NUMBER #IMPLIED - --<Title>desired width in units-- - - height NUMBER #IMPLIED - --<Title>desired height in units-- - - imagemap (CDATA) #IMPLIED - --<Title>imagemap-002-- - - fileformat NOTATION (GIF , JPG , DVI , BMP , EPS , PNG , - PICT , TIFF , XBM , XPM) #IMPLIED - --<Title>(P)Format of overlay image file if not implicit-- - > - -<!ATTLIST CREDIT - --<Title>html_p~1 - Attribute List-087-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (left , right , center , justify) #IMPLIED - --<Title>Horizontal alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAFORM CDATA #FIXED "Fn" - --<Title>(O)SDAFORM-- - > - -<!ATTLIST FIGTEXT - --<Title>html_p~1 - Attribute List-088-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST A - --<Title>html_p~1 - Attribute List-089-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - href CDATA #IMPLIED - --<Title>URL for linked resource. RFC1808 (June 95) and RFC1738 (Dec 94)-- - - urn CDATA #IMPLIED - --<Title>URN when available-- - - name CDATA #IMPLIED - --<Title>Named link end-- - - rel CDATA #IMPLIED - --<Title>forward link types-- - - rev CDATA #IMPLIED - --<Title>reverse link types-- - - ismap (ismap) #IMPLIED - --<Title>Use server image map-- - - md CDATA #IMPLIED - --<Title>message digest for linked object-- - - target CDATA #IMPLIED - --<Title>(N) name for the target window-- - - type CDATA #IMPLIED - --<Title>Internet media type-- - - accesskey CDATA #IMPLIED - --<Title>accessibility key character-- - - shape (rect , circle , poly , default) "rect" - - --<Title>For use with OBJECT SHAPES-- - - coords CDATA #IMPLIED - --<Title>coords-- - - tabindex NUMBER #IMPLIED - --<Title>Position in tabbing order-- - - notab (notab) #IMPLIED - --<Title>Exclude from tabbing order-- - - onClick CDATA #IMPLIED - --<Title>intrinsic event-- - - onMouseOver CDATA #IMPLIED - --<Title>onMouseOver-- - - onMouseOut CDATA #IMPLIED - --<Title>onMouseOut-- - - nocolor (nocolor) #IMPLIED - --<Title>(T)defeats LINK color-- - - selected (selected) #IMPLIED - --<Title>(T)specifies this link is highlighted when 2+ appear on screen-- - - bulletin-date CDATA #IMPLIED - --<Title>(B) HTTP-format date/time of posting-- - - bulletin-text CDATA #IMPLIED - --<Title>(B) text to display-- - - bulletin-expires CDATA #IMPLIED - --<Title>(B) HTTP-format expiration date/time-- - - bulletin-image CDATA #IMPLIED - --<Title>(B) URL for a visual bulletin-- - - bulletin-href CDATA #IMPLIED - --<Title>(B) URL for a link to bulletin-- - - SDAPREF CDATA #FIXED "<Anchor: #AttList>" - - --<Title>SDAPREF-017-- - > - -<!ATTLIST CITE - --<Title>html_p~1 - Attribute List-090-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - key IDREF #IMPLIED - --<Title>Link to source-- - - SDAFORM CDATA #FIXED "It" - --<Title>SDAFORM-025-- - > - -<!ATTLIST DFN - --<Title>html_p~1 - Attribute List-091-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - key IDREF #IMPLIED - --<Title>Link to source-- - - SDAFORM CDATA #FIXED "It" - --<Title>SDAFORM-026-- - > - -<!ATTLIST (U , S , STRIKE , BIG , SMALL , SUB , SUP , Q , SPAN , AU , - PERSON , ACRONYM , ABBREV) - --<Title>html_p~1 - Attribute List-092-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST (ENTITY , ELEMENT , ATTRIB) - --<Title>html_p~1 - Attribute List-093-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST (EM , I , VAR , LANG , INS , DEL) - --<Title>html_p~1 - Attribute List-094-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - SDAFORM CDATA #FIXED "It" - --<Title>SDAFORM-027-- - > - -<!ATTLIST (CODE , KBD , SAMP , TT) - --<Title>html_p~1 - Attribute List-095-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - SDAFORM CDATA #FIXED "Lit" - --<Title>SDAFORM-028-- - > - -<!ATTLIST (B , STRONG , BLACKFACE) - --<Title>html_p~1 - Attribute List-096-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - SDAFORM CDATA #FIXED "B" - --<Title>SDAFORM-029-- - > - -<!ATTLIST LIMITTEXT - --<Title>html_p~1 - Attribute List-097-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - size NUMBER #IMPLIED - --<Title>(T) specify width in characters-- - - width NUMBER #IMPLIED - --<Title>(T) specify width in pixels-- - - value CDATA #REQUIRED - --<Title>(T) supplies the text whose value is to be limited-- - > - -<!ATTLIST NOSMARTQUOTES - --<Title>html_p~1 - Attribute List-098-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST SHADOW - --<Title>html_p~1 - Attribute List-099-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST FONT - --<Title>html_p~1 - Attribute List-100-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - size CDATA #IMPLIED - --<Title>[+/-]nn eg size="+1", size="4", size="-2"; range is 1 thru 7-- - - color CDATA #IMPLIED - --<Title>#RRGGBB in hex, e.g. red: color="#FF0000"-- - - end CDATA #IMPLIED - --<Title>end-002-- - - face CDATA #IMPLIED - --<Title>comma separated list of font names-- - - effect (relief , emboss , shadow) #IMPLIED - --<Title>(T) variant-- - - transparency NUMBER "0" - --<Title>(T) degree of transparency (0=opaque, 100=clear)-- - > - -<!ATTLIST SPOT - --<Title>html_p~1 - Attribute List-101-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST TAB - --<Title>html_p~1 - Attribute List-102-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - indent NUMBER "0" - --<Title>en units before new tab stop-- - - to IDREF #IMPLIED - --<Title>jump to same location as a previous tab stop with this ID value-- - - align (left , center , right , decimal) "left" - - --<Title>what kind of alignment-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - dp CDATA #IMPLIED - --<Title>specify the decimal point e.g. dp=","-- - > - -<!ATTLIST MATH - --<Title>html_p~1 - Attribute List-103-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - box CDATA #IMPLIED - --<Title>box-- - - position (display , inline) #REQUIRED - --<Title>Position in the paragraph-- - > - -<!ATTLIST BOX - --<Title>html_p~1 - Attribute List-104-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - size (normal , medium , large , huge) "normal" - - --<Title>Delimiter size-- - > - -<!ATTLIST ABOVE - --<Title>html_p~1 - Attribute List-105-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - sym ENTITY #IMPLIED - --<Title>Symbol (character entity reference) from ISOams*-- - > - -<!ATTLIST BELOW - --<Title>html_p~1 - Attribute List-106-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - sym ENTITY #IMPLIED - --<Title>Symbol (character entity reference) from ISOams*-- - > - -<!ATTLIST ARRAY - --<Title>html_p~1 - Attribute List-107-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align (top , middle , bottom) "middle" - - --<Title>align-003-- - - coldef CDATA #IMPLIED - --<Title>Column alignment and separator-- - - ldelim CDATA #IMPLIED - --<Title>Stretchy left delimiter-- - - rdelim CDATA #IMPLIED - --<Title>Stretchy right delimiter-- - - labels (labels) #IMPLIED - --<Title>TeX's \bordermatrix style-- - > - -<!ATTLIST ROW - --<Title>html_p~1 - Attribute List-108-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST ITEM - --<Title>html_p~1 - Attribute List-109-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - align CDATA #IMPLIED - --<Title>Override coldef alignment-- - - colspan NUMBER "1" - --<Title>Span columns as in TABLE-- - - rowspan NUMBER "1" - --<Title>Span rows as in TABLE-- - > - -<!ATTLIST (T , BT) - --<Title>html_p~1 - Attribute List-110-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - > - -<!ATTLIST XMP - --<Title>html_p~1 - Attribute List-111-- - - clear CDATA #IMPLIED - --<Title>(H3) control of text flow-- - - SDAFORM CDATA #FIXED "Lit" - --<Title>SDAFORM-030-- - - SDAPREF CDATA #FIXED "Example: " - --<Title>SDAPREF-018-- - > - -<!ATTLIST LISTING - --<Title>html_p~1 - Attribute List-112-- - - id ID #IMPLIED - --<Title>Document-wide unique ID-- - - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - - dir (ltr , rtl) #IMPLIED - --<Title>Directionality-- - - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - - clear CDATA #IMPLIED - --<Title>(H3)control of text flow-- - - SDAFORM CDATA #FIXED "Lit" - --<Title>SDAFORM-031-- - - SDAPREF CDATA #FIXED "Listing: " - --<Title>SDAPREF-019-- - > - -<!ATTLIST PLAINTEXT - --<Title>html_p~1 - Attribute List-113-- - - SDAFORM CDATA #FIXED "Lit" - --<Title>SDAFORM-032-- - > - -<!NOTATION GIF SYSTEM "gif" - --<Title>Compu$erve Graphics Interchange Format-- - > - -<!NOTATION JPEG SYSTEM "jpg" - --<Title>Joint Photographic Experts Group-- - > - -<!NOTATION EPS SYSTEM "eps" - --<Title>Encapsulated Adobe PostScript-- - > - -<!NOTATION DVI SYSTEM "dvi" - --<Title>TeX typesetting system binary typeset format-- - > - -<!NOTATION BMP SYSTEM "bmp" - --<Title>Microsoft Windows BitMap-- - > - -<!NOTATION PNG SYSTEM "png" - --<Title>Portable Network Graphics-- - > - -<!NOTATION TIFF SYSTEM "tif" --<Title>Tagged Image Format-- > - -<!NOTATION PICT SYSTEM "pict" --<Title>Apple Mac Picture-- > - -<!NOTATION XBM SYSTEM "xbm" - --<Title>X Window system bitmap-- - > - -<!NOTATION XPM SYSTEM "xpm" - --<Title>X Window system pixmap-- - > - -<!NOTATION AU SYSTEM "au" --<Title>UNIX audio-- > - -<!NOTATION SND SYSTEM "snd" --<Title>Apple Mac SouND-- > - -<!NOTATION WAV SYSTEM "wav" --<Title>Windows WAVe audio-- > - -<!NOTATION MOV SYSTEM "mov" --<Title>Windows Movie-- > - -<!NOTATION MPEG SYSTEM "mpg" - --<Title>Motion Picture Experts Group (video) file-- - > - -<!NOTATION VIV SYSTEM "viv" --<Title>Vivo Video format-- > - -<!NOTATION CSS1 SYSTEM "css" - --<Title>Cascading Style Sheets-- - > - -<!NOTATION DSSSL SYSTEM "dsssl" - --<Title>Document Style and Semantics Specification Language (ISO 10179)-- - > - -<!ENTITY % thisversion - ' - VERSION CDATA #FIXED "+//Silmaril//DTD HTML Pro v0r11 19970101//EN" - ' - --<Title>the current version of the DTD-- - > - -<!ENTITY % commonatts - " - id ID #IMPLIED - --<Title>Document-wide unique ID-- - class NAMES #IMPLIED - --<Title>Comma-separated list of classes-- - style CDATA #IMPLIED - --<Title>Style info for this occurrence only-- - title CDATA #IMPLIED - --<Title>Advisory title (rec'd max 64 chars)-- - lang NAME #IMPLIED - --<Title>RFC 1766 language value-- - dir (ltr,rtl) #IMPLIED - --<Title>Directionality-- - noindex (noindex) #IMPLIED - --<Title>Defeats robot indexing-- - " - --<Title>attributes common to all elements-- - > - -<!ENTITY % horiz.align - " - align (left,right,center,justify) #IMPLIED - --<Title>Horizontal alignment-- - " - --<Title>horizontal alignment on some structural elements-- - > - -<!ENTITY % vert.align - ' - align (top,middle,bottom) "middle" - --<Title>Vertical alignment-- - ' - --<Title>vertical alignment on some elements-- - > - -<!ENTITY % SDAFORM " - SDAFORM CDATA #FIXED - " - --<Title>One to one mapping-- - > - -<!ENTITY % SDAPREF " - SDAPREF CDATA #FIXED - " - --<Title>Generated text prefix-- - > - -<!ENTITY % SDARULE " - SDARULE CDATA #FIXED - " - --<Title>Context-sensitive mapping-- - > - -<!ENTITY % SDASUFF " - SDASUFF CDATA #FIXED - " - --<Title>Generated text suffix-- - > - -<!ENTITY % SDASUSP " - SDASUSP NAME #FIXED - " - --<Title>Suspend transform process-- - > - -<!ENTITY % VBorder - "(VSingle|VDouble|VTriple|VDash|VDot|VBold|VBlank|VNone)" - --<Title>VBorder-- - > - -<!ENTITY % HBorder - "(HSingle|HDouble|HTriple|HDash|HDot|HBold|HBlank|HNone)" - --<Title>HBorder-- - > - -<!ENTITY % TblUnit "(percent|pixels|points|picas|mm|cm|inches)" - --<Title>TblUnit-- - > - -<!ENTITY zwnj CDATA " " - --<Title>=zero width non-joiner-- - --=zero width non-joiner-- - > - -<!ENTITY zwj CDATA " -" - --<Title>=zero width joiner-- --=zero width joiner-- - > - -<!ENTITY lrm CDATA "¢ - ¼Ôéôìå¾½ìåæôôïòéçèô íáòë ½ìåæôôïòéçèô íáòë - ¾ - -¼¡ÅÎÔÉÔÙ òìí ÃÄÁÔÁ ¢" - --<Title>=right-to-left mark-- --=right-to-left mark-- - > - -<!ENTITY amp CDATA "&" - --<Title>(H1) ampersand-- - > - -<!ENTITY lt CDATA "<" - --<Title>(H1) less-than-- - > - -<!ENTITY gt CDATA ">" - --<Title>(H1) greater-than-- - > - -<!ENTITY quot CDATA '"' - --<Title>(I) internationalised application-dependent double-quote-- - > - -<!ENTITY nbsp CDATA " " - --<Title>(H3) non-breaking space-- - > - -<!ENTITY copy CDATA "(C)" - --<Title>(I) copyright symbol-- - > - -<!ENTITY reg CDATA "(R)" - --<Title>(I) registered symbol-- - > - -<!ENTITY % ISOlat1 PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN" - --<Title>Latin-1 (accented) characters-- - > - -<!ENTITY % ISOlat2 PUBLIC "ISO 8879-1986//ENTITIES Added Latin 2//EN" - --<Title>Latin-2 more accented characters-- - > - -<!ENTITY % ISOpub PUBLIC "ISO 8879-1986//ENTITIES Publishing//EN" - --<Title>Publishers' symbols-- - > - -<!ENTITY % ISOtech PUBLIC - "ISO 8879-1986//ENTITIES General Technical//EN" - --<Title>Technical symbols-- - > - -<!ENTITY % ISOnum PUBLIC - "ISO 8879-1986//ENTITIES Numeric and Special Graphic//EN" - --<Title>Numeric and graphic symbols-- - > - -%ISOlat1; -%ISOlat2; -%ISOpub; -%ISOtech; -%ISOnum;
--- a/etc/sgml/ie30-s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -<!-- html-s.dtd - - Document Type Definition for the HyperText Markup Language - with strict validation (HTML Strict DTD). - - $Id: ie30-s.dtd,v 1.1 1997/03/16 01:18:16 steve Exp $ - - Author: Daniel W. Connolly <connolly@w3.org> - See Also: http://www.w3.org/hypertext/WWW/MarkUp/MarkUp.html ---> - -<!ENTITY % HTML.Version - "-//IETF//DTD HTML 2.0 Strict//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//IETF//DTD HTML Strict//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html PUBLIC "-//IETF//DTD HTML 2.0//EN"> -%html;
--- a/etc/sgml/ie30.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,867 +0,0 @@ -<!-- - Microsoft Document Type Definition for Internet Explorer 3.0 HTML. - - Version: 0.9 Date: 11/7/96 - - Author: Mark Buckley <mbuckley@microsoft.com> - - This markup is based as much as possible on the DTD for HTML 3. -2 - published by W3C (also known as the Wilbur DTD), dated 5/31/96. ---> - -<!ENTITY % HTML.Version - "-//Microsoft//DTD Internet Explorer 3.0 HTML//EN" > - -<!--================== Deprecated Features Switch =========================--> - -<!ENTITY % HTML.Recommended "IGNORE" > - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE"> - -<!--================== Imported Names =====================================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning a MIME content type, as per RFC1521 - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification - --> - -<!ENTITY % URL "CDATA" - -- The term URL means a CDATA attribute - whose value is a Uniform Resource Locator, - See RFC1808 (June 95) and RFC1738 (Dec 94). - --> - -<!--========= Common attributes ============================================--> - -<!ENTITY % attrs -- common attributes. Taken from the HTML 3 DTD -- - 'id ID #IMPLIED -- as target for hrefs (link ends) -- - lang CDATA "en.us" -- ISO language, country code -- - class NAMES #IMPLIED -- for subclassing elements -- - style CDATA #IMPLIED'> - -<!--========= Color attribute ============================================--> - -<!ENTITY % color "CDATA" -- a color specification: #HHHHHH @@ details? --> - - -<!--================ Character mnemonic entities ==========================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!--================ Entities for special symbols =========================--> -<!-- &trade ­ and &cbsp are not widely deployed and so not included here --> - -<!ENTITY copy CDATA "©" -- copyright sign --> -<!ENTITY reg CDATA "®" -- registered sign --> -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> -<!ENTITY nbsp CDATA " " -- non breaking space --> - -<!-- Parameter Entities --> - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - - -<!--=================== Text Content =======================================--> - -<![ %HTML.Deprecated [ -<!ENTITY % font "TT | I | B | U | STRIKE | BIG | SMALL | SUB | SUP | FONT | S" -> -]]> - -<!ENTITY % font "TT | I | B | U | STRIKE | BIG | SMALL | SUB | SUP | FONT"> - -<![ %HTML.Deprecated [ - <!ENTITY % phrase "EM | STRONG | DFN |CODE | SAMP | KBD | VAR | CITE | -ENTITY"> -]]> - -<!ENTITY % phrase "EM | STRONG | DFN | CODE | SAMP | KBD | VAR | CITE | SPAN"> - -<!ENTITY % break "BR | NOBR | WBR" > - -<!ENTITY % anchors "A" > - -<![ %HTML.Deprecated [ -<!ENTITY % mmobjects "IMG | APPLET | SCRIPT | NOSCRIPT | MAP | BGSOUND | MARQUE -E | OBJECT | EMBED" > -]]> - -<!ENTITY % mmobjects "IMG | APPLET | SCRIPT | NOSCRIPT | MAP | BGSOUND | MARQUE -E | OBJECT" > - -<!ENTITY % formitems "INPUT | SELECT | TEXTAREA"> - -<![ %HTML.Deprecated [ - <!ENTITY % text "#PCDATA | %font | %phrase | %break | %anchors | %mmobj -ects | %formitems"> -]]> - -<!ENTITY % text "#PCDATA | %font | %phrase | %break | %anchors | %mmobjects"> - -<!--=================== Flow Content =======================================--> - -<!ENTITY % list "UL | OL | DL | DIR | MENU"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING | PLAINTEXT"> -]]> - -<!ENTITY % preformatted "PRE"> - - -<![ %HTML.Deprecated [ -<!ENTITY % block - "P | %list | %preformatted | DIV | BLOCKQUOTE | FORM | ISINDEX | - HR | TABLE | IFRAME | CENTER"> -]]> - -<!ENTITY % block - "P | %list | %preformatted | DIV | BLOCKQUOTE | FORM | ISINDEX | - HR | TABLE | IFRAME"> - - -<![ %HTML.Deprecated [ -<!ENTITY % mixed.content "(%heading|%text|%block|ADDRESS|BASEFONT)*" > -]]> - -<!-- %flow is used for DD and LI --> - -<![ %HTML.Deprecated [ -<!ENTITY % flow "(%mixed.content)*"> -]]> - -<!ENTITY % flow "(%text | %block)*"> - -<![ %HTML.Deprecated [ -<!ENTITY % font.content "(%mixed.content)*"> -]]> - -<!ENTITY % font.content "(%text)*"> - - -<!-- Text Elements --> - -<!ELEMENT (%font) - - %font.content > - -<!ATTLIST FONT - %attrs; - size CDATA #IMPLIED -- [+]nn e.g. size="+1", size=4 -- - color %color #IMPLIED -- #RRGGBB in hex, e.g. red: color="#FF0000 -" -- - face CDATA #IMPLIED - > - -<!ATTLIST (TT | I | B | U | STRIKE | BIG | SMALL | SUB | SUP) - %attrs; - size CDATA #IMPLIED -- [+]nn e.g. size="+1", size=4 -- - color %color #IMPLIED -- #RRGGBB in hex, e.g. red: color="#FF0000 -" -- - face CDATA #IMPLIED - > - -<![ %HTML.Deprecated [ - <!ATTLIST S - %attrs; - > -]]> - -<!ELEMENT (%phrase) - - (%text)*> -<!ATTLIST (%phrase) - %attrs; - > - -<!ELEMENT (%break) - O EMPTY -- forced line break --> - -<!ATTLIST BR - %attrs; - clear (left|all|right|none) none -- control of text flow -- - > - -<!ATTLIST (NOBR | WBR) - %attrs; - > - -<!--=================== Document Body =====================================--> - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(%heading|%block|%mmobjects|ADDRESS|BASEFONT)* -" > -]]> - -<![ %HTML.Deprecated [ -<!ENTITY % body.content "%mixed.content" > -]]> - -<!ENTITY % body-color-attrs " - bgcolor %color #IMPLIED - text %color #IMPLIED - link %color #IMPLIED - vlink %color #IMPLIED - alink %color #IMPLIED - "> - -<!ELEMENT BODY O O %body.content> -<!ATTLIST BODY - %attrs; - background %URL #IMPLIED -- texture tile for document backgrou -nd -- - %body-color-attrs; -- bgcolor, text, link, vlink, alink -- - bgproperties CDATA #IMPLIED - leftmargin NUMBER #IMPLIED - topmargin NUMBER #IMPLIED - > - -<![ %HTML.Deprecated [ - <!ENTITY % address.content "((%text;) | P | CENTER)*"> -]]> - -<!ENTITY % address.content "((%text;) | P )*"> - -<!ELEMENT ADDRESS - - %address.content> -<!ATTLIST ADDRESS - %attrs; - > - -<!ELEMENT DIV - - %body.content> -<!ATTLIST DIV - %attrs - align (left|center|right) left -- alignment of following text -- - > - -<![ %HTML.Deprecated [ - <!-- CENTER is a shorthand for DIV with ALIGN=CENTER --> - <!ELEMENT center - - %mixed.content> - <!ATTLIST center - %attrs - > -]]> - -<!--================== The Anchor Element =================================--> - -<!ELEMENT A - - (%text)* -(A)> -<!ATTLIST A - %attrs - name CDATA #IMPLIED -- named link end -- - href %URL #IMPLIED -- URL for linked resource -- - rel CDATA #IMPLIED -- forward link types -- - rev CDATA #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - target CDATA #IMPLIED -- frame target -- - > - -<!--================== Client-side image maps ============================--> - -<!-- These can be placed in the same document or grouped in a - separate document although this isn't yet widely supported --> - -<!ENTITY % SHAPE "(rect|rectangle|circ|circle|poly|polygon|default)"> -<!ENTITY % COORDS "CDATA" -- comma separated list of numbers --> - -<!ELEMENT MAP - - (AREA)*> -<!ATTLIST MAP - name CDATA #IMPLIED - > - -<!ELEMENT AREA - O EMPTY> -<!ATTLIST AREA - %attrs - shape %SHAPE rect - coords %COORDS #IMPLIED -- always needed except for shape=default -- - href %URL #IMPLIED -- this region acts as hypertext link -- - nohref (nohref) #IMPLIED -- this region has no action -- - alt CDATA #IMPLIED - target CDATA #IMPLIED - > - -<!--================== The LINK Element ==================================--> - -<!ENTITY % Types "CDATA" - -- See Internet Draft: draft-ietf-html-relrev-00.txt - LINK has been part of HTML since the early days - although few browsers as yet take advantage of it. - - Relationship values can be used in principle: - - a) for document specific toolbars/menus when used - with the LINK element in document head: - b) to link to a separate style sheet (rel=stylesheet) - c) to make a link to a script (rel=script) - d) by stylesheets to control how collections of - html nodes are rendered into printed documents - e) to make a link to a printable version of this document - e.g. a postscript or pdf version (rel=print) ---> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - %attrs; - href %URL #IMPLIED -- URL for linked resource -- - rel %Types #IMPLIED -- forward link types -- - rev %Types #IMPLIED -- reverse link types -- - title CDATA #IMPLIED -- advisory title string -- - > - -<!--=================== Images ============================================--> - -<!ENTITY % Length "CDATA" -- nn for pixels or nn% for percentage length --> -<!ENTITY % Pixels "CDATA" -- integer representing length in pixels --> - -<!-- Suggested widths are used for negotiating image size - with the module responsible for painting the image. - align=left or right cause image to float to margin - and for subsequent text to wrap around image --> - -<!ENTITY % IAlign "(top|middle|bottom|left|right)"> - -<!ELEMENT IMG - O EMPTY -- Embedded image --> -<!ATTLIST IMG - %attrs; - src %URL #REQUIRED -- URL of image to embed -- - alt CDATA #IMPLIED -- for display in place of image -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #IMPLIED -- suggested height in pixels -- - width %Pixels #IMPLIED -- suggested width in pixels -- - border %Pixels #IMPLIED -- suggested link border width -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - usemap %URL #IMPLIED -- use client-side image map -- - ismap (ismap) #IMPLIED -- use server image map -- - dynsrc %URL #IMPLIED -- URL of image to embed -- - start NAMES #IMPLIED - loop NMTOKEN #IMPLIED - controls (controls) #IMPLIED - vrml CDATA #IMPLIED - > - -<!-- USEMAP points to a MAP element which may be in this document - or an external document, although the latter is not widely supported --> - -<!--=================== Java APPLET tag ===================================--> -<!-- - This tag is supported by all java enabled browsers. Applet resources - (including their classes) are normally loaded relative to the document - URL (or <BASE> element if it is defined). The CODEBASE attribute is used - to change this default behavior. If the CODEBASE attribute is defined then - it specifies a different location to find applet resources. The value - can be an absolute URL or a relative URL. The absolute URL is used as is - without modification and is not effected by the documents <BASE> element. - When the codebase attribute is relative, then it is relative to the - document URL (or <BASE> tag if defined). <TEXTFLOW> avoids the problems - with SGML mixed content. It can always be omitted *except* when the APPLET - element hasn't any content. White space, comments and PARAM elements - don't count as content for this purpose. TEXTFLOW was introduced into - the DTD to satisfy SGML parsers, but is ignored by current Web browsers. ---> -<!ELEMENT APPLET - - (PARAM*, TEXTFLOW)> -<!ATTLIST APPLET - %attrs - codebase %URL #IMPLIED -- code base -- - code CDATA #REQUIRED -- class file -- - name CDATA #IMPLIED -- applet name -- - alt CDATA #IMPLIED -- for display in place of applet -- - align %IAlign #IMPLIED -- vertical or horizontal alignment -- - height %Pixels #REQUIRED -- suggested height in pixels -- - width %Pixels #REQUIRED -- suggested width in pixels -- - hspace %Pixels #IMPLIED -- suggested horizontal gutter -- - vspace %Pixels #IMPLIED -- suggested vertical gutter -- - border NUMBER #IMPLIED - > - - -<!ELEMENT TEXTFLOW O O (%text)* -- needed to bypass mixed content model --> - -<!-- -Here is an example: - - <applet codebase="applets/NervousText" - code=NervousText.class - width=300 - height=50> - <param name=text value="Java is Cool!"> - <img src=sorry.gif alt="This looks better with Java support"> - </applet> ---> - -<!--=================== Horizontal Rule ===================================--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - %attrs; - align (left|right|center) #IMPLIED - noshade (noshade) #IMPLIED - size %Pixels #IMPLIED - width %Length #IMPLIED - color %color #IMPLIED - > - -<!--=================== Paragraphs=========================================--> - -<![ %HTML.Deprecated [ - <!ENTITY % P.content "(%text|CENTER)*" > -]]> - -<!ENTITY % P.content "(%text)*" > - -<!ELEMENT P - O %P.content > -<!ATTLIST P - %attrs; - align (left|center|right) #IMPLIED - > - - -<!--=================== Base Font =========================================--> - -<!ELEMENT BASEFONT - O EMPTY> -<!ATTLIST BASEFONT - %attrs; - size NUMBER #IMPLIED - color %color #IMPLIED - face CDATA #IMPLIED - > - -<!--=================== Background Sound =================================--> - -<!ELEMENT BGSOUND - O EMPTY> -<!ATTLIST BGSOUND - %attrs; - src %URL #IMPLIED - loop NMTOKEN #IMPLIED - start CDATA #IMPLIED - > - -<!--=================== Marquee =========================================--> - -<!ELEMENT MARQUEE - O (%text)*> -<!ATTLIST MARQUEE - %attrs; - align (top|middle|bottom) top - behavior (scroll|slide|alternate) SCROLL - bgcolor %color #IMPLIED - direction (left|right) LEFT - height CDATA #IMPLIED - hspace NUMBER #IMPLIED - loop CDATA #IMPLIED - scrollamount NUMBER #IMPLIED - scrolldelay NUMBER #IMPLIED - vspace NUMBER #IMPLIED - width CDATA #IMPLIED - border NUMBER #IMPLIED - background %URL #IMPLIED -- texture tile for document background -- - > - -<!--=================== Headings ==========================================--> - -<!-- - There are six levels of headers from H1 (the most important) - to H6 (the least important). ---> - -<!ELEMENT ( %heading ) - - %P.content > -<!ATTLIST ( %heading ) - %attrs - align (left|center|right) #IMPLIED - > - -<!--=================== Preformatted Text =================================--> - -<!-- excludes images and changes in font size --> - -<!ENTITY % pre.exclusion "IMG|BIG|SMALL|SUB|SUP|FONT"> - -<!ELEMENT PRE - - (%text)* -(%pre.exclusion)> -<!ATTLIST PRE - %attrs; - width NUMBER #implied - > - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ELEMENT PLAINTEXT - O %literal> - -<!ATTLIST (XMP|LISTING|PLAINTEXT) - %attrs; - > - -]]> - -<!--=================== Block-like Quotes =================================--> - -<!ELEMENT BLOCKQUOTE - - %body.content> -<!ATTLIST BLOCKQUOTE - %attrs; - > - -<!--=================== Lists =============================================--> - -<!-- - HTML 3.2 allows you to control the sequence number for ordered lists. - You can set the sequence number with the START and VALUE attributes. - The TYPE attribute may be used to specify the rendering of ordered - and unordered lists. ---> - -<!-- definition lists - DT for term, DD for its definition --> - -<!ELEMENT DL - - (DT|DD)*> -<!ATTLIST DL - %attrs; - compact (compact) #IMPLIED -- more compact style -- - > - -<!ELEMENT DT - O (%text)*> -<!ATTLIST DT - %attrs; - > - -<!ELEMENT DD - O %flow;> -<!ATTLIST DD - %attrs; - > - -<!-- Ordered lists OL, and unordered lists UL --> -<!ELEMENT (OL|UL) - - (LI)*> - -<!-- - Numbering style - 1 arabic numbers 1, 2, 3, ... - a lower alpha a, b, c, ... - A upper alpha A, B, C, ... - i lower roman i, ii, iii, ... - I upper roman I, II, III, ... - - The style is applied to the sequence number which by default - is reset to 1 for the first list item in an ordered list. - - This can't be expressed directly in SGML due to case folding. ---> - -<!ENTITY % OLStyle "CDATA" -- constrained to: [1|a|A|i|I] --> - -<!ATTLIST OL -- ordered lists -- - %attrs; - type %OLStyle #IMPLIED -- numbering style -- - start NUMBER #IMPLIED -- starting sequence number -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!-- bullet styles --> - -<!ENTITY % ULStyle "disc|square|circle"> - -<!ATTLIST UL -- unordered lists -- - %attrs; - type (%ULStyle) #IMPLIED -- bullet style -- - compact (compact) #IMPLIED -- reduced interitem spacing -- - > - -<!ELEMENT (DIR|MENU) - - (LI)* -(%block)> -<!ATTLIST (DIR|MENU) - %attrs; - compact (compact) #IMPLIED - > - -<!-- The type attribute can be used to change the bullet style - in unordered lists and the numbering style in ordered lists --> - -<!ENTITY % LIStyle "CDATA" -- constrained to: "(%ULStyle|%OLStyle)" --> - -<!ELEMENT LI - O %flow -- list item --> -<!ATTLIST LI - %attrs; - type %LIStyle #IMPLIED -- list item style -- - value NUMBER #IMPLIED -- reset sequence number -- - > - -<!--================ Forms ===============================================--> - -<!ELEMENT FORM - - %body.content -(FORM) +(%formitems)> -<!ATTLIST FORM - %attrs; - action %URL #REQUIRED -- server-side form handler -- - method (%HTTP-Method) GET -- see HTTP specification -- - enctype %Content-Type; "application/x-www-form-urlencoded" - name CDATA #IMPLIED - target CDATA #IMPLIED - > - -<!ENTITY % InputType - "(TEXT | TEXTAREA | PASSWORD | CHECKBOX | RADIO | SUBMIT - | RESET | FILE | HIDDEN | IMAGE)"> - -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - %attrs; - type %InputType TEXT -- what kind of widget is needed -- - name CDATA #IMPLIED -- required for all but submit and reset -- - value CDATA #IMPLIED -- required for radio and checkboxes -- - checked (checked|true|false) #IMPLIED -- for radio buttons and check bo -xes -- - size CDATA #IMPLIED -- specific to each type of field -- - maxlength NUMBER #IMPLIED - src %URL #IMPLIED -- for fields with background images -- - align (top|middle|bottom|left|right) top -- image alignment -- - > - -<!ELEMENT SELECT - - (OPTION+)> -<!ATTLIST SELECT - %attrs; - name CDATA #REQUIRED - size NUMBER #IMPLIED - multiple (multiple) #IMPLIED - > - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - %attrs; - selected (selected) #IMPLIED - value CDATA #IMPLIED -- defaults to element content -- - > - -<!-- Multi-line text input field. --> - -<!ELEMENT TEXTAREA - - (#PCDATA)* -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST TEXTAREA - %attrs; - name CDATA #REQUIRED - rows NUMBER #REQUIRED - cols NUMBER #REQUIRED - > - -<!--======================= Tables ========================================--> - -<!-- Invoke TABLES DTD --> -<!ENTITY % ietables PUBLIC "-//Microsoft//DTD Internet Explorer 3.0 Tables//EN" - > -%ietables; - -<!--================ Document Head ========================================--> - -<!ENTITY % head.misc "SCRIPT|STYLE|META|LINK|BGSOUND" -- repeatable head elemen -ts --> - -<![ %HTML.Deprecated [ - <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & NEXTID?"> -]]> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE?"> - -<!ELEMENT HEAD O O (%head.content) +(%head.misc)> - -<!ELEMENT TITLE - - (#PCDATA)* -(%head.misc) - -- The TITLE element is not considered part of the flow of text. - It should be displayed, for example as the page header or - window title. - --> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - %attrs - prompt CDATA #IMPLIED -- prompt message -- - action CDATA #IMPLIED > - -<!-- - The BASE element gives an absolute URL for dereferencing relative - URLs, e.g. - - <BASE href="http://foo.com/index.html"> - ... - <IMG SRC="images/bar.gif"> - - The image is deferenced to - - http://foo.com/images/bar.gif - - In the absence of a BASE element the document URL should be used. - Note that this is not necessarily the same as the URL used to - request the document, as the base URL may be overridden by an HTTP - header accompanying the document. ---> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - href %URL #REQUIRED - target CDATA #IMPLIED - > - -<![ %HTML.Deprecated [ - <!ELEMENT NEXTID - O EMPTY> - <!ATTLIST NEXTID - N CDATA #REQUIRED > -]]> - -<!ELEMENT META - O EMPTY -- Generic Metainformation --> -<!ATTLIST META - http-equiv NAME #IMPLIED -- HTTP response header name -- - name NAME #IMPLIED -- metainformation name -- - content CDATA #REQUIRED -- associated information -- - charset CDATA #IMPLIED - > - -<!-- SCRIPT/STYLE are place holders for transition to next version of HTML --> - -<!ELEMENT STYLE - - (#PCDATA)* -(%head.misc) -- style info --> -<!ATTLIST STYLE - type CDATA #IMPLIED - title CDATA #IMPLIED > - -<!-- Script markup taken from WD-script-960208 found at - http://www.w3.org/pub/WWW/TR/WD-script.html --> - -<!-- SCRIPT is a character-like element for embedding script code - that can be placed anywhere in the document HEAD or BODY --> - -<!ENTITY % Event "CDATA" -- event name and optional param list --> - -<!ELEMENT SCRIPT - - (#PCDATA)* -(%head.misc)> -<!ATTLIST SCRIPT - %attrs; - type CDATA #IMPLIED -- script language media type -- - language CDATA #IMPLIED -- predefined script language name -- - src %URL #IMPLIED -- URL for an external script -- - name CDATA #IMPLIED - > - -<!ELEMENT NOSCRIPT - - (%body.content)> -<!ATTLIST NOSCRIPT - %attrs; - > - -<!--================ Document Structure ===================================--> - -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<!ELEMENT HTML O O (HEAD, (BODY|FRAMESET) )> -<!ATTLIST HTML - %attrs - %version.attr - > - -<!-- Frames --> - -<!ELEMENT FRAMESET - - (FRAMESET|FRAME|NOFRAMES)+ > -<!ATTLIST FRAMESET - %attrs; - layout (TILES|PAGES) TILES - rows CDATA #IMPLIED - cols CDATA #IMPLIED - framespacing CDATA #IMPLIED - frameborder NUMBER #IMPLIED - > - -<!ELEMENT FRAME - O EMPTY > -<!ATTLIST FRAME - %attrs; - src CDATA #REQUIRED - name CDATA #IMPLIED - height NUMBER #IMPLIED - hspace NUMBER #IMPLIED - width NUMBER #IMPLIED - vspace NUMBER #IMPLIED - marginwidth NUMBER #IMPLIED -- check this -- - marginheight NUMBER #IMPLIED -- check this -- - frameborder CDATA #IMPLIED -- need to check with IE -- - framespacing NUMBER #IMPLIED - scrolling (YES|NO|AUTO) AUTO - noresize (NORESIZE) #IMPLIED - align (LEFT|CENTER|RIGHT|TOP|TEXTTOP|MIDDLE|ABSMIDDLE| - BASELINE|BOTTOM|ABSBOTTOM) #IMPLIED - > - -<!ELEMENT IFRAME - O EMPTY > -<!ATTLIST IFRAME - %attrs; - src CDATA #REQUIRED - name CDATA #IMPLIED - marginwidth NUMBER #IMPLIED - marginheight NUMBER #IMPLIED - border CDATA #IMPLIED - frameborder CDATA #IMPLIED - framespacing NUMBER #IMPLIED - scrolling (YES|NO|AUTO) AUTO - noresize (NORESIZE) #IMPLIED - align (LEFT|CENTER|RIGHT|TOP|MIDDLE|BOTTOM) #IMPLIED - > - -<!ELEMENT NOFRAMES - - %body.content > - -<!-- Objects - -Adapted from -WD-object-960422: Inserting objects into HTM -http://www.w3.org/pub/WWW/TR/WD-object.html -5/9/96 - ---> - -<!ENTITY % OAlign "(texttop|middle|textmiddle|baseline| - textbottom|left|center|right)"> - -<!-- OBJECT is a character-like element for inserting objects --> -<!ELEMENT OBJECT - - (PARAM | %body.content;)*> -<!ATTLIST OBJECT - %attrs -- id, class, style, lang, dir -- - declare (declare) #IMPLIED -- declare but don't instantiate flag -- - classid %URL #IMPLIED -- identifies an implementation -- - codebase %URL #IMPLIED -- some systems need an additional URL -- - data %URL #IMPLIED -- reference to object's data -- - type CDATA #IMPLIED -- Internet media type for data -- - codetype CDATA #IMPLIED -- Internet media type for code -- - standby CDATA #IMPLIED -- message to show while loading -- - align %OAlign #IMPLIED -- positioning inside document -- - height %Length #IMPLIED -- suggested height -- - width %Length #IMPLIED -- suggested width -- - border %Length #IMPLIED -- suggested link border width -- - hspace %Length #IMPLIED -- suggested horizontal gutter -- - vspace %Length #IMPLIED -- suggested vertical gutter -- - ismap (ismap) #IMPLIED -- use server image map -- - usemap %URL #IMPLIED -- reference to image map -- - shapes (shapes) #IMPLIED -- object has shaped hypertext links -- - name %URL #IMPLIED -- submit as part of form -- - > - -<!ELEMENT PARAM - O EMPTY -- named property value --> -<!ATTLIST PARAM - name CDATA #REQUIRED -- property name -- - value CDATA #IMPLIED -- property value -- - valuetype (DATA|REF|OBJECT) DATA -- How to interpret value -- - type CDATA #IMPLIED -- Internet media type -- - > - -<![ %HTML.Deprecated [ - -<!ELEMENT EMBED - - (NOEMBED | %body.content;)* > -<!ATTLIST EMBED - %attrs; - name CDATA #IMPLIED - height CDATA #IMPLIED - width CDATA #IMPLIED - param CDATA #IMPLIED - src %URL #REQUIRED -- URL of image to embed -- - > - -<!ELEMENT NOEMBED - O EMPTY> - -]]> - - -
--- a/etc/sgml/ie3tables.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,179 +0,0 @@ -<!-- Note: I originally excerpted this from the document entitled -"The HTML3 Table Model" by Dave Raggett, which I found at -http://www.w3.org/hypertext/WWW/TR/WD-tables. This file -identified itself as W3C Working Draft, dated 12/22/95. There are -slight modifications. - -Added width attribute to th and td elements. - -Version: 11/07/96 - ---> - -<!-- Content model entities imported from parent DTD: - - %body.content; allows table cells to contain headers, paras, - lists, form elements and even arbitrarily nested tables. - - %text; is text characters, including character entities and - character emphasis elements, IMG and anchors ---> - -<!ENTITY % attrs - "id ID #IMPLIED -- element identifier -- - class NAMES #IMPLIED -- for subclassing elements -- - style CDATA #IMPLIED -- rendering annotation -- - lang NAME #IMPLIED -- as per RFC 1766 -- - -- dir (ltr|rtl) #IMPLIED -- -- I18N text direction --"> - -<!-- - The BORDER attribute sets the thickness of the frame around the - table. The default units are screen pixels. - - The FRAME attribute specifies which parts of the frame around - the table should be rendered. The values are not the same as - CALS to avoid a name clash with the VALIGN attribute. - - The value "border" is included for backwards compatibility with - <TABLE BORDER> which yields frame=border and border=implied - For <TABLE BORDER=1> you get border=1 and frame=implied. In this - case, its appropriate to treat this as frame=border for backwards - compatibility with deployed browsers. ---> - -<!ENTITY % Frame "(void|above|below|hsides|lhs|rhs|vsides|box|border)"> - -<!-- - The RULES attribute defines which rules to draw between cells: - - If RULES is absent then assume: - "none" if BORDER is absent or BORDER=0 otherwise "all" ---> - -<!ENTITY % Rules "(none | groups | rows | cols | all)"> - -<!-- horizontal placement of table relative to window --> -<!ENTITY % Where "(left|center|right)"> -<!-- horizontal alignment attributes for cell contents --> -<!ENTITY % cell.halign - "align (left|center|right|justify|char) #IMPLIED - char CDATA #IMPLIED -- alignment char, e.g. char=':' -- - charoff CDATA #IMPLIED -- offset for alignment char --" - > - -<!-- vertical alignment attributes for cell contents --> -<!ENTITY % cell.valign - "valign (top|middle|bottom|baseline) #IMPLIED" - > - -<!ELEMENT table - - (caption?, colgroup*, thead?, tfoot?, tbody+)> -<!ELEMENT caption - - (%text;)+> -<!ELEMENT thead - O (tr+)> -<!ELEMENT tfoot - O (tr+)> -<!ELEMENT tbody O O (tr+)> -<!ELEMENT colgroup - O (col*)> -<!ELEMENT col - O EMPTY> -<!ELEMENT tr - O (th|td)+> -<!ELEMENT (th|td) - O %body.content> - -<!ATTLIST table -- table element -- - %attrs; -- id, lang, style, dir and class -- - align %Where; #IMPLIED -- table position relative to window -- - width CDATA #IMPLIED -- table width relative to window -- - cols NUMBER #IMPLIED -- used for immediate display mode -- - border CDATA #IMPLIED -- controls frame width around table -- - frame %Frame; #IMPLIED -- which parts of table frame to include -- - rules %Rules; #IMPLIED -- rulings between rows and cols -- - cellspacing CDATA #IMPLIED -- spacing between cells -- - cellpadding CDATA #IMPLIED -- spacing within cells -- - background %URL #IMPLIED -- background picture -- - bgcolor CDATA #IMPLIED -- table background color -- - bordercolor CDATA #IMPLIED -- table border color -- - bordercolorlight CDATA #IMPLIED -- 3D table border color -- - bordercolordark CDATA #IMPLIED -- 3D table border color -- - > - -<!-- ALIGN is used here for compatibility with deployed browsers --> -<!ENTITY % Caption "(top|bottom)"> - -<!ATTLIST caption -- table caption -- - %attrs; -- id, lang, style, dir and class -- - align %Caption; #IMPLIED -- relative to table -- - > - -<!-- -COLGROUP groups a set of COL elements. It allows you to group -several columns together. ---> - -<!ATTLIST colgroup - %attrs; -- id, lang, style, dir and class -- - span NUMBER 1 -- default number of columns in group -- - width CDATA #IMPLIED -- default width for enclosed COLs -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!-- - COL elements define the alignment properties for cells in a given - column or spanned columns. The WIDTH attribute specifies the - width of the columns, e.g. - - width=64 width in screen pixels - width=0.5* relative width of 0.5 ---> - -<!ATTLIST col -- column groups and properties -- - %attrs; -- id, lang, style, dir and class -- - span NUMBER 1 -- number of columns spanned by group -- - width CDATA #IMPLIED -- column width specification -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!-- - Use THEAD to duplicate headers when breaking table - across page boundaries, or for static headers when - body sections are rendered in scrolling panel. - - Use TFOOT to duplicate footers when breaking table - across page boundaries, or for static footers when - body sections are rendered in scrolling panel. - - Use multiple TBODY sections when rules are needed - between groups of table rows. ---> -<!ATTLIST (thead|tbody|tfoot) -- table section -- - %attrs; -- id, lang, style, dir and class -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - > - -<!ATTLIST tr -- table row -- - %attrs; -- id, lang, style, dir and class -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - bgcolor CDATA #IMPLIED -- table background color -- - bordercolor CDATA #IMPLIED -- table border color -- - bordercolorlight CDATA #IMPLIED -- 3D table border color -- - bordercolordark CDATA #IMPLIED -- 3D table border color -- - > - -<!ATTLIST (th|td) -- header or data cell -- - %attrs; -- id, lang, style, dir and class -- - axis CDATA #IMPLIED -- defaults to cell content -- - axes CDATA #IMPLIED -- list of axis names -- - nowrap (nowrap) #IMPLIED -- suppress word wrap -- - rowspan NUMBER 1 -- number of rows spanned by cell -- - colspan NUMBER 1 -- number of cols spanned by cell -- - %cell.halign; -- horizontal alignment in cells -- - %cell.valign; -- vertical alignment in cells -- - background CDATA #IMPLIED -- background graphic -- - bgcolor CDATA #IMPLIED -- background color for cell -- - bordercolor CDATA #IMPLIED -- cell border color -- - bordercolorlight CDATA #IMPLIED -- 3D cell border color -- - bordercolordark CDATA #IMPLIED -- 3D cell border color -- - height CDATA #IMPLIED - width CDATA #IMPLIED - > -
--- a/etc/sgml/iehtml-s.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -<!-- html-s.dtd - - Document Type Definition for HTML that works with Internet Explorer, - based on IETF's Strict HTML DTD. ---> - -<!ENTITY % HTML.Version - "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//EN" - - -- Typical usage: - - <!DOCTYPE HTML PUBLIC - "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//EN"> - <html> - ... - </html> - -- - > - -<!-- Feature Test Entities --> -<!ENTITY % HTML.Recommended "INCLUDE"> - -<!ENTITY % html PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML//EN"> -%html;
--- a/etc/sgml/iehtml.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,835 +0,0 @@ -<!-- DTD for Internet Explorer 2.0 HTML - - Beta version: 0.9 Date: 3/4/96 - - Document Type Definition for the HyperText Markup Language - for Internet Explorer, V 2.0. - - Author: Mark Buckley <mbuckley@microsoft.com> - - This markup is based as much as possible on the DTD for HTML 2.0 - published in the 12/95 IETF working draft. Table markup is based - on the table DTD included in the HTML3 DTD, not the 12/95 tables - draft. - - Note that SGML Document Access (SDA) fixed attributes have not - necessarily been worked out yet for added elements. - - Principal changes from the IETF DTD: - - Took out the HTML.Highlighting and HTML.Forms marked sections. - Highlighting and form elements are now always included. - - Moved entity declarations for common content models together & up - top in the DTD to allow for more effective recombination for the - deprecated case. - - Moved DL into %lists for simplification. - - Added IE HTML extensions and most Netscape extensions. - - Changes since 2/26/96: - - 3/4/96: - Added BGSOUND to HEAD. - - ---> - -<!ENTITY % HTML.Version "-//Microsoft//DTD Internet Explorer 2.0 HTML//EN" > - - -<!--============ Feature Test Entities ========================--> - -<!ENTITY % HTML.Recommended "IGNORE" - -- Certain features of the language are necessary for - compatibility with widespread usage, but they may - compromise the structural integrity of a document. - This feature test entity enables a more prescriptive - document type definition that eliminates - those features. - --> - -<![ %HTML.Recommended [ - <!ENTITY % HTML.Deprecated "IGNORE"> -]]> - -<!ENTITY % HTML.Deprecated "INCLUDE" - -- Certain features of the language are necessary for - compatibility with earlier versions of the specification, - but they tend to be used and implemented inconsistently, - and their use is deprecated. This feature test entity - enables a document type definition that eliminates - these features. - --> - - -<!--============== Imported Names ==============================--> - -<!ENTITY % Content-Type "CDATA" - -- meaning an internet media type - (aka MIME content type, as per RFC1521) - --> - -<!ENTITY % HTTP-Method "GET | POST" - -- as per HTTP specification, in progress - --> - - -<!--======= Character mnemonic entities =================--> - -<!ENTITY % ISOlat1 PUBLIC - "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML"> -%ISOlat1; - -<!ENTITY amp CDATA "&" -- ampersand --> -<!ENTITY gt CDATA ">" -- greater than --> -<!ENTITY lt CDATA "<" -- less than --> -<!ENTITY quot CDATA """ -- double quote --> - - -<!ENTITY nbsp SDATA "[nbsp ]" -- non-breaking space --> -<!ENTITY reg SDATA "®" -- registered trademark symbol --> -<!ENTITY copy SDATA "©" -- copyright symbol --> - - -<!--========= SGML Document Access (SDA) Parameter Entities =====--> - -<!-- HTML 2.0 contains SGML Document Access (SDA) fixed attributes -in support of easy transformation to the International Committee -for Accessible Document Design (ICADD) DTD - "-//EC-USA-CDA/ICADD//DTD ICADD22//EN". -ICADD applications are designed to support usable access to -structured information by print-impaired individuals through -Braille, large print and voice synthesis. For more information on -SDA & ICADD: - - ISO 12083:1993, Annex A.8, Facilities for Braille, - large print and computer voice - - ICADD ListServ - <ICADD%ASUACAD.BITNET@ARIZVM1.ccit.arizona.edu> - - Usenet news group bit.listserv.easi - - Recording for the Blind, +1 800 221 4792 ---> - -<!ENTITY % SDAFORM "SDAFORM CDATA #FIXED" - -- one to one mapping --> -<!ENTITY % SDARULE "SDARULE CDATA #FIXED" - -- context-sensitive mapping --> -<!ENTITY % SDAPREF "SDAPREF CDATA #FIXED" - -- generated text prefix --> -<!ENTITY % SDASUFF "SDASUFF CDATA #FIXED" - -- generated text suffix --> -<!ENTITY % SDASUSP "SDASUSP NAME #FIXED" - -- suspend transform process --> - -<!--========= Common attributes ============================================--> - -<!ENTITY % attrs -- common attributes. Taken from the HTML 3 DTD -- - 'id ID #IMPLIED -- as target for hrefs (link ends) -- - lang CDATA "en.us" -- ISO language, country code -- - class NAMES #IMPLIED -- for subclassing elements --'> - -<!--========= Common content models and element groups =====================--> - - -<!ENTITY % heading "H1|H2|H3|H4|H5|H6"> - -<!ENTITY % list "UL | OL | DL | DIR | MENU" > - -<!ENTITY % mmobjects "IMG|MAP|FETCH|BGSOUND|MARQUEE" > - -<!ENTITY % font "TT | B | I | U | STRIKE | FONT"> - -<![ %HTML.Deprecated [ - <!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE - | DFN | ENTITY"> -]]> - -<!ENTITY % phrase "EM | STRONG | CODE | SAMP | KBD | VAR | CITE"> - -<!ENTITY % break "BR | NOBR | WBR" > - -<!ENTITY % text "#PCDATA | A | %mmobjects | %break | %phrase | %font"> - -<!ENTITY % block.forms "BLOCKQUOTE | FORM | ISINDEX"> - -<![ %HTML.Deprecated [ - <!ENTITY % preformatted "PRE | XMP | LISTING"> -]]> - -<!ENTITY % preformatted "PRE"> - -<![ %HTML.Deprecated [ -<!ENTITY % block "P | TABLE - | %list - | %preformatted - | %block.forms - | COMMENT - | CENTER"> -]]> - -<!ENTITY % block "P | TABLE - | %list - | %preformatted - | %block.forms - | CENTER"> - -<!ENTITY % mixed.content "(%heading|%text|%block|HR|ADDRESS|BASEFONT)*" > - -<![ %HTML.Recommended [ - <!ENTITY % body.content "(%heading|%block|%mmobjects|HR|ADDRESS|BASEFONT)*" > -]]> - -<!ENTITY % body.content "%mixed.content" > - -<![ %HTML.Recommended [ - <!ENTITY % font.content "(%text)*" > -]]> - -<!ENTITY % font.content "(%body.content)*" > - -<!ENTITY % flow "(%text|%block)*"> - - -<!--========== Text Markup =====================--> -<!ELEMENT (%font) - - %font.content > - -<!ELEMENT (%phrase) - - (%text)* > - -<!ATTLIST FONT - %attrs; - SIZE NUMBER #IMPLIED - COLOR CDATA #IMPLIED - FACE CDATA #IMPLIED - > - -<!ATTLIST ( TT | CODE | SAMP | KBD | VAR ) - %attrs; - %SDAFORM; "Lit" - > -<!ATTLIST ( B | STRONG ) - %attrs; - %SDAFORM; "B" - > -<!ATTLIST ( I | EM | CITE ) - %attrs; - %SDAFORM; "It" - > - -<!ATTLIST (U | STRIKE) - %attrs; - > - -<![ %HTML.Deprecated [ -<!ATTLIST (DFN | ENTITY) - %attrs; - > -]]> - -<!-- <FONT> Font --> -<!-- <TT> Typewriter text --> -<!-- <B> Bold text --> -<!-- <I> Italic text --> -<!-- <U> Underlined text --> - -<!-- <EM> Emphasized phrase --> -<!-- <STRONG> Strong emphasis --> -<!-- <CODE> Source code phrase --> -<!-- <SAMP> Sample text or characters --> -<!-- <KBD> Keyboard phrase, e.g. user input --> -<!-- <VAR> Variable phrase or substitutable --> -<!-- <CITE> Name or title of cited work --> - -<!ENTITY % pre.content "#PCDATA | A | HR | BR | %font | %phrase"> - -<!ELEMENT BR - O EMPTY> -<!ATTLIST BR - %attrs; - CLEAR (ALL|LEFT|RIGHT) #IMPLIED - %SDAPREF; "&#RE;" - > - -<!-- <BR> Line break --> - -<!ELEMENT NOBR - O EMPTY> -<!ATTLIST NOBR - %attrs; - > - -<!-- <NOBR> Disallow Line break --> - -<!ELEMENT WBR - O EMPTY> -<!ATTLIST WBR - %attrs; - > - -<!-- <WBR> Word break --> - -<!--========= Link Markup ======================--> - -<!ENTITY % linkType "NAMES"> - -<!ENTITY % linkExtraAttributes - "REL %linkType #IMPLIED - REV %linkType #IMPLIED - URN CDATA #IMPLIED - TITLE CDATA #IMPLIED - METHODS NAMES #IMPLIED - "> - -<![ %HTML.Recommended [ - <!ENTITY % A.content "(%text)*" - -- <H1><a name="xxx">Heading</a></H1> - is preferred to - <a name="xxx"><H1>Heading</H1></a> - --> -]]> - -<!ENTITY % A.content "(%heading|%text)*"> - -<!ELEMENT A - - %A.content -(A)> -<!ATTLIST A - %attrs; - HREF CDATA #IMPLIED - NAME CDATA #IMPLIED - X-SIZE NUMBER #IMPLIED - NOCACHE (NOCACHE) #IMPLIED - %linkExtraAttributes; - %SDAPREF; "<Anchor: #AttList>" - > -<!-- <A> Anchor; source/destination of link --> -<!-- <A NAME="..."> Name of this anchor --> -<!-- <A HREF="..."> Address of link destination --> -<!-- <A URN="..."> Permanent address of destination --> -<!-- <A REL=...> Relationship to destination --> -<!-- <A REV=...> Relationship of destination to this --> -<!-- <A TITLE="..."> Title of destination (advisory) --> -<!-- <A METHODS="..."> Operations on destination (advisory) --> - - -<!--========== Images ==========================--> - -<!ELEMENT IMG - O EMPTY> -<!ATTLIST IMG - %attrs; - SRC CDATA #REQUIRED - DYNSRC CDATA #IMPLIED - LOOP NMTOKEN #IMPLIED - START CDATA #IMPLIED - BORDER NUMBER #IMPLIED - ALT CDATA #IMPLIED - ALIGN (LEFT|RIGHT|TOP|TEXTTOP|MIDDLE|ABSMIDDLE| - BASELINE|BOTTOM|ABSBOTTOM) #IMPLIED - -- Values supported by IE2: - (LEFT|RIGHT|TOP||MIDDLE|BOTTOM) -- - ISMAP (ISMAP) #IMPLIED - USEMAP CDATA #IMPLIED - HEIGHT CDATA #IMPLIED - WIDTH CDATA #IMPLIED - VSPACE NUMBER #IMPLIED - HSPACE NUMBER #IMPLIED - CONTROLS (CONTROLS) #IMPLIED - VRML CDATA #IMPLIED - %SDAPREF; "<Fig><?SDATrans Img: #AttList>#AttVal(Alt)</Fig>" - > - -<!-- <IMG> Image; icon, glyph or illustration --> -<!-- <IMG SRC="..."> Address of image object --> -<!-- <IMG ALT="..."> Textual alternative --> -<!-- <IMG ALIGN=...> Position relative to text --> -<!-- <IMG ISMAP> Each pixel can be a link --> - -<!ELEMENT MAP - - (AREA)+> -<!ATTLIST MAP - %attrs; - NAME CDATA #REQUIRED - > - -<!-- <MAP> Map --> - -<!ELEMENT AREA - O EMPTY> -<!ATTLIST AREA - %attrs; - COORDS CDATA #IMPLIED - HREF CDATA #IMPLIED - NOHREF (NOHREF) #IMPLIED - SHAPE (RECT|RECTANGLE|CIRC|CIRCLE|POLY|POLYGON) #IMPLIED - ALT CDATA #IMPLIED - > - -<!-- <AREA> Area --> - -<!ELEMENT FETCH - O EMPTY> -<!ATTLIST FETCH - %attrs; - DESC CDATA #IMPLIED - GUID CDATA #IMPLIED - REQUIRED CDATA #IMPLIED - SRC CDATA #IMPLIED - TS CDATA #IMPLIED - > - -<!-- <FETCH> Fetc --> - -<!--========== Paragraphs=======================--> - -<!ELEMENT P - O (%text|CENTER)*> -<!ATTLIST P - %attrs; - %SDAFORM; "Para" - ALIGN (CENTER) #IMPLIED - > - -<!-- <P> Paragraph --> - - -<!--========== Headings, Titles, Sections ===============--> - -<!ELEMENT HR - O EMPTY> -<!ATTLIST HR - %attrs; - %SDAPREF; "&#RE;&#RE;" - SIZE NUMBER #IMPLIED - WIDTH CDATA #IMPLIED - ALIGN (LEFT|RIGHT|CENTER) #IMPLIED - NOSHADE (NOSHADE) #IMPLIED -- Not supported by IE2 -- - > - -<!-- <HR> Horizontal rule --> - -<!ELEMENT ( %heading ) - - (%text;|CENTER)*> -<!ATTLIST H1 - %attrs; - ALIGN (CENTER) #IMPLIED - %SDAFORM; "H1" - > -<!ATTLIST H2 - %attrs; - ALIGN (CENTER) #IMPLIED - %SDAFORM; "H2" - > -<!ATTLIST H3 - %attrs; - ALIGN (CENTER) #IMPLIED - %SDAFORM; "H3" - > -<!ATTLIST H4 - %attrs; - ALIGN (CENTER) #IMPLIED - %SDAFORM; "H4" - > -<!ATTLIST H5 - %attrs; - ALIGN (CENTER) #IMPLIED - %SDAFORM; "H5" - > -<!ATTLIST H6 - %attrs; - ALIGN (CENTER) #IMPLIED - %SDAFORM; "H6" - > - -<!-- <H1> Heading, level 1 --> -<!-- <H2> Heading, level 2 --> -<!-- <H3> Heading, level 3 --> -<!-- <H4> Heading, level 4 --> -<!-- <H5> Heading, level 5 --> -<!-- <H6> Heading, level 6 --> - - -<!--========== Text Flows ======================--> - - -<!ELEMENT PRE - - (%pre.content)*> -<!ATTLIST PRE - %attrs; - WIDTH CDATA #implied - %SDAFORM; "Lit" - > - -<!-- <PRE> Preformatted text --> -<!-- <PRE WIDTH=...> Maximum characters per line --> - -<![ %HTML.Deprecated [ - -<!ENTITY % literal "CDATA" - -- historical, non-conforming parsing mode where - the only markup signal is the end tag - in full - --> - -<!ELEMENT (XMP|LISTING) - - %literal> -<!ATTLIST XMP - %attrs; - %SDAFORM; "Lit" - %SDAPREF; "Example:&#RE;" - > -<!ATTLIST LISTING - %attrs; - %SDAFORM; "Lit" - %SDAPREF; "Listing:&#RE;" - > - -<!-- <XMP> Example section --> -<!-- <LISTING> Computer listing --> - -<!ELEMENT PLAINTEXT - O %literal> -<!-- <PLAINTEXT> Plain text passage --> - -<!ATTLIST PLAINTEXT - %attrs; - %SDAFORM; "Lit" - > -]]> - - -<!--========== Lists ==================--> - -<!ELEMENT DL - - (DT | DD)+> -<!ATTLIST DL - %attrs; - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "Definition List:" - > - -<!ELEMENT DT - O (%text)*> -<!ATTLIST DT - %attrs; - %SDAFORM; "Term" - > - -<!ELEMENT DD - O %flow> -<!ATTLIST DD - %attrs; - %SDAFORM; "LItem" - > - -<!-- <DL> Definition list, or glossary --> -<!-- <DL COMPACT> Compact style list --> -<!-- <DT> Term in definition list --> -<!-- <DD> Definition of term --> - -<!ELEMENT (OL|UL) - - (LI)+> -<!ATTLIST OL - %attrs; - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - TYPE CDATA #IMPLIED - START NUMBER #IMPLIED - > -<!ATTLIST UL - %attrs; - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - TYPE (DISC|CIRCLE|SQUARE) #IMPLIED -- Not supported by IE2 -- - > -<!-- <UL> Unordered list --> -<!-- <UL COMPACT> Compact list style --> -<!-- <OL> Ordered, or numbered list --> -<!-- <OL COMPACT> Compact list style --> - - -<!ELEMENT (DIR|MENU) - - (LI)+ -(%block)> -<!ATTLIST DIR - %attrs; - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "<LHead>Directory</LHead>" - > -<!ATTLIST MENU - %attrs; - COMPACT (COMPACT) #IMPLIED - %SDAFORM; "List" - %SDAPREF; "<LHead>Menu</LHead>" - > - -<!-- <DIR> Directory list --> -<!-- <DIR COMPACT> Compact list style --> -<!-- <MENU> Menu list --> -<!-- <MENU COMPACT> Compact list style --> - -<!ELEMENT LI - O %flow> -<!ATTLIST LI - %attrs; - %SDAFORM; "LItem" - TYPE CDATA #IMPLIED - VALUE NUMBER #IMPLIED - > - -<!-- <LI> List item --> - -<!--========== Document Body ===================--> - -<!ELEMENT BODY O O %body.content > -<!ATTLIST BODY - %attrs; - BACKGROUND CDATA #IMPLIED - BGCOLOR CDATA #IMPLIED - BGPROPERTIES CDATA #IMPLIED - LEFTMARGIN NUMBER #IMPLIED - TOPMARGIN NUMBER #IMPLIED - TEXT CDATA #IMPLIED - LINK CDATA #IMPLIED - VLINK CDATA #IMPLIED - ALINK CDATA #IMPLIED - > - -<!-- <BODY> Document body --> - - -<!ELEMENT CENTER - - %mixed.content > -<!ATTLIST CENTER - %attrs; - %SDAFORM; "Para" - > - -<!-- <CENTER> Center --> - -<![ %HTML.Deprecated [ -<!ELEMENT COMMENT - - (%text|CENTER)*> - -<!-- <COMMENT> Comment --> -]]> - -<!ELEMENT BASEFONT - O EMPTY> -<!ATTLIST BASEFONT - %attrs; - SIZE NUMBER #IMPLIED - COLOR CDATA #IMPLIED - FACE CDATA #IMPLIED - > - -<!-- <BASEFONT> Basefont --> - -<!ELEMENT BGSOUND - O EMPTY> -<!ATTLIST BGSOUND - %attrs; - SRC CDATA #IMPLIED - LOOP NMTOKEN #IMPLIED - > - -<!-- <BGSOUND> Background sound. - Only one background sound should exist in a document. --> - -<!ELEMENT MARQUEE - O (%text)*> -<!ATTLIST MARQUEE - %attrs; - ALIGN (TOP|MIDDLE|BOTTOM) MIDDLE -- is this the right default? -- - DIRECTION (LEFT|RIGHT) LEFT - BEHAVIOR (SCROLL|SLIDE|ALTERNATE) SCROLL - SCROLLAMOUNT NUMBER #IMPLIED - SCROLLDELAY NUMBER #IMPLIED - LOOP CDATA "INFINITE" -- is this the right default? -- - BGCOLOR CDATA #IMPLIED - BORDER NUMBER #IMPLIED - HEIGHT CDATA #IMPLIED - WIDTH CDATA #IMPLIED - HSPACE NUMBER #IMPLIED - VSPACE NUMBER #IMPLIED - > - -<!-- <MARQUEE> Marquee --> - -<!ELEMENT BLOCKQUOTE - - %body.content> -<!ATTLIST BLOCKQUOTE - %attrs; - %SDAFORM; "BQ" - > - -<!-- <BLOCKQUOTE> Quoted passage --> - -<!ELEMENT ADDRESS - - (%text|P|CENTER)*> -<!ATTLIST ADDRESS - %attrs; - %SDAFORM; "Lit" - %SDAPREF; "Address:&#RE;" - > - -<!-- <ADDRESS> Address, signature, or byline --> - - -<!--======= Forms ====================--> - -<!ELEMENT FORM - - %body.content -(FORM) +(INPUT|SELECT|TEXTAREA)> -<!ATTLIST FORM - %attrs; - ACTION CDATA #IMPLIED - METHOD (%HTTP-Method) GET - ENCTYPE %Content-Type; "application/x-www-form-urlencoded" - %SDAPREF; "<Para>Form:</Para>" - %SDASUFF; "<Para>Form End.</Para>" - > - -<!-- <FORM> Fill-out or data-entry form --> -<!-- <FORM ACTION="..."> Address for completed form --> -<!-- <FORM METHOD=...> Method of submitting form --> -<!-- <FORM ENCTYPE="..."> Representation of form data --> - -<!ENTITY % InputType "(TEXT | PASSWORD | CHECKBOX | - RADIO | SUBMIT | RESET | - IMAGE | HIDDEN )"> -<!ELEMENT INPUT - O EMPTY> -<!ATTLIST INPUT - %attrs; - TYPE %InputType TEXT - NAME CDATA #IMPLIED - VALUE CDATA #IMPLIED - SRC CDATA #IMPLIED - CHECKED (CHECKED) #IMPLIED - SIZE CDATA #IMPLIED - MAXLENGTH NUMBER #IMPLIED - ALIGN (TOP|MIDDLE|BOTTOM) #IMPLIED - %SDAPREF; "Input: " - > - -<!-- <INPUT> Form input datum --> -<!-- <INPUT TYPE=...> Type of input interaction --> -<!-- <INPUT NAME=...> Name of form datum --> -<!-- <INPUT VALUE="..."> Default/initial/selected value --> -<!-- <INPUT SRC="..."> Address of image --> -<!-- <INPUT CHECKED> Initial state is "on" --> -<!-- <INPUT SIZE=...> Field size hint --> -<!-- <INPUT MAXLENGTH=...> Data length maximum --> -<!-- <INPUT ALIGN=...> Image alignment --> - -<!ELEMENT SELECT - - (OPTION+) -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST SELECT - %attrs; - NAME CDATA #REQUIRED - SIZE NUMBER #IMPLIED - MULTIPLE (MULTIPLE) #IMPLIED - %SDAFORM; "List" - %SDAPREF; - "<LHead>Select #AttVal(Multiple)</LHead>" - > - -<!-- <SELECT> Selection of option(s) --> -<!-- <SELECT NAME=...> Name of form datum --> -<!-- <SELECT SIZE=...> Options displayed at a time --> -<!-- <SELECT MULTIPLE> Multiple selections allowed --> - -<!ELEMENT OPTION - O (#PCDATA)*> -<!ATTLIST OPTION - %attrs; - SELECTED (SELECTED) #IMPLIED - VALUE CDATA #IMPLIED - %SDAFORM; "LItem" - %SDAPREF; - "Option: #AttVal(Value) #AttVal(Selected)" - > - -<!-- <OPTION> A selection option --> -<!-- <OPTION SELECTED> Initial state --> -<!-- <OPTION VALUE="..."> Form datum value for this option--> - -<!ELEMENT TEXTAREA - - (#PCDATA)* -(INPUT|SELECT|TEXTAREA)> -<!ATTLIST TEXTAREA - %attrs; - NAME CDATA #REQUIRED - ROWS NUMBER #REQUIRED - COLS NUMBER #REQUIRED - %SDAFORM; "Para" - %SDAPREF; "Input Text -- #AttVal(Name): " - > - -<!-- <TEXTAREA> An area for text input --> -<!-- <TEXTAREA NAME=...> Name of form datum --> -<!-- <TEXTAREA ROWS=...> Height of area --> -<!-- <TEXTAREA COLS=...> Width of area --> - - -<!--======= Document Head ======================--> - -<![ %HTML.Recommended [ - <!ENTITY % head.extra ""> -]]> -<!ENTITY % head.extra "& NEXTID?"> - -<!ENTITY % head.content "TITLE & ISINDEX? & BASE? %head.extra"> - -<!ELEMENT HEAD O O ((%head.content),BGSOUND*) +(META|LINK)> - -<!-- <HEAD> Document head --> - -<!ELEMENT TITLE - - (#PCDATA)* -(META|LINK)> -<!ATTLIST TITLE - %attrs; - %SDAFORM; "Ti" > - -<!-- <TITLE> Title of document --> - -<!ELEMENT LINK - O EMPTY> -<!ATTLIST LINK - HREF CDATA #REQUIRED - %linkExtraAttributes; - %SDAPREF; "Linked to : #AttVal (TITLE) (URN) (HREF)>" > - -<!-- <LINK> Link from this document --> -<!-- <LINK HREF="..."> Address of link destination --> -<!-- <LINK URN="..."> Lasting name of destination --> -<!-- <LINK REL=...> Relationship to destination --> -<!-- <LINK REV=...> Relationship of destination to this --> -<!-- <LINK TITLE="..."> Title of destination (advisory) --> -<!-- <LINK METHODS="..."> Operations allowed (advisory) --> - -<!ELEMENT ISINDEX - O EMPTY> -<!ATTLIST ISINDEX - %attrs; - %SDAPREF; - "<Para>[Document is indexed/searchable.]</Para>" - PROMPT CDATA #IMPLIED - ACTION CDATA #IMPLIED - > - -<!-- <ISINDEX> Document is a searchable index --> - -<!ELEMENT BASE - O EMPTY> -<!ATTLIST BASE - %attrs; - HREF CDATA #REQUIRED > - -<!-- <BASE> Base context document --> -<!-- <BASE HREF="..."> Address for this document --> - -<![ %HTML.Deprecated [ -<!ELEMENT NEXTID - O EMPTY> -<!ATTLIST NEXTID - %attrs; - N CDATA #REQUIRED > - -<!-- <NEXTID> Next ID to use for link name --> -<!-- <NEXTID N=...> Next ID to use for link name --> -]]> - -<!ELEMENT META - O EMPTY> -<!ATTLIST META - HTTP-EQUIV NAME #IMPLIED - NAME NAME #IMPLIED - CONTENT CDATA #REQUIRED > - -<!-- <META> Generic Meta-information --> -<!-- <META HTTP-EQUIV=...> HTTP response header name --> -<!-- <META NAME=...> Meta-information name --> -<!-- <META CONTENT="..."> Associated information --> - -<!--======= Document Structure =================--> - -<![ %HTML.Deprecated [ - <!ENTITY % html.content "HEAD, BODY, PLAINTEXT?"> -]]> -<!ENTITY % html.content "HEAD, BODY"> - -<!ELEMENT HTML O O (%html.content)> -<!ENTITY % version.attr "VERSION CDATA #FIXED '%HTML.Version;'"> - -<!ATTLIST HTML - %version.attr; - %SDAFORM; "Book" - > - -<!-- <HTML> HTML Document --> - -<!-- Invoke TABLES DTD --> -<!ENTITY % ietables PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 Tables//EN" > -%ietables;
--- a/etc/sgml/ietables.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -<!-- DTD for Internet Explorer 2.0 Tables - - Beta Version 0.9 Date: 2/26/96 - - This markup is based on the tables markup - contained in the IETF March 1995 Draft HTML3 DTD. - - Attributes have been added as noted. - - Typical invocation: - - <!ENTITY % ietables PUBLIC - "-//Microsoft//DTD Internet Explorer 2.0 Tables//EN" > - ---> - -<!ENTITY % attrs -- common attributes for elements -- - 'id ID #IMPLIED -- as target for hrefs (link ends) -- - lang CDATA "en.us" -- ISO language, country code -- - class NAMES #IMPLIED -- for subclassing elements --'> - -<!ENTITY % needs -- Attributes for controlling text flow. Used in headers - and other elements to guarantee sufficient room -- - 'clear CDATA "no" -- (left|right|all|no) move down past figures -- - needs CDATA #IMPLIED -- minimum width needed in em"s or pixels -- - -- e.g. "40 em" or "100 pixels" --'> - -<!ENTITY % cell "TH | TD"> -<!ENTITY % horiz.align "left|center|right|justify"> -<!ENTITY % vert.align "top|middle|bottom|baseline"> -<!ENTITY % block.align - "align (bleedleft|left|center|right|bleedright|justify) center"> - - -<!ELEMENT TABLE - - (CAPTION?, TR*) -- mixed headers and data --> -<!ATTLIST TABLE - %attrs; - %needs; -- for control of text flow -- - border NUMBER #IMPLIED -- draw borders -- - colspec CDATA #IMPLIED -- column widths and alignment. - Not supported by IE2 -- - units (en|pixels|relative) en -- units for column widths - Not supported by IE2 -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," - Not supported by IE2 -- - width CDATA #IMPLIED -- absolute or percentage width -- - %block.align; -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - noflow (noflow) #IMPLIED -- noflow around table - Not supported by IE2 -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - - -- Added for IE2 -- - bgcolor CDATA #IMPLIED -- Table background color -- - bordercolor CDATA #IMPLIED -- table border color -- - bordercolorlight CDATA #IMPLIED -- 3D table border color -- - bordercolordark CDATA #IMPLIED -- 3D table border color -- - cellpadding NUMBER #IMPLIED -- cell padding. -- - cellspacing NUMBER #IMPLIED -- cell spacing -- - > - -<!ELEMENT TR - O (%cell)* -- row container --> -<!ATTLIST TR - %attrs; - align (%horiz.align) #IMPLIED -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," - Not supported by IE2 -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - - -- Added for IE2 -- - bgcolor CDATA #IMPLIED -- background color for cell -- - bordercolor CDATA #IMPLIED -- cell border color -- - bordercolorlight CDATA #IMPLIED -- 3D cell border color -- - bordercolordark CDATA #IMPLIED -- 3D cell border color -- - width CDATA #IMPLIED -- cell width -- - > - -<!ELEMENT (%cell) - O %body.content> -<!ATTLIST (%cell) - %attrs; - colspan NUMBER 1 -- columns spanned -- - rowspan NUMBER 1 -- rows spanned -- - align (%horiz.align) #IMPLIED -- horizontal alignment -- - valign (%vert.align) top -- vertical alignment -- - dp CDATA #IMPLIED -- decimal point e.g. dp="," - Not supported by IE2 -- - nowrap (nowrap) #IMPLIED -- don't wrap words -- - axis CDATA #IMPLIED -- axis name, defaults to element content - Not supported by IE2 -- - axes CDATA #IMPLIED -- comma separated list of axis names - Not supported by IE2 -- - - -- Added for IE2 -- - bgcolor CDATA #IMPLIED -- background color for cell -- - bordercolor CDATA #IMPLIED -- cell border color -- - bordercolorlight CDATA #IMPLIED -- 3D cell border color -- - bordercolordark CDATA #IMPLIED -- 3D cell border color -- - width CDATA #IMPLIED -- added for IE2 -- - > - -<!--======================= Captions ======================================--> - -<!ELEMENT CAPTION - - (%text;)+ -- table or figure caption --> -<!ATTLIST CAPTION - %attrs; - align (left|right|center) #IMPLIED - valign (top|bottom) #IMPLIED - > -
--- a/etc/sgml/iso88591.map Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -160 [nbsp ] -161 [iexcl ] -162 [cent ] -163 [pound ] -164 [curren] -165 [yen ] -166 [brvbar] -167 [sect ] -168 [uml ] -169 [copy ] -170 [ordf ] -171 [laquo ] -172 [not ] -173 [shy ] -174 [reg ] -175 [macr ] -176 [deg ] -177 [plusmn] -178 [sup2 ] -179 [sup3 ] -180 [acute ] -181 [micro ] -182 [para ] -183 [middot] -184 [cedil ] -185 [sup1 ] -186 [ordm ] -187 [raquo ] -188 [frac14] -189 [frac12] -190 [frac34] -191 [iquest] -192 [Agrave] -193 [Aacute] -194 [Acirc ] -195 [Atilde] -196 [Auml ] -197 [Aring ] -198 [AElig ] -199 [Ccedil] -200 [Egrave] -201 [Eacute] -202 [Ecirc ] -203 [Euml ] -204 [Igrave] -205 [Iacute] -206 [Icirc ] -207 [Iuml ] -208 [ETH ] -209 [Ntilde] -210 [Ograve] -211 [Oacute] -212 [Ocirc ] -213 [Otilde] -214 [Ouml ] -216 [Oslash] -217 [Ugrave] -218 [Uacute] -219 [Ucirc ] -220 [Uuml ] -221 [Yacute] -222 [THORN ] -223 [szlig ] -224 [agrave] -225 [aacute] -226 [acirc ] -227 [atilde] -228 [auml ] -229 [aring ] -230 [aelig ] -231 [ccedil] -232 [egrave] -233 [eacute] -234 [ecirc ] -235 [euml ] -236 [igrave] -237 [iacute] -238 [icirc ] -239 [iuml ] -240 [eth ] -241 [ntilde] -242 [ograve] -243 [oacute] -244 [ocirc ] -245 [otilde] -246 [ouml ] -248 [oslash] -249 [ugrave] -250 [uacute] -251 [ucirc ] -252 [uuml ] -253 [yacute] -254 [thorn ] -255 [yuml ] -192 À -193 Á -194 Â -195 Ã -196 Ä -197 Å -198 Æ -199 Ç -200 È -201 É -202 Ê -203 Ë -204 Ì -205 Í -206 Î -207 Ï -208 Ð -209 Ñ -210 Ò -211 Ó -212 Ô -213 Õ -214 Ö -216 Ø -217 Ù -218 Ú -219 Û -220 Ü -221 Ý -222 Þ -223 ß -224 à -225 á -226 â -227 ã -228 ä -229 å -230 æ -231 ç -232 è -233 é -234 ê -235 ë -236 ì -237 í -238 î -239 ï -240 ð -241 ñ -242 ò -243 ó -244 ô -245 õ -246 ö -248 ø -249 ù -250 ú -251 û -252 ü -253 ý -254 þ -255 ÿ
--- a/etc/sgml/sinfo.dtd Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,449 +0,0 @@ -<!-- This is sinfo.dtd, - by MORIOKA Tomohiko - $Id: sinfo.dtd,v 1.2 1996/12/28 21:02:49 steve Exp $ ---> - -<!entity % emph - "em|it|bf|sf|sl|tt|cparam|code|verb|var|mail|file|kbd|key"> - -<!entity % index "idx|cdx" > - -<!-- url added by HG; htmlurl added by esr --> -<!entity % xref - " a|label|ref|dref|cf|cite|ncite|concept " > - -<!entity % inline - " (#pcdata | f| x| %emph; |sq| %xref | %index )* " > - -<!entity % list - " list | ul | ol | dl | kl | vl | memo | lisp | rfc | standard - | report | inproc " > - -<!entity % par - " %list; | comment | lq | quote | tscreen " > - -<!entity % mathpar " dm | eq " > - -<!entity % thrm - " defun | define | defvar | prop | lemma | coroll | proof | theorem " > - -<!entity % sectpar - " %par; | figure | table | faq | %mathpar; | - %thrm; "> -<!element sinfo o o (head, body) > - -<!element head - - (titlepag, header?, toc?, lof?, lot?)> -<!attlist head opts cdata "null"> - -<!element body - - ( abstract?, (p|noindent)*, h1*, - (appendix, h1+)?, biblio?) +(footnote)> -<!attlist body opts cdata "null"> - -<!entity % general system -- general purpose characters -- > -%general; -<!entity Ae 'Ä' > -<!entity ae 'ä' > -<!entity Oe 'Ö' > -<!entity oe 'ö' > -<!entity Ue 'Ü' > -<!entity ue 'ü' > -<!entity sz 'ß' > -<!element noindent o o (( %inline | %sectpar )+) +(newline) > -<!element p o o (( %inline | %sectpar )+) +(newline) > -<!entity ptag '<p>' > -<!entity psplit '</p><p>' > - -<!element em - - (%inline)> -<!element bf - - (%inline)> -<!element it - - (%inline)> -<!element sf - - (%inline)> -<!element sl - - (%inline)> -<!element tt - - (%inline)> -<!element sq - - (%inline)> -<!element cparam - - (%inline)> - -<!entity ftag '<f>' -- formula begin -- > -<!entity qendtag '</sq>'> - -<!element lq - - ((p|noindent)*)> -<!element quote - - ((%inline; | %sectpar;)*, (p|noindent)*)+ > -<!element tscreen - - ((%inline; | %sectpar;)*, (p|noindent)*)+ > -<!element ul - - (li+)> -<!element ol - - (li+)> -<!element list - - (li+)> -<!element memo - - ((%inline; | %sectpar; )*, (p|noindent)*)+ > -<!attlist memo title cdata "Memo"> -<!element rfc - o empty> -<!attlist rfc - name cdata #implied - number cdata #required - type cdata #implied - author cdata #required - title cdata #required - date cdata #required - obsolete cdata #implied> -<!element standard - o empty> -<!attlist standard - abbrev cdata #implied - org cdata #implied - title-cn cdata #implied - title-en cdata #implied - title-fr cdata #implied - title-ja cdata #implied - number cdata #required - year cdata #implied> -<!element report - o empty> -<!attlist report - abbrev cdata #implied - author cdata #required - title-cn cdata #implied - title-en cdata #implied - title-fr cdata #implied - title-ja cdata #implied - date cdata #implied> -<!element inproc - o empty> -<!attlist inproc - abbrev cdata #implied - author cdata #required - title-cn cdata #implied - title-en cdata #implied - title-fr cdata #implied - title-ja cdata #implied - book-cn cdata #implied - book-en cdata #implied - book-fr cdata #implied - book-ja cdata #implied - date cdata #implied> -<!element dl - - (dt,dd)+ > -<!element dt - o ((%inline; | %sectpar;)*, (p|noindent)*) > -<!element dd - o ((%inline; | %sectpar;)*, (p|noindent|newline)*) > - -<!element kl - - ((kt,kd)|(dt,dd))+ > -<!element kt - o ((%inline; | %sectpar;)*, (p|noindent)*) > -<!element kd - o ((%inline; | %sectpar;)*, (p|noindent|newline)*) > - -<!element vl - - (dt,dd)+ > - -<!element li - o ((%inline; | %sectpar;)*, (p|noindent)*) > - -<!element tag - o (%inline)> -<!entity space " "> -<!entity null ""> - -<!element faq - - (keyword?, (poster?, pdate?, (question| answer| coment)? )*)+> -<!element keyword - o (%inline;)*> -<!element poster - o (%inline;)*> -<!element pdate - o (%inline;)*> -<!element question - o ((%inline; | %sectpar;)*, (p|noindent)*)+> -<!element answer - o ((%inline; | %sectpar;)*, (p|noindent)*)+> -<!element coment - o ((%inline; | %sectpar;)*, (p|noindent)*)+> - -<!element figure - - ((eps | ph ), caption?)> -<!attlist figure - loc cdata "tbp"> - -<!-- eps attributes added by mb and td --> -<!element eps - o empty > -<!attlist eps - file cdata #required - height cdata "5cm" - angle cdata "0"> - -<!element ph - o empty > -<!attlist ph - vspace cdata #required> - -<!element caption - o (%inline)> - -<!element rowsep - o empty> -<!element colsep - o empty> -<!element hline - o empty> - -<!entity rowsep "<rowsep>"> -<!entity colsep "<colsep>"> - -<!element table - - (tabular, caption?) > -<!attlist table - loc cdata "tbp"> - -<!element code - - rcdata> -<!element verb - - rcdata> -<!element var - - rcdata> -<!element lisp - - rcdata> -<!element mail - - rcdata> -<!element file - - rcdata> -<!element kbd - - rcdata> -<!element key - - rcdata> - -<!shortref ttmap -- also on one-line -- - "B&#RE;" space - "&#RS;&#RE;" null - "&#RS;B&#RE;" null - "&#RS;B" null - '#' num - '%' percnt - '~' tilde - '_' lowbar - '^' circ - '{' lcub - '}' rcub - '|' verbar > - -<!usemap ttmap tt> -<!element mc - - cdata > -<!entity % sppos "tu" > -<!entity % fcs "%sppos;|phr" > -<!entity % fcstxt "#pcdata|mc|%fcs;" > -<!entity % fscs "rf|v|fi" > -<!entity % limits "pr|in|sum" > -<!entity % fbu "fr|lim|ar|root" > -<!entity % fph "unl|ovl|sup|inf" > -<!entity % fbutxt "(%fbu;) | (%limits;) | - (%fcstxt;)|(%fscs;)|(%fph;)" > -<!entity % fphtxt "p|#pcdata" > -<!element f - - ((%fbutxt;)*) > - -<!entity fendtag '</f>' -- formula end -- > - -<!shortref fmap - "&#RS;B" null - "&#RS;B&#RE;" null - "&#RS;&#RE;" null - "_" thinsp - "~" nbsp - "]" fendtag - "#" num - "%" percnt - "^" circ - "{" lcub - "}" rcub - "|" verbar> - -<!usemap fmap f > - -<!element dm - - ((%fbutxt;)*)> -<!element eq - - ((%fbutxt;)*)> - -<!shortref dmmap - "&#RE;" space - "_" thinsp - "~" nbsp - "]" fendtag - "#" num - "%" percnt - "^" circ - "{" lcub - "}" rcub - "|" verbar> - -<!usemap dmmap (dm,eq)> -<!element fr - - (nu,de) > -<!element nu o o ((%fbutxt;)*) > -<!element de o o ((%fbutxt;)*) > -<!element sub o o ((%fbutxt;)*) > -<!element super o o ((%fbutxt;)*) > -<!element opd - o ((%fbutxt;)*) > -<!element pr - - (ll,u,opd?) > -<!element in - - (ll,u,opd?) > -<!element sum - - (ll,u,opd?) > -<!element lim - - (op,ll,u,opd?) > -<!element op o o (%fcstxt;|rf|%fph;) -(tu) > -<!element root - - ((%fbutxt;)*) > -<!attlist root - n cdata ""> -<!element col o o ((%fbutxt;)*) > -<!element row o o (col, (arc, col)*) > - -<!element ar - - (row, (arr, row)*) > -<!attlist ar - ca cdata #required > -<!element arr - o empty > -<!element arc - o empty > -<!entity arr "<arr>" > -<!entity arc "<arc>" > - -<!shortref arrmap - "&#RE;" space - "@" arr - "|" arc - "_" thinsp - "~" nbsp - "#" num - "%" percnt - "^" circ - "{" lcub - "}" rcub > - -<!usemap arrmap ar > -<!element sup - - ((%fbutxt;)*) -(tu) > -<!element inf - - ((%fbutxt;)*) -(tu) > -<!element unl - - ((%fbutxt;)*) > -<!element ovl - - ((%fbutxt;)*) > -<!element rf - o (#pcdata) > -<!element phr - o ((%fphtxt;)*) > -<!element v - o ((%fcstxt;)*) - -(tu|%limits;|%fbu;|%fph;) > -<!element fi - o (#pcdata) > -<!element tu - o empty > - -<!element defun - - (args?,opts?,rest?,(p|noindent|newline)*)> -<!attlist defun - name cdata #required> -<!element args - o (#pcdata)> -<!element opts - o (#pcdata)> -<!element rest - o (#pcdata)> - -<!element define - - (args?,opts?,rest?,(p|noindent|newline)*)> -<!attlist define - type cdata #required - name cdata #required> - -<!element defvar - - ((p|noindent)+) > -<!attlist defvar - name cdata #required> -<!element prop - - (thtag?, p+) > -<!element lemma - - (thtag?, p+) > -<!element coroll - - (thtag?, p+) > -<!element proof - - (p+) > -<!element theorem - - (thtag?, p+) > -<!element thtag - - (%inline)> - -<!entity qtag '<sq>' > - -<!element label - o empty> -<!attlist label id cdata #required> - -<!element concept - - cdata> - -<!element a - - (p+)> -<!attlist a - file cdata #implied - node cdata #implied - href cdata #implied> - -<!element cf - o empty> -<!attlist cf - file cdata #implied - node cdata #implied - href cdata #implied > - -<!element ref - o empty> -<!attlist ref - file cdata #implied - node cdata #implied> - -<!element dref - - cdata> -<!attlist dref - file cdata #implied> - -<!element comment - - (%inline)> -<!element x - - ((#pcdata | mc)*) > -<!usemap #empty x > - -<!-- Hacked by mdw, abstract now part of titlepag --> -<!element titlepag o o (title, author, date?, trans?, tdate?)> -<!element title - o (%inline, subtitle?) +(newline)> -<!element subtitle - o (%inline)> -<!element author - o (name, thanks?, inst?, mail?, - (and, name, thanks?, inst?)*)> -<!element trans - o (name, thanks?, inst?, - (and, name, thanks?, inst?)*)> -<!element name o o (%inline) +(newline)> -<!element and - o empty> -<!element thanks - o (%inline)> -<!element inst - o (%inline) +(newline)> -<!element date - o (#pcdata) > -<!element tdate - o (#pcdata) > - -<!element newline - o empty > -<!entity nl "<newline>"> - -<!-- Hacked by ono --> -<!element abstract - o (%inline, (p|noindent)*)+ +(newline)> - - -<!element toc - o empty> -<!element lof - o empty> -<!element lot - o empty> -<!element header - - (lhead, rhead) > -<!element lhead - o (%inline)> -<!element rhead - o (%inline)> -<!entity % sec-b "(p|noindent)*, (cindex|findex|vindex)* " > -<!entity % sect "heading, node?, %sec-b " > -<!element heading o o (%inline)> -<!element h1 - o (%sect, h2*) +(footnote)> -<!element h2 - o (%sect, h3*)> -<!element h3 - o (%sect, h4*)> -<!element h4 - o (%sect, h5*)> -<!element h5 - o (%sect)> -<!element node - o (heading)> -<!element cindex - o empty> -<!element findex - o empty> -<!element vindex - o empty> -<!element appendix - o empty > -<!element footnote - - (%inline)> -<!element cite - o empty> -<!attlist cite - id cdata #required> - -<!element ncite - o empty> -<!attlist ncite - id cdata #required - note cdata #required> - -<!element idx - - (#pcdata)> -<!element cdx - - (#pcdata)> - -<!element biblio - o empty> -<!attlist biblio - style cdata "sinfo" - files cdata ""> -<!element slides - - (slide*) > - -<!attlist slides - opts cdata "null"> -<!element slide - o (title?, p+) > -<!entity % addr "(address?, email?, phone?, fax?)" > - -<!element letter - - - (from, %addr, to, %addr, cc?, subject?, sref?, rref?, - rdate?, opening, p+, closing, encl?, ps?)> - -<!attlist letter - opts cdata "null"> - -<!element from - o (#pcdata) > -<!element to - o (#pcdata) > - -<!element address - o (#pcdata) +(newline) > -<!element email - o (#pcdata) > -<!element phone - o (#pcdata) > -<!element fax - o (#pcdata) > - -<!element subject - o (%inline;) > -<!element sref - o (#pcdata) > -<!element rref - o (#pcdata) > -<!element rdate - o (#pcdata) > - -<!element opening - o (%inline;) > - -<!element closing - o (%inline;) > -<!element cc - o (%inline;) +(newline) > -<!element encl - o (%inline;) +(newline) > - -<!element ps - o (p+) > - -<!element telefax - - - (from, %addr, to, address, email?, - phone?, fax, cc?, subject?, - opening, p+, closing, ps?)> - -<!attlist telefax - opts cdata "null" - length cdata "2"> - -<!element notes - - (title?, p+) > -<!attlist notes - opts cdata "null" > - -<!-- end of sinfo dtd -->
--- a/etc/sgml/webtechs.catalog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ - -- catalog: SGML Open style entity catalog for HTML -- - -- $Id: webtechs.catalog,v 1.1.1.1 1996/12/18 22:42:23 steve Exp $ -- - -- well that $id is messed up now cos I edited the file! -- - - -- ISO latin 1 entity set for HTML -- = -PUBLIC "-//IETF//ENTITIES Added Latin 1 for HTML//EN" ISOlat1.sgml -PUBLIC "ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML" ISOlat1.sgml - - -- fake HTMLicons reference -- -PUBLIC "-//IETF//ENTITIES icons for HTML//EN" html-icons.sgml - - -- fake HTMLmath reference -- -PUBLIC "-//IETF//ENTITIES Math and Greek for HTML//EN" html-math.sgml - - -- Ways to refer to Level 3.2: most general to most specific -- -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd - - -- Ways to refer to Level 3: most general to most specific -- -PUBLIC "-//IETF//DTD HTML//EN//3.0" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN//" html-3.dtd -PUBLIC "-//W3O//DTD W3 HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML 3.0//EN//" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN" html-3.dtd -PUBLIC "-//IETF//DTD HTML Level 3//EN//3.0" html-3.dtd - - -- Ways to refer to strict Level 3: most general to most specific -- -PUBLIC "-//IETF//DTD HTML Strict//EN//3.0" html-3s.dtd -PUBLIC "-//W3O//DTD W3 HTML Strict 3.0//EN//" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN" html-3s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 3//EN//3.0" html-3s.dtd - - -- Ways to refer to Level 2: most general to most specific -- -PUBLIC "HTML" html.dtd -PUBLIC "-//IETF//DTD HTML//EN" html.dtd -PUBLIC "-//IETF//DTD HTML//EN//2.0" html.dtd -PUBLIC "-//IETF//DTD HTML 2.0//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN" html.dtd -PUBLIC "-//IETF//DTD HTML Level 2//EN//2.0" html.dtd - - -- Ways to refer to Level 1: most general to most specific -- -PUBLIC "-//IETF//DTD HTML Level 1//EN" html-1.dtd -PUBLIC "-//IETF//DTD HTML Level 1//EN//2.0" html-1.dtd - - -- Ways to refer to Level 0: most general to most specific -- -PUBLIC "-//IETF//DTD HTML Level 0//EN" html-0.dtd -PUBLIC "-//IETF//DTD HTML Level 0//EN//2.0" html-0.dtd - - -- Ways to refer to Strict Level 2 -- -PUBLIC "-//IETF//DTD HTML Strict//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict//EN//2.0" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN" html-s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 2//EN//2.0" html-s.dtd - - -- Ways to refer to Strict Level 1 -- -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN" html-1s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 1//EN//2.0" html-1s.dtd - - -- Ways to refer to Strict Level 0 -- -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN" html-0s.dtd -PUBLIC "-//IETF//DTD HTML Strict Level 0//EN//2.0" html-0s.dtd - - -- Ways to refer to Netscape extensions HTML -- -PUBLIC "-//Netscape Comm. Corp.//DTD HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML//EN" html-mcom.dtd -PUBLIC "-//WebTechs//DTD Mozilla HTML 2.0//EN" html-mcom.dtd -PUBLIC "-//Netscape Comm. Corp.//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML//EN" html-mcoms.dtd -PUBLIC "-//WebTechs//DTD Strict HTML 2.0//EN" html-mcoms.dtd - - -- Ways to refer to Sun Microsystems HotJava extensions -- -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava HTML//EN" html-hj.dtd -PUBLIC "-//Sun Microsystems Corp.//DTD HotJava Strict HTML//EN" html-hjs.dtd - - -- Ways to refer to PUML -- -PUBLIC "-//WebTechs//DTD PUML 1.0//EN" puml.dtd - - -- Ways to Refer to SoftQuad HTML 2.0 + extensions -- -PUBLIC "-//SQ//DTD HTML 2.0 HoTMetaL + extensions//EN" SQ.dtd - - -- Ways to refer to Microsoft extensions HTML -- -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML//EN" iehtml.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 HTML Strict//EN" iehtml-s.dtd -PUBLIC "-//Microsoft//DTD Internet Explorer 2.0 Tables//EN" ietables.dtd - -PUBLIC "-//W3C//DTD HTML 3.2//EN" html-3.2.dtd -
--- a/etc/viperCard.tex Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,739 +0,0 @@ -% ViperCard -- The Reference Card for Viper under GNU Emacs 20 and XEmacs 20 -%**start of header -\newcount\columnsperpage - -% This file can be printed with 1 or 2 columns per page (see below). -% Specify how many you want here. Nothing else needs to be changed. - -\columnsperpage=2 - -% Copyright (c) 1995, 1996, 1997 Free Software Foundation, Inc. - -% This file is part of GNU Emacs. - -% This file is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY. No author or distributor -% accepts responsibility to anyone for the consequences of using it -% or for whether it serves any particular purpose or describes -% any piece of software unless they say so in writing. Refer to the -% GNU Emacs General Public License for full details. -% -% Permission is granted to copy, modify and redistribute this source -% file provided the copyright notice and permission notices are -% preserved on all copies. -% -% Permission is granted to process this file through TeX and print the -% results, provided the printed document carries copyright and -% permission notices identical to the ones below. - -% This file is intended to be processed by plain TeX (TeX82). -% -% The final reference card has six columns, three on each side. -% This file can be used to produce it in any of three ways: -% 1 column per page -% produces six separate pages, each of which needs to be reduced to 80%. -% This gives the best resolution. -% 2 columns per page -% produces three already-reduced pages. -% You will still need to cut and paste. -% 3 columns per page -% produces two pages which must be printed sideways to make a -% ready-to-use 8.5 x 11 inch reference card. -% For this you need a dvi device driver that can print sideways. -% Which mode to use is controlled by setting \columnsperpage above. -% -% Author of Viper: -% Michael Kifer -% email: kifer@cs.sunysb.edu -% -% Author of VIP 4.3: -% Aamod Sane -% email: sane@cs.uiuc.edu -% -% Author of VIP 3.5: -% Masahiko Sato -% email: ms@sail.stanford.edu -% -% The original TeX code for formatting the reference card was written by: -% Stephen Gildea -% UUCP: mit-erl!gildea -% email: gildea@erl.mit.edu - - -\def\versionnumber{2.96} -\def\year{1997} -\def\version{August \year\ v\versionnumber} - -\def\shortcopyrightnotice{\vskip 1ex plus 2 fill - \centerline{\small \copyright\ \year\ Free Software Foundation, Inc. - Permissions on back. v\versionnumber}} - -\def\copyrightnotice{ -%\vskip 1ex plus 2 fill\begingroup\small -\vskip 1ex \begingroup\small -\centerline{Copyright \copyright\ \year\ Free Software Foundation, Inc.} -\centerline{by Michael Kifer, Viper \version} -\centerline{by Aamod Sane, VIP version 4.3} -\centerline{by Masahiko Sato, VIP version 3.5} - -Permission is granted to make and distribute copies of -this card provided the copyright notice and this permission notice -are preserved on all copies. - -For copies of the GNU Emacs manual, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\endgroup} - -% make \bye not \outer so that the \def\bye in the \else clause below -% can be scanned without complaint. -\def\bye{\par\vfill\supereject\end} - -\newdimen\intercolumnskip -\newbox\columna -\newbox\columnb - -\def\ncolumns{\the\columnsperpage} - -\message{[\ncolumns\space - column\if 1\ncolumns\else s\fi\space per page]} - -\def\scaledmag#1{ scaled \magstep #1} - -% This multi-way format was designed by Stephen Gildea -% October 1986. -% Slightly modified by Masahiko Sato, September 1987. -\if 1\ncolumns - \hsize 4in - \vsize 10in - %\voffset -.7in - \voffset -.57in - \font\titlefont=\fontname\tenbf \scaledmag3 - \font\headingfont=\fontname\tenbf \scaledmag2 - \font\miniheadingfont=\fontname\tenbf \scaledmag1 % masahiko - \font\smallfont=\fontname\sevenrm - \font\smallsy=\fontname\sevensy - - \footline{\hss\folio} - \def\makefootline{\baselineskip10pt\hsize6.5in\line{\the\footline}} -\else - %\hsize 3.2in - %\vsize 7.95in - \hsize 3.41in % masahiko - \vsize 8in % masahiko - \hoffset -.75in - \voffset -.745in - \font\titlefont=cmbx10 \scaledmag2 - \font\headingfont=cmbx10 \scaledmag1 - \font\miniheadingfont=cmbx10 % masahiko - \font\smallfont=cmr6 - \font\smallsy=cmsy6 - \font\eightrm=cmr8 - \font\eightbf=cmbx8 - \font\eightit=cmti8 - \font\eightsl=cmsl8 - \font\eighttt=cmtt8 - \font\eightsy=cmsy8 - \textfont0=\eightrm - \textfont2=\eightsy - \def\rm{\eightrm} - \def\bf{\eightbf} - \def\it{\eightit} - \def\sl{\eightsl} % masahiko - \def\tt{\eighttt} - \normalbaselineskip=.8\normalbaselineskip - \normallineskip=.8\normallineskip - \normallineskiplimit=.8\normallineskiplimit - \normalbaselines\rm %make definitions take effect - - \if 2\ncolumns - \let\maxcolumn=b - \footline{\hss\rm\folio\hss} - \def\makefootline{\vskip 2in \hsize=6.86in\line{\the\footline}} - \else \if 3\ncolumns - \let\maxcolumn=c - \nopagenumbers - \else - \errhelp{You must set \columnsperpage equal to 1, 2, or 3.} - \errmessage{Illegal number of columns per page} - \fi\fi - - %\intercolumnskip=.46in - \intercolumnskip=.19in % masahiko .19x4 + 3.41x3 = 10.99 - \def\abc{a} - \output={% - % This next line is useful when designing the layout. - %\immediate\write16{Column \folio\abc\space starts with \firstmark} - \if \maxcolumn\abc \multicolumnformat \global\def\abc{a} - \else\if a\abc - \global\setbox\columna\columnbox \global\def\abc{b} - %% in case we never use \columnb (two-column mode) - \global\setbox\columnb\hbox to -\intercolumnskip{} - \else - \global\setbox\columnb\columnbox \global\def\abc{c}\fi\fi} - \def\multicolumnformat{\shipout\vbox{\makeheadline - \hbox{\box\columna\hskip\intercolumnskip - \box\columnb\hskip\intercolumnskip\columnbox} - \makefootline}\advancepageno} - \def\columnbox{\leftline{\pagebody}} - - \def\bye{\par\vfill\supereject - \if a\abc \else\null\vfill\eject\fi - \if a\abc \else\null\vfill\eject\fi - \end} -\fi - -% we won't be using math mode much, so redefine some of the characters -% we might want to talk about -\catcode`\^=12 -\catcode`\_=12 - -\chardef\\=`\\ -\chardef\{=`\{ -\chardef\}=`\} - -\hyphenation{mini-buf-fer} - -\parindent 0pt -\parskip 1ex plus .5ex minus .5ex - -\def\small{\smallfont\textfont2=\smallsy\baselineskip=.8\baselineskip} - -\outer\def\newcolumn{\vfill\eject} - -\outer\def\title#1{{\titlefont\centerline{#1}}\vskip 1ex plus .5ex} - -\outer\def\section#1{\par\filbreak - \vskip 3ex plus 2ex minus 2ex {\headingfont #1}\mark{#1}% - \vskip 2ex plus 1ex minus 1.5ex} - -% masahiko -\outer\def\subsection#1{\par\filbreak - \vskip 2ex plus 2ex minus 2ex {\miniheadingfont #1}\mark{#1}% - \vskip 1ex plus 1ex minus 1.5ex} - -\newdimen\keyindent - -\def\beginindentedkeys{\keyindent=1em} -\def\endindentedkeys{\keyindent=0em} -\endindentedkeys - -\def\paralign{\vskip\parskip\halign} - -\def\<#1>{$\langle${\rm #1}$\rangle$} - -\def\kbd#1{{\tt#1}\null} %\null so not an abbrev even if period follows - -\def\beginexample{\par\leavevmode\begingroup - \obeylines\obeyspaces\parskip0pt\tt} -{\obeyspaces\global\let =\ } -\def\endexample{\endgroup} - -\def\key#1#2{\leavevmode\hbox to \hsize{\vtop - {\hsize=.75\hsize\rightskip=1em - \hskip\keyindent\relax#1}\kbd{#2}\hfil}} - -\newbox\metaxbox -\setbox\metaxbox\hbox{\kbd{M-x }} -\newdimen\metaxwidth -\metaxwidth=\wd\metaxbox - -\def\metax#1#2{\leavevmode\hbox to \hsize{\hbox to .75\hsize - {\hskip\keyindent\relax#1\hfil}% - \hskip -\metaxwidth minus 1fil - \kbd{#2}\hfil}} - -\def\fivecol#1#2#3#4#5{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad&\kbd{#4}\quad&\kbd{#5}\cr} - -\def\fourcol#1#2#3#4{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad&\kbd{#4}\quad\cr} - -\def\threecol#1#2#3{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad\cr} - -\def\twocol#1#2{\hskip\keyindent\relax\kbd{#1}\hfil&\kbd{#2}\quad\cr} - -\def\twocolkey#1#2#3#4{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad&\relax#3\hfil&\kbd{#4}\quad\cr} - -%**end of header - -\beginindentedkeys - -\title{ViperCard: Viper Reference Pal} - -\centerline{(For Version 2.96 under Emacs 20 and XEmacs 20)} - -%\copyrightnotice - -\section{Loading Viper} - -Just type \kbd{M-x viper-mode} followed by \kbd{RET} - -OR put (require 'viper) in .emacs - -\section{Viper States} - -Viper has four states: {\it emacs state}, {\it vi state}, {\it insert state}, -{\it replace state}. -Mode line tells you which state you are in. -In emacs state you can do all the normal GNU Emacs editing. -This card explains only vi state and insert state (replace state is similar -to insert state). -{\bf GNU Emacs Reference Card} explains emacs state. -You can switch states as follows. - -\key{from emacs state to vi state}{C-z} -\key{from vi state to emacs state}{C-z} -\metax{from vi state to insert state}{i, I, a, A, o, O} -\metax{from vi state to replace state}{c, C, R} -\key{from insert or replace state to vi state}{ESC} - - -\section{Insert Mode} -You can do editing in insert state. - -\metax{go back to vi state}{ESC} -\metax{delete previous character}{C-h, DEL} -\key{delete previous word}{C-w} -\key{delete line word}{C-u} -\key{indent shiftwidth forward}{C-t} -\key{indent shiftwidth backward}{C-d} -\key{delete line word}{C-u} -\key{quote following character}{C-v} -\key{emulate Meta key in emacs state}{C-\\} -\key{escape to Vi state for one command}{C-z} - -\vskip 2mm - -{\bf The rest of this card explains commands in {\bf vi state}.} - -\section{Getting Information on Viper} - -Execute info command by typing \kbd{M-x info} and select menu item -\kbd{viper}. Also: - -\key{describe function attached to the key {\it x}}{$\backslash$ C-h k {\it x}} - -\section{Leaving Emacs} - -\metax{suspend Emacs}{:st {\rm or} :su} -\metax{exit Emacs permanently}{C-xC-c} -\metax{exit current file}{:wq {\rm or} :q} - -\shortcopyrightnotice - -\section{Error Recovery} - -\metax{abort command}{C-c (user level = 1)} -\metax{abort command}{C-g (user level > 1)} -\key{redraw messed up screen}{C-l} -\metax{{\bf recover} after system crash}{:rec file} -\metax{restore a buffer }{:e!\ {\rm or} M-x revert-buffer} - - -\section{Counts} - -Most commands in vi state accept a {\it count} which can be supplied as a -prefix to the commands. In most cases, if a count is given, the -command is executed that many times. E.g., \kbd{5 d d} deletes 5 -lines. - -\section{Registers} - -There are 26 registers (\kbd{a} to \kbd{z}) that can store texts -and marks. -You can append a text at the end of a register (say \kbd{x}) by -specifying the register name in capital letter (say \kbd{X}). -There are also 9 read only registers (\kbd{1} to \kbd{9}) that store -up to 9 previous changes. -We will use {\it x\/} to denote a register. -\section{Entering Insert Mode} - -\key{{\bf insert} at point}{i} -\key{{\bf append} after cursor}{a} -\key{{\bf insert} before first non-white}{I} -\key{{\bf append} at end of line}{A} -\key{{\bf open} line below}{o} -\key{{\bf open} line above}{O} - -\section{Buffers and Windows} - -\key{move cursor to {\bf next} window}{C-x o} -\key{delete current window}{C-x 0} -\key{delete other windows}{C-x 1} -\key{split current window into two windows}{C-x 2} -\key{{\bf switch} to a buffer in the current window}{C-x {\sl buffer}} -\metax{{\bf switch} to a buffer in another window}{:n, :b, {\rm or} C-x 4 {\sl buf}} -\key{{\bf kill} a buffer}{:q! {\rm or} C-x k} -\key{list existing {\bf buffers}}{:args {\rm or} C-x b} - -\section{Files} - -\metax{{\bf visit} file in the current window}{v {\sl file} {\rm or} :e {\sl file}} -\key{{\bf visit} file in another window}{V {\sl file}} -\key{{\bf visit} file in another frame}{C-v {\sl file}} -\key{{\bf save} buffer to the associated file}{:w {\rm or} C-xC-s} -\metax{{\bf write} buffer to a specified file}{:w {\sl file} {\rm or} C-xC-w} -\metax{{\bf insert} a specified file at point}{:r {\sl file} {\rm or} C-xi} -\key{{\bf get} information on the current {\bf file}}{C-c g {\rm or} :f} -\key{run the {\bf directory} editor}{:e RET {\rm or} C-xd} - -%\shortcopyrightnotice - -\section{Viewing the Buffer} - -\key{scroll to next screen}{C-f} -\key{scroll to previous screen}{C-b} -\key{scroll {\bf down} half screen}{C-d} -\key{scroll {\bf up} half screen}{C-u} -\key{scroll down one line}{C-e} -\key{scroll up one line}{C-y} - -\key{put current line on the {\bf home} line}{z H {\rm or} z RET} -\key{put current line on the {\bf middle} line}{z M {\rm or} z .} -\key{put current line on the {\bf last} line}{z L {\rm or} z -} - -\section{Marking and Returning} - -\key{{\bf mark} point in register {\it x}}{m {\it x}} -\key{set mark at buffer beginning}{m <} -\key{set mark at buffer end}{m >} -\key{set mark at point}{m .} -\key{jump to mark}{m ,} -\key{exchange point and mark}{` `} -\key{... and skip to first non-white on line}{' '} -\key{go to mark {\it x}}{` {\it x}} -\key{... and skip to first non-white on line}{' {\it x}} -\key{view contents of marker {\it x}}{[ {\it x}} -\key{view contents of register {\it x}}{] {\it x}} - -\section{Macros} - -Emacs style macros: - -\key{start remembering keyboard macro}{C-x (} -\key{finish remembering keyboard macro}{C-x )} -\key{call last keyboard macro}{*} - -\key{start remembering keyboard macro}{@ \#} -\key{finish macro and put into register {\it x}}{@ {\it x}} -\key{execute macro stored in register {\it x}}{@ {\it x}} -\key{repeat last @{\it x} command}{@ @} - -\key{Pull last macro into register {\it x}}{@ ! {\it x}} - -Vi-style macros (keys to be hit in quick succession): - -\key{define Vi-style macro for Vi state}{:map} -\key{define Vi-style macro for Insert state}{:map!} - -\key{toggle case-sensitive search}{//} -\key{toggle regular expression search}{///} -\key{toggle `\%' to ignore parentheses inside comments}{\%\%\%} - - -\section{Motion Commands} - -\key{go backward one character}{h {\rm or} C-h} -\key{go forward one character}{l} -\metax{next line keeping the column}{j {\rm or} LF {\rm or} C-n} -\key{previous line keeping the column}{k} -\metax{next line at first non-white}{+ {\rm or} RET {\rm or} C-p} -\key{previous line at first non-white}{-} - -\key{beginning of line}{0} -\key{first non-white on line}{^} -\key{end of line}{\$} -\key{go to {\it n}-th column on line}{{\it n} |} - -\key{go to {\it n}-th line}{{\it n} G} -\key{go to last line}{G} -\key{find matching parenthesis for \kbd{()}, \kbd{\{\}} and \kbd{[]}}{\%} - -\key{go to {\bf home} window line}{H} -\key{go to {\bf middle} window line}{M} -\key{go to {\bf last} window line}{L} - -\subsection{Words, Sentences, Paragraphs, Headings} - -\key{forward {\bf word}}{w {\rm or} W} -\key{{\bf backward} word}{b {\rm or} B} -\key{{\bf end} of word}{e {\rm or} E} - -In the case of capital letter commands, a word is delimited by a -non-white character. - -\key{forward sentence}{)} -\key{backward sentence}{(} - -\key{forward paragraph}{\}} -\key{backward paragraph}{\{} - -\key{forward heading}{]]} -\key{backward heading}{[[} -\key{end of heading}{[]} - -\subsection{Find Characters on the Line} - -\key{{\bf find} {\it c} forward on line}{f {\it c}} -\key{{\bf find} {\it c} backward on line}{F {\it c}} -\key{up {\bf to} {\it c} forward on line}{t {\it c}} -\key{up {\bf to} {\it c} backward on line}{T {\it c}} -\key{repeat previous \kbd{f}, \kbd{F}, \kbd{t} or \kbd{T}}{;} -\key{... in the opposite direction}{,} - -%\newcolumn -%\title{Viper Quick Reference Card} - -\section{Searching and Replacing} - -\key{search forward for {\sl pat}}{/ {\sl pat}} -\key{search backward with previous {\sl pat}}{?\ RET} -\key{search forward with previous {\sl pat}}{/ RET} -\key{search backward for {\sl pat}}{?\ {\sl pat}} -\key{repeat previous search}{n} -\key{... in the opposite direction}{N} - -\key{{\bf query} replace}{Q} -\key{{\bf replace} a character by another character {\it c}}{r {\it c}} -\key{{\bf overwrite} {\it n} lines}{{\it n} R} - -\metax{{\bf buffer} search (if enabled)}{g {\it move command}} - -\section{Modifying Commands} - -Most commands that operate on text regions accept the motion commands, -to describe regions. They also accept the Emacs region specifications -{\bf r} and {\bf R}. {\bf r} describes the region between {\it point} -and {\it mark}, and {\bf R} describes whole lines in that region. -Motion commands are classified into {\it point commands} and -{\it line commands}. In the case of line commands, whole lines will -be affected by the command. - -The point commands are as follows: - -\hskip 5ex -\kbd{h l 0 ^ \$ w W b B e E ( ) / ?\ ` f F t T \% ; ,} - -The line commands are as follows: - -\hskip 5ex -\kbd{j k + - H M L \{ \} G '} - -These region specifiers will be referred to as {\it m} below. - -\subsection{Delete/Yank/Change Commands} - -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\tabskip=0pt&#\cr -\fourcol{}{{\bf delete}}{{\bf yank}}{{\bf change}} -\fourcol{region determined by {\it m}}{d {\it m}}{y {\it m}}{c {\it m}} -\fourcol{... into register {\it x}}{" {\it x\/} d {\it m}}{" {\it x\/} y {\it m}}{" {\it x\/} c {\it m}} -\fourcol{a line}{d d}{Y {\rm or} y y}{c c} -\fourcol{current {\bf region}}{d r}{y r}{c r} -\fourcol{expanded {\bf region}}{d R}{y R}{c R} -\fourcol{to end of line}{D}{y \$}{c \$} -\fourcol{a character after point}{x}{y l}{c l} -\fourcol{a character before point}{DEL}{y h}{c h} -} - -\vskip 2ex -\key{Overwrite {\it n} lines}{{\it n} R} - -\subsection{Put Back Commands} - -Deleted/yanked/changed text can be put back by the following commands. - -\key{{\bf Put} back at point/above line}{P} -\key{... from register {\it x}}{" {\it x\/} P} -\key{{\bf put} back after point/below line}{p} -\key{... from register {\it x}}{" {\it x\/} p} - -\subsection{Repeating and Undoing Modifications} - -\key{{\bf undo} last change}{u {\rm or} :und} -\key{repeat last change}{.\ {\rm (dot)}} - -Undo is undoable by \kbd{u} and repeatable by \kbd{.}. -For example, \kbd{u...} will undo 4 previous changes. -A \kbd{.} after \kbd{5dd} is equivalent to \kbd{5dd}, -while \kbd{3.} after \kbd{5dd} is equivalent to \kbd{3dd}. - -\section{Miscellaneous Commands} - -\endindentedkeys - -\paralign to \hsize{#\tabskip=5pt plus 1 fil&#\tabskip=0pt&#\tabskip=0pt&#\tabskip=0pt&#\cr -\fivecol{}{{\bf shift left}}{{\bf shift right}}{{\bf filter shell command}}{{\bf indent}} -\fivecol{region}{< {\it m}}{> {\it m}}{!\ {\it m\/} {\sl shell-com}}{= {\it m}} -\fivecol{line}{< <}{> >}{!\ !\ {\sl shell-com}}{= =} -} - -\key{{\bf join} lines}{J} -\key{toggle case (takes count)}{\~{}} - -\key{view register {\it x}}{] {\it x}} -\key{view marker {\it x}}{] {\it x}} - -\key{lowercase region}{\# c {\it m}} -\key{uppercase region}{\# C {\it m}} -\key{execute last keyboard macro on each line in the region}{\# g {\it m}} - -\key{insert specified string for each line in the region}{\# q {\it m}} -\key{check spelling of the words in the region}{\# s {\it m}} - -\key{repeat previous ex substitution}{\&} -\key{change to previous file}{C-^} - -\key{Viper Meta key}{_} - -\section{Customization} - -By default, search is case sensitive. -You can change this by including the following line in your \kbd{\~{}/.vip} file. - -\hskip 5ex -\kbd{(setq viper-case-fold-search t)} - -The following is a subset of the variety of -options available for customizing Viper. -See the Viper manual for details on these and other options. - -\beginindentedkeys - -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\cr -\twocol{{\bf variable}}{{\bf default value}} -\twocol{viper-search-wrap-around}{t} -\twocol{viper-case-fold-search}{nil} -\twocol{viper-re-search}{t} -\twocol{viper-re-replace}{t} -\twocol{viper-re-query-replace}{t} -\twocol{viper-auto-indent}{nil} -\twocol{viper-shift-width}{8} -\twocol{viper-tags-file-name}{"TAGS"} -\twocol{viper-no-multiple-ESC}{t} -\twocol{viper-ex-style-motion}{t} -\twocol{viper-always}{t} -\twocol{viper-custom-file-name}{"\~{}/.vip"} -\twocol{ex-find-file-shell}{"csh"} -\twocol{ex-cycle-other-window}{t} -\twocol{ex-cycle-through-non-buffers}{t} -\twocol{blink-matching-paren}{t} -\twocol{buffer-read-only}{{\it buffer dependent}} -} - -To bind keys in Vi command state, put lines like these in your -\kbd{\~{}/.vip} file: - -\beginexample -(define-key viper-vi-global-user-map "\\C-v" 'scroll-down) -(define-key viper-vi-global-user-map "\\C-cm" 'smail) -\endexample - - -\newcolumn - -\title{Ex Commands in Viper} - -In vi state, an Ex command is entered by typing: - -\hskip 5ex -\kbd{:\ {\sl ex-command} RET} - -\section{Ex Addresses} - -\paralign to \hsize{#\tabskip=5pt plus 1 fil&#\tabskip=2pt&#\tabskip=5pt plus 1 fil&#\cr -\twocolkey{current line}{.}{next line with {\sl pat}}{/ {\sl pat} /} -\twocolkey{line {\it n}}{{\it n}}{previous line with {\sl pat}}{?\ {\sl pat} ?} -\twocolkey{last line}{\$}{{\it n\/} line before {\it a}}{{\it a} - {\it n}} -\twocolkey{next line}{+}{{\it a\/} through {\it b}}{{\it a\/} , {\it b}} -\twocolkey{previous line}{-}{line marked with {\it x}}{' {\it x}} -\twocolkey{entire buffer}{\%}{previous context}{' '} -} - -Addresses can be specified in front of a command. -For example, - -\hskip 5ex -\kbd{:.,.+10m\$} - -moves 11 lines below current line to the end of buffer. - -\section{Ex Commands} - -Avoid Ex text manipulation commands except substitute. -There are better VI equivalents -for all of them. Also note that all Ex commands expand \% to -current file name. To include a \% in the command, escape it with a $\backslash$. -Similarly, \# is replaced by previous file. For Viper, this is the -first file in the {\sl :args} listing for that buffer. This defaults -to the previous file in the VI sense if you have one window. -Ex commands can be made to have history. See the manual for details. - -\subsection{Ex Text Commands} - -\endindentedkeys - -\key{mark lines matching {\sl pat} and execute {\sl cmds} on these lines}{:g /{\sl pat}/ {\sl cmds}} - -\key{mark lines {\it not\/} matching {\sl pat} and execute {\sl cmds} on these lines}{:v /{\sl pat}/ {\sl cmds}} - - -\key{{\bf move} specified lines after {\sl addr}}{:m {\sl addr}} -\key{{\bf copy} specified lines after {\sl addr}}{:co\rm\ (or \kbd{:t})\ \sl addr} -\key{{\bf delete} specified lines [into register {\it x\/}]}{:d {\rm [{\it x\/}]}} -\key{{\bf yank} specified lines [into register {\it x\/}]}{:y {\rm [{\it x\/}]}} -\key{{\bf put} back text [from register {\it x\/}]}{:pu {\rm [{\it x\/}]}} - -\key{{\bf substitute} {\sl repl} for first string on line matching {\sl pat}}{:s /{\sl pat}/{\sl repl}/} - -\key{repeat last substitution}{:\&} -\key{repeat previous substitute with previous search pattern as {\sl pat}}{:\~{}} - -\subsection{Ex File and Shell Commands} - -\key{{\bf edit} file}{:e {\sl file}} -\key{reedit messed up current file}{:e!} -\key{edit previous file}{:e\#} -\key{{\bf read} in a file}{:r {\sl file}} -\key{{\bf read} in the output of a shell command}{:r {\sl !command}} -\key{write out specified lines into {\sl file}}{:w {\sl file}} -\key{save all modified buffers, ask confirmation}{:W {\sl file}} -\key{save all modified buffers, no confirmation}{:WW {\sl file}} -\key{write out specified lines at the end of {\sl file}}{:w>> {\sl file}} -\key{{\bf write} to the input of a shell command}{:w {\sl !command}} -\key{write out and then quit}{:wq {\sl file}} - -\key{run a sub{\bf shell} in a window}{:sh} -\key{execute shell command {\sl command}}{:!\ {\sl command}} -\key{execute previous shell command with {\it args} appended}{:!! {\sl args}} - -\subsection{Ex Miscellaneous Commands} - -\key{define a macro {\it x} that expands to {\sl cmd}}{:map {\it x} {\sl cmd}} -\key{remove macro expansion associated with {\it x}}{:unma {\it x}} -\key{define a macro {\it x} that expands to {\sl cmd} in insert state}{:map!\ {\it x} {\sl cmd}} -\key{remove macro expansion associated with {\it x} in insert state}{:unma!\ {\it x}} - -\key{print line number}{:.=} -\key{print last line number}{:=} -\key{print {\bf version} number of Viper}{:ve} - -\key{shift specified lines to the right}{:>} -\key{shift specified lines to the left}{:<} - -\key{{\bf join} lines}{:j} -\key{mark specified line to register {\it x}}{:k {\it x}} -\key{{\bf set} a variable's value}{:se} -\key{find first definition of {\bf tag} {\sl tag}}{:ta {\sl tag}} - -\key{Current directory}{:pwd} - - -\copyrightnotice - -\bye - -% Local variables: -% compile-command: "tex viperCard" -% End:
--- a/etc/vm/audio_stamp-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -/* XPM */ -static char *audio_stamp[] = { -/* width height num_colors chars_per_pixel */ -" 18 24 12 1", -/* colors */ -". c #000000", -"# c #00ffff", -"a c #00ff00", -"b c #bebebe s background", -"c c #ff00ff", -"d c #ff0000", -"e c #6e6e6e", -"f c #ffffff", -"g c #ffff00", -"h c #e7e7e7", -"i c #bfbfbf", -"j c #0000ff", -/* pixels */ -"bbbbbbbbbbbbbbbbbb", -"bbbbbbbbbbbbabbbbb", -"bbbbbbbbbbbebbbbbb", -"bbbbbbbeebbbbbebbb", -"bbbbbbbe.bbbbjebbb", -"bbbbbbeh.bbejijhbb", -"bbbbbebh.bijhieiib", -"bbbbiehh.bieiejibb", -"b..e.hhh.biebjjiib", -"b.hehhhh.bejibebci", -"b.hhhhhh.ijjiibiib", -"b.hhhhhh.ihiiieiii", -"b.hhhhhh.ibiiieiii", -"b.hhhhhh.bhfbbdhii", -"b.hhhhhh.bbbbieiib", -"b.hehhhh.bbbideiib", -"b..e.hhh.bbbidebbb", -"bbbbbehh.bbbiibbbb", -"bbbbbebh.bbbbbbbgi", -"bbbbiieh.bbbbbbbgg", -"bbbbiibe.bb#bbbbib", -"bbbbbbbeebbbh#bbgb", -"bbbbbbbbbbbbbbbbii", -"bbbbbbbbbbbbbbbbgb" -};
--- a/etc/vm/audio_stamp-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -/* XPM */ -static char *audio_stamp[] = { -/* width height num_colors chars_per_pixel */ -" 18 24 12 1", -/* colors */ -". c #000000", -"# c #00ffff", -"a c #00ff00", -"b c #bebebe s background", -"c c #ff00ff", -"d c #ff0000", -"e c #6e6e6e", -"f c #ffffff", -"g c #ffff00", -"h c #e7e7e7", -"i c #bfbfbf", -"j c #0000ff", -/* pixels */ -"bbbbbbbbbbbbbbbbbb", -"bbbbbbbbbbbbabbbbb", -"bbbbbbbbbbbebbbbbb", -"bbbbbbbeebbbbbebbb", -"bbbbbbbe.bbbbjebbb", -"bbbbbbeh.bbejijhbb", -"bbbbbebh.bijhieiib", -"bbbbiehh.bieiejibb", -"b..e.hhh.biebjjiib", -"b.hehhhh.bejibebci", -"b.hhhhhh.ijjiibiib", -"b.hhhhhh.ihiiieiii", -"b.hhhhhh.ibiiieiii", -"b.hhhhhh.bhfbbdhii", -"b.hhhhhh.bbbbieiib", -"b.hehhhh.bbbideiib", -"b..e.hhh.bbbidebbb", -"bbbbbehh.bbbiibbbb", -"bbbbbebh.bbbbbbbgi", -"bbbbiieh.bbbbbbbgg", -"bbbbiibe.bb#bbbbib", -"bbbbbbbeebbbh#bbgb", -"bbbbbbbbbbbbbbbbii", -"bbbbbbbbbbbbbbbbgb" -};
--- a/etc/vm/autofile-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, - 0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb, - 0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0x5f,0xfe,0xff,0xff,0xff,0xff,0x7f, - 0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff, - 0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff, - 0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xfe,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xfe,0xff, - 0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe, - 0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb, - 0xfe,0xff,0xff,0xff,0xff,0xff,0xfa,0xdb,0xfe,0xff,0xff,0xff,0xff,0xff,0x01, - 0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xfc,0x0f,0x90,0xff,0xff,0xff,0xc3, - 0xff,0xfc,0xcf,0x9f,0xff,0xff,0xff,0xdb,0x4c,0x18,0xce,0x93,0xe1,0xff,0xff, - 0x99,0xcc,0xcc,0xcc,0x93,0xcc,0xff,0xff,0x99,0xcc,0xcc,0x0c,0x92,0xcc,0xff, - 0xff,0x81,0xcc,0xcc,0xcc,0x93,0xc0,0xff,0xff,0x3c,0xcc,0xcc,0xcc,0x93,0xfc, - 0xff,0xff,0x3c,0xc4,0xc4,0xcc,0x93,0xcc,0xff,0xff,0x3c,0xc9,0x19,0xce,0x93, - 0xe1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/autofile-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * autofile_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXooXXXXXXXXXXXooXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXooooXXXXXXXXXXooXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXoXXoXXooXXooXooooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXoooooXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooooooXooXXooXXooXXooXXooXXooXXXXooXooXooooooXXXXXXXXXX", -"XXXXXXXXooXXXXooooXXooXXooXXooXXooXXooXXXXooXooXooXXXXXXXXXXXXXX", -"XXXXXXXXooXXXXooooXoooXXooXoooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXooXXXXooXooXooXXXooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/autofile-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff, - 0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04, - 0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x80, - 0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x80,0x00,0x00,0x01,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x05,0x24,0x01,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x18,0x00,0x03,0xf0,0x6f,0x00,0x00,0x00,0x3c, - 0x00,0x03,0x30,0x60,0x00,0x00,0x00,0x24,0xb3,0xe7,0x31,0x6c,0x1e,0x00,0x00, - 0x66,0x33,0x33,0x33,0x6c,0x33,0x00,0x00,0x66,0x33,0x33,0xf3,0x6d,0x33,0x00, - 0x00,0x7e,0x33,0x33,0x33,0x6c,0x3f,0x00,0x00,0xc3,0x33,0x33,0x33,0x6c,0x03, - 0x00,0x00,0xc3,0x3b,0x3b,0x33,0x6c,0x33,0x00,0x00,0xc3,0x36,0xe6,0x31,0x6c, - 0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/autofile-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * autofile_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXooXXXXXXXXXXXooXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXooooXXXXXXXXXXooXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXoXXoXXooXXooXooooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooXXooXooXXooXXooXXooXXooXXoooooXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXXooooooXooXXooXXooXXooXXooXXooXXXXooXooXooooooXXXXXXXXXX", -"XXXXXXXXooXXXXooooXXooXXooXXooXXooXXooXXXXooXooXooXXXXXXXXXXXXXX", -"XXXXXXXXooXXXXooooXoooXXooXoooXXooXXooXXXXooXooXooXXooXXXXXXXXXX", -"XXXXXXXXooXXXXooXooXooXXXooXXooooXXXooXXXXooXooXXooooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/autofile-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3c, - 0x00,0x03,0x30,0x60,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x66,0x33,0x33,0x33,0x6c,0x33,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x7e,0x33,0x33,0x33,0x6c,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xc3,0x3b,0x3b,0x33,0x6c,0x33,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/compose-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x01,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xe7,0xff, - 0xff,0xff,0xff,0xff,0xff,0xfd,0xd7,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0x87, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0x0f,0x00, - 0x00,0xf0,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x2f, - 0xff,0x7f,0xf4,0xff,0xff,0xff,0xff,0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff, - 0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff,0xef,0x03,0x78,0xf4,0xff,0xff,0xff, - 0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x03,0xfe,0xf7,0xff,0xff, - 0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x83,0xff,0xf7,0xff, - 0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7, - 0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x0f,0x00,0x00, - 0xf0,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe6, - 0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x3f,0x2c,0x62,0x72,0x38,0x1c,0xfe,0x3f, - 0x9f,0xc9,0x4c,0x24,0x93,0xc9,0xfc,0x3f,0x9f,0xc9,0x4c,0x26,0x13,0xcf,0xfc, - 0x3f,0x9f,0xc9,0x4c,0x26,0x73,0x0c,0xfc,0x3f,0x9f,0xc9,0x4c,0x26,0xf3,0xc8, - 0xff,0x7f,0x86,0xc9,0x4c,0x24,0x93,0xc9,0xfc,0xff,0x30,0xcc,0x4c,0x72,0x38, - 0x1c,0xfe,0xff,0xff,0xff,0x7f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/compose-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * compose_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXXXXooooXXoXoooXoooXXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXoooXXXXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXoooXXooooooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXXoooXooXXXXXXXXXX", -"XXXXXXXooXXooooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXXXooooXXooooXXooXXooXXooXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/compose-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x18,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x78, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0xf0,0xff, - 0xff,0x0f,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xd0, - 0x00,0x80,0x0b,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x19, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xc0,0xd3,0x9d,0x8d,0xc7,0xe3,0x01,0xc0, - 0x60,0x36,0xb3,0xdb,0x6c,0x36,0x03,0xc0,0x60,0x36,0xb3,0xd9,0xec,0x30,0x03, - 0xc0,0x60,0x36,0xb3,0xd9,0x8c,0xf3,0x03,0xc0,0x60,0x36,0xb3,0xd9,0x0c,0x37, - 0x00,0x80,0x79,0x36,0xb3,0xdb,0x6c,0x36,0x03,0x00,0xcf,0x33,0xb3,0x8d,0xc7, - 0xe3,0x01,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/compose-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * compose_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXXXXooooXXoXoooXoooXXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXoooXXXXooXXooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXoooXXooooooXXXXXX", -"XXXXXXooXXXXXooXXooXooXXooXXooXooXXooXooXXooXXXXoooXooXXXXXXXXXX", -"XXXXXXXooXXooooXXooXooXXooXXooXoooXooXooXXooXooXXooXooXXooXXXXXX", -"XXXXXXXXooooXXooooXXooXXooXXooXooXooXXXooooXXXooooXXXooooXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/compose-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x19, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, - 0x60,0x36,0xb3,0xdb,0x6c,0x36,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xc0,0x60,0x36,0xb3,0xd9,0x8c,0xf3,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x79,0x36,0xb3,0xdb,0x6c,0x36,0x03,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/delete-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0xf8, - 0xf1,0xff,0xff,0xff,0xff,0xff,0xfd,0x33,0xf0,0xff,0xff,0xff,0xff,0x1f,0xf0, - 0x0b,0xfc,0xff,0xff,0xff,0xff,0x0f,0x80,0x83,0xff,0xff,0xff,0xff,0xff,0xff, - 0x05,0x82,0xff,0xff,0xff,0xff,0xff,0xff,0x3d,0xb0,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7d,0xb8,0xff,0xff,0xff,0xff,0xff,0xff,0x3d,0xa0,0xff,0xff,0xff,0xff, - 0xff,0xff,0x1d,0x83,0xff,0xff,0xff,0xff,0xff,0xff,0x8d,0x0f,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xc5,0x3f,0xfc,0xff,0xff,0xff,0xff,0xff,0xe1,0xbf,0xf0,0xff, - 0xff,0xff,0xff,0xff,0xf0,0xbf,0xe1,0xff,0xff,0xff,0xff,0x3f,0xfc,0xbf,0xc3, - 0xff,0xff,0xff,0xff,0x1f,0xfc,0xbf,0xc7,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xf8,0x9f,0xff,0xfc,0xff,0xff,0xff,0x3f, - 0xf3,0x9f,0xff,0xfc,0xff,0xff,0xff,0x3f,0x67,0x98,0x61,0x18,0xfe,0xff,0xff, - 0x3f,0x27,0x93,0xcc,0xcc,0xfc,0xff,0xff,0x3f,0x27,0x93,0xcc,0xcc,0xfc,0xff, - 0xff,0x3f,0x27,0x90,0xc0,0x0c,0xfc,0xff,0xff,0x3f,0x27,0x9f,0xfc,0xcc,0xff, - 0xff,0xff,0x3f,0x33,0x93,0xcc,0xc4,0xfc,0xff,0xff,0x3f,0x78,0x98,0xe1,0x19, - 0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/delete-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * delete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOooXXooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooOOOOOOo+ooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoooooooooooOOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOooooooOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOooooooOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOooooOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoooooooOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoooOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoooOOOOOoooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOoXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOoXXooooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOOOoXXXooooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooOOOOOOOOOOOOoXXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooooooXooXooooooXXooXXooooooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXooXXooXooXooXXooXXooXoooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXooooXXooXXooooXXXXooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/delete-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0e,0x00,0x00,0x00,0x00,0x00,0x02,0xcc,0x0f,0x00,0x00,0x00,0x00,0xe0,0x0f, - 0xf4,0x03,0x00,0x00,0x00,0x00,0xf0,0x7f,0x7c,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfa,0x7d,0x00,0x00,0x00,0x00,0x00,0x00,0xc2,0x4f,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0xc2,0x5f,0x00,0x00,0x00,0x00, - 0x00,0x00,0xe2,0x7c,0x00,0x00,0x00,0x00,0x00,0x00,0x72,0xf0,0x01,0x00,0x00, - 0x00,0x00,0x00,0x3a,0xc0,0x03,0x00,0x00,0x00,0x00,0x00,0x1e,0x40,0x0f,0x00, - 0x00,0x00,0x00,0x00,0x0f,0x40,0x1e,0x00,0x00,0x00,0x00,0xc0,0x03,0x40,0x3c, - 0x00,0x00,0x00,0x00,0xe0,0x03,0x40,0x38,0x00,0x00,0x00,0x00,0x00,0x02,0x40, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x07,0x60,0x00,0x03,0x00,0x00,0x00,0xc0, - 0x0c,0x60,0x00,0x03,0x00,0x00,0x00,0xc0,0x98,0x67,0x9e,0xe7,0x01,0x00,0x00, - 0xc0,0xd8,0x6c,0x33,0x33,0x03,0x00,0x00,0xc0,0xd8,0x6c,0x33,0x33,0x03,0x00, - 0x00,0xc0,0xd8,0x6f,0x3f,0xf3,0x03,0x00,0x00,0xc0,0xd8,0x60,0x03,0x33,0x00, - 0x00,0x00,0xc0,0xcc,0x6c,0x33,0x3b,0x03,0x00,0x00,0xc0,0x87,0x67,0x1e,0xe6, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/delete-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * delete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOooXXooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooOOOOOOo+ooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoooooooooooOOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOooooooOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOooooooOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOooooOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoooooooOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoooOOoooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoooOOOOOoooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOoXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOoXXooooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooooOOOOOOOOOOOOoXXXooooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooOOOOOOOOOOOOoXXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooooooXooXooooooXXooXXooooooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXooXXooXXooXXooXooXooXXooXXooXoooXXooXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXoooooXXXXooooXXooXXooooXXXXooXXooooXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/delete-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x0f, - 0xf4,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfa,0x7d,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xe2,0x7c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x3a,0xc0,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x0f,0x40,0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xe0,0x03,0x40,0x38,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x07,0x60,0x00,0x03,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x98,0x67,0x9e,0xe7,0x01,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xd8,0x6c,0x33,0x33,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xd8,0x60,0x03,0x33,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x87,0x67,0x1e,0xe6, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/document-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -/* XPM */ -static char *document2[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 32 1", -/* colors */ -". c #000000", -"# c #a4a5a4", -"a c #9f9f9f", -"b c #999999", -"c c #919191", -"d c #818181", -"e c #6d6d6d", -"f c #5d5d5d", -"g c #494949", -"h c #eaeaea", -"i c #373737", -"j c #e3e4e3", -"k c #d4d4d4", -"l c #c8c8c8", -"m c #0d0d0d", -"n c #b4b4b4", -"o c #b0aeb0", -"p c #aeaeae", -"q c #aaaaaa s background", -"r c #888888", -"s c #767676", -"t c #646464", -"u c #545454", -"v c #ffffff", -"w c #f6f7f6", -"x c #efefef", -"y c #dfdfdf", -"z c #dad9da", -"A c #242424", -"B c #cfcfcf", -"C c #bfbfbf", -"D c #b9b9b9", -/* pixels */ -"qqqqqaetr#qqqqqqqqqqqqqq", -"qqqq#errefd#qqqqqqqqqqqq", -"qqq#rzklCqcdsdra#qqqqqqq", -"qqqrkvvxzkkln#rtfdaqqqqq", -"qq#dvvvvvvxxzklCqcrdsr#q", -"qq#rresr#lxvvvvxhzl#tisq", -"qqqqqdsefgieCxvvvvxiAiiq", -"qqqqqrCttffuuuernkagtiiq", -"qqqq#nxvxxcsuetsuigrsitq", -"qqqqczhzxhzzlC#seffscifq", -"qqqqrvlyxxzlCCzxxkCaCmrq", -"qqqq#vvlzqhzvvvklalvciaq", -"qqqckhlkzzhlCCkhhxvvguqq", -"qqqrvvxvklalxxxlq#xvmd#q", -"qqqcvxklkvxvxllkhxvlArqq", -"qq#Cvvvvvvvvvvvvhxvtgqqq", -"qqrxxvvvvvvvvvvvvvvAeqqq", -"qqrvkzhzhxxvvvvvvvkmrqqq", -"qqqlhvvlCrnkhvvvvvci#qqq", -"qckxxxhxxkzzllllvvguqqqq", -"qrvklklxxxhlnlzxvhmrqqqq", -"qahzvvhCcCnxvxlhvqicqqqq", -"clxkkqlzhkkklCzvvfg#qqqq", -"txvvvvxlrzlzvvkvvAeqqqqq", -"dtalvvvvvvxknzhvlArqqqqq", -"rgimmgdqhvvvvvvvei#qqqqq", -"qq#rtiA..i#xvvvvitqqqqqq", -"qqqqqarsgimmis#Cmrqqqqqq", -"qqqqqqqqq#ceiA..icqqqqqq", -"qqqqqqqqqqqq#rdfeqqqqqqq" -};
--- a/etc/vm/document-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #000000", -"a c #818181", -"b c #EAEAEA", -"c c #D4D4D4", -"d c #AAAAAA s background", -"e c #545454", -"f c #FFFFFF", -"g c #242424", -/* pixels */ -"ddddddaeaddddddddddddddd", -"dddddaaaaeaddddddddddddd", -"ddddacccddaaaaaddddddddd", -"dddacffbccccddaeeadddddd", -"dddaffffffbbcccddaaaaadd", -"dddaaaaadcbffffbbccdegad", -"dddddaaaeegadbffffbggggd", -"dddddadeeeeeeeaadcdeeggd", -"ddddddbfbbaaeaeaegeaaged", -"ddddacbcbbcccddaaeeaaged", -"ddddafccbbccddcbbcddd`ad", -"dddddffccdbcfffccdcfagdd", -"dddacbccccbcddcbbbffeedd", -"dddaffbfccdcbbbcddbf`add", -"dddafbcccfbfbcccbbfcgadd", -"ddddffffffffffffbbfeeddd", -"ddabbffffffffffffffgaddd", -"ddafccbcbbbfffffffc`addd", -"dddcbffcdadcbfffffagdddd", -"dacbbbbbbcccccccffeedddd", -"dafccccbbbbcdccbfb`adddd", -"ddbcffbdaddbfbcbfdgadddd", -"acbccdccbccccdcffeeddddd", -"ebffffbcacccffcffgaddddd", -"aedcffffffbcdcbfcgaddddd", -"aeg``eadbfffffffagdddddd", -"dddaegg``gdbffffgedddddd", -"ddddddaaeg``gadd`adddddd", -"ddddddddddaagg``gadddddd", -"dddddddddddddaaeaddddddd" -};
--- a/etc/vm/file-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0x00, - 0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb, - 0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0x5f,0xfe,0xff,0xff,0xff,0xff,0x7f, - 0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff, - 0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff, - 0xff,0x7f,0xfb,0xdf,0xfe,0xff,0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0xff,0xff,0xfe,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xfe,0xff, - 0xff,0xff,0xff,0x7f,0x03,0xc0,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe, - 0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb,0xfe,0xff,0xff,0xff,0xff,0x7f,0xfb,0xdb, - 0xfe,0xff,0xff,0xff,0xff,0xff,0xfa,0xdb,0xfe,0xff,0xff,0xff,0xff,0xff,0x01, - 0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x80,0xfc,0xff,0xff,0xff,0xff,0xff, - 0x7f,0xfe,0xfc,0xff,0xff,0xff,0xff,0xff,0x7f,0x9e,0x0c,0xff,0xff,0xff,0xff, - 0xff,0x7f,0x9e,0x64,0xfe,0xff,0xff,0xff,0xff,0x7f,0x90,0x64,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0x9e,0x04,0xfe,0xff,0xff,0xff,0xff,0x7f,0x9e,0xe4,0xff,0xff, - 0xff,0xff,0xff,0x7f,0x9e,0x64,0xfe,0xff,0xff,0xff,0xff,0x7f,0x9e,0x0c,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/file-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * file_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooooXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/file-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff, - 0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04, - 0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x80, - 0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x80,0x00,0x00,0x01,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x05,0x24,0x01,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x7f,0x03,0x00,0x00,0x00,0x00,0x00, - 0x80,0x01,0x03,0x00,0x00,0x00,0x00,0x00,0x80,0x61,0xf3,0x00,0x00,0x00,0x00, - 0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x80,0x6f,0x9b,0x01,0x00,0x00, - 0x00,0x00,0x80,0x61,0xfb,0x01,0x00,0x00,0x00,0x00,0x80,0x61,0x1b,0x00,0x00, - 0x00,0x00,0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x80,0x61,0xf3,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/file-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * file_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray60", -"+ c Gray90", -"@ c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo++++++++++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOooooooooooooOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOo@@@@@@@o++oOOoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooooXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXooXXooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooXXXXooXooXXooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/file-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0xa0,0x01,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x20,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xfc,0x3f,0x01,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x01,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24,0x01, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x04,0x24, - 0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x80,0x01,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x80,0x61,0xfb,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x80,0x61,0x9b,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/film-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -/* XPM */ -static char *film[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 32 1", -/* colors */ -". c #000000", -"# c #799fa1", -"a c #060919", -"b c #411707", -"c c #8fc7ff", -"d c #3f4040", -"e c #873d06", -"f c #62b1e6", -"g c #392e26", -"h c #292a2a", -"i c #9a9e9f", -"j c #284367", -"k c #646666", -"l c #aacae6", -"m c #238fc1", -"n c #182a50", -"o c #93673e", -"p c #7f7f80", -"q c #131516", -"r c #aaaaaa s background", -"s c #ddf2fd", -"t c #6991ac", -"u c #1c0804", -"v c #494b4a", -"w c #948b79", -"x c #733006", -"y c #151c34", -"z c #592009", -"A c #9f4c05", -"B c #54585d", -"C c #376389", -"D c #231305", -/* pixels */ -"rrrrrrrrwirrrrrrrrrrrrrr", -"rrrrpddv..prrrrrrrrrrrrr", -"rrrpjdkyajjprriiiwiiwirr", -"rrrnf.pfu.tgri.q....agir", -"rrktC.dlC.hCpiivqCCjjhBr", -"rrdcv..lca.tjrrddoBoogdr", -"rptcj.ulcj.djrrvdAAAAzBr", -"rBtcj..lcCuapprvgxxxxbdr", -"rvcfB.alkr..#BrBdDDDDuBr", -"rdjkt.kB.#..#vrBgnnnhadr", -"rjq.lCla.kq.BvrBgttmtjhr", -"rn..llc..Bh.BvrkvAAAAbBr", -"rh..rjl..Bh.kvrkgAAAAzdr", -"rn..#tla.pa.pdrBgxxxxbdr", -"rv..rccq.py.pBrvgzbzbqkr", -"rjhhlniC.ra.rdrvha.auhBr", -"rv#lt.Bctc..fBrdgCmCChkr", -"rvcct.qlc#.utkrhztCtpnBr", -"rBflC..lcC.nCiidxAAAxdkr", -"rptcB..lcj.Cvrphbeeezhpr", -"rrdcC.qlfuutkrkhDbzbqhrr", -"rrktt.Bcv.Cnrrkq....ddrr", -"rrihtnrtaaBkrrhnCCCnhBrr", -"rrrdq#t..avrrpBepppDqwrr", -"rrrp..BipwrrrvDeeexqdrrr", -"rrrrh.krrrrrkqDbDbDhkrrr", -"rrrrp.qrrrrphynnyaudrrrr", -"rrrrrd.hkpBqhoBkjqdprrrr", -"rrrrrrv......u.qhhprrrrr", -"rrrrrrrpvqu..uadpirrrrrr" -};
--- a/etc/vm/film-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #000000", -"a c #8FC7FF", -"b c #284367", -"c c #238FC1", -"d c #7F7F80", -"e c #AAAAAA s background", -"f c #592009", -"g c #9F4C05", -/* pixels */ -"eeeeeeeedeeeeeeeeeeeeeee", -"eeeedbbb``deeeeeeeeeeeee", -"eeedbbd``bbdeeeeedeedeee", -"eeeba`da``dfee```````fee", -"eeddb`bab`fbdeeb`bbbbfbe", -"eebab``aa``dbeebbgbggfbe", -"eddab``aab`bbeebbggggfbe", -"ebdab``aab``ddebffffffbe", -"ebaab``ade``dbebb`````be", -"ebbdd`db`d``dbebfbbbf`be", -"eb``aba``d``bbebfddcdbfe", -"eb``aaa``bf`bbedbggggfbe", -"ef``eba``bf`dbedfggggfbe", -"eb``dda``d``dbebffffffbe", -"eb``eaa``d``dbebfffff`de", -"ebffabeb`e``ebebf````fbe", -"ebdad`bada``abebfbcbbfde", -"ebaad``aad``ddeffdbddbbe", -"ebaab``aab`bbeebfgggfbde", -"eddab``aab`bbedffgggffde", -"eebab``aa``ddedf`fff`fee", -"eeddd`bab`bbeed`````bbee", -"eeefdbed``bdeefbbbbbfbee", -"eeeb`dd```beedbgddd``dee", -"eeed``beddeeeb`gggf`beee", -"eeeef`deeeeed``f`f`fdeee", -"eeeed``eeeedf`bb```beeee", -"eeeeeb`fddb`fgbdb`bdeeee", -"eeeeeeb`````````ffdeeeee", -"eeeeeeedb``````bdeeeeeee" -};
--- a/etc/vm/gear-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,279 +0,0 @@ -/* XPM */ -static char *gear[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 242 2", -/* colors */ -".. c #aaaaaa s background", -"zz c #aaaaaa", -".# c #8e8e8e", -".a c #4d4d4d", -".b c #9f9f9f", -".c c #888888", -".d c #848484", -".e c #838383", -".f c #828282", -".g c #484848", -".h c #303030", -".i c #131313", -".j c #141414", -".k c #707070", -".l c #777777", -".m c #2b2b2b", -".n c #1d1d1d", -".o c #121212", -".p c #393939", -".q c #727272", -".r c #a0a0a0", -".s c #8b8b8b", -".t c #3e3e3e", -".u c #878787", -".v c #151515", -".w c #2d2d2d", -".x c #8a8a8a", -".y c #171717", -".z c #202020", -".A c #0c0c0c", -".B c #191919", -".C c #222222", -".D c #333333", -".E c #2f2f2f", -".F c #353535", -".G c #cacaca", -".H c #e9e9e9", -".I c #5c5c5c", -".J c #c5c5c5", -".K c #323232", -".L c #d9d9d9", -".M c #f9f9f9", -".N c #ffffff", -".O c #fbfbfb", -".P c #c7c7c7", -".Q c #1e1e1e", -".R c #6c6c6c", -".S c #a7a7a7", -".T c #242424", -".U c #1a1a1a", -".V c #6e6e6e", -".W c #bababa", -".X c #efefef", -".Y c #fefefe", -".Z c #f6f6f6", -".0 c #eaeaea", -".1 c #e8e8e8", -".2 c #454545", -".3 c #d3d3d3", -".4 c #e0e0e0", -".5 c #f7f7f7", -".6 c #4f4f4f", -".7 c #232323", -".8 c #e4e4e4", -".9 c #f0f0f0", -"#. c #e7e7e7", -"## c #e5e5e5", -"#a c #bfbfbf", -"#b c #fcfcfc", -"#c c #d1d1d1", -"#d c #d2d2d2", -"#e c #ececec", -"#f c #f5f5f5", -"#g c #111111", -"#h c #363636", -"#i c #7f7f7f", -"#j c #e6e6e6", -"#k c #e2e2e2", -"#l c #e1e1e1", -"#m c #f4f4f4", -"#n c #cfcfcf", -"#o c #cdcdcd", -"#p c #d5d5d5", -"#q c #1c1c1c", -"#r c #101010", -"#s c #919191", -"#t c #666666", -"#u c #dfdfdf", -"#v c #dddddd", -"#w c #2e2e2e", -"#x c #dbdbdb", -"#y c #cecece", -"#z c #cccccc", -"#A c #c8c8c8", -"#B c #c6c6c6", -"#C c #c3c3c3", -"#D c #a3a3a3", -"#E c #1f1f1f", -"#F c #212121", -"#G c #a1a1a1", -"#H c #272727", -"#I c #565656", -"#J c #4e4e4e", -"#K c #b2b2b2", -"#L c #dedede", -"#M c #5d5d5d", -"#N c #6a6a6a", -"#O c #dadada", -"#P c #d0d0d0", -"#Q c #cbcbcb", -"#R c #c9c9c9", -"#S c #c4c4c4", -"#T c #c2c2c2", -"#U c #c1c1c1", -"#V c #373737", -"#W c #0f0f0f", -"#X c #969696", -"#Y c #d7d7d7", -"#Z c #d8d8d8", -"#0 c #d6d6d6", -"#1 c #d4d4d4", -"#2 c #bdbdbd", -"#3 c #494949", -"#4 c #181818", -"#5 c #343434", -"#6 c #dcdcdc", -"#7 c #bebebe", -"#8 c #bcbcbc", -"#9 c #0e0e0e", -"a. c #c0c0c0", -"a# c #bbbbbb", -"aa c #b8b8b8", -"ab c #414141", -"ac c #b6b6b6", -"ad c #f8f8f8", -"ae c #b9b9b9", -"af c #b7b7b7", -"ag c #b5b5b5", -"ah c #3d3d3d", -"ai c #404040", -"aj c #7b7b7b", -"ak c #b4b4b4", -"al c #afafaf", -"am c #444444", -"an c #161616", -"ao c #4b4b4b", -"ap c #b3b3b3", -"aq c #b1b1b1", -"ar c #adadad", -"as c #ababab", -"at c #8f8f8f", -"au c #b0b0b0", -"av c #aeaeae", -"aw c #acacac", -"ax c #a9a9a9", -"ay c #a6a6a6", -"az c #a4a4a4", -"aA c #9d9d9d", -"aB c #9b9b9b", -"aC c #a8a8a8", -"aD c #a5a5a5", -"aE c #9e9e9e", -"aF c #9c9c9c", -"aG c #9a9a9a", -"aH c #989898", -"aI c #383838", -"aJ c #8c8c8c", -"aK c #959595", -"aL c #939393", -"aM c #6d6d6d", -"aN c #a2a2a2", -"aO c #999999", -"aP c #979797", -"aQ c #949494", -"aR c #929292", -"aS c #909090", -"aT c #8d8d8d", -"aU c #292929", -"aV c #858585", -"aW c #3f3f3f", -"aX c #474747", -"aY c #868686", -"aZ c #525252", -"a0 c #2c2c2c", -"a1 c #7a7a7a", -"a2 c #4c4c4c", -"a3 c #585858", -"a4 c #686868", -"a5 c #7e7e7e", -"a6 c #898989", -"a7 c #717171", -"a8 c #3a3a3a", -"a9 c #515151", -"b. c #5a5a5a", -"b# c #424242", -"ba c #818181", -"bb c #050505", -"bc c #797979", -"bd c #505050", -"be c #747474", -"bf c #808080", -"bg c #7c7c7c", -"bh c #2a2a2a", -"bi c #4a4a4a", -"bj c #fafafa", -"bk c #1b1b1b", -"bl c #767676", -"bm c #737373", -"bn c #262626", -"bo c #f1f1f1", -"bp c #0d0d0d", -"bq c #0b0b0b", -"br c #787878", -"bs c #757575", -"bt c #6f6f6f", -"bu c #434343", -"bv c #3b3b3b", -"bw c #5e5e5e", -"bx c #696969", -"by c #252525", -"bz c #5f5f5f", -"bA c #575757", -"bB c #282828", -"bC c #010101", -"bD c #6b6b6b", -"bE c #676767", -"bF c #646464", -"bG c #636363", -"bH c #616161", -"bI c #000000", -"bJ c #5b5b5b", -"bK c #464646", -"bL c #656565", -"bM c #595959", -"bN c #3c3c3c", -"bO c #606060", -"bP c #555555", -"bQ c #545454", -"bR c #626262", -"bS c #535353", -"bT c #7d7d7d", -"bU c #313131", -/* pixels */ -"................................................", -"..................aB.I.l.#.a.a.IaB..............", -".................l.n.i.m.n.i.i.i.i#t............", -"...............p.i.i#N.i.i.i.i.n.n.a............", -"...........H.0.z.iab.M.Gab.i.n.i.i#t............", -".......W.M.0.H.l.i#N.H.3.0#N.i.i.i.m.r...r......", -"......#K#X.H.4...p...3.G.J.I.i.i.i.i.6ab.z.r....", -"......#N.m.4.3.3.G.G.J.J.W.z.i.i.i.n.i.i.i.I....", -".....J.6.r.4.3.G.G.J.W.W#K#X.n.6#t.i.i.i.i.n.#..", -"..#K.0.0.0.3.G.J.J.W.W#Kzzzz.#.H.#.n.i.i.i.i#t..", -"...G.H.3.3.G.J.J.W.W#Kzzzz.r.raB#X.6.i.i.i.aaB..", -"...4.3.G.G.J.J.W#K#Kzzzz.r.raB#X#X#i.n.i.n#i....", -"..#X.r.G.J.J#K.W#K.raB.r.raB#X.#.#.c.a.n.i.6....", -"..aB.p.r.J.W#K#KaB.p.m#NaB#X.#.#.c.l.z.i.i.m....", -"....aBaB.W#K#Kzz#t.n.i.h.#.#.#.c#iab.i.i.i.i#g.I", -"....#K#K#Kzzzz.r.a.z.a.i#X.c.c#i.l.a.i.i.i.i.i.6", -"...W.Hzzzz.r.raB.a.I.m.i.l.##i.l.l.I.i.i.i.n.h#t", -"...J.Gzz.r.raB#X#tab#t.i.Izz.l#N#N#N.a.p.n.h.6#t", -".....3.r.raB#X#X#N.p.p#g.m#K.l#N#N#t.I.I.h.6ab.l", -".....3aBaB#X#X.#.c.c.i.i#t.r#N#t#t.I.6.6ababab..", -".....3.#.c.#.c.c.czz.l.p.J.l#t.I.I.I.6.6.pab....", -"....#X.a.p#N.c#i#i#i#K.G.c#t.I.I.6.6abab.n.p....", -"..........#t#i#i.l#N#N#t.I.I.I.6.6ab.m.z.i.naB..", -"...........J.l#N#N#N#t.I.I.6.6.a.a.h.i.i.i#i....", -"........#K.r.l#N#N#t.I.I.6.6.aabab.h.i.i.a......", -"..........#N#t#t#t.I.I.6.6.aabab.p.p.z.p.r......", -"...........rab.6.m.p.6.6.aab.p.p.h.h.p.r........", -".............r.I.c.c.p.aab.h.n.n.h.h#X..........", -"..................aB.mab.p.p.i.i.z.#............", -"...................r.z.m.m.mab#N................" -};
--- a/etc/vm/gear-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 9 1", -/* colors */ -"` c #7F7F7F", -"a c #393939", -"b c #111111", -"c c #AAAAAA s background", -"C c #AAAAAA", -"d c #969696", -"e c #5C5C5C", -"f c #F9F9F9", -"g c #D3D3D3", -/* pixels */ -"cccccccccccccccccccccccc", -"cccccccccde`deeedccccccc", -"cccccccc`bbabbbbbecccccc", -"cccccccabbebbbbbbecccccc", -"cccccffbbafgabbbbecccccc", -"ccccfff`befgfebbbacccccc", -"ccccdfgCaCgggebbbbeabccc", -"ccceagggggggCbbbbbbbbecc", -"ccgeCgggggCCCdbeebbbbbdc", -"ccfffggggCCCCCdfdbbbbbec", -"cgfgggggCCCCCCCddebbbedc", -"cggggggCCCCCCCddd`bbb`cc", -"cdCgggCCCCdCCdddd`ebbecc", -"cdaCgCCCdaaedddd``bbbacc", -"ccddCCCCebbaddd``abbbbbe", -"ccCCCCCCebebd````ebbbbbe", -"ccfCCCCdeeab`d```ebbbbae", -"cggCCCddeaebec`eeeeabaee", -"ccgCCdddeaabac`eeeeeaea`", -"ccgddddd``bbeCeeeeeeaaac", -"ccgd`d```C`ag`eeeeeeaacc", -"ccdeae````Cg`eeeeeaabacc", -"ccccce```eeeeeeeeaabbbdc", -"cccccg`eeeeeeeeeeabbb`cc", -"cccccc`eeeeeeeeaaabbeccc", -"ccccceeeeeeeeeaaaabacccc", -"ccccccaeaaeeeaaaaaaccccc", -"ccccccce``aeaabbaadccccc", -"cccccccccdaaaabbbdcccccc", -"ccccccccccbaaaaecccccccc" -};
--- a/etc/vm/getmail-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define getmail-dn_width 64 -#define getmail-dn_height 42 -static char getmail-dn_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xf0,0xff,0xff,0xff, - 0xff,0xff,0xff,0x9f,0xc3,0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0x0f,0xff,0xff, - 0xff,0xff,0xff,0xff,0x4f,0x3d,0xfc,0xff,0xff,0xff,0xff,0xff,0x07,0xea,0xf0, - 0xff,0xff,0xff,0xff,0xff,0x07,0xd0,0xc3,0xff,0xff,0xff,0xff,0xff,0x13,0xa0, - 0x0e,0xff,0xff,0xff,0xff,0xff,0xab,0x00,0x3d,0xfc,0xff,0xff,0xff,0xff,0x53, - 0x05,0x2a,0xf9,0xff,0xff,0xff,0xff,0xfb,0x0a,0x90,0xf2,0xff,0xff,0xff,0xff, - 0x1b,0x57,0x40,0xf5,0xff,0xff,0xff,0xff,0x1b,0xac,0xaa,0xe8,0xff,0xff,0xff, - 0xff,0x1b,0x70,0x55,0xe0,0xff,0xff,0xff,0xff,0x1b,0xc0,0x22,0xe3,0xff,0xff, - 0xff,0xff,0x1b,0x02,0x55,0xe0,0xff,0xff,0xff,0xff,0x1b,0x0e,0xa4,0xe0,0xff, - 0xff,0xff,0xff,0x33,0x3e,0x56,0xe1,0xff,0xff,0xff,0xff,0xcf,0xff,0xa6,0xea, - 0xff,0xff,0xff,0xff,0x3f,0xff,0x57,0xe5,0xff,0xff,0xff,0xff,0xff,0xfc,0xa7, - 0xea,0xff,0xff,0xff,0xff,0xff,0xf1,0x57,0xe5,0xff,0xff,0xff,0xff,0xff,0xcf, - 0xa7,0xf8,0xff,0xff,0xff,0xff,0xff,0x1f,0x57,0xfe,0xff,0xff,0xff,0xff,0xff, - 0x7f,0x84,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe1,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xfd,0xff,0xff,0xff,0xff,0xff,0x83,0xff,0xf9,0xf3,0xf9,0x27,0xff, - 0xff,0x39,0xff,0xf9,0xf3,0xf9,0x3f,0xff,0xff,0xfc,0xc3,0xf0,0xe3,0x18,0x26, - 0xff,0xff,0xfc,0x99,0xf9,0xe3,0xc8,0x24,0xff,0xff,0x0c,0x99,0xf9,0x43,0xf8, - 0x24,0xff,0xff,0x3c,0x81,0xf9,0x53,0x19,0x24,0xff,0xff,0x3c,0xf9,0xf9,0x13, - 0xc9,0x24,0xff,0xff,0x39,0x99,0xe9,0xb3,0xc9,0x24,0xff,0xff,0x43,0xc3,0xf3, - 0xb3,0x19,0x21,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/getmail-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * getmail-up_xpm[] = { -"64 42 6 1", -" c gray75 s backgroundToolBarColor", -"@ c #C0C0C0C0C0C0", -". c gray60", -"X c #808080808080", -"o c #FFFFFFFFFFFF", -"O c gray60", -" ", -" ..... ", -" ..@@@XX.. ", -" .Xo@@@@@XX.. ", -" .o@o@o@@@@XX.. ", -" .ooooo@o@o@@@XX.. ", -" .oooooooo@o@@@@XX.. ", -" .o@oooooooo@o@o@@@XX.. ", -" .@o@o@oooooooo@o@@@@XX.. ", -" .o@o@o@o@oooooo@o@o@..@X. ", -" .@@@@@o@o@oooooooo@.X@X@X. ", -" .@@..X@@@o@o@ooooo.X@X@X@. ", -" .@@.O..X@@o@o@o@o@.@X@..X@. ", -" .@@.OO...X@@@o@o@.@X@.XX.X. ", -" .@@.OO.....X@@o@o.X@X.@@X.. ", -" .@@.OO.@X....X@o@.@X@X.oX.. ", -" .@@..O.@@@X....X@.X@X@.oX.. ", -" ..@@X..@@@@@X..@@.@X@X@..X. ", -" ..@@@@@@@@@@X@@.X@X@X@X@. ", -" ..@@@@@@@@@@@.@X@X@X@X. ", -" ..@@@@@@@@@.X@X@X@X@. ", -" ...@@@@@@@.@X@X@X@.. ", -" ..@@@@@.X@X@X.. ", -" ...@@@.@X@.. ", -" X..@.X.. ", -" .... ", -" ", -" ", -" . ", -" ..... .. .. .. .. .. ", -" .. .. .. .. .. .. ", -" .. .... .... ... ... .... .. .. ", -" .. .. .. .. ... ... .. .. .. .. ", -" .. .... .. .. .. .... .... .. .. .. ", -" .. .. ...... .. .. . . .. ..... .. .. ", -" .. .. .. .. .. ... .. .. .. .. .. ", -" .. .. .. .. .. . .. . .. .. .. .. .. ", -" .... . .... .. .. . .. ... .... .. ", -" ", -" ", -" ", -" "};
--- a/etc/vm/getmail-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define getmail-up_width 64 -#define getmail-up_height 42 -static char getmail-up_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x0f,0x00,0x00,0x00, - 0x00,0x00,0x00,0x60,0x3c,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0xf0,0x00,0x00, - 0x00,0x00,0x00,0x00,0xb0,0xc2,0x03,0x00,0x00,0x00,0x00,0x00,0xf8,0x15,0x0f, - 0x00,0x00,0x00,0x00,0x00,0xf8,0x2f,0x3c,0x00,0x00,0x00,0x00,0x00,0xec,0x5f, - 0xf1,0x00,0x00,0x00,0x00,0x00,0x54,0xff,0xc2,0x03,0x00,0x00,0x00,0x00,0xac, - 0xfa,0xd5,0x06,0x00,0x00,0x00,0x00,0x04,0xf5,0x6f,0x0d,0x00,0x00,0x00,0x00, - 0xe4,0xa8,0xbf,0x0a,0x00,0x00,0x00,0x00,0xe4,0x53,0x55,0x17,0x00,0x00,0x00, - 0x00,0xe4,0x8f,0xaa,0x1f,0x00,0x00,0x00,0x00,0xe4,0x3f,0xdd,0x1c,0x00,0x00, - 0x00,0x00,0xe4,0xfd,0xaa,0x1f,0x00,0x00,0x00,0x00,0xe4,0xf1,0x5b,0x1f,0x00, - 0x00,0x00,0x00,0xcc,0xc1,0xa9,0x1e,0x00,0x00,0x00,0x00,0x30,0x00,0x59,0x15, - 0x00,0x00,0x00,0x00,0xc0,0x00,0xa8,0x1a,0x00,0x00,0x00,0x00,0x00,0x03,0x58, - 0x15,0x00,0x00,0x00,0x00,0x00,0x0e,0xa8,0x1a,0x00,0x00,0x00,0x00,0x00,0x30, - 0x58,0x07,0x00,0x00,0x00,0x00,0x00,0xe0,0xa8,0x01,0x00,0x00,0x00,0x00,0x00, - 0x80,0x7b,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x1e,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x02,0x00,0x00,0x00,0x00,0x00,0x7c,0x00,0x06,0x0c,0x06,0xd8,0x00, - 0x00,0xc6,0x00,0x06,0x0c,0x06,0xc0,0x00,0x00,0x03,0x3c,0x0f,0x1c,0xe7,0xd9, - 0x00,0x00,0x03,0x66,0x06,0x1c,0x37,0xdb,0x00,0x00,0xf3,0x66,0x06,0xbc,0x07, - 0xdb,0x00,0x00,0xc3,0x7e,0x06,0xac,0xe6,0xdb,0x00,0x00,0xc3,0x06,0x06,0xec, - 0x36,0xdb,0x00,0x00,0xc6,0x66,0x16,0x4c,0x36,0xdb,0x00,0x00,0xbc,0x3c,0x0c, - 0x4c,0xe6,0xde,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/getmail-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * getmail-up_xpm[] = { -"64 42 6 1", -" c #C3C3C3C3C3C3 s backgroundToolBarColor", -"@ c #C0C0C0C0C0C0", -". c #000000000000", -"X c #808080808080", -"o c #FFFFFFFFFFFF", -"O c #FFFF00000000", -" ", -" ..... ", -" ..@@@XX.. ", -" .Xo@@@@@XX.. ", -" .o@o@o@@@@XX.. ", -" .ooooo@o@o@@@XX.. ", -" .oooooooo@o@@@@XX.. ", -" .o@oooooooo@o@o@@@XX.. ", -" .@o@o@oooooooo@o@@@@XX.. ", -" .o@o@o@o@oooooo@o@o@..@X. ", -" .@@@@@o@o@oooooooo@.X@X@X. ", -" .@@..X@@@o@o@ooooo.X@X@X@. ", -" .@@.O..X@@o@o@o@o@.@X@..X@. ", -" .@@.OO...X@@@o@o@.@X@.XX.X. ", -" .@@.OO.....X@@o@o.X@X.@@X.. ", -" .@@.OO.@X....X@o@.@X@X.oX.. ", -" .@@..O.@@@X....X@.X@X@.oX.. ", -" ..@@X..@@@@@X..@@.@X@X@..X. ", -" ..@@@@@@@@@@X@@.X@X@X@X@. ", -" ..@@@@@@@@@@@.@X@X@X@X. ", -" ..@@@@@@@@@.X@X@X@X@. ", -" ...@@@@@@@.@X@X@X@.. ", -" ..@@@@@.X@X@X.. ", -" ...@@@.@X@.. ", -" X..@.X.. ", -" .... ", -" ", -" ", -" . ", -" ..... .. .. .. .. .. ", -" .. .. .. .. .. .. ", -" .. .... .... ... ... .... .. .. ", -" .. .. .. .. ... ... .. .. .. .. ", -" .. .... .. .. .. .... .... .. .. .. ", -" .. .. ...... .. .. . . .. ..... .. .. ", -" .. .. .. .. .. ... .. .. .. .. .. ", -" .. .. .. .. .. . .. . .. .. .. .. .. ", -" .... . .... .. .. . .. ... .... .. ", -" ", -" ", -" ", -" "};
--- a/etc/vm/help-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x07,0xf8,0xff,0xff, - 0xff,0xff,0xff,0x7f,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,0x00,0xbe, - 0xff,0xff,0xff,0xff,0x0f,0x00,0x00,0x7c,0xeb,0xff,0xff,0xdf,0x07,0x48,0x12, - 0x38,0xe0,0xff,0xff,0xd4,0x83,0x00,0x80,0x70,0xe0,0xff,0xff,0xc0,0x01,0x02, - 0x00,0x00,0xc0,0xff,0xff,0x01,0x08,0x90,0x24,0x04,0xc9,0xff,0xff,0x03,0x40, - 0x00,0x00,0x00,0xe0,0xff,0xff,0x0b,0x00,0x02,0x80,0x90,0xe1,0xff,0xff,0x63, - 0x12,0x40,0x12,0x02,0xc1,0xff,0xff,0x23,0x80,0x08,0x00,0x00,0xc1,0xff,0xff, - 0xb3,0x00,0x00,0x40,0x40,0x80,0xff,0xff,0x03,0x10,0x22,0x09,0x02,0x12,0xfe, - 0xff,0x01,0x40,0x00,0x00,0x00,0x00,0xff,0xff,0x01,0x01,0x08,0x40,0x80,0xff, - 0xff,0xff,0xff,0x00,0x81,0x04,0x90,0xff,0xff,0xff,0xff,0x00,0x00,0x00,0xc0, - 0xff,0xff,0xff,0xff,0x05,0x00,0x00,0xe0,0xff,0xff,0xff,0xff,0x03,0x50,0x05, - 0xf0,0xff,0xff,0xff,0xff,0x07,0xe0,0x0c,0xf8,0xff,0xff,0xff,0xff,0x0f,0x80, - 0x35,0xfe,0xff,0xff,0xff,0xff,0x7f,0x00,0xad,0xff,0xff,0xff,0xff,0xff,0xff, - 0x81,0x56,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xba,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7f,0xad,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe5,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xc3,0xff,0x9f,0x7c,0xf0,0xff,0xf3,0xe7,0x93,0xff,0xbf,0x7c,0xe6,0xff,0xff, - 0xe7,0x33,0x63,0xd9,0x78,0x66,0x2c,0x33,0xe6,0x33,0x49,0xf2,0x7c,0xa6,0x49, - 0x92,0xe6,0x33,0x49,0xf2,0x7c,0x70,0x48,0x92,0xe7,0x33,0x49,0xf2,0x7c,0x3e, - 0x49,0x92,0xe7,0x93,0x49,0xf2,0x7c,0x3e,0x49,0x92,0xfe,0xc3,0x63,0xf2,0x79, - 0x7e,0x42,0x32,0xe6,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/help-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * help3_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"i c Gray60", -"@ c white", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXiiiiiiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXiiii@@@@@@@@iiiXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXi@@@@@@@@@@@@@@@iiiXXXXXiXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXii@@@@@@@@@@@@@@@@@@@iXXXXX@XX@XiXXXXXXXXXXX", -"XXXXXXXXXXXXXiXXXXXi@@@@@@@@@@@@@@@@@@@@@@iXXXi@@ii@@XXXXXXXXXXX", -"XXXXXXXXiiXiXiXXXXi@@@@@@@@@@@@@@@@@@@@@@@@iXXXi@@@@iXXXXXXXXXXX", -"XXXXXXXXi@@@@iXXXi@@@@@@@@@@@@@@@@@@@@@@@@@@iii@@@@@@iXXXXXXXXXX", -"XXXXXXXXXi@@@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@i@@@@@@@iXXXXXXXXXX", -"XXXXXXXXXX@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iiii@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXXi@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@iXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@ii@@@@iii@@iXXXXXXXXX", -"XXXXXXXXXXi@iii@@@oo@@@@@@@@@@@@@@@@@@@@@@oooi@@@@@@@@@@iXXXXXXX", -"XXXXXXXXXi@@@@@@@@oo@@@@@@@@@@@@@@@@@@@@@ooo@@@iiiiiiiiiXXXXXXXX", -"XXXXXXXXXiiiiiii@@@ooi@@@@@@@@@@@@@@@@@ioooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@ioooi@@@@@@@@@@@i@@oooooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@@ooooooi@i@@@@iioooooooi@@iXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXi@@iooooooooooooooooooooi@@iXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXii@@ioooi@@@@i@@@oooooi@@iXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXi@@@iioooi@@@i@@@oo@@@iiXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXiii@@@iiio@@@i@@@@iiiXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXii@@@@@i@@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXiiiiiX@@@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXi@@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXi@@@@@@iXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXi@@@iiXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXooooXXXXXXXXXXXXXXXooXooXXXXXoooooXXXXXXXXXXXXXXooXXXXXXXooXXX", -"XXooXooXXXXXXXXXXXXXXXoXooXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXooXXX", -"XXooXXooXXoooXXoXooXXoXXoooXXXXooXXooXXoooXXoXooXXooXXoooXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXooXoXXooXooXooXooXooXoXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXoooooXXXooooXooXooXooXooXXXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXXXXooXXX", -"XXooXooXXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXoXXXXXXX", -"XXooooXXXXoooXXooXooXXXXXooXXXXooXXXXXXooXooooXooXooXXoooXXooXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX",
--- a/etc/vm/help-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0x07,0x00,0x00, - 0x00,0x00,0x00,0x80,0x07,0x38,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0xc0,0x41, - 0x00,0x00,0x00,0x00,0x30,0x00,0x00,0x02,0x10,0x00,0x00,0x20,0x08,0x48,0x12, - 0x44,0x06,0x00,0x00,0x2b,0x84,0x00,0x80,0x88,0x10,0x00,0x00,0x21,0x02,0x02, - 0x00,0x70,0x20,0x00,0x00,0xc2,0x09,0x90,0x24,0x24,0x29,0x00,0x00,0x00,0x40, - 0x00,0x00,0xc0,0x13,0x00,0x00,0xec,0x00,0x02,0x80,0x50,0x12,0x00,0x00,0x84, - 0x12,0x40,0x12,0x82,0x22,0x00,0x00,0x54,0x80,0x08,0x00,0x80,0x22,0x00,0x00, - 0xc4,0x00,0x00,0x40,0x58,0x4e,0x00,0x00,0x74,0x1c,0x22,0x09,0x3e,0x12,0x01, - 0x00,0x02,0x4c,0x00,0x00,0x8e,0xff,0x00,0x00,0xfe,0x39,0x08,0xc0,0x4f,0x00, - 0x00,0x00,0x00,0xf9,0x81,0xcc,0x5f,0x00,0x00,0x00,0x00,0xf1,0x17,0xfe,0x27, - 0x00,0x00,0x00,0x00,0xf6,0xff,0xff,0x13,0x00,0x00,0x00,0x00,0xcc,0xff,0xff, - 0x09,0x00,0x00,0x00,0x00,0x88,0xff,0x3d,0x06,0x00,0x00,0x00,0x00,0x70,0xbc, - 0xf7,0x01,0x00,0x00,0x00,0x00,0x80,0x41,0x6d,0x00,0x00,0x00,0x00,0x00,0x00, - 0xfe,0xd6,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x7a,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x6d,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x1d,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x3c,0x00,0x60,0x83,0x0f,0x00,0x0c,0x18,0x6c,0x00,0x40,0x83,0x19,0x00,0x00, - 0x18,0xcc,0x9c,0x26,0x87,0x99,0xd3,0xcc,0x19,0xcc,0xb6,0x0d,0x83,0x59,0xb6, - 0x6d,0x19,0xcc,0xb6,0x0d,0x83,0x8f,0xb7,0x6d,0x18,0xcc,0xb6,0x0d,0x83,0xc1, - 0xb6,0x6d,0x18,0x6c,0xb6,0x0d,0x83,0xc1,0xb6,0x6d,0x01,0x3c,0x9c,0x0d,0x86, - 0x81,0xbd,0xcd,0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/help-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * help3_xpm[] = { -"64 42 6 1", -"X c Gray75 s backgroundToolBarColor", -"i c Gray20", -"@ c rgb:00/df/ff", -"T c red", -"t c pink", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXiiiiiiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXiiii@@@@@@@@iiiXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXi@@@@@@@@@@@@@@@iiiXXXXXiXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXii@@@@@@@@@@@@@@@@@@@iXXXXX@XX@XiXXXXXXXXXXX", -"XXXXXXXXXXXXXiXXXXXi@@@@@@@@@@@@@@@@@@@@@@iXXXi@@ii@@XXXXXXXXXXX", -"XXXXXXXXiiXiXiXXXXi@@@@@@@@@@@@@@@@@@@@@@@@iXXXi@@@@iXXXXXXXXXXX", -"XXXXXXXXi@@@@iXXXi@@@@@@@@@@@@@@@@@@@@@@@@@@iii@@@@@@iXXXXXXXXXX", -"XXXXXXXXXi@@@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@i@@@@@@@iXXXXXXXXXX", -"XXXXXXXXXX@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iiii@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@iii@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXXi@@iXXXXXXXXXXX", -"XXXXXXXXXXi@@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@iXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@iXi@@@iXXXXXXXXXX", -"XXXXXXXXXXi@XXi@@@@@@@@@@@@@@@@@@@@@@@@@@@@ii@@@@iii@@iXXXXXXXXX", -"XXXXXXXXXXi@iii@@@oo@@@@@@@@@@@@@@@@@@@@@@oooi@@@@@@@@@@iXXXXXXX", -"XXXXXXXXXi@@@@@@@@oo@@@@@@@@@@@@@@@@@@@@@ooo@@@iiiiiiiiiXXXXXXXX", -"XXXXXXXXXiiiiiii@@@ooi@@@@@@@@@@@@@@@@@ioooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@ioooi@@@@@@@@@@@i@@oooooo@@iXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXi@@@ooooooi@i@@@@iioooooooi@@iXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXi@@iooooooooooooooooooooi@@iXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXii@@ioooiiTiTiTiToooooi@@iXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXi@@@iioooiTTTiTTToo@@@iiXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXiii@@@iiioTTTiTTTTiiiXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXii@@@@@iTTTTTTTiXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXiiiiiiTtTTTtTTiXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiTtTTTTTiXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiTtTTTTiXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiTTTiiXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXiiiXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXooooXXXXXXXXXXXXXXXooXooXXXXXoooooXXXXXXXXXXXXXXooXXXXXXXooXXX", -"XXooXooXXXXXXXXXXXXXXXoXooXXXXXooXXooXXXXXXXXXXXXXXXXXXXXXXooXXX", -"XXooXXooXXoooXXoXooXXoXXoooXXXXooXXooXXoooXXoXooXXooXXoooXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXooXoXXooXooXooXooXooXoXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXoooooXXXooooXooXooXooXooXXXXooXXX", -"XXooXXooXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXXXXooXXX", -"XXooXooXXooXooXooXooXXXXooXXXXXooXXXXXooXooXooXooXooXooXoXXXXXXX", -"XXooooXXXXoooXXooXooXXXXXooXXXXooXXXXXXooXooooXooXooXXoooXXooXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX",
--- a/etc/vm/help-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf8,0x07,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x40,0x00,0xc0,0x41, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0x08,0x00,0x00, - 0x44,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x21,0x02,0x88, - 0x24,0x70,0x20,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20, - 0x01,0x00,0xc0,0x13,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x84, - 0x00,0x20,0x00,0x89,0x22,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x44,0x12,0x02,0x24,0x58,0x4e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x22,0x0c,0x80,0x00,0x8e,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0xf9,0x11,0xc8,0x4f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xf2,0xff,0xff,0x13,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x88,0xff,0xbf,0x06,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x41,0x7b,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x6e,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x1d,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x6c,0x00,0x40,0x83,0x19,0x00,0x00, - 0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xcc,0xb6,0x0d,0x83,0x59,0xb6, - 0x6d,0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xcc,0xb6,0x0d,0x83,0xc1, - 0xb6,0x6d,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3c,0x9c,0x0d,0x86, - 0x81,0xbd,0xcd,0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/message-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -/* XPM */ -static char *message[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 25 1", -/* colors */ -". c #000000", -"# c #a4a579", -"a c #9f9c66", -"b c #918e5d", -"c c #817f53", -"d c #6d6b46", -"e c #5d5b3c", -"f c #49482f", -"g c #eae696", -"h c #373623", -"i c #d4d088", -"j c #c8c480", -"k c #0d0d08", -"l c #b4b173", -"m c #aaa76d s background", -"n c #888657", -"o c #76744c", -"p c #646240", -"q c #545236", -"r c #fffaa3", -"s c #efeb99", -"t c #dfdb8f", -"u c #bac384", -"v c #242317", -"w c #bfbc7a", -/* pixels */ -"mmmmmadpn#mmmmmmmmmmmmmm", -"mmmm#dnndec#mmmmmmmmmmmm", -"mmm#nuijwmbcocna#mmmmmmm", -"mmmnirrsuiijl#npecammmmm", -"mm#crrrrrrssuijwmbncon#m", -"mm#nndon#jsrrrrsguj#phom", -"mmmmmcodefhdwsrrrrshvhhm", -"mmmmmnwppeeqqqdnliafphhm", -"mmmm#lsrssboqdpoqhfnohpm", -"mmmmbugusguujw#odeeobhem", -"mmmmnrjtssujwwussiwawknm", -"mmmm#rrjumgurrrijajrbham", -"mmmbigjiuugjwwiggsrrfqmm", -"mmmnrrsrijajsssjm#srkc#m", -"mmmbrsijirsrsjjigsrjvnmm", -"mm#wrrrrrrrrrrrrgsrpfmmm", -"mmnssrrrrrrrrrrrrrrvdmmm", -"mmnriugugssrrrrrrriknmmm", -"mmmjgrrjwnligrrrrrbh#mmm", -"mbisssgssiuujjjjrrfqmmmm", -"mnrijijsssgjljusrgknmmmm", -"magurrgwbwlsrsjgrmhbmmmm", -"bjsiimjugiiijwurref#mmmm", -"psrrrrsjnujurrirrvdmmmmm", -"cpajrrrrrrsilugrjvnmmmmm", -"nfhkkfcmgrrrrrrrdh#mmmmm", -"mm#nphv..h#srrrrhpmmmmmm", -"mmmmmanofhkkho#wknmmmmmm", -"mmmmmmmmm#bdhv..hbmmmmmm", -"mmmmmmmmmmmm#ncedmmmmmmm" -};
--- a/etc/vm/message-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #000000", -"a c #817F53", -"b c #FFFAA3", -"c c #545236", -"d c #BFBC7A", -"e c #AAA76D s background", -"f c #242317", -"g c #D4D088", -/* pixels */ -"eeeeeeacaeeeeeeeeeeeeeee", -"eeeeeaaaacaeeeeeeeeeeeee", -"eeeeadgddeaaaaaeeeeeeeee", -"eeeagbbbdggdeeaccaeeeeee", -"eeeabbbbbbbbdgddeaaaaaee", -"eeeaaaaaedbbbbbbbddecfae", -"eeeeeaaaccfadbbbbbbffffe", -"eeeeeadcccccccaaegeccffe", -"eeeeeebbbbaacacacfcaafce", -"eeeeadbdbbddddeaaccaafce", -"eeeeabdgbbdddddbbgded`ae", -"eeeeebbddebdbbbgdedbafee", -"eeeagbdgddbdddgbbbbbccee", -"eeeabbbbgdedbbbdeebb`aee", -"eeeabbgdgbbbbddgbbbdfaee", -"eeedbbbbbbbbbbbbbbbcceee", -"eeabbbbbbbbbbbbbbbbfaeee", -"eeabgdbdbbbbbbbbbbg`aeee", -"eeedbbbddaegbbbbbbafeeee", -"eagbbbbbbgddddddbbcceeee", -"eabgdgdbbbbdeddbbb`aeeee", -"eebdbbbdadebbbdbbefaeeee", -"adbggeddbgggdddbbcceeeee", -"cbbbbbbdadddbbgbbfaeeeee", -"acedbbbbbbbgedbbdfaeeeee", -"acf``caebbbbbbbbafeeeeee", -"eeeacff``febbbbbfceeeeee", -"eeeeeeaacf``faed`aeeeeee", -"eeeeeeeeeeaaff``faeeeeee", -"eeeeeeeeeeeeeaacaeeeeeee" -};
--- a/etc/vm/mime-colorful-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,137 +0,0 @@ -/* XPM */ -static char *mime-colorful-dn[] = { -/* width height num_colors chars_per_pixel */ -" 64 42 88 2", -/* colors */ -".. c #878787", -".# c #818181", -".a c #7f7f7f", -".b c #939393", -".c c #969696", -".d c #979797", -".e c #9f9f9f", -".f c #a7a7a7", -".g c #a1a1a1", -".h c #a5a5a5", -".i c #aeaeae", -".j c #adadad", -".k c #959595", -".l c #9a9a9a", -".m c #939393", -".n c #868686", -".o c #828282", -".p c #8b8b8b", -".q c #a3a3a3", -".r c #838383", -".s c #8e8e8e", -".t c #a2a2a2", -".u c #7d7d7d", -".v c #7b7b7b", -".w c #797979", -".x c #767676", -".y c #757575", -".z c #757575", -".A c #777777", -".B c #727272", -".C c #6f6f6f", -".D c #6a6a6a", -".E c #636363", -".F c #6b6b6b", -".G c #8a8a8a", -".H c #8e8e8e", -".I c #676767", -".J c #6e6e6e", -".K c #7a7a7a", -".L c #626262", -".M c #7e7e7e", -".N c #8d8d8d", -".O c #565656", -".P c #505050", -".Q c #4d4d4d", -".R c #494949", -".S c #434343", -".T c #404040", -".U c #575757", -".V c #393939", -".W c #3d3d3d", -".X c #3f3f3f", -".Y c #4f4f4f", -".Z c #585858", -".0 c #5b5b5b", -".1 c #5a5a5a", -".2 c #858585", -".3 c #5e5e5e", -".4 c #4b4b4b", -".5 c #7b7b7b", -".6 c #3a3a3a", -".7 c #636363", -".8 c #444444", -".9 c #3c3c3c", -"#. c #353535", -"## c #515151", -"#a c #323232", -"#b c #6c6c6c", -"#c c #6a6a6a", -"#d c #6f6f6f", -"#e c #2a2a2a", -"#f c #666666", -"#g c #838383", -"#h c #2d2d2d", -"#i c #737373", -"#j c #8f8f8f", -"#k c #6c6c6c", -"#l c #a3a3a3", -"#m c #9f9f9f", -"#n c Gray60", -"#o c #969696", -"#p c #b0b0b0", -"#q c #ababab", -"#r c #9e9e9e", -"#s c #9a9a9a", -"#t c #8a8a8a", -"#u c Gray60", -"#v c #a7a7a7", -/* pixels */ -"...#.#.......a.a.#.....b.b.c.d.d.d.e.d.e.e.e.e.e.e.f.g.g.h.h.e.f.h.i.h.h.f.h.h.f.h.j.j.f.h.f.j.f.h.j.h.j.h.g.e.e.e.d.d.k.c.l.b.m", -".b.n...........o...p.b.b.b.b.c.d.d.e.c.d.e.e.e.d.g.e.e.e.g.l.g.e.e.g.g.e.g.q.f.h.h.h.g.h.h.h.j.i.h.h.h.h.e.e.e.e.l.e.c.d.e.c.m.c", -".r.r...#...........b.b.b.s.b.m.d.d.c.l.e.d.l.e.d.e.m.d.l.d.e.e.e.e.e.e.e.e.d.g.d.e.e.e.h.g.f.h.h.h.h.f.h.g.t.e.e.d.e.d.c.c.d.c.c", -".#.o.a.#.#.#...#.......p...b.b.b.m.k.d.b.d.d.m.b.b.d.d.b.b.b.m.k.d.d.d.d.d.b.m.k.d.d.d.d.g.g.g.e.e.g.e.g.e.e.d.d.d.d.d.b.k.b.b.d", -".s.......#.#.#...#.o.#.....#.....p.....p.......#.a.#.#.......#.............b.b.b...b.b.k.e.c.e.d.e.d.e.d.e.e.d.d.k.c.b.b.m.b.m.d", -".#.#.o.r.a.u.a.u.o.u.u.u.a.#.o.u.u.r.u.u.u.v.u.w.w.x.u.u.u.u.u.u.a.#.o.#.o.............s.s.b.k.k.k.b.k.b.m.b.b.s.......s...b.s.b", -"...a.u.u.w.u.u.y.w.z.z.u.u.u.z.u.w.z.y.z.z.u.z.z.z.z.z.y.u.w.u.z.#.a.u.#.a.#.#.#...#.....#...........p.b.b...#.o.o.a.o.o.#.s.s.s", -".a.w.z.u.w.z.w.w.w.z.A.u.z.z.z.B.z.z.A.z.A.z.A.y.z.C.A.z.z.y.w.w.w.a.o.a.#.#.o.a.o...o...#...#.#.#.#.r.#.#...o.a.a.o.u.a.o.o.#..", -".#.o.u.z.z.z.z.B.B.z.y.B.z.B.B.B.B.B.B.B.B.B.B.B.C.B.B.w.w.w.w.x.u.w.u.u.o...a...#.....#.#...n.#.#.#.n...#.#.o.#.#.....#.o.r.#.#", -".w.a.w.w.B.B.B.z.B.B.z.B.B.D.C.B.C.B.B.C.D.C.E.C.C.F.z.B.B.B.w.B.u.u.u.u.u.#.#.#.....G.......H...#.#.#.........#.....H..........", -".w.x.z.z.B.B.z.C.z.B.B.B.C.C.D.C.E.I.C.E.E.D.D.C.B.F.B.B.F.z.w.w.w.u.#.v.o.a...........G...G...b.s.H.s.H.....G.s.H...G.b.s......", -".w.x.z.B.B.z.A.z.B.B.B.F.C.B.F.E.C.E.E.C.E.F.E.B.J.B.B.B.w.w.w.w.w.o.u.#.o.#.#...n.#.....s...p.s.b...b.b...G.b...G.b...p.b...G..", -".w.w.w.x.B.#.B.w.B.F.B.B.F.D.B.D.B.D.D.I.F.E.C.D.B.B.F.z.z.z.B.w.z.w.o.K.u.#.o.w.o.n...#.G.....H.b...s.G.b.b.s.H.p.b.b.s...G...#", -".u.w.w.w.w.w.w.K.u.z.B.B.B.F.B.B.C.D.C.E.F.L.E.L.L.I.E.F.C.C.B.F.B.C.C.z.z.u.M.w.a.o.a.#.....H...s.G.b.b.N...b.....p...s.G.N...#", -".a.w.a.w.a.o.a.u.y.w.B.B.B.B.C.E.L.O.P.P.Q.R.S.S.T.Q.R.R.R.P.P.U.O.L.L.L.E.B.F.B.B.x.w.M.w.#.o.o.#.#.......s.....s.s.G...s......", -".#...o...o.r.a.#.u.u.B.C.F.E.P.U.R.V.P.R.V.W.T.V.V.X.S.S.T.Q.R.P.Y.Z.0.1.Z.1.L.1.E.L.B.B.B.x.w.w.o.2...#...G...#.n.s...G.....#..", -".....#...#.o.r.a.w.w.B.F.3.P.Z.4.R.R.Q.V.S.S.T.W.V.S.V.S.V.S.S.W.R.P.Z.U.L.0.0.L.0.U.L.E.F.C.z.w.a.5.#.#.o.#...#...n.o.#...o....", -".........#.o.a.o.x.x.C.O.Z.U.R.Y.R.R.R.W.W.S.S.W.W.V.6.6.W.S.W.W.R.S.W.R.S.R.P.Z.L.L.L.0.0.0.7.F.B.x.w.w.K.o.o.o.o...n.....n....", -".s.H.......o.a.w.x.F.U.Z.U.Y.P.R.Y.R.S.S.8.R.6.S.S.6.S.W.6.9.9.9.9#..9#..6.S.R.Y.U.Z.P##.L.L.0.L.0.F.F.B.x.x.M.o.5...n.n.o...G..", -".b.s.H...#.n.K.x.F.1.L.L.P.P.4.Y.R.8.Z.Y.L.Z.V.W.R.S.W#..9#.#..6.S.8.8.W.6.W.R.R.R.R.R.Z.L.L.F.L.L.U.0.F.F.M.w.M.o.n.2...o......", -".s.s...n.#.o.w.F.L.L.L.1.L.L.U.Z.Z.Z.Z.5.7.R.S.S.R.S.9#a.9#.#.#b#b#c.Z.R.W.S.S.Y.R.Y.R.Y.Y.U.7.L.L.F.L.E.F.F.M.M.w.M.o.n.....G.s", -".s.G.....o.K.M.1.F.F.E.F.L.L.Z#d.o.K.n.n.7.Z.Z.Y.S.W#a#e#a#e.6#d#d.5#b.R.8.S.Y#d.Z.R.R.R.8.Z.Z.U.7.F.B#d.C.B.x.A.#.o.a...G.H.b.k", -".s.N.G...o.5.B.F.C.C.3.F.F#f#d.n.K.o.n#g#c.Z.Z.Z.S.6#.#e#h#..8#d.5#g.5.Z.8.Y.U.5.5#c.Y.Y.Y.R.Y.L.L.F.F.B.x.F.A.x.5..#g.....b.k.k", -".H.s...n.o.w.C.F.B.C.C.F#f.M.o#g.n.n.H.G.5#d.U.Y.Y.6#.#a#.#..6#d#b.5#d.Z.Y.Z.7#g.n.5#d.Z.R.Y.Y.P.L.7.F.F.B.o.K.#.o.n...G.H.b.H.d", -".s.H.....#.w.B.B#i.F#d.B.o.n.n.H.H.n.H#j.5.Z.Z.Z.L.U.Z.Y.6#..W.7#d.7#d.Z.7.7#d.H#j.H.G.5.Z.U.4.Z.Z.L.L#k.A.w.5.o.....G.m.b.k.b.k", -".s.H...n.#.w.w.x.B.z.B.5.5.n#g.n.n.H#j.H#g#c.L.L#d#d#d.7.Y.R.W.Y.7#d.7.Y.Z#c.n#l#m.G#m.H.A.7.F.L.0.L.C.A.B.F.o.....G.b.H.k.d.d.g", -".k.H.....n.#.o.w#n#n#n#n#n.n.n.n.H#m.k#o.H.5#c#c#b#b#c#d#d#d#d.7#b#b#d#c#d#d#p#q#l#n#n.5.A.x.M.M.A.A#d.F#d.#.N.G.b.k.k.k.d.g.k.g", -".b.H.G...n.#.o.5#n#n.B.x#n#n.n.H.k#r.k.t.t.H#d#c#b#b#d#d#c.5#d#d#d#d#d#b#d#l#p.t#q#n#n.M.M.M.M.M.M.o.G.H.G.H.b.k.k.k.d.g#s.d.g#m", -".H.k.H.H...o.n#n#n.B.B.B#n#n.n.G#n#n#n#n.t#m#g#n#n#n#n#d#d#d#n#n#n#n#d#d#r#n#n#l#n#n.5.5#n#n#n#n.M.5.n.b.k.k.k.k.g.b#m.b.g.g.g.k", -".d#m.b.k.#.o.o#n#n.x.B.B#n#n.n#n#n.k#l#n#n#p#n#n#d#d#n#n#d#n#n#d#b#n#n.k#n#n#q#n#n#n.n#n#n.M.M#n.o.n.s.G.b.k.g.k.b#m.k.g.g#r.g.k", -".b.k.b.k...o#n#n.o.w.B.B#n#n#n#n.G.k#r#n#n#n#n#r.5.5#b#d#n#n#b#d#d#n#n#n#n#p#r.H#n#n#n#n.M.A#g#n.o.n.H.H.d#m.d.g.g.g.g.g.e.g.g.g", -".k.d.g.k.H.o#n#n.w.B.w#n#n.M#n#n#n#n#n#n#r#n#n#l.t#m.H#g#n#n.5.H#n#n#p#n#n#m.G#n#n#t#n#n#n#n#n#n.H.k.H.k.d.g#m.g.g.g.g.g.h.g.g.g", -".g.e.d.d.H.o#n#n.x.w.w#n#n#n#n.o#g.n.o#g#n#n.s#m#r#n#n#n#n#m#m#u#u#n#n#n#m.G#u#u#n#u#u.n#u#u.n.n.H.H.k#u#u.e#u#u#u#u#u.g.h.h.f.h", -".e.k.g.k.b#n#n.M.M.M#n#n.5#n#n.a.o#n#n.n#n#n.G.H#n#n.s#n#n.H.H#u#u#u#n#n.N#u#u#u#j#u#u.N#u#u#u.H.H.b#u#u#u.g#u#u.h.h.g#q.h#q.h.h", -".e#m.d.d.b#n#n#n#n#n#n.o.w.M#n#n#n#n.w.5.##n#n#n#n.H.H.G#n#n#n#u#u#u.G#n#n#u#u#u.H#u#u#n#u#u#u.k.k.H#u#u#u.g#u#u.g.h.h.h.h.i.h.g", -".d.g.g.k.d.k.p.s...#...n.5.5.#.5.M.A.M.#.5.o...5.n.G...n#g.G#g#u#u#u#u.n#u#u#u#u.k#u#u.b#u#u#u#u.g#u#u#u#u.h#u#u#u#u#u.h#v.f.f#q", -".g.g.g.g.d.d.b.G.H...G.....n.o.o.A.o.s.M.#.n.5.o.o.n.o#g.x.n.n#u#u.b#u.G#u.k#u#u.H#u#u.g#u#u.g#u.g#u.h#u#u.i#u#u.i.g.i.f.i.g.h.i", -".g.t.g.g.d.e.k.b.H.H.G.H.G.....5.o.n.o.5...5.G.o.n.....G.M.G..#u#u.d#u#u#u#m#u#u.k#u#u.g#u#u.g#u#u#u.h#u#u.h#u#u.h#q.f#q.h.i.h.j", -".t.h.h.g.g#r.d.d.H.s.H.b.H.H.G.G.......n.G...G.n.G.H.H.H.n.H.H#u#u.g#m#u.g#m#u#u#r#u#u#r#u#u.h#q#u#q.h#u#u.i#u#u#q.h#q.h.i#q.i.h", -".g.t.h.g.g.g.k.d.k.b.H.b.H.k.b.H.G.s.n.H.G.H.H.s.H.k.d.k.s.H.H#u#u#m#m#u#s#m#u#u#m#u#u#m#u#u#q.g#u.g#q#u#u.i#u#u#u#u#u#q.h.i.h#q", -".h.h#v.h.g.g.g#m.d.d.k.d.k.k.k.d.H.k.G.s.H.b.b.k.b.d.b.H.e#m.H.k.g#m#m.g#r.g.g#q.g.h#q.h#q.g#q.h#q#q.h.i.i.h.i.i.i.i.h.i.h.i.h.f", -".g.g.h.f.h.g.g.e.d.g.b.k.d.k.b.k.k.k.d.b.b.k.k.k.d.d.d.g.k.g.k.g#r.g.g.g.t.g.h#q#m.h#v#q.h#q.h#q#q#q.i#q.i.h.h#q.h.i.h.i.h.f.i.h" -};
--- a/etc/vm/mime-colorful-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,133 +0,0 @@ -/* XPM */ -static char * mime-fancy-up_xpm[] = { -"64 42 88 1", -" c #B8B878785050", -". c #B0B070705050", -"X c #B0B070704848", -"o c #C8C880806060", -"O c #C8C888885858", -"+ c #C8C888886060", -"@ c #D0D090906868", -"# c #D8D898987070", -"$ c #D0D090907070", -"% c #D0D098987070", -"& c #D8D8A0A08080", -"* c #D8D8A0A07878", -"= c #C0C088886060", -"- c #D0D088886060", -"; c #C0C088885858", -": c #B0B078785858", -"> c #B0B070705858", -", c #C0C078785858", -"< c #D0D098986868", -"1 c #B8B870705050", -"2 c #C0C080805050", -"3 c #C8C898987070", -"4 c #A8A870704848", -"5 c #B0B068684848", -"6 c #A8A868684848", -"7 c #A0A068684848", -"8 c #A8A860604848", -"9 c #A0A068684040", -"0 c #A0A068685050", -"q c #A0A060604848", -"w c #989860604848", -"e c #989858584040", -"r c #909050504040", -"t c #909060604040", -"y c #B8B878786060", -"u c #B8B880806060", -"i c #909058584040", -"p c #989860604040", -"a c #A0A070704848", -"s c #808058584040", -"d c #A8A870705050", -"f c #B8B880805858", -"g c #787848483838", -"h c #686848483838", -"j c #686840404040", -"k c #606040403838", -"l c #585838383838", -"z c #505038383838", -"x c #787848484040", -"c c #484830303838", -"v c #484838383838", -"b c #505038383030", -"n c #606048484040", -"m c #707050504040", -"M c #787850504040", -"N c #808048484040", -"B c #B0B078785050", -"V c #808050504040", -"C c #606040404040", -"Z c #A0A070705050", -"A c #404038383838", -"S c #808058584848", -"D c #505040403838", -"F c #484838383030", -"G c #404030303030", -"H c #686848484040", -"J c #383830303030", -"K c #808068685050", -"L c #888860604848", -"P c #888868685050", -"I c #303028282828", -"U c #888858584848", -"Y c #A8A878785858", -"T c #383828282828", -"R c #989868684848", -"E c #B8B880806868", -"W c #909060604848", -"Q c #C8C898987878", -"! c #C8C890907878", -"~ c #FFFFFFFFFFFF", -"^ c #C0C088886868", -"/ c #D0D0A8A88888", -"( c #D0D0A0A08080", -") c #C8C890907070", -"_ c #C8C888887070", -"` c #B0B080805858", -"' c #000000000000", -"] c #D0D098988080", -" .. XX. ooO+++@+@@@@@@#$$%%@#%&%%#%%#%**#%#*#%*%*%$@@@++=O-o;", -"o: > ,ooooO++@O+@@@+$@@@$-$@@$$@$<#%%%$%%%*&%%%%@@@@-@O+@O;O", -"11 . ooo2o;++O-@+-@+@;+-+@@@@@@@@+$+@@@%$#%%%%#%$3@@+@+OO+OO", -".>X... . , ooo;=+o++;oo++ooo;=+++++o;=++++$$$@@$@$@@+++++o=oo+", -"2 ... .>. . , , .X.. . ooo oo=@O@+@+@+@@++=Ooo;o;+", -"..>1X4X4>444X.>44144454667444444X.>.> 22o===o=o;oo2 2 o2o", -" X446448699444946989949999984649.X4.X... . . ,oo .>>X>>.222", -"X69469666904999q990909089w0998666X>X..>X> > . ....1.. >XX>4X>>. ", -".>49999qq98q9qqqqqqqqqqqwqq666674644> X . .. :...: ..>.. .>1..", -"6X66qqq9qq9qqewqwqqwewrwwt9qqq6q44444... y u ... . u ", -"6799qq9w9qqqwwewriwrreewqtqqt96664.5>X y y o2u2u y2u yo2 ", -"679qq909qqqtwqtrwrrwrtrqpqqq66666>4.>.. :. 2 ,2o oo yo yo ,o y ", -"6667q.q6qtqqteqeqeeitrweqqt999q696>a4.>6>: .y uo 2yoo2u,oo2 y .", -"4666666a49qqqtqqwewrtsrssirtwwqtqww994d6X>X. u 2yoof o , 2yf .", -"X6X6X>X486qqqqwrsghhjkllzjkkkhhxgsssrqtqq76d6.>>.. 2 22y 2 ", -". > >1X.44qwtrhxkchkcvzccbllzjkhnmMNmNsNrsqqq766>B . y .:2 y . ", -" . .>1X66qtVhmCkkjcllzvclclcllvkhmxsMMsMxsrtw96XZ..>. . :>. > ", -" .>X>77wgmxknkkkvvllvvcAAvlvvklvklkhmsssMMMStq766a>>>> : : ", -"2u >X67txmxnhknkllDkAllAlvAFFFFGFGAlknxmhHssMsMttq77d>Z ::> y ", -"o2u .:a7tNsshhCnkDmnsmcvklvGFGGAlDDvAvkkkkkmsstssxMttd6d>:B > ", -"22 :.>6tsssNssxmmmmZSkllklFJFGGKKLmkvllnknknnxSsstsrttdd6d>: y2", -"2y >adNttrtssmP>a::SmmnlvJIJIAPPZKkDlnPmkkkDmmxStqPwq70.>X yuo=", -"2fy >ZqtwwVttUP:a>:YLmmmlAGITGDPZYZmDnxZZLnnnknssttq7t07Z Y o==", -"u2 :>6wtqwwtUd>Y::uyZPxnnAGJGGAPKZPmnmSY:ZPmknnhsSttq>a.>: yuou+", -"2u .6qqRtPq>::uu:uEZmmmsxmnAGvSPSPmSSPuEuyZmxCmmssW06Z> y;o=o=", -"2u :.667q9qZZ:Y::uEuYLssPPPSnkvnSPSnmL:Q!y!u0StsMsw0qt> you=++$", -"=u :.>6~~~~~:::u!=^uZLLKKLPPPPSKKPLPP/(Q~~Z07dd00PtP.fyo===+$=$", -"ouy :.>Z~~q7~~:u=)=33uPLKKPPLZPPPPPKPQ/3(~~dddddd>yuyuo===+$_+$!", -"u=uu >:~~qqq~~:y~~~~3!Y~~~~PPP~~~~PP)~~Q~~ZZ~~~~dZ:o====$o!o$$$=", -"+!o=.>>~~7qq~~:~~=Q~~/~~PP~~P~~PK~~=~~(~~~:~~dd~>:2yo=$=o!=$$)$=", -"o=o= >~~>6qq~~~~y=)~~~~)ZZKP~~KPP~~~~/)u~~~~d0Y~>:uu+!+$$$$$@$$$", -"=+$=u>~~6q6~~d~~~~~~)~~Q3!uY~~Zu~~/~~!y~~`~~~~~~u=u=+$!$$$$$%$$$", -"$@++u>~~766~~~~>Y:>Y~~2!)~~~~!!''~~~!y''~'':''::uu=''@'''''$%%#%", -"@=$=o~~ddd~~Z~~X>~~:~~yu~~2~~uu'''~~f'''E''f'''uuo'''$''%%$(%(%%", -"@!++o~~~~~~>6d~~~~6Z.~~~~uuy~~~'''y~~'''u''~'''==u'''$''$%%%%&%$", -"+$$=+=,2 . :ZZ.Zd0d.Z> Z:y :YyY'''':''''=''o''''$''''%'''''%]##(", -"$$$$++oyu y :>>0>2d.:Z>>:>Y7::''o'y'=''u''$''$'$'%''&''&$&#&$%&", -"$3$$+@=ouuyuy Z>:>Z Zy>: ydy ''+'''!''=''$''$'''%''%''%(#(%&%*", -"3%%$$)++u2uouuyy :y y:yuuu:uu''$!'$!'')'')''%('(%''&''(%(%&(&%", -"$3%$$$=+=ouou=ouy2:uyuu2u=+=2uu''!!'_!''!''!''($'$(''&'''''(%&%(", -"%%]%$$$!++=+===+u=y2uoo=o+ou@!u=$!!$)$$($%(%($(%((%&&%&&&&%&%&%#", -"$$%#%$$@+$o=+=o===+oo===+++$=$=$)$$$3$%(!%](%(%(((&(&%%(%&%&%#&%"};
--- a/etc/vm/mime-colorful-xx.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -/* XPM */ -static char * mime-fancy-up_xpm[] = { -"64 42 89 1", -" c #B8B878785050", -". c #B0B070705050", -"X c #B0B070704848", -"o c #C8C880806060", -"O c #C8C888885858", -"+ c #C8C888886060", -"@ c #D0D090906868", -"# c #D8D898987070", -"$ c #D0D090907070", -"% c #D0D098987070", -"& c #D8D8A0A08080", -"* c #D8D8A0A07878", -"= c #C0C088886060", -"- c #D0D088886060", -"; c #C0C088885858", -": c #B0B078785858", -"> c #B0B070705858", -", c #C0C078785858", -"< c #D0D098986868", -"1 c #B8B870705050", -"2 c #C0C080805050", -"3 c #C8C898987070", -"4 c #A8A870704848", -"5 c #B0B068684848", -"6 c #A8A868684848", -"7 c #A0A068684848", -"8 c #A8A860604848", -"9 c #A0A068684040", -"0 c #A0A068685050", -"q c #A0A060604848", -"w c #989860604848", -"e c #989858584040", -"r c #909050504040", -"t c #909060604040", -"y c #B8B878786060", -"u c #B8B880806060", -"i c #909058584040", -"p c #989860604040", -"a c #A0A070704848", -"s c #808058584040", -"d c #A8A870705050", -"f c #B8B880805858", -"g c #787848483838", -"h c #686848483838", -"j c #686840404040", -"k c #606040403838", -"l c #585838383838", -"z c #505038383838", -"x c #787848484040", -"c c #484830303838", -"v c #484838383838", -"b c #505038383030", -"n c #606048484040", -"m c #707050504040", -"M c #787850504040", -"N c #808048484040", -"B c #B0B078785050", -"V c #808050504040", -"C c #606040404040", -"Z c #A0A070705050", -"A c #404038383838", -"S c #808058584848", -"D c #505040403838", -"F c #484838383030", -"G c #404030303030", -"H c #686848484040", -"J c #383830303030", -"K c #808068685050", -"L c #888860604848", -"P c #888868685050", -"I c #303028282828", -"U c #888858584848", -"Y c #A8A878785858", -"T c #383828282828", -"R c #989868684848", -"E c #B8B880806868", -"W c #909060604848", -"Q c #C8C898987878", -"! c #C8C890907878", -"~ c Gray60", -"^ c #C0C088886868", -"/ c #D0D0A8A88888", -"( c #D0D0A0A08080", -") c #C8C890907070", -"_ c #C8C888887070", -"` c #B0B080805858", -"' c Gray60", -"] c #D0D098988080", -"[ c black s backgroundToolBarColor", -" [.[ [X[.[ [o[+[+[+[@[@[@[$[%[@[%[%[#[%[%[*[%[*[%[%[%[@[@[+[O[o[", -"[:[ [ [>[,[o[o[+[@[+[@[+[@[@[-[@[$[@[<[%[%[%[%[&[%[%[@[@[@[+[O[O", -"1[ [ [ [ [o[2[;[+[-[+[@[@[+[+[@[@[@[@[$[@[@[$[%[%[#[$[@[+[+[O[O[", -"[>[.[.[.[ [,[o[o[=[o[+[o[+[o[o[=[+[+[o[=[+[+[$[@[$[$[@[+[+[o[o[+", -"2[ [.[.[.[.[ [ [,[ [ [ [X[.[ [.[ [ [ [o[ [o[@[@[@[@[@[+[=[o[;[;[", -"[.[1[4[4[4[4[.[4[1[4[5[6[7[4[4[4[.[.[ [ [ [2[o[=[o[o[o[2[ [2[o[o", -" [4[6[4[6[9[4[9[6[8[9[9[9[9[4[4[.[4[X[.[ [ [.[ [ [,[o[.[>[>[.[2[", -"[6[4[9[6[9[4[9[q[9[9[9[8[w[9[8[6[X[X[.[X[ [ [ [.[.[.[ [X[>[X[>[ ", -".[4[9[9[q[8[9[q[q[q[q[q[w[q[6[6[4[4[>[X[.[ [.[:[.[:[.[>[.[ [>[.[", -"[X[6[q[9[q[q[e[q[q[w[w[w[t[q[q[q[4[4[.[.[ [ [ [ [.[ [ [.[ [ [ [ ", -"6[9[q[9[9[q[w[e[r[w[r[e[q[q[t[6[6[.[>[ [ [ [ [ [2[2[ [y[u[y[2[ [", -"[7[q[9[9[q[t[q[r[r[w[t[q[q[q[6[6[>[.[.[ [.[ [ [2[ [o[y[ [o[,[ [ ", -"6[6[q[q[q[q[t[q[q[e[t[w[q[t[9[q[9[>[4[>[>[ [y[ [o[2[o[2[,[o[ [ [", -"[6[6[6[a[9[q[t[q[e[r[s[s[i[t[w[t[w[9[4[6[>[.[ [ [y[o[ [ [,[2[f[.", -"X[X[X[X[8[q[q[w[s[h[j[l[z[k[k[h[g[s[r[t[q[6[6[>[.[ [ [ [2[y[2[ [", -"[ [ [1[.[4[w[r[x[c[k[v[c[b[l[j[h[m[N[N[N[s[q[7[6[B[.[y[.[2[y[ [ ", -" [.[.[1[6[q[V[m[k[j[l[z[c[c[c[l[k[m[s[M[M[s[t[9[X[.[>[ [ [>[ [ [", -"[ [ [>[>[7[g[x[n[k[v[l[v[c[A[l[v[l[k[k[m[s[M[M[t[7[6[>[>[ [ [:[ ", -"2[ [ [X[7[x[x[h[n[l[D[A[l[l[A[F[F[F[A[k[x[h[s[M[M[t[7[d[Z[:[>[y[", -"[2[ [:[7[N[s[h[n[D[n[m[v[l[G[G[A[D[v[v[k[k[m[s[s[x[t[d[d[:[ [ [ ", -"2[ [.[6[s[s[s[x[m[m[S[l[k[F[F[G[K[m[v[l[k[k[n[S[s[s[t[d[6[>[ [y[", -"[y[ [a[N[t[t[s[P[a[:[m[n[v[I[I[P[Z[k[l[P[k[k[m[x[t[P[q[0[>[ [u[=", -"2[y[>[q[w[V[t[P[a[:[L[m[l[G[T[D[Z[Z[D[x[Z[n[n[n[s[t[7[0[Z[Y[ [=[", -"[2[:[6[t[w[t[d[Y[:[y[P[n[A[J[G[P[Z[m[m[Y[Z[m[n[h[S[t[>[.[:[y[o[+", -"2[ [.[q[R[P[>[:[u[u[Z[m[s[m[A[v[P[P[S[P[E[y[m[C[m[s[0[Z[ [y[o[o[", -"[u[:[6[7[9[Z[:[:[u[u[L[s[P[S[k[n[P[n[L[Q[y[u[S[s[s[0[t[ [y[u[+[$", -"=[ [:[>[~[~[~[:[u[=[u[L[K[L[P[P[K[P[P[/[Q[~[0[d[0[P[P[f[o[=[+[=[", -"[u[ [.[Z[~[7[~[u[)[3[u[L[K[P[Z[P[P[K[Q[3[~[d[d[d[>[u[u[=[=[$[+[!", -"u[u[ [:[~[q[~[:[~[~[3[Y[~[~[P[~[~[P[)[~[~[Z[~[~[d[:[=[=[$[![$[$[", -"[![=[>[~[7[q[~[~[=[~[/[~[P[~[~[P[~[=[~[~[~[~[d[~[:[y[=[=[![$[)[=", -"o[o[ [~[>[q[~[~[y[)[~[~[Z[K[~[K[P[~[~[)[~[~[d[Y[>[u[+[+[$[$[@[$[", -"[+[=[>[~[q[~[d[~[~[~[~[Q[![Y[~[u[~[~[![~[`[~[~[~[=[=[$[$[$[$[$[$", -"$[+[u[~[7[6[~[~[Y[>[~[2[)[~[~[!['[~[!['[~['['[:[u[=['['['['[%[#[", -"[=[=[~[d[d[~[~[X[~[:[~[u[~[~[u['['[~['['['[f['[u[o['[$['[%[([([%", -"@[+[o[~[~[~[6[~[~[6[.[~[~[u[~[~['[y[~['[u['['['[=['['['[$[%[%[%[", -"[$[=[=[2[.[:[Z[Z[0[.[>[Z[y[:[y['['[:['['['[o['['['['[%['['[%[#[(", -"$[$[+[o[u[y[ [>[0[2[.[Z[>[>[7[:['['['['[u['['[$[$[%['['[&[&[&[%[", -"[3[$[@[o[u[u[ [Z[:[Z[Z[>[ [y[y['[+['[!['['[$['['['['[%['[([([&[*", -"3[%[$[+[u[u[u[y[ [ [y[y[y[u[:[u['[![$['[)['['[%['[%['['[([([&[&[", -"[3[$[$[+[o[o[=[u[2[u[u[2[=[=[u['[!['[!['['[!['[$[$['[&['['[([&[(", -"%[][$[$[+[=[=[=[u[y[u[o[o[o[@[u[$[![)[$[$[([([([([%[&[&[&[%[%[%[", -"[$[#[$[@[$[=[=[=[=[o[=[=[+[$[$[$[$[$[$[([%[([([([([([%[([&[&[#[%"};
--- a/etc/vm/mime-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define e_width 64 -#define e_height 42 -static char e_bits[] = { - 0x39,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x42,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0x8f,0xda,0x7f,0xb8,0xff,0xff,0xff,0xff,0x0c,0x41,0x02,0x00,0xf4, - 0xff,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0xed,0xbf,0xed,0x00,0x00,0x00,0x00, - 0x44,0x2f,0x64,0xb2,0x02,0x00,0x00,0x00,0xb0,0x66,0x4c,0x36,0x00,0x00,0x00, - 0x00,0x00,0xff,0x78,0xff,0x00,0x00,0x00,0x00,0xd0,0xff,0xff,0xff,0x00,0x00, - 0x00,0x00,0x92,0xfd,0xff,0xff,0x00,0x00,0x00,0x00,0x44,0xf7,0xff,0x7f,0x00, - 0x00,0x00,0x00,0x00,0xf2,0xff,0x7f,0x20,0x00,0x00,0x00,0x00,0xc0,0xfc,0xff, - 0x3e,0x00,0x00,0x00,0x00,0x00,0x77,0xbf,0x6b,0x00,0x00,0x00,0x00,0x00,0x50, - 0xf7,0xaf,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0x3f,0x00,0x00,0x00,0x0a,0x00, - 0x80,0xfe,0x2f,0x00,0x00,0x68,0x00,0x00,0x00,0xff,0x2f,0x00,0x00,0x68,0x00, - 0x00,0x00,0xfc,0x1f,0x00,0x0d,0x3c,0x00,0x00,0x00,0xfa,0x1f,0x80,0x0e,0x3c, - 0x02,0x00,0x00,0xfe,0x1f,0xc0,0x0f,0x3c,0x80,0x01,0x20,0xff,0x0f,0xf0,0x0f, - 0x20,0x80,0x07,0x80,0xff,0x0f,0xe0,0x1f,0x00,0xc0,0x0f,0xc0,0xff,0x5f,0xff, - 0x1f,0x00,0xc0,0x07,0xc0,0xff,0x5f,0xf3,0x3f,0x00,0xe0,0x07,0xfe,0xff,0xff, - 0xf1,0xff,0xc7,0xf3,0xf3,0xfc,0xff,0xef,0xf1,0xff,0x6c,0xfe,0x9f,0xff,0xff, - 0xff,0xf1,0xff,0x30,0xfe,0xcf,0xff,0xff,0xff,0xd8,0xff,0xbf,0xff,0xff,0xff, - 0xff,0xff,0xf8,0xff,0x7f,0x3e,0xc9,0x27,0xf8,0x7f,0x6c,0xff,0x7f,0x1c,0x89, - 0x23,0xff,0xff,0xcf,0xe3,0x7f,0x1c,0x89,0x23,0xff,0xff,0x0d,0x60,0x7f,0x08, - 0x09,0x21,0xf8,0xff,0xff,0xa6,0x6f,0x2a,0x49,0x25,0xff,0xff,0x7f,0xd7,0x6f, - 0x22,0x49,0x24,0xff,0xff,0xff,0xff,0x7f,0x36,0xc9,0x26,0xff,0xff,0xff,0xff, - 0x7f,0x36,0xc9,0x26,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/mime-simple-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"64 42 8 1", -/* colors */ -"` c Gray60", -"a c #666666666666", -"b c #9A9A9A9A9A9A", -"c c #B0B0B0B0B0B0", -"d c #2A2A2A2A2A2A", -"e c #878787878787", -"f c Gray60", -"g c #434343434343", -/* pixels */ -"eeeeeeeeeeebbbbbbbbbbbbbbcbbccbccccccccccccccccccccccbbbbbbbbbbb", -"beeeeeeeeebbbbbbbbbbbbbbbbbbbbbbbbbbbbccccbcccccccccbbbbbbbbbbbb", -"eeeeeeeeebbbebbbbbbbbbbbbbbbbbbbbbbbbbbbbbbcbcccccccbbbbbbbbbbbb", -"eeeeeeeeeeeeebbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb", -"eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeebbbebbbbbbbbbbbbbbbbbbbbbbb", -"eeeeeeeeeeeeeeeeeeeeeeeeeaeeeeeeeeeeeeeeeeeeebbbbbbbbbbeeeeeebeb", -"eeeeeeeaeaaeeeaeeaaaaeaaaaaaeeeaeeeeeeeeeeeeeeeeeeebbeeeeeeeeeee", -"eeaeeaeeeaeeaaaaaaeaeaeaaaeaaaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", -"eeeaaaaaaaaaaaaaaaaaaaaaaaaeeeeaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", -"eeeeaaaaaaaaaaaaaaaaaaaaaaaaaaeaeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee", -"eaaaaaaaaaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeeeeeebeeeeeeeeeeebeeee", -"eaaaaaeaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeeeeeeeeebebbeebeebeebeee", -"eeeaaeaeaaaaaaaaaaaaaaaaaaaaaaaeaeeeeeeeeeeeeeeebeeebbeeebbeeeee", -"eeeeeeeeeaaaaaaaaaaaaaaaaaaaaaaaaaaaaeeeeeeeeeeeeebbeebeeeeeeeee", -"eeeeeeeeaeaaaaaaaagggggggggggggaaaaaaaaaaaeeeeeeeeeeeeeeeeeeeeee", -"eeeeeeeeeeaaaagagggggggggggggggggaaaaaaaaaaaaaeeeeeeeeeeeeeeeeee", -"eeeeeeeeeeaaagagggggggggggggggggggaaaaaaaaaaaaaeeeeeeeeeeeeeeeee", -"eeeeeeeeaaaaaagggggggggggggggggggggggggaaaaaaaaaaaeeeeeeeeeeeeee", -"eeeeeeeeaaaaaggggggggggggggggggggdgdggggaaggaaaaaaaaaaeeeeeeeeee", -"beeeeeeaaaaaggggggagaagggggdgddggggggggggggaaaaaaaaaaeeeeeeeeeee", -"eeeeeeeaaaaaaaaaaaaeaggggggdgddaaaaggggggggggaaaaaaaaaeeeeeeeeee", -"eeeeeeeaaaaaaaaaeeeeaaagggddddgaaeaggggaaggggaaaaaaaaaaeeeeeeebb", -"eeeeeeaaaaaaaaaeeeeeaaaaggddddgaeeeaggaeeagggggaaaaaaaeaeeeeebbb", -"eeeeeeaaaaaaaeeeeeeeeaagggddddgaaeaagaaeeeaaggggaaaaaeeeeeeeebeb", -"eeeeeeaaaaaaeeeeeeeeeaaaaaaggdgaaaaaaaaeeeeeaagaaaaaeeeeeeebbbbb", -"eeeeeeeaaaaeeeeeeeeeeaaaaaaaggggaaagaaebbebeeaaaaaaeaaeeeebebbbb", -"beeeeeeefffffeeeebbbeeaaaaaaaaaaaaaaaaccbffeeaeeeeaaaeeebbbbbbbb", -"beeeeeeeffaaffeebbbbbeaaaaaaaeaaaaaaabcbcffeeeeeeeeeeebbbbbbbbbb", -"ebeeeeeffaaaffeeffffbbeffffaaaffffaabffbffeeffffeeebbbbbbbbbbbbb", -"bbbbeeeffaaaffeffbbffcffaaffaffaaffbffcfffeffeefeeeebbbbbbbbbbbb", -"bbbbeeffeeaaffffebbffffbeeaaffaaaffffcbeffffeeefeeeebbbbbbbbbbbb", -"bbbbeeffeaeffeffffffbffbbbeeffeeffcffbeffeffffffebebbbbbbbbbcbbb", -"bbbbeeffaeeffffeeeeeffebbffffbb``fffbe``f``e``eeeeb``b`````bcccc", -"bbbbbffeeeffeffeeffeffeeffeffee```ffe```e``e```eeb```b``ccbccccc", -"bbbbbffffffeeeffffeeeffffeeefff```eff```e``f```bbe```b``bccccccb", -"bbbbbbeeeeeeeeeeeeeeeeeeeeeeeee````e````b``b````b````c`````ccccc", -"bbbbbbbeeeeeeeeeeeeeeeeeeeeeaee``b`e`b``e``b``b`b`c``c``cbcccbcc", -"bbbbbbbbeeeeeeeeeeeeeeeeeeeeeee``b```b``b``b``b```c``c``cccccccc", -"bccbbbbbeeebeeeeeeeeeeeeeeeeeee``bb`bb``b``b``cc`cc``c``cccccccc", -"bbcbbbbbbbebebbeeeeeeeeeebbbeee``bb`bb``b``b``cb`bc``c`````ccccc", -"ccccbbbbbbbbbbbbebeeebbbbbbebbebbbbbbbbcbccccbcccccccccccccccccc", -"bbcccbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbccbccccccccccccccccccccccc" -};
--- a/etc/vm/mime-simple-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"64 42 8 1", -/* colors */ -"` c #000000000000", -"a c #B8B878785050", -"b c #D0D0A8A88888", -"c c #585838383838", -"d c #303028282828", -"e c #FFFFFFFFFFFF", -"f c #D0D090906868", -"g c #909050504040", -/* pixels */ -"aaaaaaaaaaaffffffffffffffffffffffbfffffffbbfffbffbfbfffffffffffa", -"faaaaaaaaaffffffffffffffffffffffffffffffffffffbbffffffffffffffaf", -"aaaaaaaaafffafaffffffffffaffffffffffffffffffffffffffffffffffffff", -"aaaaaaaaaaaaafffafffffafffffffafffffffafffffffffffffffffffffffff", -"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafffafffffffffffffffffffafaf", -"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafffffffaffaaaaaafaf", -"aaaaaaaaaggaaagaagaggagggggaaaagaaaaaaaaaaaaaaaaaaaffaaaaaaaaaaa", -"aagaagaaagaaggggggagagaaggaggaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", -"aaagggggggaggggggggggggggggaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaggggggggggggggggggggggggggagaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", -"aaggggggggggggggggggggggggggggaaaaaaaaaaaaaaaaafaaaaaaaaaaafaaaa", -"aaggggagggggggggggggggggggggaaaaaaaaaaaaaaaaaaaafaffaafaafaafaaa", -"aaaagagagggggggggggggggggggggggagaaaaaaaaaaaaaaafaaaffaaaffaaaaa", -"aaaaaaaaaggggggggggggggggggggggggggggaaaaaaaaaaaaaffaafaaaaaaaaa", -"aaaaaaaaaaggggggggcccccccccccccggggggggggaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaaaaaaaggggcgcccccccccccccccccggggggggggggaaaaaaaaaaaaaaaaaaa", -"aaaaaaaaaagggcgcccccccccccccccccccgggggggggggggaaaaaaaaaaaaaaaaa", -"aaaaaaaaaaggggcccccccccccccccccccccccccggggggggggaaaaaaaaaaaaaaa", -"aaaaaaaaaggggccccccccccccccccccccdcdccccggccggggggggaaaaaaaaaaaa", -"faaaaaaaggggccccccgcggcccccdcddccccccccccccggggggggggaaaaaaaaaaa", -"aaaaaaaggggggggggggagccccccdcddggggccccccccccgggggggggaaaaaaaaaa", -"aaaaaaagggggggggaaaagggcccddddcggagccccggccccgggggggggaaaaaaaaff", -"aaaaaagggggggggaaaaaggggccddddcgaaagccgaagcccccgggggagaaaaaaafff", -"aaaaaagggggggaaaaaaaaggcccddddcggaggcggaaaggccccgggggaaaaaaaafaf", -"aaaaaaggggggaaaaaaaaaggggggccdcggggggggaaaaaggcgggggaaaaaaaaffff", -"aaaaaaaagggaaaaaaaaaagggggggccccgggcggaffafaaggggggaggaaaafaffff", -"faaaaaaaeeeeeaaaafffaaggggggggggggggggbbfeeaaaaaaagggaaaffffffff", -"faaaaaaaeegaeeaafffffagggggggagggggggfbfbeeaaaaaaaaaaaffffffffff", -"afaaaaaeegggeeaaeeeeffaeeeegggeeeeggfeefeeaaeeeeaaafffffffffffff", -"ffffaaaeeaggeeaeeffeebeeggeegeeggeefeebeeeaeeaaeaaaaffffffffffff", -"ffffaaeeaaggeeeeaffeeeefaaggeegggeeeebfaeeeeaaaeaaaaffffffffffff", -"ffffaaeeagaeeaeeeeeefeefffaaeeaaeebeefaeeaeeeeeeafafffffffffffff", -"ffffaaeeaaaeeeeaaaaaeeaffeeeeff``eeefa``e``a``aaaaf``f`````fffff", -"fffffeeaaaeeaeeaaeeaeeaaeeaeeaa```eea```a``a```aaf```f``fffbfbff", -"fffffeeeeeeaaaeeeeaaaeeeeaaaeee```aee```a``e```ffa```f``fffffbff", -"ffffffaaaaaaaaaaaaaaaaaaaaaaaaa````a````f``f````f````f`````fbffb", -"fffffffaaaaaaaaaaaaaaaaaaaaaaaa``f`a`f``a``f``f`f`f``b``bfbfbffb", -"ffffffffaaaaaaaaaaaaaaaaaaaaaaa``f```f``f``f``f```f``f``fbfbfbfb", -"ffffffffaaafaaaaaaaaaaaaaaaaaaa``ff`ff``f``f``fb`bf``b``bfbfbbbf", -"ffffffffffafaffaaaaaaaaaafffaaa``ff`ff``f``f``bf`fb``b`````bfbfb", -"ffbfffffffffffffafaaaffffffaffaffffffffbffbfbfbfbbfbbfbbbbfbfbff", -"fffffffffffffffffffffffffffffffffffffffbffbbfbfbbbbbbffbfbfbffbf" -};
--- a/etc/vm/mime-simple-xx.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"64 42 8 1", -/* colors */ -"` c #000000000000", -"a c #D0D0A8A88888", -"b c #B8B870705050", -"c c #888868685050", -"d c #999999999999", -"e c #505040403838", -"f c #303028282828", -"g c #787848483838", -/* pixels */ -"b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b`", -"`b`b`b`b`b`b`b`b`a`b`a`b`a`a`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b", -"b`b`b`b`b`b`b`b`b`b`b`a`a`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`b`b`b`b`", -"`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`b`b`b`b`b", -"b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`a`a`a`a`a`b`b`b`b`b`", -"`b`b`b`b`b`b`b`b`b`b`b`b`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`b`b`b`c`b`c`b`b`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`c`b`c`b`c`c`c`c`c`b`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`c`c`c`b`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`c`c`c`c`c`c`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`c`c`c`c`c`c`c`g`c`g`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`c`c`c`c`c`c`c`g`g`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`c`c`c`c`c`c`c`c`c`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`b`b`c`c`c`c`c`g`g`g`c`c`c`c`c`c`b`b`b`b`b`b`b`b`b`b`b`b`b`b", -"b`b`b`b`b`c`c`c`g`g`g`e`e`e`e`g`g`g`g`c`c`b`b`b`b`b`b`b`b`b`b`b`", -"`b`b`b`b`b`c`g`g`e`e`e`e`e`e`g`g`g`g`g`g`g`c`c`b`b`b`b`b`b`b`b`b", -"b`b`b`b`b`c`g`g`e`g`e`e`e`e`e`e`e`g`g`g`g`g`c`c`b`b`b`b`b`b`b`b`", -"`b`b`b`b`c`g`g`e`e`e`e`e`e`e`e`e`e`e`e`g`g`g`g`c`c`b`b`b`b`b`b`b", -"b`b`b`b`c`g`g`g`e`e`e`e`e`e`e`e`e`e`e`e`g`g`g`g`g`c`c`b`b`b`b`b`", -"`b`b`b`c`g`g`g`e`e`e`g`e`e`f`f`e`e`e`e`e`e`g`g`g`g`c`b`b`b`b`b`b", -"b`b`b`b`g`g`g`g`g`g`c`e`e`e`e`f`c`g`e`e`e`e`e`c`g`g`c`b`b`b`b`b`", -"`b`b`b`g`c`c`g`c`b`b`g`e`e`f`f`c`b`e`e`c`e`e`g`g`c`c`c`c`b`b`b`b", -"b`b`b`c`c`g`c`c`b`b`c`g`e`f`f`e`b`b`e`g`b`e`e`e`g`c`c`c`b`b`b`b`", -"`b`b`b`c`c`c`b`b`b`b`c`e`e`f`f`c`b`g`g`b`b`g`e`g`c`c`b`b`b`b`b`b", -"b`b`b`c`c`c`b`b`b`b`b`g`g`g`e`e`c`c`c`c`b`b`g`e`g`g`c`b`b`b`b`b`", -"`b`b`b`c`c`b`b`b`b`b`c`g`c`c`e`e`c`e`c`a`b`b`c`g`g`c`c`b`b`b`b`a", -"b`b`b`b`d`d`d`b`b`b`b`c`c`c`c`c`c`c`c`a`a`d`c`b`c`c`c`b`b`b`b`b`", -"`b`b`b`b`d`c`d`b`a`a`b`c`c`c`b`c`c`c`a`a`d`b`b`b`b`b`b`b`b`a`b`a", -"b`b`b`b`d`c`d`b`d`d`a`b`d`d`c`d`d`c`a`d`d`b`d`d`b`b`b`b`a`a`a`a`", -"`a`b`b`d`c`c`d`d`b`d`a`d`c`d`d`c`d`b`d`d`d`d`b`d`b`b`b`b`a`a`a`b", -"b`b`b`d`b`c`d`d`b`a`d`d`b`c`d`c`c`d`d`a`d`d`b`b`b`b`b`b`a`a`a`a`", -"`b`b`b`d`c`d`b`d`d`d`d`a`a`b`d`b`d`d`a`d`b`d`d`d`b`b`a`a`a`a`a`a", -"a`b`b`d`c`b`d`d`b`b`d`b`a`d`d`a`d`d`a`d`d`d`d`b`b`b`d`d`d`d`a`a`", -"`b`b`d`b`b`d`d`b`d`b`d`b`d`d`b`d`d`d`d`d`d`b`d`b`b`d`a`d`a`a`a`a", -"a`b`b`d`d`d`b`d`d`b`b`d`d`b`d`d`d`b`d`d`b`d`d`d`b`d`d`d`a`a`a`a`", -"`a`b`b`b`b`b`b`b`c`b`b`b`b`b`b`d`d`b`d`d`d`b`d`d`d`d`a`d`d`a`a`a", -"a`a`b`b`b`b`b`b`c`b`b`b`b`b`c`b`d`d`d`d`b`d`d`a`a`a`d`d`a`a`a`a`", -"`a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`d`b`d`a`d`d`a`d`d`d`d`a`d`a`a`a`a", -"a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`b`d`a`a`d`a`d`d`a`d`a`d`d`a`a`a`a`", -"`a`a`a`b`b`b`b`b`b`b`b`b`b`b`b`d`a`d`a`d`d`a`d`a`a`d`a`d`d`a`a`a", -"a`a`a`a`b`b`b`b`b`b`b`b`b`b`a`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`", -"`a`a`a`a`a`b`b`b`b`b`b`b`b`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a`a" -};
--- a/etc/vm/mime-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -#define e_width 64 -#define e_height 42 -static unsigned char e_bits[] = { - 0xc6, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0xbd, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x25, 0x80, 0x47, - 0x00, 0x00, 0x00, 0x00, 0xf3, 0xbe, 0xfd, 0xff, 0x0b, 0x00, 0x00, 0x00, - 0xfe, 0xff, 0xff, 0xff, 0xff, 0x12, 0x40, 0x12, 0xff, 0xff, 0xff, 0xff, - 0xbb, 0xd0, 0x9b, 0x4d, 0xfd, 0xff, 0xff, 0xff, 0x4f, 0x99, 0xb3, 0xc9, - 0xff, 0xff, 0xff, 0xff, 0xff, 0x00, 0x87, 0x00, 0xff, 0xff, 0xff, 0xff, - 0x2f, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0x6d, 0x02, 0x00, 0x00, - 0xff, 0xff, 0xff, 0xff, 0xbb, 0x08, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff, - 0xff, 0x0d, 0x00, 0x80, 0xdf, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x03, 0x00, - 0xc1, 0xff, 0xff, 0xff, 0xff, 0xff, 0x88, 0x40, 0x94, 0xff, 0xff, 0xff, - 0xff, 0xff, 0xaf, 0x08, 0x50, 0xff, 0xff, 0xff, 0xff, 0xff, 0x1f, 0x00, - 0xc0, 0xff, 0xff, 0xff, 0xf5, 0xff, 0x7f, 0x01, 0xd0, 0xff, 0xff, 0x97, - 0xff, 0xff, 0xff, 0x00, 0xd0, 0xff, 0xff, 0x97, 0xff, 0xff, 0xff, 0x03, - 0xe0, 0xff, 0xf2, 0xc3, 0xff, 0xff, 0xff, 0x05, 0xe0, 0x7f, 0xf1, 0xc3, - 0xfd, 0xff, 0xff, 0x01, 0xe0, 0x3f, 0xf0, 0xc3, 0x7f, 0xfe, 0xdf, 0x00, - 0xf0, 0x0f, 0xf0, 0xdf, 0x7f, 0xf8, 0x7f, 0x00, 0xf0, 0x1f, 0xe0, 0xff, - 0x3f, 0xf0, 0x3f, 0x00, 0xa0, 0x00, 0xe0, 0xff, 0x3f, 0xf8, 0x3f, 0x00, - 0xa0, 0x0c, 0xc0, 0xff, 0x1f, 0xf8, 0x01, 0x00, 0x00, 0x0e, 0x00, 0x38, - 0x0c, 0x0c, 0x03, 0x00, 0x10, 0x0e, 0x00, 0x93, 0x01, 0x60, 0x00, 0x00, - 0x00, 0x0e, 0x00, 0xcf, 0x01, 0x30, 0x00, 0x00, 0x00, 0x27, 0x00, 0x40, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x07, 0x00, 0x80, 0xc1, 0x36, 0xd8, 0x07, - 0x80, 0x93, 0x00, 0x80, 0xe3, 0x76, 0xdc, 0x00, 0x00, 0x30, 0x1c, 0x80, - 0xe3, 0x76, 0xdc, 0x00, 0x00, 0xf2, 0x9f, 0x80, 0xf7, 0xf6, 0xde, 0x07, - 0x00, 0x00, 0x59, 0x90, 0xd5, 0xb6, 0xda, 0x00, 0x00, 0x80, 0x28, 0x90, - 0xdd, 0xb6, 0xdb, 0x00, 0x00, 0x00, 0x00, 0x80, 0xc9, 0x36, 0xd9, 0x00, - 0x00, 0x00, 0x00, 0x80, 0xc9, 0x36, 0xd9, 0x07, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - };
--- a/etc/vm/mime-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define ee_width 64 -#define ee_height 42 -static char ee_bits[] = { - 0xc6,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x70,0x25,0x80,0x47,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0x12,0x40,0x12,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfd,0xff,0xff,0xff,0x4f,0x99,0xb3,0xc9,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0x2f,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xbb,0x08,0x00,0x80,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xdf,0xff,0xff,0xff,0xff,0x3f,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x94,0xff,0xff,0xff,0xff,0xff,0xaf, - 0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xf5,0xff, - 0x7f,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0xff,0xff,0x97,0xff, - 0xff,0xff,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x7f,0xf1,0xc3, - 0xfd,0xff,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x0f,0xf0, - 0xdf,0x7f,0xf8,0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x00, - 0xe0,0xff,0x3f,0xf8,0x3f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x0e,0x00,0x38,0x0c,0x0c,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x0e,0x00,0xcf,0x01,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x07,0x00,0x80,0xc1,0x36,0xd8,0x07,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x30,0x1c,0x80,0xe3,0x76,0xdc,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x59,0x90,0xd5,0xb6,0xda,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xc9,0x36,0xd9,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/mona_stamp-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 86 2", -/* colors */ -"`` c #B88D37", -"`a c #200505", -"`b c #F49B12", -"`c c #704B25", -"`d c #B65D0A", -"`e c #4D2713", -"`f c #FFAC19", -"`g c #64300F", -"`h c #321B0C", -"`i c #582E03", -"`j c #C07920", -"`k c #874F09", -"`l c #593514", -"`m c #A07C21", -"`n c #DE7F1C", -"`o c #481103", -"`p c #542D15", -"`q c #58220F", -"`r c #D1AC4A", -"`s c #DFA644", -"`t c #EC9708", -"`u c #501A07", -"`v c #3D1608", -"`w c #90602B", -"`x c #350000", -"`y c #A77B13", -"`z c #A04E13", -"a` c #AC7E39", -"aa c #997319", -"ab c #DA9C1A", -"ac c #8B6F1F", -"ad c #280C0A", -"ae c #98460B", -"af c #AF5707", -"ag c #631C0F", -"ah c #764F35", -"ai c #E6B339", -"aj c #804500", -"ak c #DEAB31", -"al c #802B00", -"am c #C06B21", -"an c #91732E", -"ao c #643C19", -"ap c #A54F03", -"aq c #A78A40", -"ar c #7E5C25", -"as c #793313", -"at c #804F1D", -"au c #AD913F", -"av c #85681B", -"aw c #CB6E00", -"ax c #30120D", -"ay c #B89846", -"az c #8C3904", -"b` c #B96219", -"ba c #FABB1D", -"bb c #A68527", -"bc c #85652B", -"bd c #F2B315", -"be c #FFC125", -"bf c #7D430C", -"bg c #C86B0D", -"bh c #EAAB0D", -"bi c #420907", -"bj c #9D5828", -"bk c #D68000", -"bl c #813A1D", -"bm c #F7A413", -"bn c #9C6E2A", -"bo c #A1833C", -"bp c #75551E", -"bq c #BF6307", -"br c #997B34", -"bs c #D27213", -"bt c #431F0E", -"bu c #712A0D", -"bv c #74411D", -"bw c #CAA239", -"bx c #C0982F", -"by c #A7551A", -"bz c #E98912", -"c` c #E1810A", -"ca c #501321", -"cb c #DB7B04", -"cc c #EF911E", -"cd c #390C00", -/* pixels */ -"acananacbcanbrananacbracbpararacanacananananbrbr", -"avananacacacacanbnbp`pbtaxad`hbtaobcananbrbrbobr", -"anbranaaanananar`vad`x`a`a`a`a`a`aad`eavbrbobobr", -"br`mbbbbbbbrbpadadbibi`aad`a`a`a`a`a`aaxbcbobobo", -"bbbbbbbbaqbnad`a`x`ucd`x`a`a`a`a`aadad`a`hanauaq", -"bbbbaq``aq`v`uae`jc``nbsae`qad`a`a`aad`a`a`eaqaq", -"bb``bxayat`vafab`fbabd`bbzapagbi`a`a`aad`a`aarau", -"````ay``btbubzbdbebababa`bbsajcdad`a`a`a`a`a`hau", -"ayayay`wadaeab`fbdbdbdbd`tawaeagbi`aad`a`a`a`aac", -"bwbx```qbiae`tbmbh`fbh`fc`bs`dae`gbi`a`a`a`a`a`p", -"`s`rbjbi`hbqc`bmbmbh`fbm`bc``nbqaecdadadad`a`a`h", -"aiakbvadbibsbzc``tbm`tbqaf`dbqaebuadad`xadad`aax", -"bw```qbibiasazasafc`azbiblal`obicd`x`aad`xadad`a", -"a`br`uadbibtbl`uasbzagalafca`uas`z`uadadad`aadad", -"bcbo`vbi`hbsbsbyawccalbybs`d`dbkbg`u`xadadadadad", -"`ebv`vad`uc`bhbmc`bzafbsbhbabmcbap`uad`xadadadad", -"`v`e`vbibibgbmbmbzbm`dbs`tbm`tbqbl`xad`xad`x`xbi", -"`v`vbiadadaf`t`tc`bzaf`dcc`tbsae`q`xbiadbiadadad", -"bi`h`x`vbibubsc`bq`z`vbu`tcbafbu`uadadbiadbiadbi", -"`vbibiad`h`uapbqbzas`qaeafafaebu`ubiadadadbiadad", -"`h`hbibibi`haeapbyae`q`uazbqapbu`vadadcdaxadbiax", -"btbtad`hbiadagbqc`afbfbfapbybf`ucdad`xaxbiadadbi", -"`ibtbibiadbiad`qbsbm`n`daeas`u`vcd`xadbiad`hbiad", -"ao`e`hbiaxadadadasc`bk`z`q`u`vbibiaxadadbiadadbi", -"ar`c`v`hbiadbi`aad`u`u`vcdbiadadbibiadbiadadbiad", -"bparbt`x`hbiad`aadadbibiad`xbiadbi`h`xadadadadad", -"bp`c`eaxbiadbi`aadadas`g`v`hbibt`v`q`v`xadadbiad", -"ar`c`lbiaxbiadadad`abu`daj`q`u`ubuaj`qbiadadadad", -"ahaobtax`hbiaxadadad`u`dae`kbfbfaeaebf`vbiad`vcd", -"ax`h`hbiadadbiadbi`q`d`yb``d`d`ybgam`d`gbi`hcd`v" -};
--- a/etc/vm/mona_stamp-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 8 1", -/* colors */ -"` c #F49B12", -"a c #64300F", -"b c #280C0A", -"c c #B89846", -"d c #8C3904", -"e c #FFC125", -"f c #9D5828", -"g c #D68000", -/* pixels */ -"ffffffffffffffffffffffff", -"ffffffffffabbbbbafffffcf", -"ffffffffbbbbbbbbbbaffccf", -"ffcccffbbbbbbbbbbbbbfccc", -"cccccfbbbabbbbbbbbbbbfcc", -"cccccbadggggdabbbbbbbacc", -"ccccfbf``e```dabbbbbbbfc", -"ccccba``eeee`gdbbbbbbbbc", -"cccfbd```````gdabbbbbbbf", -"cccabd``````ggfdabbbbbba", -"ccfbbgg``````gggdbbbbbbb", -"e`abbg`g```gffgdabbbbbbb", -"ccabbadafgdbddbbbbbbbbbb", -"cfabbbdaa`adfaaafabbbbbb", -"fcbbbggfg`dfgffggabbbbbb", -"aabbag``g`fg`e`gdabbbbbb", -"babbbg````fg```gdbbbbbbb", -"bbbbbf``g`ff``gdabbbbbbb", -"bbbbbagggfba`gfaabbbbbbb", -"bbbbbadg`aadffdaabbbbbbb", -"bbbbbbddfdaadgdabbbbbbbb", -"bbbbbbaggfdddfdabbbbbbbb", -"abbbbbbag`gfdaabbbbbbbbb", -"aabbbbbbaggfaabbbbbbbbbb", -"fabbbbbbbaabbbbbbbbbbbbb", -"ffbbbbbbbbbbbbbbbbbbbbbb", -"faabbbbbbbaabbbbbabbbbbb", -"faabbbbbbbafdaaaadabbbbb", -"fabbbbbbbbafdddddddbbbbb", -"bbbbbbbbbaffffffgffabbbb" -};
--- a/etc/vm/next-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xcf,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xff,0xff,0xff,0xff,0xff, - 0x1f,0x00,0x60,0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xbf,0xfe,0xff,0xff,0xff, - 0xff,0x5f,0x00,0x00,0xfd,0xff,0xff,0xff,0xff,0x5f,0x00,0x00,0xf8,0xff,0xff, - 0xff,0xff,0x5f,0x00,0x00,0xfc,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0xfe,0xff, - 0xff,0xff,0xff,0x1f,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xcf,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x73,0xfe,0xff,0xf9,0xff,0xff,0xff,0xff, - 0x63,0xfe,0xff,0xf9,0xff,0xff,0xff,0xff,0x63,0x86,0x99,0xf0,0xff,0xff,0xff, - 0xff,0x53,0x32,0x99,0xf9,0xff,0xff,0xff,0xff,0x53,0x32,0xc3,0xf9,0xff,0xff, - 0xff,0xff,0x33,0x02,0xe7,0xf9,0xff,0xff,0xff,0xff,0x33,0xf2,0xc3,0xf9,0xff, - 0xff,0xff,0xff,0x73,0x32,0x99,0xe9,0xff,0xff,0xff,0xff,0x73,0x86,0x99,0xf3, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/next-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * next_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooWWoXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWWWWWWWWWWWWWWWWoWoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXooooXXooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooooooXXXooXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooXXXXXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/next-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x50,0x00,0x00,0x00,0x00,0x00, - 0xe0,0xff,0x9f,0x00,0x00,0x00,0x00,0x00,0x20,0x00,0x40,0x01,0x00,0x00,0x00, - 0x00,0xa0,0xff,0xff,0x02,0x00,0x00,0x00,0x00,0xa0,0xff,0xff,0x07,0x00,0x00, - 0x00,0x00,0xa0,0xff,0xff,0x03,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x01,0x00, - 0x00,0x00,0x00,0xe0,0xff,0xff,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x30,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x8c,0x01,0x00,0x06,0x00,0x00,0x00,0x00, - 0x9c,0x01,0x00,0x06,0x00,0x00,0x00,0x00,0x9c,0x79,0x66,0x0f,0x00,0x00,0x00, - 0x00,0xac,0xcd,0x66,0x06,0x00,0x00,0x00,0x00,0xac,0xcd,0x3c,0x06,0x00,0x00, - 0x00,0x00,0xcc,0xfd,0x18,0x06,0x00,0x00,0x00,0x00,0xcc,0x0d,0x3c,0x06,0x00, - 0x00,0x00,0x00,0x8c,0xcd,0x66,0x16,0x00,0x00,0x00,0x00,0x8c,0x79,0x66,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/next-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * next_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooWWoXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWWWWWWWWWWWWWWWWoWoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXoooXXooXXooooXXooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXoXooXooXXooXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooooooXXXooXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXoooXooXXXXXXooooXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/next-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x50,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0x00,0x40,0x01,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0xff,0xff,0x07,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x01,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x9c,0x01,0x00,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xac,0xcd,0x66,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xcc,0xfd,0x18,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x8c,0xcd,0x66,0x16,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/previous-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0x06,0x00,0xf8,0xff,0xff,0xff,0xff,0x7f,0xfd,0xff,0xfb,0xff,0xff,0xff, - 0xff,0xbf,0x00,0x00,0xfa,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0xfa,0xff,0xff, - 0xff,0xff,0x3f,0x00,0x00,0xfa,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0xf8,0xff, - 0xff,0xff,0xff,0xff,0x00,0x00,0xf8,0xff,0xff,0xff,0xff,0xff,0xf1,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x3f,0xf0,0xff,0xff,0xf9,0xff,0xff,0xff,0x3f,0xe7, - 0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x87,0x84,0x39,0x19,0x66,0x86,0xff,0x3f, - 0x07,0x30,0x39,0xc9,0x64,0x32,0xff,0x3f,0x10,0x33,0x93,0xc9,0x64,0xe2,0xff, - 0x3f,0x9f,0x03,0x93,0xc9,0x64,0x8e,0xff,0x3f,0x9f,0xf3,0xc7,0xc9,0x64,0x1e, - 0xff,0x3f,0x9f,0x33,0xc7,0xc9,0x24,0x32,0xff,0x3f,0x9f,0x87,0xef,0x19,0x4e, - 0x86,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/previous-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * previous_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoWWooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoWoWWWWWWWWWWWWWWWWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooooooXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooooXooXooooXXooXXXooXooXXooooXXooXXooXXooooXXXXXXXXX", -"XXXXXXooXXXoooooooooXXooXooXXXooXooXooXXooXooXXooXooXXooXXXXXXXX", -"XXXXXXooooooXoooXXooXXooXXooXooXXooXooXXooXooXXooXoooXXXXXXXXXXX", -"XXXXXXooXXXXXooXXXooooooXXooXooXXooXooXXooXooXXooXXXoooXXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXXXXXXoooXXXooXooXXooXooXXooXXXXoooXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXooXXXoooXXXooXooXXooXooXoooXooXXooXXXXXXXX", -"XXXXXXooXXXXXooXXXXooooXXXXXoXXXXooXXooooXXXooXooXXooooXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/previous-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x0c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0a,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xf9,0xff,0x07,0x00,0x00,0x00,0x00,0x80,0x02,0x00,0x04,0x00,0x00,0x00, - 0x00,0x40,0xff,0xff,0x05,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x05,0x00,0x00, - 0x00,0x00,0xc0,0xff,0xff,0x05,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0x07,0x00, - 0x00,0x00,0x00,0x00,0xff,0xff,0x07,0x00,0x00,0x00,0x00,0x00,0x0e,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x0c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xc0,0x0f,0x00,0x00,0x06,0x00,0x00,0x00,0xc0,0x18, - 0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x78,0x7b,0xc6,0xe6,0x99,0x79,0x00,0xc0, - 0xf8,0xcf,0xc6,0x36,0x9b,0xcd,0x00,0xc0,0xef,0xcc,0x6c,0x36,0x9b,0x1d,0x00, - 0xc0,0x60,0xfc,0x6c,0x36,0x9b,0x71,0x00,0xc0,0x60,0x0c,0x38,0x36,0x9b,0xe1, - 0x00,0xc0,0x60,0xcc,0x38,0x36,0xdb,0xcd,0x00,0xc0,0x60,0x78,0x10,0xe6,0xb1, - 0x79,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/previous-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * previous_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"W c white", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoWoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoWWooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoWoWWWWWWWWWWWWWWWWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoWoooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooWoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXooooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooooooooooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooooooXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXooXXXooooXooXooooXXooXXXooXooXXooooXXooXXooXXooooXXXXXXXXX", -"XXXXXXooXXXoooooooooXXooXooXXXooXooXooXXooXooXXooXooXXooXXXXXXXX", -"XXXXXXooooooXoooXXooXXooXXooXooXXooXooXXooXooXXooXoooXXXXXXXXXXX", -"XXXXXXooXXXXXooXXXooooooXXooXooXXooXooXXooXooXXooXXXoooXXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXXXXXXoooXXXooXooXXooXooXXooXXXXoooXXXXXXXX", -"XXXXXXooXXXXXooXXXooXXooXXXoooXXXooXooXXooXooXoooXooXXooXXXXXXXX", -"XXXXXXooXXXXXooXXXXooooXXXXXoXXXXooXXooooXXXooXooXXooooXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/previous-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0a,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x02,0x00,0x04,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0xff,0xff,0x05,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0xff,0xff,0x07,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0e,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x18, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0, - 0xf8,0xcf,0xc6,0x36,0x9b,0xcd,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xc0,0x60,0xfc,0x6c,0x36,0x9b,0x71,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xc0,0x60,0xcc,0x38,0x36,0xdb,0xcd,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/print-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0xfc, - 0xff,0xff,0xff,0xff,0xff,0xff,0xc2,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xfe, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xe2,0x57,0xfe,0xff,0xff,0xff,0xff,0xff, - 0xfe,0xe7,0xfd,0xff,0xff,0xff,0xff,0xff,0x00,0xf0,0xfc,0xff,0xff,0xff,0xff, - 0x7f,0xff,0x77,0xfd,0xff,0xff,0xff,0xff,0xbf,0xff,0xaf,0xfd,0xff,0xff,0xff, - 0xff,0x1f,0x00,0xc0,0xfd,0xff,0xff,0xff,0xff,0xdf,0xff,0xdf,0xfd,0xff,0xff, - 0xff,0xff,0xdf,0xff,0xdf,0xfc,0xff,0xff,0xff,0xff,0xdf,0xff,0x5f,0xfe,0xff, - 0xff,0xff,0xff,0xdf,0xff,0x9f,0xfe,0xff,0xff,0xff,0xff,0x1f,0x00,0x40,0xff, - 0xff,0xff,0xff,0xff,0xbf,0xff,0xaf,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xd7, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xe7,0xff,0xff,0xff,0xff,0xff,0xff,0x00, - 0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x3f,0xff,0xf9,0xff,0xff,0xff,0xff, - 0x73,0xfe,0xff,0xf9,0xff,0xff,0xff,0xff,0x73,0x08,0xc9,0xf0,0xff,0xff,0xff, - 0xff,0x73,0x00,0x91,0xf9,0xff,0xff,0xff,0xff,0x03,0x31,0x99,0xf9,0xff,0xff, - 0xff,0xff,0xf3,0x39,0x99,0xf9,0xff,0xff,0xff,0xff,0xf3,0x39,0x99,0xf9,0xff, - 0xff,0xff,0xff,0xf3,0x39,0x99,0xe9,0xff,0xff,0xff,0xff,0xf3,0x39,0x99,0xf3, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/print-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * print_xpm,[] = { -"64 42 6 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"@ c Gray90", -"# c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOooooOOoXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOoooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOoXo+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOoo++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooo++++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@o+++o+oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@o+o++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@oo#oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo#oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo+++++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++ooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooooXooooXooXooXXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXoooooooooXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXoooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/print-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xff,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x3d,0x05,0x00,0x00,0x00,0x00,0x00,0x00,0x01, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x1d,0xa8,0x01,0x00,0x00,0x00,0x00,0x00, - 0x01,0x18,0x02,0x00,0x00,0x00,0x00,0x00,0xff,0x0f,0x03,0x00,0x00,0x00,0x00, - 0x80,0x00,0x88,0x02,0x00,0x00,0x00,0x00,0x40,0x00,0x50,0x02,0x00,0x00,0x00, - 0x00,0xe0,0xff,0x3f,0x02,0x00,0x00,0x00,0x00,0x20,0x00,0x20,0x02,0x00,0x00, - 0x00,0x00,0x20,0x00,0x20,0x03,0x00,0x00,0x00,0x00,0x20,0x00,0xa0,0x01,0x00, - 0x00,0x00,0x00,0x20,0x00,0x60,0x01,0x00,0x00,0x00,0x00,0xe0,0xff,0xbf,0x00, - 0x00,0x00,0x00,0x00,0x40,0x00,0x50,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x28, - 0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xc0,0x00,0x06,0x00,0x00,0x00,0x00, - 0x8c,0x01,0x00,0x06,0x00,0x00,0x00,0x00,0x8c,0xf7,0x36,0x0f,0x00,0x00,0x00, - 0x00,0x8c,0xff,0x6e,0x06,0x00,0x00,0x00,0x00,0xfc,0xce,0x66,0x06,0x00,0x00, - 0x00,0x00,0x0c,0xc6,0x66,0x06,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x06,0x00, - 0x00,0x00,0x00,0x0c,0xc6,0x66,0x16,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/print-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -/* XPM */ -static char * print_xpm,[] = { -"64 42 6 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"@ c Gray90", -"# c Gray40", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOooooOOoXoXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOoooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOoooOOOOOOoXo+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOoo++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoooooooooooo++++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@o+++o+oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@o+o++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o++ooXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@o+ooXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@oo#oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooooooooooooooo#oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXo+++++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++o#oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXo+++++++++++ooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXooooXooooXooXooXXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXoooooooooXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooooooXoooXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXooXXXXXooXXXooXooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/print-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x01, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x01,0x18,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x80,0x00,0x88,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0xe0,0xff,0x3f,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x20,0x00,0x20,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x20,0x00,0x60,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x40,0x00,0x50,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xc0,0x00,0x06,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x8c,0xf7,0x36,0x0f,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfc,0xce,0x66,0x06,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0c,0xc6,0x66,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/quit-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f, - 0xc0,0xff,0xff,0xf0,0xff,0xff,0xff,0x0f,0x27,0xff,0xff,0xf8,0xfc,0xff,0xff, - 0x87,0x7f,0xff,0xff,0x7c,0xfc,0xff,0xff,0xe7,0xff,0xff,0xff,0x7f,0xfe,0xff, - 0xff,0xe3,0x9f,0xfe,0xff,0x3f,0xfe,0xff,0xff,0xe3,0xbf,0x83,0x61,0x10,0xf5, - 0xff,0xff,0x73,0xbf,0xc7,0xa3,0x38,0xff,0xff,0xff,0xfb,0x3f,0xf7,0xfb,0xbe, - 0xef,0xff,0xff,0xf3,0x3f,0xe7,0xf3,0x3c,0xff,0xff,0xff,0x53,0x10,0xe7,0xf3, - 0x3c,0xff,0xff,0xff,0x77,0x19,0xe7,0xf3,0x34,0xfd,0xff,0xff,0xf7,0x9f,0xe7, - 0xf3,0x3c,0xe7,0xff,0xff,0xa7,0xb2,0xa7,0xf1,0x3c,0xe7,0xff,0xff,0x7f,0xf2, - 0xf7,0x58,0xbc,0xf7,0xff,0xff,0xdf,0xf7,0xff,0xf7,0xfe,0xfd,0xff,0xff,0xff, - 0x2f,0xde,0xff,0xd7,0xf7,0xff,0xff,0xff,0x67,0xfe,0xff,0xff,0xff,0xff,0xff, - 0xff,0xf7,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xdf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/quit-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -/* XPM */ -static char * quit-up_xpm[] = { -"64 42 9 1", -"X c Gray75 s backgroundToolBarColor", -". c Gray60", -"G c Gray60", -"o c Gray60", -"O c Gray60", -"+ c Gray60", -"@ c Gray60", -"# c Gray60", -"$ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXX.GGGGGGoXXXXXXXXXXXXXXXXXX.GGoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXX.GOOoXX.G..oXXXXXXXXXXXXXXXXGOGX+XXX.oXXXXXXXXXXXXXX", -"XXXXXXXXXXX.OOGX@@#$XXo.XXXXXXXXXXXXXXXXGGX##XX.Oo+XXXXXXXXXXXXX", -"XXXXXXXXXXXGO.$@@$XXXXXX$+XXXXXXXXXXXXXXoX#@#XXGO+#XXXXXXXXXXXXX", -"XXXXXXXXXX.OGX#@$XXXX.oX+$XXXXXXXXXXXXXXX+##$X.OG##XXXXXXXXXXXXX", -"XXXXXXXXXXGO.$@#XXXXXo.XX$oGGGoXX.GGGoX.GGGoX.OO.+XoXXXXXXXXXXXX", -"XXXXXXXXXXGGX#@$XXXXXX.oX#$GGGX+XoGGGX+oGGGX+oG.X$$++XXXXXXXXXXX", -"XXXXXXXXXXGGX##XXXXXXXGGX##.oX##XX.oX##X.oX##X.oX#@#$XXXXXXXXXXX", -"XXXXXXXXXXGGX##XXXXXXXGGX##GGX##XXGGX##XGGX##XGGX##XXXXXXXXXXXXX", -"XXXXXXXXXXGGX+$.GGGoX.OGX##GGX##XXGGX##XGGX##XGGX##XXXXXXXXXXXXX", -"XXXXXXXXXXo.XXXoo.G.XGO.$@#GGX##XXGGX##XGGX##XGGX##XXXXXXXXXXXXX", -"XXXXXXXXXXX.oX$#$$XXXGGX#@$GGX##XXGGX##XGGX##XGGX##.oXXXXXXXXXXX", -"XXXXXXXXXXXo.X+++X.oXo.$@#XGGX+$X.OGX##XGGX##XGGX##Go+XXXXXXXXXX", -"XXXXXXXXXXXXX$+o..OGX$#@@$Xo.XXX..G.X+$.OGX+$Xo.X+X.+#XXXXXXXXXX", -"XXXXXXXXXXXXX+$$#$XoX#@#$XXXX$##$++$###Xo+###+XX$#$+$$XXXXXXXXXX", -"XXXXXXXXXXXXXXX+###Xo+$.oXXXX+####$+###$+####$XX+###$XXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXGGXXGo+XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXo.XX+$#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX$#@@$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX+##$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/quit-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x21,0x00,0x00,0x10,0x00,0x00,0x00, - 0x00,0x4f,0x00,0x00,0x18,0x04,0x00,0x00,0xe0,0x03,0x03,0x00,0x1d,0x06,0x00, - 0x00,0xc0,0x01,0x02,0x00,0x1e,0x06,0x00,0x00,0xe0,0x20,0x02,0x20,0x00,0x02, - 0x00,0x00,0x60,0x80,0x86,0x82,0xb0,0x1c,0x00,0x00,0x68,0x00,0xd6,0x68,0x1a, - 0x0e,0x00,0x00,0x60,0x00,0xc6,0x60,0x18,0x06,0x00,0x00,0x40,0x00,0xc6,0x60, - 0x18,0x06,0x00,0x00,0x04,0x09,0xc7,0x60,0x18,0x06,0x00,0x00,0xd0,0x03,0xc7, - 0x60,0x18,0x06,0x00,0x00,0x80,0xa0,0x83,0x60,0x18,0x26,0x00,0x00,0x60,0xe2, - 0x13,0x48,0x90,0x30,0x00,0x00,0xc0,0xe3,0xe1,0x77,0x3e,0x3f,0x00,0x00,0x80, - 0x27,0xc0,0xff,0x1f,0x0e,0x00,0x00,0x00,0x00,0x02,0x00,0x00,0x00,0x00,0x00, - 0x00,0x90,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x03,0x00,0x00,0x00,0x00, - 0x00,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/quit-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -/* XPM */ -static char * quit-up_xpm[] = { -"64 42 10 1", -"X c Gray75 s backgroundToolBarColor", -"x c Gray75", -". c #BEBEBEBEBEBE", -"G c #DEDEDEDEDEDE", -"o c #9E9E9E9E9E9E", -"O c #FEFEFEFEFEFE", -"+ c #606060606060", -"@ c #000000000000", -"# c #202020202020", -"$ c #404040404040", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXX.GGGGGGoXXXXXXXXXXXXXXXXXX.GGoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXX.GOOoxx.G..oXXXXXXXXXXXXXXXXGOGx+XXX.oXXXXXXXXXXXXXX", -"XXXXXXXXXXX.OOGx@@#$xxo.XXXXXXXXXXXXXXXXGGx##XX.Oo+XXXXXXXXXXXXX", -"XXXXXXXXXXXGO.$@@$XXXxxx$+XXXXXXXXXXXXXXox#@#XXGO+#XXXXXXXXXXXXX", -"XXXXXXXXXX.OGx#@$XXXX.ox+$XXXXXXXXXXXXXXX+##$X.OG##XXXXXXXXXXXXX", -"XXXXXXXXXXGO.$@#XXXXXo.xx$oGGGoXX.GGGoX.GGGoX.OO.+xoXXXXXXXXXXXX", -"XXXXXXXXXXGGx#@$XXXXXX.ox#$GGGx+XoGGGX+oGGGX+oG.x$$++XXXXXXXXXXX", -"XXXXXXXXXXGGx##XXXXXXXGGx##.ox##XX.ox##X.ox##X.ox#@#$XXXXXXXXXXX", -"XXXXXXXXXXGGx##XXXXXXXGGx##GGx##XXGGx##XGGx##XGGx##XXXXXXXXXXXXX", -"XXXXXXXXXXGGx+$.GGGox.OGx##GGx##XXGGx##XGGx##XGGx##XXXXXXXXXXXXX", -"XXXXXXXXXXo.xxxoo.G.xGO.$@#GGx##XXGGx##XGGx##XGGx##XXXXXXXXXXXXX", -"XXXXXXXXXXX.ox$#$$xxxGGx#@$GGx##XXGGx##XGGx##XGGx##.oXXXXXXXXXXX", -"XXXXXXXXXXXo.x+++X.oxo.$@#XGGx+$X.OGx##XGGx##XGGx##Go+XXXXXXXXXX", -"XXXXXXXXXXXXX$+o..OGx$#@@$Xo.xxx..G.x+$.OGx+$Xo.x+x.+#XXXXXXXXXX", -"XXXXXXXXXXXXX+$$#$xox#@#$XXXX$##$++$###Xo+###+XX$#$+$$XXXXXXXXXX", -"XXXXXXXXXXXXXXX+###xo+$.oXXXX+####$+###$+####$XX+###$XXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXGGxxGo+XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXo.xx+$#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX$#@@$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXX+##$XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/quit-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x00,0x10,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x03,0x01,0x00,0x1c,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x20,0x02,0x20,0x00,0x02, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x00,0xd6,0x68,0x9a, - 0x1e,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x00,0xc6,0x60, - 0x18,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x03,0xc7, - 0x60,0x18,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x20,0xe0, - 0x03,0x60,0x18,0x32,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, - 0x57,0xe1,0xff,0x3e,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xe0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/recover-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xfa, - 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x6f, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfd,0xff,0xff,0xff,0xff,0xff,0xff, - 0xef,0xfe,0xff,0xff,0xff,0xff,0xff,0x7f,0xdf,0x75,0xff,0xff,0xff,0xff,0xff, - 0xdf,0xb5,0xae,0xfb,0xff,0xff,0xff,0xff,0x5f,0xef,0x7d,0xfd,0xff,0xff,0xff, - 0xff,0xef,0x5a,0xab,0xff,0xff,0xff,0xff,0xff,0xbf,0xf7,0xde,0xfa,0xff,0xff, - 0xff,0xff,0xdf,0x5a,0x6b,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xff,0xaf,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfb,0xff, - 0xff,0xff,0xff,0xff,0xff,0xef,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfd, - 0xff,0xff,0xff,0xff,0xff,0xff,0xdf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xbf, - 0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xce, - 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xce,0x70,0x38,0xcc,0x19,0x26,0xff,0x7f, - 0x4e,0x26,0x93,0xc9,0xc9,0x04,0xff,0x7f,0x60,0x26,0x9f,0x99,0xcc,0xc4,0xff, - 0x7f,0x66,0x20,0x9f,0x99,0x0c,0xe4,0xff,0x7f,0x4e,0x3e,0x9f,0x39,0xce,0xe7, - 0xff,0x7f,0x4e,0x26,0x93,0x39,0xce,0xe4,0xff,0x7f,0xce,0x70,0x38,0x7c,0x1f, - 0xe6,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/recover-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * recover-up_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"# c Gray60", -"o c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXooXXXooXXooooXXooXooXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXooXXXooXooXXooXoooooXXXXXXXX", -"XXXXXXXooooooXXooXXooXooXXXXXooXXooXXooXooXXooXXooXoooXXXXXXXXXX", -"XXXXXXXooXXooXXooooooXooXXXXXooXXooXXooXooXXooooooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXXXXooXXXXXooXXooXXXoooXXXooXXXXXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXXXoooXXXooXXooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXXXXoXXXXXooooXXooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/recover-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xb0,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x06, - 0x00,0x00,0x00,0x00,0x00,0x00,0x50,0x03,0x00,0x00,0x00,0x00,0x00,0x00,0xf0, - 0x06,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x03,0x00,0x00,0x00,0x00,0x00,0x00, - 0xf0,0x06,0x00,0x00,0x00,0x00,0x00,0x70,0xab,0x7d,0x07,0x00,0x00,0x00,0x00, - 0xd0,0x7e,0xab,0x03,0x00,0x00,0x00,0x00,0xd0,0xd5,0xdd,0x06,0x00,0x00,0x00, - 0x00,0x60,0x7b,0xb7,0x05,0x00,0x00,0x00,0x00,0xb0,0xad,0xdd,0x06,0x00,0x00, - 0x00,0x00,0x60,0xef,0xb6,0x03,0x00,0x00,0x00,0x00,0x00,0xb0,0x03,0x00,0x00, - 0x00,0x00,0x00,0x00,0xd0,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0xd0,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0xb0, - 0x03,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x1f,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x31, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x31,0x8f,0xc7,0x33,0xe6,0xd9,0x00,0x80, - 0xb1,0xd9,0x6c,0x36,0x36,0xfb,0x00,0x80,0x9f,0xd9,0x60,0x66,0x33,0x3b,0x00, - 0x80,0x99,0xdf,0x60,0x66,0xf3,0x1b,0x00,0x80,0xb1,0xc1,0x60,0xc6,0x31,0x18, - 0x00,0x80,0xb1,0xd9,0x6c,0xc6,0x31,0x1b,0x00,0x80,0x31,0x8f,0xc7,0x83,0xe0, - 0x19,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/recover-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -/* XPM */ -static char * recover-up_xpm[] = { -"64 42 3 1", -"X c Gray75 s backgroundToolBarColor", -"# c red", -"o c black", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXX#######################XXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXX#######XXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXooXXXooXXooooXXooXooXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXooXXXooXooXXooXoooooXXXXXXXX", -"XXXXXXXooooooXXooXXooXooXXXXXooXXooXXooXooXXooXXooXoooXXXXXXXXXX", -"XXXXXXXooXXooXXooooooXooXXXXXooXXooXXooXooXXooooooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXXXXooXXXXXooXXooXXXoooXXXooXXXXXooXXXXXXXXXXX", -"XXXXXXXooXXXooXooXXooXooXXooXooXXooXXXoooXXXooXXooXooXXXXXXXXXXX", -"XXXXXXXooXXXooXXooooXXXooooXXXooooXXXXXoXXXXXooooXXooXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/recover-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0xf0,0x07,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0x07,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x70,0xd7,0xba,0x07,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0xbe,0xb7,0x02,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x6a,0xed,0x07,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xb0,0x03,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xb0,0x03, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xd0, - 0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x31, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x80, - 0xb1,0xd9,0x6c,0x36,0x36,0xfb,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x80,0x99,0xdf,0x60,0x66,0xf3,0x1b,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x80,0xb1,0xd9,0x6c,0xc6,0x31,0x1b,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/reply-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0x01,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xe7,0xff, - 0xff,0xff,0xff,0xff,0xff,0xfd,0xd7,0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0x87, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0x0f,0x00, - 0x00,0xf0,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x2f, - 0xff,0x7f,0xf4,0xff,0xff,0xff,0xff,0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff, - 0xef,0xff,0x7f,0xf5,0xff,0xff,0xff,0xff,0xef,0x03,0x78,0xf4,0xff,0xff,0xff, - 0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x03,0xfe,0xf7,0xff,0xff, - 0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0x83,0xff,0xf7,0xff, - 0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7, - 0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xf7,0xff,0xff,0xff,0xff,0x0f,0x00,0x00, - 0xf0,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0xff,0x3f,0xff,0xff,0xff,0xff,0xff, - 0x9c,0xff,0x3f,0xff,0xff,0xff,0xff,0xff,0x9c,0x61,0x32,0x39,0xff,0xff,0xff, - 0xff,0x9c,0x4c,0x24,0x39,0xff,0xff,0xff,0xff,0xc0,0x4c,0x26,0x93,0xff,0xff, - 0xff,0xff,0xcc,0x40,0x26,0x93,0xff,0xff,0xff,0xff,0x9c,0x7c,0x26,0xc7,0xff, - 0xff,0xff,0xff,0x9c,0x4c,0x24,0xc7,0xff,0xff,0xff,0xff,0x9c,0x61,0x32,0xcf, - 0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xef,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe, - 0xe7,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xf3,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/reply-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * reply_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXooXXooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXooXXooooooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXXXXooXXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXXXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/reply-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x18,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x78, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0xf0,0xff, - 0xff,0x0f,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xd0, - 0x00,0x80,0x0b,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x3f,0x00,0xc0,0x00,0x00,0x00,0x00,0x00, - 0x63,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x63,0x9e,0xcd,0xc6,0x00,0x00,0x00, - 0x00,0x63,0xb3,0xdb,0xc6,0x00,0x00,0x00,0x00,0x3f,0xb3,0xd9,0x6c,0x00,0x00, - 0x00,0x00,0x33,0xbf,0xd9,0x6c,0x00,0x00,0x00,0x00,0x63,0x83,0xd9,0x38,0x00, - 0x00,0x00,0x00,0x63,0xb3,0xdb,0x38,0x00,0x00,0x00,0x00,0x63,0x9e,0xcd,0x30, - 0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x10,0x00,0x00,0x00,0x00,0x00,0x80,0x01, - 0x18,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x0c,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/reply-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -/* XPM */ -static char * reply_xpm[] = { -"64 42 5 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c Gray90", -"+ c Gray60", -"@ c white", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooooooooooXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOo+oXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@oo@@@@@@@@@@@@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@o+o@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooooo@@@@ooo@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooooo@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@ooooo@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXo@@@@@@@@@@@@@@@@@@@@@@oXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooooooooooooooooooooooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXooXXXooXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooooooXXooXXooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXooXXooooooXooXXooXooXXooXooXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXXXXooXXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXooXXooXoooXooXooXXXoooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXooXXXooXXooooXXooXooXXooXXXXooXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXXooXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/reply-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xfe,0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x02,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x80,0x0a,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x87,0x0b,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0xfc,0x01,0x08,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x7c,0x00,0x08,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x10,0x00,0x00,0x08, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0xff,0xff, - 0x0f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x63,0x00,0xc0,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x63,0xb3,0xdb,0xc6,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x33,0xbf,0xd9,0x6c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x63,0xb3,0xdb,0x38,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x10,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x80,0x01,0x0c,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/stuffed_box-colorful.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,291 +0,0 @@ -/* XPM */ -static char *stuffed_box[] = { -/* width height num_colors chars_per_pixel */ -" 24 30 254 2", -/* colors */ -".. c #000000", -".# c #b1b1b1", -".a c #242120", -".b c #505955", -".c c #491909", -".d c #3e1608", -".e c #a9a9a9 s background", -".f c #eeeef0", -".g c #a7a7a7", -".h c #a3411c", -".i c #663622", -".j c #5c210b", -".k c #a83e17", -".l c #2f2824", -".m c #9f7b71", -".n c #d38141", -".o c #a3a3a3", -".p c #d27f40", -".q c #a1a1a1", -".r c #511c0a", -".s c #ccc1be", -".t c #9d9d9d", -".u c #cd773b", -".v c #903a13", -".w c #592a15", -".x c #1e1d1d", -".y c #cdcccc", -".z c #959595", -".A c #939393", -".B c #e8ac69", -".C c #919191", -".D c #8f8f8f", -".E c #8d8d8d", -".F c #240e05", -".G c #652810", -".H c #a55f3b", -".I c #878787", -".J c #f2f1f0", -".K c #a0491f", -".L c #8a4a27", -".M c #0c0401", -".N c #efbf80", -".O c #7d7d7d", -".P c #3d3531", -".Q c #2a0b04", -".R c #7b7b7b", -".S c #81401e", -".T c #797979", -".U c #adacac", -".V c #904d26", -".W c #eab071", -".X c #11132a", -".Y c #737373", -".Z c #999695", -".0 c #ab4119", -".1 c #d16d31", -".2 c #b3b8b5", -".3 c #030305", -".4 c #212129", -".5 c #b74c1e", -".6 c #ca7b41", -".7 c #696969", -".8 c #404644", -".9 c #2d1e17", -"#. c #656565", -"## c #8b3417", -"#a c #dfae7d", -"#b c #f5eeef", -"#c c #5e260f", -"#d c #d58445", -"#e c #5f5f5f", -"#f c #763416", -"#g c #5a200b", -"#h c #301006", -"#i c #7a2f10", -"#j c #edb87a", -"#k c #4e1b09", -"#l c #da8e4d", -"#m c #8b8a8a", -"#n c #d97435", -"#o c #d58648", -"#p c #32160b", -"#q c #fefefe", -"#r c #e8ad6b", -"#s c #020000", -"#t c #474747", -"#u c #bfbfc0", -"#v c #4f505c", -"#w c #6b280e", -"#x c #fcdf9c", -"#y c #e39e5c", -"#z c #160803", -"#A c #3f3f3f", -"#B c #61230e", -"#C c #140601", -"#D c #3c0e04", -"#E c #7e3010", -"#F c #eaeaea", -"#G c #a4a3a2", -"#H c #bb5121", -"#I c #cd642c", -"#J c #b94f1f", -"#K c #cb622a", -"#L c #333333", -"#M c #d88747", -"#N c #110601", -"#O c #d58344", -"#P c #070301", -"#Q c #511e0b", -"#R c #bf9f84", -"#S c #d2d2d2", -"#T c #6f290e", -"#U c #eed6b2", -"#V c #c55c27", -"#W c #441708", -"#X c #bab8b7", -"#Y c #e9ae6b", -"#Z c #823110", -"#0 c #171717", -"#1 c #eccba6", -"#2 c #51200e", -"#3 c #a33c16", -"#4 c #983915", -"#5 c #7f6352", -"#6 c #eab26f", -"#7 c #361207", -"#8 c #bd5222", -"#9 c #d0672e", -"a. c #a35326", -"a# c #da8f52", -"aa c #aaaaaa", -"ab c #a8a8a8", -"ac c #a6a6a6", -"ad c #a4a4a4", -"ae c #d38041", -"af c #303246", -"ag c #a2a2a2", -"ah c #b85020", -"ai c #d17e3f", -"aj c #521d0b", -"ak c #a0a0a0", -"al c #e6a764", -"am c #d07c3e", -"an c #cf7a3d", -"ao c #9e9e9e", -"ap c #9c9c9c", -"aq c #c75d28", -"ar c #1b0a03", -"as c #d88a49", -"at c #433f3e", -"au c #989898", -"av c #65250d", -"aw c #969696", -"ax c #0a0806", -"ay c #949494", -"az c #581e0a", -"aA c #c6c5c5", -"aB c #909090", -"aC c #d67d3d", -"aD c #9ea0a1", -"aE c #121211", -"aF c #db7838", -"aG c #414249", -"aH c #8a8a8a", -"aI c #d88c4c", -"aJ c #b0461b", -"aK c #28322d", -"aL c #4f5150", -"aM c #833613", -"aN c #848484", -"aO c #361306", -"aP c #808080", -"aQ c #551e0a", -"aR c #762d10", -"aS c #837b79", -"aT c #17110f", -"aU c #cfcfd4", -"aV c #943413", -"aW c #767676", -"aX c #98534f", -"aY c #ad461b", -"aZ c #727272", -"a0 c #1c1917", -"a1 c #c06a34", -"a2 c #6c6c6c", -"a3 c #722b0f", -"a4 c #c96029", -"a5 c #9a9999", -"a6 c #60616a", -"a7 c #67240e", -"a8 c #764a37", -"a9 c #3b1407", -"b. c #504e4d", -"b# c #100601", -"ba c #e7aa67", -"bb c #f4e0b9", -"bc c #d4d6d5", -"bd c #423028", -"be c #545454", -"bf c #d66f32", -"bg c #c05623", -"bh c #d36b2f", -"bi c #d2692e", -"bj c #4a4a4a", -"bk c #762e0f", -"bl c #461d0e", -"bm c #56150a", -"bn c #6c290f", -"bo c #ecb472", -"bp c #c58859", -"bq c #404040", -"br c #5f220c", -"bs c #3a3a3a", -"bt c #cd652c", -"bu c #363636", -"bv c #e7e7e7", -"bw c #732c0f", -"bx c #fee4a1", -"by c #68270e", -"bz c #dfdfdf", -"bA c #7a3819", -"bB c #2c2c2c", -"bC c #dbdbdb", -"bD c #f0ece9", -"bE c #d48243", -"bF c #282828", -"bG c #4e4b4a", -"bH c #5c5b5b", -"bI c #988f8c", -"bJ c #de7c39", -"bK c #b54c1e", -"bL c #b44a1d", -"bM c #b3481c", -"bN c #342f2d", -"bO c #220701", -"bP c #c45b26", -"bQ c #190802", -"bR c #c35925", -"bS c #d56c30", -"bT c #3f3d3b", -"bU c #e0803e", -"bV c #fbfafa", -"bW c #dd9252", -"bX c #afb0b6", -"bY c #772b0f", -"bZ c #f7f6f6", -"b0 c #220b04", -"b1 c #0e0e0e", -"b2 c #cb763d", -"b3 c #dd9b5f", -"b4 c #ad4219", -"b5 c #fadb99", -"b6 c #67756f", -"b7 c #e9e8e8", -/* pixels */ -".e.e.e.e.e.e.e.e.e.e.e.e.o.e.e.e.e.e.e.e.e.e.e.e", -".e.e.e.e.e.e.e.e.e.e.e.o.2.Z.m.o.e.e.e.e.o.o.e.e", -".e.e.e.e.e.e.e.e.e.e.obcbZ.6bp.H.m.o.e.e.e.s.o.o", -".e.e.e.e.e.e.e.e.e.e.fbZbZbbbc.Nbp.H.map.2.mbZbz", -".e.e.e.e.e.e.e.e.e.e#RbIbc#b.qbp.W.Bbpa.a8.YaA.7", -".e.e.e.e.e.e.e.ebIa8.y.sbD#S.Ibe.L.B#rbob3.Lbl.o", -".e.e.e.e.e.e.o#5a1#abe.y.o.qb.#e.q#U.Nbobob5.w.e", -".e.e.e.e.ebI.H.n#RbI.q#eaPbdb..o.I#X.N.W.N#lbl.e", -".e.e.e.oaXa1.nai.Vblb.#..9.x.Rbc#S.i#a.N#daF.d.e", -".e.e.e.ia1bU.uai.n.6bdbs.3#z.dbI#jal.N#n#n.SaLaA", -".e.e.e#W#c.Hai.u.6a#.m.3a8aI.H.Hal.N#n.1.Sat#XbI", -".e.e.e#W.v.j.V.uai.n#l.6bpas#lal#1#n#I.S.vbnaTaN", -".e.e.e.Q.v.v#w.Ga1.u#d#das#lbW.N#I#I.S#Z.1#Ibl.e", -".e.e.e.9bO#T.v#Z.j.H.u.n.na#.N.u#V.v.F#Ra#.1.9.U", -".e.e.e.P#haE.G.v.v.jbA.ua#.N.ubg.haTb.#b#obfbl.e", -".e.e.A.o#SbHbF#p#T.v#E.Gbpa4#HbnaTaLbIbp#Va.bT.U", -".e.e.e.IbcaubH#7#7.j.v#i.v.5#E##bY.v.h#V#Hbdak.e", -".e.e.eb.a8#S.9.G#ibl.d#T##.vaY#H.5.5bgbgblaN.q.e", -".e.e.eb..Ga8.i#ZbYbY.j.Q.jaY.5.5#H#H.m.w.7.o.e.e", -".e.e.ebGbYbn#w#i#T#T#T.j#ZaJ.5.5.5.S.y#u.A.o.e.e", -".e.e.oaL.d#Tbn#T#T#T#w.G#ZaY.5.h.i.Dbz.fbV.y#u.o", -".e.eapbHaxbObTa2#T#w.G.j#iaYaYb..2aua6.Obzbz#q.2", -".e.e.o.RaL.a.q.Ube#w.j.jaR.k#4#h#A.o.Dbzau#qbcap", -".e.eapaN#Aa2.ybv#Xa8#g#g#T.k#Z.PbG#L.o.2.2bZ.A.o", -".o.I.Aak.fbZbXaZbz#.#gbl#T##bd.IaNbH#L.Obz.2.z.e", -".Aa2.Rbz.eaAaDaNaU.lax.d.j.9aP.q.e.AbHbsa2aN.o.e", -"ap.Y#AaA#S.o.DbZ.obebBb1aTaS.o.e.e.o.Ia2.Yap.e.e", -".o.AbHbeaAaU.faA.I.I.7be.Rak.e.e.e.e.eap.o.e.e.e", -".e.o.Ibe#A#u.e.R.o.oap.A.o.e.e.e.e.e.e.e.e.e.e.e", -".e.e.oaNbHbe.R.o.e.e.e.e.e.e.e.e.e.e.e.e.e.e.e.e" -};
--- a/etc/vm/stuffed_box-simple.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -"24 30 9 1", -/* colors */ -"` c #A9A9A9 s background", -"- c #A9A9A9", -"a c #A83E17", -"b c #030305", -"c c #DA8E4D", -"d c #FEFEFE", -"e c #60616A", -"f c #423028", -"g c #FADB99", -/* pixels */ -"````````````````````````", -"``````````````e`````````", -"```````````ddccae```````", -"``````````dddgdgcae``edd", -"`````````---dd-ccccafe`e", -"`````````f--dg-eaccccaf`", -"```````ecce---ee-ggccgf`", -"``````ac---eefe---gcgcf`", -"````acccafeeffedgfcgccf`", -"```fccccccffbbf-gcgccae`", -"```ffaccccebfcaacgccaf-`", -"```fafacccccccccgccaafbe", -"```baaffcccccccgccaaccf`", -"```fbfaafaccccgcaab-ccf`", -"```fbbfaafaccgcaabedccf`", -"```-gefffaafcaafbe-caaf`", -"```-d-efffaaaaaaaaaaaf``", -"```efgffafffaaaaaaaafe``", -"```efffaaafbfaaaaaefe```", -"```eaffaffffaaaaaa--````", -"```effffffffaaaaf-ddd```", -"```ebbfeffffaaae--eeddd`", -"```eef--efffaaabf--d-dd`", -"```efe-d-ffffaafef---d``", -"```-dd-edefffaf`eefed```", -"`eed---e-fbfffe```efee``", -"`ef-g--d-efbbe`````ee```", -"``ee--d---eee```````````", -"```ef--e````````````````", -"```eeee`````````````````" -};
--- a/etc/vm/undelete-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0xf8, - 0xf5,0xff,0xff,0xff,0xff,0xff,0xfd,0xbb,0xfa,0xff,0xff,0xff,0xff,0x5f,0xf5, - 0x5b,0xfd,0xff,0xff,0xff,0xff,0xaf,0xaa,0x8b,0xff,0xff,0xff,0xff,0xff,0xff, - 0x55,0x97,0xff,0xff,0xff,0xff,0xff,0xff,0xbd,0xba,0xff,0xff,0xff,0xff,0xff, - 0xff,0x7d,0xbd,0xff,0xff,0xff,0xff,0xff,0xff,0xbd,0xaa,0xff,0xff,0xff,0xff, - 0xff,0xff,0x5d,0x97,0xff,0xff,0xff,0xff,0xff,0xff,0xad,0xaf,0xfe,0xff,0xff, - 0xff,0xff,0xff,0xd5,0x3f,0xfd,0xff,0xff,0xff,0xff,0xff,0xe9,0xbf,0xfa,0xff, - 0xff,0xff,0xff,0xff,0xf5,0xbf,0xf5,0xff,0xff,0xff,0xff,0xbf,0xfc,0xbf,0xeb, - 0xff,0xff,0xff,0xff,0x5f,0xfd,0xbf,0xd7,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf, - 0xff,0xff,0xff,0xff,0xff,0xff,0xfd,0xbf,0xff,0xff,0xff,0xff,0xff,0xff,0x01, - 0x80,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0x9f,0xf3,0xff,0xfc,0xf3,0x9f,0xff,0xff,0x9f,0xf3, - 0xff,0xfc,0xf3,0x9f,0xff,0xff,0x9f,0x93,0x9c,0x0c,0x33,0x0c,0xc3,0xff,0x9f, - 0x13,0x49,0x64,0x92,0x99,0x99,0xff,0x9f,0x93,0xc9,0x64,0x92,0x99,0x99,0xff, - 0x9f,0x93,0xc9,0x04,0x12,0x98,0x81,0xff,0x9f,0x93,0xc9,0xe4,0x93,0x9f,0xf9, - 0xff,0x3f,0x99,0x49,0x64,0x92,0x99,0x98,0xff,0x3f,0x98,0x99,0x0c,0x33,0x3c, - 0xc3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/undelete-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * undelete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOoOXXoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOoOOOOOOo+OoXoXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoXoXoXoOoOoOOOo+oooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOoOoOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOoOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoOoOOOOOoOoXoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOOOOOOOOooXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooOoOOOOOOOOOoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOOOOOOOOOOoXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoXooOOOOOOOOOOOOoXXXoXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOOOOOOOOOOOOoXXXXoXoXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXooXooXXXooXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXX", -"XXXXXooXXXooXoooXooXooXoooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooooooXooXooooooXXooXXooooooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXX", -"XXXXXXooXooXXooXXooXooXoooXooXXooXooXooXXooXXooXoooXXooXXXXXXXXX", -"XXXXXXoooooXXooXXooXXooXooXXooooXXooXXooooXXXXooXXooooXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/undelete-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0a,0x00,0x00,0x00,0x00,0x00,0x02,0x44,0x05,0x00,0x00,0x00,0x00,0xa0,0x0a, - 0xa4,0x02,0x00,0x00,0x00,0x00,0x50,0x55,0x74,0x00,0x00,0x00,0x00,0x00,0x00, - 0xaa,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x42,0x45,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x42,0x00,0x00,0x00,0x00,0x00,0x00,0x42,0x55,0x00,0x00,0x00,0x00, - 0x00,0x00,0xa2,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x52,0x50,0x01,0x00,0x00, - 0x00,0x00,0x00,0x2a,0xc0,0x02,0x00,0x00,0x00,0x00,0x00,0x16,0x40,0x05,0x00, - 0x00,0x00,0x00,0x00,0x0a,0x40,0x0a,0x00,0x00,0x00,0x00,0x40,0x03,0x40,0x14, - 0x00,0x00,0x00,0x00,0xa0,0x02,0x40,0x28,0x00,0x00,0x00,0x00,0x00,0x02,0x40, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0xfe, - 0x7f,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x60,0x0c,0x00,0x03,0x0c,0x60,0x00,0x00,0x60,0x0c, - 0x00,0x03,0x0c,0x60,0x00,0x00,0x60,0x6c,0x63,0xf3,0xcc,0xf3,0x3c,0x00,0x60, - 0xec,0xb6,0x9b,0x6d,0x66,0x66,0x00,0x60,0x6c,0x36,0x9b,0x6d,0x66,0x66,0x00, - 0x60,0x6c,0x36,0xfb,0xed,0x67,0x7e,0x00,0x60,0x6c,0x36,0x1b,0x6c,0x60,0x06, - 0x00,0xc0,0x66,0xb6,0x9b,0x6d,0x66,0x67,0x00,0xc0,0x67,0x66,0xf3,0xcc,0xc3, - 0x3c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/undelete-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * undelete_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooXXXXXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOoOXXoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOoOOOOOOo+OoXoXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXoXoXoXoOoOoOOOo+oooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOoOoOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOoOoOoOoOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOoOoOOOoOooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOoOoOOOOOoOoXoXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOoOOOOOOOOooXoXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooOoOOOOOOOOOoXoXoXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOoOOOOOOOOOOoXXoXoXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoXooOOOOOOOOOOOOoXXXoXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXoXoOOOOOOOOOOOOoXXXXoXoXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOOOOoXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXooooooooooooooXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXXXXXXXXXXXXooXXXXXXXXooXXXXXXXXXooXXXXXXXXXXXXXXXXX", -"XXXXXooXXXooXooXooXXXooXooXXooooXXooXXooooXXooooXXooooXXXXXXXXXX", -"XXXXXooXXXooXoooXooXooXoooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXooXooXooXXooXXooXXooXXooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooooooXooXooooooXXooXXooooooXXXXXXXXX", -"XXXXXooXXXooXooXXooXooXXooXooXXXXXooXooXXXXXXooXXooXXXXXXXXXXXXX", -"XXXXXXooXooXXooXXooXooXoooXooXXooXooXooXXooXXooXoooXXooXXXXXXXXX", -"XXXXXXoooooXXooXXooXXooXooXXooooXXooXXooooXXXXooXXooooXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/undelete-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xfe,0x07, - 0x0a,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xa0,0x0a, - 0xa4,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0xaa,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x82,0x42,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0xa2,0x68,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x2a,0xc0,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x0a,0x40,0x0a,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0xa0,0x02,0x40,0x28,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x02,0x40,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x60,0x0c,0x00,0x03,0x0c,0x60,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x6c,0x63,0xf3,0xcc,0xf3,0x3c,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x6c,0x36,0x9b,0x6d,0x66,0x66,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60,0x6c,0x36,0x1b,0x6c,0x60,0x06, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x67,0x66,0xf3,0xcc,0xc3, - 0x3c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/visit-dn.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfb, - 0xf3,0xf9,0xff,0xff,0xff,0xff,0x7f,0x74,0x34,0xfa,0xff,0xff,0xff,0xff,0x9f, - 0x87,0xc3,0xfb,0xff,0xff,0xff,0xff,0xdf,0x7f,0xfc,0xfd,0xff,0xff,0xff,0xff, - 0xbf,0x9f,0xff,0xfd,0xff,0xff,0xff,0xff,0xbf,0xdf,0xe3,0xfe,0xff,0xff,0xff, - 0xff,0xbf,0x5f,0xfc,0xfe,0xff,0xff,0xff,0xff,0x7f,0xef,0xff,0xfe,0xff,0xff, - 0xff,0xff,0x7f,0xef,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x36,0x1f,0xff,0xff, - 0xff,0xff,0xff,0xff,0xf6,0xe3,0xff,0xff,0xff,0xff,0xff,0xff,0x76,0xfc,0xff, - 0xff,0xff,0xff,0xff,0xff,0x89,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf1,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xe1,0x9f,0xf9,0xff,0xff,0xff,0xff, - 0xe7,0xf9,0xff,0xf9,0xff,0xff,0xff,0xff,0xcf,0x64,0x98,0xf0,0xff,0xff,0xff, - 0xff,0xcf,0x24,0x93,0xf9,0xff,0xff,0xff,0xff,0xcf,0x24,0x9e,0xf9,0xff,0xff, - 0xff,0xff,0xdf,0xe6,0x98,0xf9,0xff,0xff,0xff,0xff,0x1f,0xe6,0x91,0xf9,0xff, - 0xff,0xff,0xff,0x3f,0x27,0x93,0xe9,0xff,0xff,0xff,0xff,0x3f,0x67,0x98,0xf3, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff};
--- a/etc/vm/visit-dn.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * visit_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c Gray60", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXooXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooOoXXXoooOoXXooo+oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooOOOOooooOOOoooo++++oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooo+++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOoo++++++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo++++ooo+++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo+ooo++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++++++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++oo+++++oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++oo+++++oooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++++++oooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo+++oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoo+oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooooXXXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXXooooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXooXXooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXoooXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXXoXXooXXXoooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooXXooXXXXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/visit-up.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x04, - 0x0c,0x06,0x00,0x00,0x00,0x00,0x80,0x8b,0xcb,0x05,0x00,0x00,0x00,0x00,0x60, - 0x78,0x3c,0x04,0x00,0x00,0x00,0x00,0x20,0x80,0x03,0x02,0x00,0x00,0x00,0x00, - 0x40,0x60,0x00,0x02,0x00,0x00,0x00,0x00,0x40,0x20,0x1c,0x01,0x00,0x00,0x00, - 0x00,0x40,0xa0,0x03,0x01,0x00,0x00,0x00,0x00,0x80,0x10,0x00,0x01,0x00,0x00, - 0x00,0x00,0x80,0x10,0x83,0x00,0x00,0x00,0x00,0x00,0x00,0xc9,0xe0,0x00,0x00, - 0x00,0x00,0x00,0x00,0x09,0x1c,0x00,0x00,0x00,0x00,0x00,0x00,0x89,0x03,0x00, - 0x00,0x00,0x00,0x00,0x00,0x76,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x0e,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x18,0x1e,0x60,0x06,0x00,0x00,0x00,0x00, - 0x18,0x06,0x00,0x06,0x00,0x00,0x00,0x00,0x30,0x9b,0x67,0x0f,0x00,0x00,0x00, - 0x00,0x30,0xdb,0x6c,0x06,0x00,0x00,0x00,0x00,0x30,0xdb,0x61,0x06,0x00,0x00, - 0x00,0x00,0x20,0x19,0x67,0x06,0x00,0x00,0x00,0x00,0xe0,0x19,0x6e,0x06,0x00, - 0x00,0x00,0x00,0xc0,0xd8,0x6c,0x16,0x00,0x00,0x00,0x00,0xc0,0x98,0x67,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- a/etc/vm/visit-up.xpm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -/* XPM */ -static char * visit_xpm[] = { -"64 42 4 1", -"X c Gray75 s backgroundToolBarColor", -"o c black", -"O c white", -"+ c Gray60", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXoXXXXXXXooXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoooOoXXXoooOoXXooo+oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooOOOOooooOOOoooo++++oXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoOOOOOOOOOooo+++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOoo++++++++++oXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo++++ooo+++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXoOOOOOOo+ooo++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++++++++++oXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXoOOOOo+++oo+++++oXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++oo+++++oooXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo++++++oooXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXoOOo+++oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoo+oooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXoooXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooooXXXXXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXooXXXXooXXXXXXXXXXXXXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXXooooXXooXooooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXooXXooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXooXXooXooXoooXXXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXoXXoXXooXXXoooXXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXooooXXooXXXXoooXooXXooXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXooXXooXooXXooXoXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXooXXXooXXooooXXooXXXooXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", -"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- a/etc/vm/visit-xx.xbm Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -#define noname_width 64 -#define noname_height 42 -static char noname_bits[] = { - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x04, - 0x0c,0x06,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x60, - 0x78,0x3c,0x04,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x40,0x60,0x00,0x02,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x40,0xa0,0x03,0x01,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x80,0x10,0x83,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x09,0x1c,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x76,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x18,0x1e,0x60,0x06,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x30,0x9b,0x67,0x0f,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x30,0xdb,0x61,0x06,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xe0,0x19,0x6e,0x06,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x98,0x67,0x0c, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, - 0x00,0x00,0x00,0x00,0x00,0x00};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/xemacs-beta.xpm Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,170 @@ +/* XPM */ +static char *magick[] = { +/* columns rows colors chars-per-pixel */ +"388 145 19 1", +" c #090909090b0b", +". c #2ef52ef52f89", +"X c #131315154c4c", +"o c #7e7e00000000", +"O c #50e450e451e5", +"+ c #6f5c6f5c705d", +"@ c #232327278888", +"# c #36363a3acccc", +"$ c #48704e4ed384", +"% c #68f76cfbddbc", +"& c #99d200000000", +"* c #af5000000000", +"= c #d23a00000000", +"- c #f5e900000000", +"; c #912a912a922b", +": c None", +"> c #8d5e9162eb8a", +", c #b3c7b7cbf93d", +"< c #d6dbd706d9dc", +/* pixels */ +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::<:::::::<::::::::::<:::::::::::::::::::::<:::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::<:::::::::::::::::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<<::::<<<<:::::::::::<<<<<<:::::::::<<::<:::::::::::::::::::::::::::::<:::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::<:<::::::::::<::::::::<::::::<:::::<::<:::::::::::::::::::<:::::::<::::<:<:::::::<:::::<:<<:::::::::<:::<:::::<:::::::::::::<:::::::::::::<::::::::<::::::<:::::<::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::<<::<<<<<::::::::::<<<<:::<<<<<:::<<<<:::::<<<::::::::::<:::::::<:::::::<<:::::::::::<<<<<:::<<<::::::::::<<<<<<::<<<<<:::<<<<<::<<<<<::::::::::<<<<:::<<<<<::<<<<<:::<::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::<:::<::<<<<<<::<:::<::<:::<::<::::<::<::::::::::::::::::::::<::::::<<<<::::<::::<<<<<::::::::::<<<<<<:<<:<:<::<::::::<::::<:<<<<<<::<<<<<:::<::<::<::::<::<::::<::<<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::<::::::::::<:::<::<::::<:<::::<::<<<::::::::::::::::::::<::<::<:::<::::<::::<<<:<<:::::<::::::::::<<:<:<::<::::<:<::::<:<<<<<<::::::::::<::<::<::::<::<::::<::<<<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::<<::<::::::::::::::<:::<::<<::<::<<::<<::<::<:::::::::::::::::::<::<::<::<<::::<::::::::::::<:::<:::::::::<<:<:<::<<:<:::<<::<<:::::::::::::::::<::<:::<::<<::<<::<:::<:<<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::<::<::<<<<<::::::::<:::<::::<::<:::<::<::<<::::::::::::::::::::<:::::::<::::<::<::<::::::<::<:<:<:<:::::::<:<:::<<::<:<::::<:<::<::<:<::::::::::<::::::::<:<::::<::::::<:<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<::::::::::::::<:::<:::::::::<:<::::::::::<::::::::::::::::::::::::::::::::::::::::::::::<::<:::::::::::::::::::::::::::::::::::::<::::::::::::::::<::::::::::<:::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::<::::::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::<::::::::::::::<:::::::::::<::::::<::::::::::::<::<:::::::::::::::::::::::::::::::::::<:::<:::::::::::::::::::::::::::::::::::::<:::::::::::::::::<:::::::::<::<:::::::::::::<::::<::::::::::::::::::::::::::::::::::::<::::::::::::::::::<:::::::::::::::::::::<:::::::::::::::<:::::::::::<::<:::::::::::::<::::<:::::::::::::::::::::::::::::::::::<::::::::::::::::::::::", +"::::::::::::::::::::::::::<::::::::::::<:<::::::::::::<::::::::::<::<::::::::::::<::::::::::::::::::::::::::::<:::::::::::::::::::<::::::::::<::::::::::<::<:::::::::::<:::::::::::::::<:::::::::<::::<::::::::::<:::::::::::::::::::::::::::::::<::::::::::::<::::::::::::::<::::::::::::<:::::::::::::<::::::::::::::<:::::::::<::::<::::::::::<::::::::::::::::::::::::::::<:::::::::::::::::::::", +"::::::::::::::::::::::<:<:::<::::::::::::::::::::::::::::::::::::::::<:<::<:::::::::::::::::::::::::::::::::::::::<:::::<:<:<:::::<::<::::::::::::::<::::<:::::::::::::::::::::::::::::::::::::::::<:<::::<::::::::::::::::::::::::::::::::::::::::<:::::<:<::::::<::<::::::::::::::<:<:<:::<::::::::::::::::::::::::::::::::::::::<:<::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::<:::::<::<::::::::<:::::::::::::::::<::::<::::::::::::::::<::::::::::::::::::::::::::::::::<:::::::::<:<:::<:::::::<:<:<:::::<::<::<::<::<::::::::<:::::::::::::::::<::::::::<:<:::::::::::::::::::::::::::::::::<:::::::::::<:::::<:::<::<::::::::<:<:<::::::::<:::::<::<::::::::<:::::::::::::::::<::::::::<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::<::<:<:<::<::::::::::::::::::::::<::::<::::<::<;;<<::<::::<:::<::::<:::::::::::<<:::::::<::::::<::::<<::::<<:::<::::::::::::::::<::<::<:::<:<::::<:::::::::::::::<::<::<:::::::<::<::<:<::<:<::::::::::::::::::::::::::<:::::::::<::::::::::::<:::::::::::::::::<::<:<::::<::::::<:::::::::::::::<::<::<:::::::<::<::<:<::<:<::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::<::<::::<::::<::::::::::::<::::::::::<::<::::<:<::::<::::::::::::<:::::::::::<<:::<:::::<::::<:<::;:::::::<::<:::::::<:<::<::::<:<:<:<::::::::::::::::::::<::::::::::<::<::::<::<::::::::::::::::::::::::::::::::<:::::<::<::::<:::<:<:::<:<:<::::::<:<:<::<::::<::<:<::<:::::::::::::::::<:&&:::::::<::<::::<::<:::::::::::::::::::::::::::::<:::<:::::::::::::::::::::::", +":::::::::::::::::::::<:<::::::<:<::::::::<::<:::<::::::<::::::::::::::<<:::<<:<:<:<<<<<<<::::<<<::::<<:<::<<<<:::::<::::::::<:<::<<:::<:<:::::::<::::<::<::::::<:<:<:::::<::<:::<::::::<::::::::::::::::<::<::<:::<:::<::::::::::::::::::::::<:::::<::<::::<:::::<:::::<::::::::<:::<::<:<:::::<::<::::::<::<:::<:::&&*&&:::::::::::::::<::<::<:::<:::<:::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::<::<<:<:::<<:::::::<:::::::::<:::<:::::::<<:<::::<::::<<:::::;:;::<:<::<;::::<<;:::<<::<:::::<:::<:::::::::::::::::::::<:::<:<::::<:<:<:::<::::::::<:::::::::<:::<::::::::::<:<:<:::<:::<:::<::::::::::::::::::::::::::::::::::::<:::::::::::<::<::::::<:::::<::<::<:<<:::<:::::::&&&&&::::::&&-=&::::::::::<:<:<:::<:::<:::<::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::<::::::::::::<:::::::::<:<::<:::<:::<:<::<:<::::::::::::<:<:<;;;::<;:::::::<:::::<:::::::::;:<::<:::<:<:::::<:<:::<:<::<:<:::::<::::<:<:::::<::::::::::<:<::<:::<:::<:<::<:<:::::::::::<<:::<:::<:::<:::<:::::::::::::::::::::::<::<::<:::<:<:<:<:::::::<::::::<<::::::::&:::<:::::::::&*---&:::<:::*--&:<:<:::::::::::<<:::<:::<:::<:::<::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::<:<::::::::<:::::::::<:<::::::::::<:::<::<:<::<::;::::::::::::::::::::::<:<::::::::::<:::<::::::::::::::::::::::::::::::::::::::<:<:::::::::<::::::::<::::::<:::::<:::<:<:::<:::<:::::::<::::::::::::::::<:::::::::::<:::<:::::<::<::::<::::::::::<&&&&&&&&:::::<:<:::=---&&<:::::=--&::::::<:::::<:::<:<:::<:::<:::::::<::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::<:::::::::::<:::::::::::::::::::::<<:<<:::<::<:::<:::::;:<:;:::::::;<::<:<::::::::::<:::::<::::<:::::<:<<:::<::<:<:<::::::<::::<:<::::::::::<::::::::::::::::::::<:<::<::<:::<::::::::::<::::<:<::::<::::::::::::::::::::<::<::<:<:::<:::::::::<::<:::::::<:&&--=&&--=&::::<::::=----&::::::&-=&:<:<::<::<:::<::::::::::<::::<:<::::<::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::<:::::::::::::::::::::::::::::::::::<::<::::;<:::;;;;<::;;;<;:;;::<:;<;<;;<:::<;;<:::<;;<;<<::::<:::::<::::::<<::<::::<:<:<<<<<<<<<<<<<:::::::::::::::::::::::::::::<::<<::::::<::<<::<:::<::<:<::::<:::::::::::<:<::::::<::::::::::::<::<:<<<:<:<:::<:<:<:<<::&=--&&&&&--=&:::::::&=----*&:::::&-=&<::<<::::::<::<<::<:::<::<:<::::<::::::::::::<:::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::<:::::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,<:<<<:::<<,,,,,,,,,,,,,,,,,,,<:<::::::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,>>>>>>>>>>,:::::::<::::::::::<:<::<::::::<:::::::<:::::<:<:::::::::<:<:::<:<:<:::::::::<:::<::<:<:<:<:<:::<:<::::<:<::<&&&:<::<::<&==&&::::&o--&::<::::&=-----&&::<:&==&:<:::::::<:::::<:<:::::::::<:<:::<:<:<:::::::::<:::::::::::::::::::::::::::", +"::::::::::::::::::::::::<::::::::,###$##########################%:::<:::<%###################%:<:<:::,######################################################:<:<::::<<:::::::::::::<:::::::<:::<:::<:<:::::<:<:::::::<<<::<::::<:<::::<::<::::::::::::::<:::<&&<::<:<:::&&&<:<::::&&-&&::<:<<&&=&&::<<:&&=------&::<:&*-&::<:::<:::<:<:::::<:<:::::::<<<:::<:::<:<::::<:::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::<:<:<::<##############################@O:<::::<%###################@O::::::<#####################################################@ <:::<<:::::<::<:<::<::<:<<:<::::::::::<::<::<:::::<:<::::::<::<:<:::::::::::::<<::<:<:<<::&&&&*=*&&&::<:<::&*&<::<<<:&=-&::<::<:<&&-&&:::::&=---=&=&&::<&=-&::::::::::<::<::<:::::<:<::::::<::::<:::::::::::::<::::::::::::::::::::::::", +":::::::::::::::::::::::::::<:::<::%@#########################@@@XO::<:<::,#@################@XO<:<<:::%@###################################################XO<:<:<:::::<:::::::<:<:<:<:::::::<::<<::::<::::<<:::::::<:<::<:::::<:<<:::::<:::<<::::::<:&&=------==&:<:<:<:&&&<:::<:&=-&&::<:<:<:&=-&::::<&----&&--&<:::--=&:::<::<<::::<::::<<:::::::<:<:<<:<:::<:<<:::::::::<:::::::::::::::::::::::", +"::::::::::::::::::::::::::::<::<:::O.XX###################@X .OO;<::<:<::;OOO$##########@@ .;:<:::<::OO. @$##################X XX@@################X+<<<<:<:<:<:<<:<:<::<::::::<::<:::::::<:<:::::::<<<:<:<:::<<:::<<<:::::::<:&&&<:::<::::::&&--***&&&=-=&:::<::&*&<::<<&*--&:::::<:<:<--&<:<:<:---*&:--*::::=--&<:::::::<:<:::::::<<<:<:<:::<::::<:<:::::::::<::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<::::<::+$################X O:<<:<<<<<<<<<::::<>#########X .+<<<<<<:<:<:::::<>################@ X+:<<<<<:;;O.X@############# ;<<<<<<<:<:<::<::<<<:::<:<::::::::::<::<::<<<::::::::::::::::<::::<<:<::::&&&&&&&::<:::<:&*-*&<<:::&--&:<:<<<*-&::::::---o<:<:::::::==&:<:<:<*--&<<&==&<<:&--&::::::<::<::<<<:::::::::::::<:<:::<:<<:<::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<:<<%###############XO::<<:<::::<<<<<:::<>######## +:::::::<<<<<:<::<<<%############### .::<:::::::::<<+O@##########@ :::::<<<<<:<:<:<:<:<<<:<::<:<::::<::::<:<<::::::::<:::<::<&&:<:<:<&*&&&&&===----*&::<:::<*-&&<:::<:&---&<:::<=-&<:<:::=--&::::<:<:::&&::::<:<o--&<:<&=&::&&--&&:<:::::<:<<::::::::<:::<::<::<:<:::::<:::<:::::::::::::::::::::::::::::::", +":::::::::::::::::::<:::::<:::::::::::::<<,$############## O;;;;;;;;;;;::<<<::,%######@ ;;;;;;;;;;:::<<:<::<,%##############@ ;;;;;;;;;;;;;;;;;;O$########@ ;+;;;;:<<<::<:::<:<:<:<:<:::::<<::<::::<:<<:<<:<:::::&&&&&&*&&<:<:&--=&&*=&&&*=--&:::::::--&<::<:::<&==&:<<:<&-&:<::::&-&&::<:::::<&&&::<:::&&&-&&::&=&&<:&--*&::<:<:::<:<<:<<:<:::::<:::::::::<<<:::<:::::<::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<::::::::<:<<:>##############XOOOOO++++++;;:<<<:,,######@ .OOO++O+O++++;::<<::<<,%##############XXOO+OO+++++++++++++++$#######X.OOOO++::<:::::::<:<::::::<<<:<::<<<:<::::::::<:::&&*&&==----=&::::&--*&&:::<&&&=-=&::::::*-&:<:<<:<::<:<::<:&&-&&<:<:&&-&::::<:<::::&&:::::::&&-*&<::&=&&<&=--&:<<<::::::::::<:::<<:::<::<:<:<::::::::<::<::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<::::::::<<;>##############X.......OO+++;::<<<,$#####@ .........OOO++OO:<::<<,############### ..........OO+OOOOOOOO%$###### .....+;:<<::::<:::<:<<<<<::<:<:<::<:<<::<:&&&<:<&&----==-=*&&&<::::*-&;::<:::::&--&:::::&&-&<<::::<:::<:<:<:<&-=&<:<::&-*&::::::<:<<&*&::<:::&---&:<:&--&:<---&<:<:<<<::<::<:<:<<::<:::::<::<:::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::<<<:;%#############@ . ..OO++;;:<<<,%#####@ X.. . . ...OO++O:<:::::<,##############@ . ..O.O+++++++OOOO%###### ..O+OO+<<:<:<::<:<:++O+O::<:<<<<:OO<:O&&=&::<&---&&&&&:<&<::::::&-&:::::::::&--&:::::&*-&&:::<::<::::::<:<&--*&:::<&--&::<:::::::&-&::::<:<=--&:<:<&-&::*--&:<<:<:<<::::<:::<:<::::::::<:<:::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::<::<<<:>############## ...O+;;::<<<,>#####@ .OO. ..O++++;:<<:::<>##############X X..OO;+++;;;+O++O>$####@ .O;:;<:<:::<:::::::<:::&&&::<<:<<O:<;&=-&:<:*--&:&<<:::<:::::::&-&::::<::::&--&<::<::&-=&<<:<:::<<::::<:<&---&<<::&--&<:::<:<::::*&&<:<:::*-=&::<:&=-&&&--&<:<:<<:<:<<:::<::<<::::<::::<::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::<::<:<<<,############## .O+;:::<<<<>#####@ .O+.. ...+;;;+::::<:+,%##############X ..O++:++;::O++OO;;%####X ..+;:;<::<:::::;<<:::::&*=&&;;+<:<<+O&&-&::::&--&:+:;<:<+::+<::+&-*;::+;:;+<&--&:::<;;&--=&&&::;<:<++;:+::&=--&:<<<:&*&:::<:::::::&&&:::<<&*-&&<<::&&-&&&--&<<<<:<:<<:<<::::::::::::::::::::::::::<::::::<:::::::::::::::::::::::::::", +"::::::::::::::::::::::::<::::::::::::<:<<:<<%#############X ..+;:<<<<<,,$####@ O;<;+.. ..O.::<<;<<<::::,$############## .;;;O:<<<<+;;;O;:>#### ..+;:;:<<:<:;++;:<<:::<&&-*&:;+::<<+;:&-&+++O&--*::::::::::::::<&-=&:<+:::+:&--&++::::<&--=--==&&&&:<:<:;:&&--&:::::&*&<::<:::::::&&&<:<::&&-&:<:<<:&=&&&--*:<:<<<<:<:<<:::<<:::<::::::::::::::<::::::<:::<::::::::::::::::::::::::::", +"::::::::::::::::::::<:::::::::::<:<:<::<:<:<>#############@ .O+;<<<::,,$##### O<;:;O. . ..O++:<<<:<::<<::,##############@ ..+;:+:+<<<:+::;;<<>#### X ..+:<;<:<::::<<;::<:<::<&--&:::<<:;::&*-&::::&--=&::::::::::::::&--&::+::::&&-*&:::::::&&&&=---===*&<:<:;<&&--&:<:<<&=&<:<:<::<<:<&=&<:<<<:&-*<::<:<:&-=---=&<::::<::::::<:::::<:::::::::::::::::<:::<:::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::<:<::::::<:<:<:<:,############## .O+:<<:<,,$####@ .<<;+;O. ...+;::<<<:;:<::<<,>##############X .O+:<:<<+:<:O::<<:<,###@&&& .O+:<:<:<;:;::<+<:<:::::&&-=::<::::<:&-=&:::<&=-=&:::::<:::;::<+&*-&<:+:<&&=-=&:::::::<:<:&&&*&=&*--&&:;<<<&--=&:<::&-*&::::<<:::<&-=:<::<:&-=&:<:<::&-----=&::::::<<:<::::::::::::::::::::<::<:::<<::<::<:::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::<:<:<<:<:<:::<<<$#############X .O+:<::<,$##### <<<:+... .O+OO+::<;OOO;:<:+,%############## .O;:+;<:O+<:<;O;::<,##&&&=* .O;;OOOO+::<OO:;;:<:OOO<<&-=&+:::++::&==&:<::&*-=&;<:+::<+O::<:<&&-&&&*=&&=-&&:::::<+;:+<:;:;OO&&&&--&&<:<&=--=&<:<:&--&::<::<<<:<&-=&<<<::&=-&&<:<:<&&----&:<:<:::::::::<:<:<<:::::::::::::::::<:<:<::::::<:::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<:::<:::<<:<::<%#############@ ..+;:<<,$####@ X::<<:+O...O+;:<<::<<<:<:<::<,$#############@ ..+;::&&&<<&&&&:<<::,##&----&...O;:<<:<:<<:<:<:<::<:::<:&&-*&<::<:<:&*=&::<:&=--&:::::::::::::::&--=----==-=&:::::::::::<<<::::<<:&--&&:&&&--&<::<:&--=&::<:::<:&&-&&::<<<&*-=&:<:<::&*---&<:<::::<::::<::::::<::::::::::::<:::::<::<:<:::::::::::::::::::::::::::::", +"::::::::::::::::::::::<:::::::<:<:<<:<::<:<:<,############## .O;:<,%##### X<:<::;O...O+;:<<:<:<:<<:<:<:<,##############@ ..+;&&*--==*==*<:<:<>##&=&*-*&..+::<<<<<::<:<:<:<<:<::<<:&*=&:<:::::&*=&:<::&---&&&&&&&&&&:<:<::&--**---&&&--&&::::::::<::<:<<::<:&---=&&:&==&:<<:<&&*-*&:<:<:<<&*=&<<<:::&&--&::<:<::&&&&&:<:<<:::::::<:<<:<::<::::::::<<:<::<:<:<:<:::<:::::::::::::::::::::::::::", +":::::::::::::::::::<::::<<::::::::<:<:<<:::::<$#############X .O;,,%##### <<<<:;+O..O+;::<<<:::<:<<:<<:,>##############X .O&*=-------=-*&:<<<<%&&=&&*=&.O+::<<:<<:<::<:<:<:<<<::<:<&-&<:<<::<&-=&:<<:*----&&*-----*<<:<::&-=&&:&&&<&&--&:<<:<::::&<<<:<:<:<&*--=&::&*=&<<:<<<&&--*&::<::&&-*&<<<<<<<*--&<<<:<<:&<:<::<::<<:::<<<:<:<::<::::::::::::<:<::::<:<::<:::::::::::::::::::::::::::::", +":::::::::::::::::<:::::::::<::<::::<:<:::<<<:<%#############@ .O:,%##### X<<<<:;+O..O+;:<<<:<<<<:<<<:<::,%##########&&&&&&& &&&---===*&&&&&&<<<:<<&*=&&&=&.O;:<<<<:<:<<<:<::<::<:<:<:<*-*&:::<<<*-=<<:::&---------**&&<<<<<:&-=&<<:<::::&*=&::::::&&&&::<<::<<&=--&&<:&==&:<<<:<<&---&<<:<<&-=&<:<::::<&*&&:::<::<<<<<<<<:::::<::::<:<:<::<::<::<::::<<<<:<::::<<::<<<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::<::<:::::<>############## >,%####@ <<<::;+O..O+;:<:::::::<::<<:<:<,#####&&&&*&&&=---*& &&&&&&&&&&&,$##;::<<:<<:&*-&&*-*&+;<<<:<:<:::<:<<<<<,<<:::<:&--*<<,,>>o-&::<<<&-----=&&&&&,,>>>><<&**&<:<:::::&==&::<::&&-=&<:<:<<,,&*-*&<<<&=-&:<<<<<<&&--*&&&&&--&&<<:<<<::<&<<<<<<<,,,>>>>>,<<<:::<:::<:<<:<:<<::<::<,,,,>>>>,<<<::::<,>>,:::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<<:::<<:<<##############X ;,%##### X<<<<:;+O..O+;:<<::::<:::<::<:<:<>####&&====&&=*=-*&& .O+:<<<:&&>### :::::::::=-&:&--*+;<:<:<<<<<<<<,,,>>%$><::::&&-*&>%###&=&%<<:<&*----o&<,,%$######%&==&<:<:<<<:&*-&<<:<::*--&::<,,>%##=-*#$>::*-*,,>>>>>>&&--=&*=--&&::<<<::::<:<:<<,,>%$#######$>,::::<:::<:<<<::<:<<<,,%$#######$>,<<:<,>###:::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::<:<:::::<<$#############@.,%##### <<<::;+OO.O+;:<<<::::::<&&&&&&&<,%####&*-&&##&&&& .O;:<<<:<&$##@ ::::::::&-=<:;&-=&:,,,,,,>>>>%%$######X+<::::&=&&####&&=&#$:<<&*---=&,,%##########&*-&::<<:::<:=-&&::<::&--=<,,>$###o--&###$<&-=#########&&*&&**&&<::::<<<:<:::<,,>%##############%<:<:<<:<:<:<<<::<,,%############$%>,,>$##@ ::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::<:<<:<:<>##############,>##### X<<<<:;+O..O+;:<<<<<:&&&&&&*-**-=&&$#####=-&####&# ..O;:<<<<&&###@.::::::::&-*<<:&--&>%$#####$########### :<<:<,&*=&&###&*=&###<<&&----&>$############=-*<::<:<:<:=--&:<::<:*--&>$####&=-&&####O&=&&#########X+:&&&<:::<::::<<<<<<,>$#################$<<:::<:<<:<:<:<,>$######################@O::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::<:<::,##############>##### <<<<:;+O..O+;:<<::<;O=-&:&&&&&&*--*&#####---&####@ ..+;<<<<,&&###X+<:<<+O::&=&&<:&=-&&##################X.<<<<<,&&-=&####==&##$@<<&----&##############*-*O:<:<:<:<&--*::<::<&--=&&##&&&-&&####$#&&&########## :::<:O;::::::::::<,,%#######@X O$#######$<<<<:<:<<<<<<,>########@X X##########XO::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::<::<<:<<%##################X :<<<:;+OO.O++;:<<:::;:--&:::<;:<&=--&#####&--&####X .O;:<<<,&&&&## ::<<<<<;&&-&&<::&==&################## +<:<,,$#&--*####-=####@+<&---=&##############&-*&<:<<;O.+&=-&<::<:<&&=--==**==*& ####%>##########@ <<:<<:;::::::::<<,>$#######X .;:<>########@<:<<:<<:<:<,>$#######X O;<:<;$########X;<:<<:<::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::<::<:<<%#################X O:<<:;+OO.O+;::<<::::;<*&&:::+::::&=-&#####&--&&### ..;:<:,,&*=&#@ ;<<::::+&*-&:<<:&=-&OXX############### :<;,,$###=-*###&-*#####.:&---&###############&&*&:<<<<:;:&&-*&:::<,>&&&*---=*& O::;%##%%##########X.::<<<<;:<:<<:::<,>########X O:<<,%#########.:<<<:<;:<<,$#######@ ;<<<<:;:%####### ;<<<::<<:<:<:::::::::::::", +"::::::::::::::::::::::::::::::<:<::<:::::::::<::,################X .;:::;+O.OO+;;:<<<<:::::&&&<<:;::::+&=&&###&&--&&### .O;:,,>$&==&#X.;O:;;+;+<--&<:<<<---&OO+>############@ ::,,$####&==&&&&-&##### ;&---&&###############&=&&::<<<;<:&==&&:;,>###&&&*&&& O;::;;$#$########### O+O::::;<<<:<O;,,%########X O;+O,,$#########XO+::++;;;,>######## .;<<:;+O++$###### :<:+;;;<<<<<<<<:::<::::::", +"::::::::::::::::::::::::::::::::::<:<<::<::::::<<$##############X .O+;;;+OO.O+;::<<<<<:<:::&&&:<:;<<<:<&==&####&=-=&##@ .OO;:,,>$###--&#X+<<+;++;+<--*::::<&--*;<<,############X.;,,$###@ X&=-**--&##### O&=--*&@ $&&&&&&####&&-&+;;::<;:<:&&&++,>#########@ ++.;+++>############@ ;++;;;;+<<<<;<<,%########@ O;;;.,%##########@..::;<<<:,$######## :;;;;++OOO>#####@ ;:;++;::<:<::::::<:::::::", +":::::::::::::::::::::::::<::::::<::<::<:<:<:::::<>#############@ OO+++O..O++::<<<<::::<::&*=&&<;<:<;<&=-&####&---&##>,&,,,>>>%%######=-&# :<:++OO++&--&<:<::&*-&;::,############ O>,$###X O&&-----=&####@ >&*---&&&&&&----&&####=&&.O+;:<;<:;&:;<,>##########X +++O+O.O>############X OOOOO+;+:<<<:<,%######### OO++++,###########@ .+;+:<<:>######### :++OOO..OO;$####@ +++OO+;;<<<:<::::<:<:::::", +":::::::::::::::::::::::::::::::::::<:::<:::<::<::>############## ..OOOOOO+;;:<<<<<<<:::;:&---&<;<<<<,*--&#####*--&##&&*&&o&##########&=&@ <:OOOO++&&-&&:<&&&&=-&&<<,###########@ O,%##@ O:<&=-----&####@O,$&---=&*-------=&####&&&..O+;:;<:;:<;,>##########@ .;++O..X+>############ ... ..O++:<<<,,%######### :.+;++>###########@ .O++:<<,>######### ;OO.....OO+%####@ OOO.OO;;<::::::::<:::::::", +"::::::::::::::::::::::::::<:::::::::<::<:<<::::<:,$#############X ......OO;::<:<::<:::::;::---&<;<:<:&--&&#####&*--=&&&=---&##########&&#X.O.+OO....&-&&&&=------&&>>###########X ,>### O.::&-----=&####@,>##=-------**&&&&&#####X .O..OOOO<:,,$########## O+.. .. ;>############ .. ...O<<,%#########@ ;:;..XO>###########@ ....O::>%#########X.. .X.....+>####X ... .O+;<:::<::<:::<:::::", +":::::::::::::::::::::::::::<:::::::::<:<::<<<:::<<%#############@ ...OO+::<<<<<<<<<:::;;<*--&<:+<<,&-*&#######&=----&&*=&&##########&&& ;;;OO.O+;&&-=&&&--=**&--&<%########### >,### O;:<&=-----&#####>>##@&-*&&&&&&&########## ..O;:<<<<<,$##########X ;+O... X.>%###########X .O+:<::,>########## .;++O...>########### ..O+:<,%##########... .O+;::,$###X... ..O;:<::::::::::::::::", +":::::::::::::::::::::::::::::::::<:::::::<:::<::::>############## ...O;;:<<:<::<:<:::::;&&--&&&&&&&=-&&#######&=-=&&&XXX@@##########&*& ;;O...O+:&--=&&&&&&&&&--*&%##########@O,$## .O;::&----=&######,$##X .+&&:;,############ .O+:<::<,%##########@ OOO. ...,%###########X .O+:<<,,##########@ ;+O...X.+##########@ .+;:<%##########@ ..+;::<<%### .. .O;:<::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::<:<:<::<:::,$#############X ..O+;:<<<:<<<<::::<<<:<&--=&*------&&######&&-*& & XXX#######&=&X+O....O+:&--&&&::<:<:<=--&###########@,>##X X.+;::&=---&######%%##X .O;::,%###########@ .O+::<<,>########### .O... ..O,$########### ..O;:<<,$########## .+O.. ..O%######### ..O;:,%##########$ .O+:<<<<>### +O. ..O;:<::::::::::::::::", +"::::::::::::::::::::::::::::::<:::::<::::<::<:::::,%#############@ ..+;:<<<<<::::<::::<<<<:&-----=**&*-*&#####&=--& .O+;+$#####&=&.O..X..O;:&=-&<:<::::::&--&###########,>##@ .O+;::,&&*-&&#####>##@ .O;;:,$###########X ..+::<<,$##########@ O.. ..O;,###########@ O+;<<,%##########@ OO.. . .O+;$#######X .O+:<$############ .O;:<<:::##@ +O.. .+;<<::::::::::::::::", +":::::::::::::::::::::::::::::::::<:::::::::<<:<:<<,$############## .O+:<<:::::::::::<<:<:<<&--*&&&<&&&&-=&####&=--& .O+;;;%#####*=&. X.O;:&--&:::<:<:<&&=-&&#########$,### .O;;:,>#&&&&&####$$## ..+;;>,############ .O+;<<,%###########X .. ..O+,>###########X .O;:<,,###########X O.. ..+;:<O@@@@X .O+:<>############. .O;:<<<<:< .;+...O+:<<::::::::::::::::", +":::::::::::::::::<:::::<::::::::::<:<<:<:::::<::<,%###############X .O;:<<::<::<<::<<<<::<<:&=-&:::,%##&=-*&###&*--=& ..O+++>#####&-& ..+;&&--&<:::<:::::&-=&#########%%##X .O+;:;,%####&#####$##@ .O++:>############ ..+:<,>###########@ .. .O+;:%########### .O;:<,$########### ..X ..O;:<::<O..X .O;:<,#############..O+:<:::::<<<:+O..O+:<<::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::<:<::::::,,%################X .O+:<<:::<<:<<:::<<::<<<&*-&:::,$##&*--&####&---& ...OOOO+%####&-& .O+&&&--*&:<::<:<::&=*&#########>##@ .O+;;;,#############@ ..O++,$###########X .O;:<,$###########X . ..+;:,%##########@ .+;:,>###########X .. .O+;:<<<<<:;O. .O;:<,##############..+;<<:<::<:<:;O..O;:<<::::::::::::::::", +"::::::::::::::::::::::::::<::::<:::::::<:<::::<,%################## ..+;<<:<::<<:<<<::<:::<:&*-&<:<,###&&*-&####&*-& ..OOOOO+%###&*-*& .O;&&=--=&<<:::<::<<&&&########$$## .O+;+>>#############X ..OO;,############X .O;:,>###########@ X .O+::,###########X .O+:<,$###########X . .O;:<<<:<<:;O.. ..+;:<<%##############.O;:<::<::<<<;+OOO;:<:::::::::::::::::", +":::::::::::::::::::::::::::<::::::::<:<::<:::<,%################### .O;<<<<::<::<<<:<<:::<<:&-&:<<%####&=-&####&&** .O;;;+;>###&--=& . .;&&---=&<:<<:<:::,%##########$##X .O+++,%############@ ...O,%###########@ .+;:,$###########X ..+;:,>########### .O;:,>############ . .O+;<<<:<<<:;+O. ..O+;<<:,##############$O+;<<::::::<:;+O+;<<<::::::::::::::::", +":::::::::::::::::::::::<::::::::::::::::<<:<<,>#####O$#############@ .O+:<<:<:+<<<<<<::<::::&=-*:;,%####&--&#####&==& & .O&&&::;,>###&=-=& .OO;:&*==&<:<::::<:<,$############# ..O++;,$############X X..+,$###########@ ..+;,>############ .O;:<,%########### .O;:,%###########X .O;:<<<<::<<:;OO.....O+;:<<<<%##############$O;:<<<<:<<<:;++;:<::::::::::::::::::", +"::::::::::::::::::::<::::::::::<:::::::::::<,>#####X.%#############@ .O+:<<:<:+<:<<<;;<:::::&--=<+,#####&-=&#####&-=&&&*&&&*=&&;;<>###&&=*& .OO:<<&&:::::<;:;:;<>#############@ .O++>>############@ ...;>############ .O+:,$###########@ ..+;:<,$##########X .O+;<,############X ..+;:<::<::<<:;;OOOOOO+;:<<:::,$##############.+;:<:<:::<<:;;::<<:::::::::::::::::", +":::::::::::::::::::::::::::::<::::::<:<:<:<,>#####X :,############## .O;:<:::::<<:;;:;:<:;<&---&>>#####&-=&####&&--=&&*=---*&&;+<>### &&.. ..OO:<<<<<<<:<<++;+;,%############# . .O+,%############X ..O,%############ .O;,,############ .O;:<<>###########X .O;:,>############ .O+:<<<::<:<<<<:;++++;;:<<::::<>##############$.+:<<:<:::<<::<<<::::::::::::::::::", +":::::::::::::::::::::<:<:<::::::<::::::<::,>#####X ;:,$#############X .O+:<<:;:::<<+O++::<;<&*--=&&####&&=&&####&&--=&&&&**&&&&<:<>### ;OO....+O<<:<;OOOO+::;:;:,%############X . O+,$###########@ X.+,$###########X ..+;,%############ ..+;<<,%########### .O;:,%###########@ ..+;:<<:<:<::<<<<::::;::<<<::::::$###############O+:<<<:<:<<<<<<:::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::<:<,,$####X ;:<<%############## ..+;<<:;:<::;:<<;<:<;<&&---=&&&&&=-o&######&&-& &...;:<<<:;<%##X :O+...O++<<::<<<:<:<;::;<,#############X ...O;>############X ..>>############X .O+:,$###########X .O+:<<,$##########@ ..+;<,############@ ..+:<<<<::<:<::<<<<:<<<<<<<:<<:<:<$##############.+;:<:<::::<:<::::::::::::::::::::", +":::::::::::::::::::::::<:<:<:::::::<::::<,$####@ +:<<:>############## .O;:<<<;:<:+::<+:<<+<<*-----------&######@ .OO;<<<:<;:>$#X+<++O..O;+<,<::<<<<<<;;::<>############@ ..O+,>############ .O,%###########@ .O+,>############ ..O;:<<>###########X .O+;<>############X .O+:<::<:<::<::<:::<<<<<<<<<:<:<::,$##############.+;:<:<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<:::::::::<,,$####@ O<<<<;>$#############X .O+:<<<+:::<OO;;;<<<OO=-----=&*&&&#######X ...+<:;OOOO+O .....OO..O,>$%<:::<<:O+:O,%############X O+,$###########XX .O+,$###########@ .+;,>############ .O+:<<,%########### .O+:,>############ .O;<<<::<::<:<<<:::<<:<:<:<<:<::::<>##############@O+;:<<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<:<::<::<:<,$####@ O<<<:;++%#############@ .O+;<<<::<::<:<::::<:<&*&&&&&&&########## .O;:<<::::::<::<<:;OOO+:<,$##O<:::::<<<:,$############ ..O:,############ .O>>############ .O+;,$###########@ .+;:<<,###########@ ..+;<,%############ .O+:<<<<::<:::::<:<::::::<:<<::<:<:<<%##############XO+:<<:<::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<:::::<,%##### O:<<<;;OO>############## .+;:<<<:<:::::<<::<:<:<&,$############## ..+;:<<<:<:<:::<<<:;OO+;:,%##@ <:::<:<:<<,############X .O+,>###########@ ..+,%############ .O;:,############X ..+;<<,>###########X .O+;<,%############ .O;:<:<<<::::<<:<:<:::::::::<<<<::::<<%#############X.O;:<<:::::::::::::::::::::::::", +":::::::::::::::::::::::::::::<:::<::<,%####@ .:<<:;;OO.+$#############X .O;:<<<<<<:<<:::::::<::<>##############@ .O+:<<:<::::::::<<:;+O+;,>###X.<:<<<:<:<<%############ .O;,$###########X ..O;,$###########X ..+;,>############ .O;:<<,$########### .O;:<,############@ .O;:<:<::<::::<<<::::::::<::<:<<<<::<<<$############# O+;<<<::::::::::::::::::::::::", +":::::::::::::::::::::::::<:::<:<:::,,%##### X<:<<:++O.OO>#############@ .O;:<<<:<:<:<:<:<:<:<<<<>##############X .O;:<<:::<<:::<:<<:;+++,,$###X;<<:<<:<<<,%############ .O+:,###########@ X..+:,############ O+:<>###########@ ..+;<<,%############ .O;:<,############@ ..+;:<:<<<:<::::::::::<:::,>,::<:<<:<:<<,$############ .O+:<<::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<::::<<,%##### <<<<:;+O.OO+,############## .O+:<<<<<:<::<:<:<<<::<,$############## .+;<<<::<:<::<<<<<::;+,,$###@ ::<<<<<<<<,############X .O;,>###########@ X.O;,>############ O .O;:,%###########@ .O+;<<,$###########@ ..+::<,############@ .O+:<<::<::<<,<::::<:<:::<,##%<::<<:<::<<>############X..O;:<<:::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<::<,%#####XX<<<<:;+O.OO+;,##############X .O;:<::<<<<::<:<::<<<<,##############@ ..+:<<::<<:::<:::<<<:::,%####@X<:<<<::<<<>############ ..+;,%########### X..+;,%###########X .,>++;:,%###########X .O+:<,>############X OOO;:<<,############@ .O;::<<::<<<,>#>:::::<<:::>###O<::<<<<:<<<%###########@ ..+;<<:::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<<,>#####X ;<<<:;+O..O+;:,%#############X .O+:<<::<:<:<<<<:<:<<<>##############@ .O+:<<::::<::<<:<<<<<,,%##### +<<<::::<<,%###########@ .O+:,############ X.O+:,$########### ,>##O:<,%###########X .+;:<,$############ X,>>;<<:,############@ .O;:<<:::<:,,$##$:::<::::<>### <::::<:::<<,$##########@ .O+:<<::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::,>#####X ;<<<:;+O.OO+;:<<>############## ..+;:<<<:::<:<<<<::<:<%##############X .O;:<<::<<<::<<:<:<<<,%###### :<<:;;;;:<,$###########X ..+;,>###########X X.+;,,############ +,$##X+<<%###########X ..+;,,%##$########## >,##$<::<$############ .O;:<:<:::<,$###XO::<::::<%###X<<<<::<<<:<<>##########@ ..+;:<::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<,>#####X :<<<:;+OO.O+;:<:<,############## .O;:<<:<:<:<<<<<<:<<,$############## ..+;<<<<<<:<::::<:::,,%######@ <<::;++;:<,############ .O+;,%########### ..+;,>###########@ .,%##@ ;<<%###########X .O+:,>##%##########@ +,$##XO<<<%############ .+;::<<::<,%###@ +:::<:::,%###@;<:<<<::<<<<,$#########@ .O;:<::::::::::::::::::::::", +":::::::::::::::::::::::::::::<,>#####@ +<<<:;+O..O+;:<<::<$#############@ .O+::<<<<::<:<:<:<:<,##############@ O+;<<<::<:::;O:<<<,,$#######XO<<:;+O+;:,>############ .O;:,############ .O;:,%###########X >>### O<<<%###########X .O;,,$##>##########X O,%##@ +::<%############@ ..+;<<:::<,>#### .<<::<<<:,$####O<<<<<<<<:<<<>#########X ..+:<::::::::::::::::::::::", +"::::::::<::::::::::::::::::<<,>###### .:<<:;+O.OO+;:<<:<:<$############## ..+;:<<::<<:<:<<<:<<%##############X .O+:<<:<<:<:<:<:<,,>######### ;<:;O.O+;:,$###########X ..+;,>###########@ X.O;:,%########### ,,$##X ;<<<%############ .+,,$##%%##########X .,>### .<<::>############# .+;:<::<,>####X <:<<<:<<<,#####.<::::<<:<:<<>######### .+;:<:::::::::::::::::::::", +":::::::::::::::<:::::<<<::<,,>######@ <:::;+OO.O+;;;:::::,>##############@ .O;:<<::<::;<:<<:<,$##############X .O;:<<<::<:<<<<,,>$#########@ ;;;+...O+<,############X .O+:,%###########X .O+;:,$########### ,,$##@ +:<<:>############$ .+,,$##@,%##########X .,>###X :<:<:<$############$ ..+:<<<<,%####X ;::<<<<<<<,######;:;;;:<<<<:<,######### .O;:<:::::::::::::::::::::", +":::::::::::::<<<:::::<<:<:<,%#######@.+;:;+O..OO;;;;;:<:::>###############. .O+:<<<:<+;;+:+<:,>###############X ..O;:<:;:;;<:<<,>$###########X.+.+O...O;,>############ .O;:,$########### .O;:<,############%,,$##@ .:<<<<,#############%%;,,%$##@ ,###########$>,>###X +<<<<<<%#############$O..+:<<,,$####@ ;<<<<::;::<>######.;++;:<<<<<<,########X .O+:<:::::::::::::::::::::", +":::::::::::::<<::::<<<<<:,,%#########O:;;;O..OO;::+O;:<<<,>###############$.XOO.OOO;::::;<:<<,$###############X ..O:<:;+;:<,,>$############# O++O...O;:,%###########@ ..+;<>###########@ ..O;:<,#############%####X +:<:<::%##############%%##### .,############%$###@ .:<:<<:::$#############$>>,,,>$#####@ O<<:<:;;+;:,>######$++O+;<<<:<<>#######@ .O+:<<::::::::::::::::::::", +":::::::::::::::<<:::<<<,,>$##########%:++OO..O+;:;<:<::<<,$################$>O+;:<:::::::<:,,%################$O. .O+:<<:,,,,>%###############@ ;O.....+;:,$###########X .O+:,%###########X .O+:<<,#################X O;:<<::;>#################### X<,################@ .;:<<<::;;>#########################@ O<:<<:;+++;:,>#######$OOO;:<:<<,$#######X .O+:<<::::::::::::::::::::", +":::::::::::::::::<:::,,>%#############$>,;..O+;:<;<<,,,,>$###################$>,,<<:<::<,,,>$##################$%>,,,,,,>>>%%$##################@ +O. . .+::,############ .O;:,$########### .O;:<<<$###############X .+;:<<;;+;$##################X ::<$############### +;::<:;;+;;%#######################@ O::<<:;+OO++:,%########%OO+:<<<,>#######X .O+:<:::::::::::::::::::::", +"::::::::<::::<<<<:::<>$##################$#.+;:<::+,%$###########################$>:<+;,%####################################################### . . ..OOO>>###########@ ..+;,,###########@ .O;<<:<%##############X O+;:<:;++;>$################X ;<<:%############## .+::::;;++;:<%#####################X O<<:::;+OOO+;:,%#########$>;,,,,%#######X .. .O;:<:::::::::::::::::::::", +"::::::::::::::::::::<>#####################.+:<<:::,##############################@;:::,######################################################## .. ..O;:,%###########X .O+:<>###########X .O+;:<<:<#############X .O+;::;+++;:>############### +:<<<<$###########@ O+;:::;++;;:<<+##################@ ;<<<<:;;+OO+;:<,$############%%$########X .O. .O;:<<::::::::::::::::::::", +":::::::::::::::::::::,##################### ;:<:::::##############################@O<:::#######################################################@ .. ..+;:<############ .O;:<%########### .O+:<<:<:,##########X .O+;;;+++;;:<;############@ O;::::;;##########X ..+;;;++++;:<<<<+@##############@X .:<<<::;+OOO+;;:<,####XXX@##############X +;O. .O+;<<:::::::::::::::::::::", +"::::::::::::::::::::::: ;:<<:::<: .<<<:: .O+:<<< .+;:<:O .O;:<<:<:<<@@###@@X .O++++++;:<<<:@@######@X .O++;;;++O@######@ .O++++O+;::<<<<<:.X@########@@X +:::::;++OOOO+::<<<### X++OXX@########@X +<:;O. .O;:<::::::::::::::::::::::", +":::::::::::::::::::::::::::<<<<:;;+O. .O;:<<<<::::::<:<<<<<:;+. .O+::<<<<<:<:<<:<<<;;O.X X.+;:<<<<<<<<<<::::;;;++O... .O;:<:<:<<<<<;+OX ..+:<<:::<:<<:;O. .O+;<<<:::<:<+. ..OOOO+;:<<:<<<OXXXX ..OOOOOOOO.XXX ..OOOO++;<<:<:<<:;+. XXXX .O+;;;;++OOOO++;:<<<<>X .:<:;O. XXXX O+:<<:+O. ..O+;:<<:::::::::::::::::::::", +":::::::::::::::::::::::::<:<<<:;;+O.. .O+;::<<<<::<::<<<<::;+O.X ..O+;;:<<<<<:<<<<:;;+.. .O+;::<<<<:::::;;;++OO... ..+::<::<:::<<;+.. .O;:<<:::::<<:+O. .O+:<<:<<:<:<<<;+. ...OO+;:<<<:<<<:;OX .....OO+;;;O.. ...OO+;:<<::::<<:;O.. ...OOOOOO..OO+;:<<:::<;;:<<:+O. X..OO+<<<<<<:;O.. ..+;:<<::::::::::::::::::::::", +":::::::::::::::::::::::::::<<:;+O... ..O++;::<<:::<:<<::;;+O.. ..O++;;:<<<:<<<:;+OO.. ..O+;;;;;;;;;;+++OOO.... .O+:<<<:<::<<:;O. ..O;<<<:::<:<<;+O. ..+;:<<:::<:<:<<:+O. ..OO;:<<<:<::<<;+O. X...O+;:::;+O. ...O+;:<<<:<:::<<:;O.. ........OO+:<:<:<<<:<:::::+O.. ..O+;;:::::;+O.....O;:<<:::::::::::::::::::::::", +":::::::::::::::::::::::::<:<:;+OO... . . ..OO++;:<<<:::<<::;++OO.. . . .....O+++;:<<<<<:;+OO... . ...OOO++++++++OOOOO.... . . ...O;:<:<::<<:<:;O.. . .O+:<<:::::<<:;+... ..O+;<<:<::<:::<<:;O. ...++::<:<:<:<<<:;+O.X ...O+;:<<<:;O. ..O+;:<<:<:<:<:<<::;OO.. ......O+;;:<:<::<:<:<<<<:+........O+;;;;;;+O....O++::<<:<:::::::::::::::::::::", +"::::::::::::::::::::::::::<<:;+OO...........OOO++;:<<:::<<:;++OOO..................OOO++;::<<<:;++OO..................OOOO+OO+OOOOOOOOO.............OO+::<:::<::<<:;+O.......OO;:<<::::<:<:;+O.......O+;:<<:<<::<::<<:;+O.. . ....O+;:<<:<:::<:<<::;+O.. . ...O+;:<<<<<;+O.. ...O+;:<<:<::::::<<<::;+O.. . . . ...OO+;;<<<:::<:<:<::<:;+O....OOOOOO++++OOO...O+;::<:::::::::::::::::::::::::", +"::::::::::::::::::::::::::<<:;++++OO+OOO+O+O++++;:<<::<::<<:;+++++O++OOOOO+OOO+OO+O+O+++;:<<<<<:;++++++O+O+O+OOOOOO+O++++++++++++++++++OOO+O+OOOO+O++;;:<<::<::<:<:;;++OOOO+++;;<<:<::::<<<:;++OOOO+O+;:<<:<:<:<<::<<<:;+OO...OOO+;;:<<<:::::::<<<<:;+OO......OO++;:<:::<<:;+OO....OO+;;:<<:<:<<::<::<<<<:;++OO.........OO+;;:<<<:<::<:::::<<<:+OOO+++++OOOOOO+OOOOO+;;:<<::::::<:::::::::::::::::::", +":::::::::::::::::::::::::::<<::;;;;;;;;;;;;;;;;:::<:::::<<<:::;;;;;;;;;;;;;;;;;;;;;;;;;:::<<<<:+::;;;;;;;;;O+;;;:;;;;+;;;;;;;;;;+O+O;;;+;;;;;;;+;;;;:::<<<:::::<<<<:O;;;;;;;;::<<<:::::::<<+O:;;;;;+O:::<<+<;<::<:::<<<:;;++++++;;::<<:::::::;::::<<:;;++OOOO++;;::<;+<:::<:;++OOOO+;;:<<<<:::::<:<:<+::<<::;;++OOOOOO+++;;:<<<<:::::::<<:<::<:;++;;;;;;;++++++++++;;::<:<::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::<<<::::::::<<<<<<<:<<<;<:::::<<<<<<<<<<:<:<::<:<:<<::::::::<<<<:<<<:<<<:::<::::.::<::<<<+:::::<;;<:<;O;.<:<<;<:<:<:;<<::<<<::::::::::<<<<;::<<<<;<<<<::::::<::<<:<<:<<;:<+:<<:O<O:::<:<::<<<:::;;;;:::<<<<::<:::::::<:::<;:;;;;;;;;::<<<:<::::<<<:;;;;;;::<<::::::<:<:::::<:<:<<<::;;+;;;;;;::<<<<::::::::::::::<<<:;:::<<::::;;;;;;;;:::<<<::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::<<:<<<<<:<<<<<:<<<<<:;::<:<:<<:<:<::<<<::<:::<<<<::<<<::::<:<::<:<:<<<<<<<<<<;;<<<<:<<<;<<<<<<;<<<<:+<O<<<<;<<:<:<<:<<<:<::<:::<<<:::<<<:::<<<<;:::<::<:<<<<::::<<:<::<<<<:<:O:+<:<:::<::<:<<<<<<<<<<<::<:::<::::<<:<:<<;:;;::;:;:<:<<::::<::::<<<:<;:;:<::<::<:<:::<::<:::<<::<<<<:+::::<<<<<<::::::::::::<:::::<<<<<<<<<<<<<::::::<<<<:<::<::::::::::::::::::::::::::", +":::::::::::::::::::::::::::<::<:<::<::<:<::::::::<<:::::::::::;;::::<;+::+:::;::;<:<;:::<:<:::;;:::::<:::<;<::::<::<<:<<<<<::<::<;:;:::::::::::<::::::::::::<;;::;:::+::;::<;::<:::;:;::<:<:::::::<;<<::::+:;::<::::::::<:<<<<<:<:<::::::::<::;:::<:<;:::<<:;:;:::::::<::::::<<<<:+:;:::::;::;:<:<::;;:::;:<;<<<<::<<<<<<<:::::::::::::::<::<:<<<<:<:::<:<<<<<<<<<<<:<::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::<::::::::::;;:::::::::::::::<:<;<:::;::<:::::::::::<<:<:::<:::::<::<:::::::::::::::::::<:<:::<:::::<::::::::::::::::<:<:::::::::::::::;::::::::::::::::::<::::<:::::<:<:::::<:::::<::<:<:<:<:::::<:::::::::<<<:+:::::::<::::<:;;;;;<:;::::<:<<:::::::::::::;<<::;:::::::::::::::::::::<::<::::<::::<:<:::::<:<:::<:<:<:::<:<:::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::<::::<:::::::::::::::<:::::::::::<:::::<<:;<<:<<<::::::::::::<:::::<::::::::::::<<:::<:<:::<:::<::<::<:<;::::::;::::::::<::::::<<:::::::::::<::::;:<::::::::::::<::<:::::::::<:::<:<:::::::::::::::::::::::::::<:::::<:::<;:::::<::<::::::::::<:;:<::<:::::::::::::::<;:<<:<:::::::::::::::::::::::::::::::::<:::<:<::::::::::::::<:::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::<::::::::::<::<<::::::<;:::;<:<:::;::<;:::::::<:::<<:::::<:<;::<::::::::::::::::<::::<:<:::::::<::::<:::::::::<<::::<;:::::::<:::::::<:::::::<::;::::::::::::::::::::::<:<:::<:::::<:<:::::::<;<:<::<:::::::::::::<<:<<::;:<::<<::::<:<::::::::;:<::<:::<:<::::<:<;:::::::<:<:::::::::<:<::::::::::::::<:<::::::::<::<::::::::<::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::<::::::<;;<::::<:;::::<<;:<:::<;;<:<:;<::;::::;:<;:::<:<:<::::<::::::;::<::::<::::::<::::::<:::::::;::::<;::::<<;:<::;;:<;;:::;;;<:;;::<:;::;;;;<::::<:<:::<::::::<::<:::::::::::<;<::<::::::<:;<:;;<:::;;:::;<<:::<<;;;;::::::::::;<<:::<::;;:::::;;:<;::<;;<:<::;::::::::::::::::::::<:::<:::::<:<::::::::::::::::::<:<::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::<:::::::::::::<:::::<<::::::::::<::::::<:::::<::::<::::::<::::::::<:::::::::::::<:::::<<:<:<:::::::::::<:<:::<<:::::<:::::::::::::::::::::::::::::::::::::::::::::::::<::::::<:<:::<::::::::::::::::::::::<::::::::::::<:::<:::::::::::::::<:<:::::::::::::::::<:::::::::::::::::::<:::::::::::<::::::::::::::<:<::<:::::<::::::::<:<:::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::;;::::::;;:<:::<:::::<:::::::::::::::<:::<::<:::::::::::::::::::::::::<:::::::::::::::::::::::::;;<::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::<:<::<::::::::<::::::::<::::::::::::<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::<::::::::::::::::<:::<:::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::<::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::<::<:<::::::::::<:<::::::::::::<::::::::::::::::::::::::::<:::::::::::::::::::::::::::::<:::::<:::::::::::::::::::<:::::::::::::::<:<::::::::::::::::::::::::::<:::::::::<:::::::::::::::::<::::::::::::::::::::::<:::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::<::::::::::::::<:::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::<:::::::::::::::::::::::<::::::::::<:<:<::::::::::::::::::::::::::::::::::<:::::<::::::::::::::::::::::::::::<::::::::::::<::<::<::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::<::<:::::::::::::<:::<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::<::::::::::<:<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::::::<::<:::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::<::::::::::::::::::::::::::::::::::::<::::::::::::::::<::<::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::<::::<:::::::::::::::::::::<:::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<::<::::::::::::::::::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::<:::::<:::::::::::::::::::::<::::::::::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::::::::::<:::::<<::<:::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::::::::::::::::::::::::::<::::::::::::::<::::<:::::::::::::::<:<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::<:::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::<:<:<::<:<::::::::::<<:::::::::::::::::::<::::::::::::::::::::::<:<::::::<:::::<:<::::::::::::::::::::::::::::::::::<::::::::::::::::::::::::::::<::::::::::::::::::::::::<<::::::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::<::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::<:::::::::::::::::::<::::<::::::<::::::<::::::::::::::::::::<:::::::<:::::::::::::::<:::::<::;:::<:<;:::::::::::::::::::::::<::::<::::<::::::<:::::::::::::::<:::::::::::::::::::::::::::::::<::::::::::<:::::::<::::::::::::::::::::::::::::::::::::::::::<::::<::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::<:::::<<:::::<::::::<:<::::::::::::<<<:::<:<::::<<<<:::<<<:<:::::<:::::<::::::<::::::::::::::::::::::::::::<:::::::<<<:::<<<<<::<<<<<<::::<:::::::::::<<<:<<::::<<:::::<<:<::::<::::::<::::::<::::::::::::::::::::::::::::::::::::::::::::<:::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::::<<:::<<<<<:::::<::::::<:::::::::::<:<<<<::<<<<<::<<<<:::<<<<<<::::<:::::<<<:::::<:<::::::::::::::::::::::::::::::::::<<<::<<<<<::<:<:<<<:::<:::::::::::<:<:<<<:::<<:<::<<<:<::<<<<<::::<:::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<::::::<:::::::::::<<<<<:::<:::<:::<:::::<<:<:<::::<::::::::<::::::::::::::::::::::::::::::::::::::::<::<:::<::::::::<::<:::<::::::::::::::<::<:<::::<:<::::<::<<<<<::::<:::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<:::::::<::::::::::<<<<<<::::::<:::<:::::<<:<:<::::<::::::::<::::::::::::::::::::::::::::::::::::::::<::<:::<::::::<:<::<:::<::::::::::::<:<::<:<::::<:<::::<::<<<<<::::<:::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<::::::<:::::<<::::<::::::<:::<:::<:::::<:::::::::<::::<<<<::::::::::::::::::::::::::::<::::::::::::<::<:::<::::::<:<::<:::<::::::::::::<:<::<:<<::<:::<::<<:::::::::::<::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::::::::::<:::::::<::::<<:::::<<<:::<<:<<<:::<<<::<<:<::<:<<<<<::::<::::::::::::::::::::::::::::<<:::::::::::<<::<<:::<<<::<<:<<:<:<<<<<:::::::::<<:<::<:::<<<::::<<<<<::<<<:::::<::::::<::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::<::::::<:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::", +"::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::" +};
--- a/info/dir Mon Aug 13 10:02:48 2007 +0200 +++ b/info/dir Mon Aug 13 10:03:52 2007 +0200 @@ -34,6 +34,8 @@ * Menu: +XEmacs 20.4 +=========== * Info:: Documentation browsing system. * XEmacs:: The extensible user-friendly self-documenting text editor. This manual is for XEmacs 20.3. @@ -75,7 +77,6 @@ TeX) or an Info file (through texinfo). * Viper:: A VI Plan for Emacs Rescue and a venomous VI PERil. * Vhdl-mode:: A major mode for editing VHDL files. -* VM:: View Mail, a replacement for Rmail. * Widget:: An Emacs Lisp widget library * tm-en:: Tools for Mime (English version) * tm-mh-e-en:: Tools for Mime for MH-E (English version)
--- a/lib-src/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,3 +1,18 @@ +1997-10-30 SL Baur <steve@altair.xemacs.org> + + * update-autoloads.sh (mule_p): EFS has been packaged. + * update-elc.sh (make_special_commands): Ditto. + + * update-elc.sh: VM has been packaged. + + * update-autoloads.sh: Add directory language + +1997-10-23 SL Baur <steve@altair.xemacs.org> + + * update-elc.sh (BYTECOMP): Specify -vanilla + * update-autoloads.sh (dirs): Ditto. + * update-custom.sh (dirs): Ditto. + 1997-10-10 Martin Buchholz <mrb@eng.sun.com> * config.values.in: Run config.values.sh
--- a/lib-src/config.values.in Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/config.values.in Mon Aug 13 10:03:52 2007 +0200 @@ -63,6 +63,7 @@ infodir "@infodir@" infodir_user_defined "@infodir_user_defined@" infopath "@infopath@" +infopath_user_defined "@infopath_user_defined@" internal_makefile_list "@internal_makefile_list@" ld "@ld@" ld_libs_all "@ld_libs_all@"
--- a/lib-src/digest-doc.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/digest-doc.c Mon Aug 13 10:03:52 2007 +0200 @@ -5,10 +5,10 @@ See also sorted-doc.c, which produces similar output but in texinfo format and sorted by function/variable name. */ -#include <stdio.h> #ifdef emacs #include <../src/config.h> #endif +#include <stdio.h> int main ()
--- a/lib-src/gnuslib.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/gnuslib.c Mon Aug 13 10:03:52 2007 +0200 @@ -33,8 +33,8 @@ static char rcsid [] = "!Header: gnuslib.c,v 2.4 95/02/16 11:57:37 arup alpha !"; #endif +#include "gnuserv.h" #include <errno.h> -#include "gnuserv.h" #ifdef SYSV_IPC static int connect_to_ipc_server (void);
--- a/lib-src/make-path.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/make-path.c Mon Aug 13 10:03:52 2007 +0200 @@ -26,15 +26,15 @@ command on some of the purer BSD systems (like Mt. Xinu) don't have that option. */ +#ifdef emacs +#include <../src/config.h> +#endif + #include <sys/types.h> #include <sys/stat.h> #include <stdio.h> #include <errno.h> -#ifdef emacs -#include <../src/config.h> -#endif - extern int errno; char *prog_name;
--- a/lib-src/update-autoloads.sh Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/update-autoloads.sh Mon Aug 13 10:03:52 2007 +0200 @@ -62,7 +62,7 @@ # Compute patterns to ignore when searching for files # These directories don't have autoloads or are partially broken. -ignore_dirs="egg eos ilisp its language locale mel mu sunpro term tooltalk" +ignore_dirs="egg eos ilisp its locale mel mu sunpro term tooltalk" # Prepare for autoloading directories with directory-specific instructions make_special_commands='' @@ -76,7 +76,7 @@ # Only use Mule XEmacs to build Mule-specific autoloads & custom-loads. echon "Checking for Mule support..." lisp_prog='(princ (featurep (quote mule)))' -mule_p="`$EMACS -batch -no-site-file -eval \"$lisp_prog\"`" +mule_p="`$EMACS -batch -vanilla -eval \"$lisp_prog\"`" if test "$mule_p" = nil ; then echo No ignore_dirs="$ignore_dirs mule leim" @@ -91,7 +91,8 @@ # make_special auctex autoloads MULE_EL=tex-jp.elc # fi #make_special cc-mode autoloads -make_special efs autoloads +# EFS is now packaged +#make_special efs autoloads #make_special eos autoloads # EOS doesn't have custom or autoloads make_special hyperbole autoloads # make_special ilisp autoloads @@ -115,7 +116,7 @@ # set -x for dir in $dirs; do - $EMACS -batch -q -l autoload -f batch-update-directory $dir + $EMACS -batch -vanilla -l autoload -f batch-update-directory $dir done eval "$make_special_commands"
--- a/lib-src/update-custom.sh Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/update-custom.sh Mon Aug 13 10:03:52 2007 +0200 @@ -72,7 +72,7 @@ # Only use Mule XEmacs to build Mule-specific autoloads & custom-loads. echon "Checking for Mule support..." lisp_prog='(princ (featurep (quote mule)))' -mule_p="`$EMACS -batch -no-site-file -eval \"$lisp_prog\"`" +mule_p="`$EMACS -batch -vanilla -eval \"$lisp_prog\"`" if test "$mule_p" = nil ; then echo No ignore_dirs="$ignore_dirs mule leim" @@ -97,4 +97,4 @@ done echo done -$EMACS -batch -q -l cus-dep -f Custom-make-dependencies $dirs +$EMACS -batch -vanilla -l cus-dep -f Custom-make-dependencies $dirs
--- a/lib-src/update-elc.sh Mon Aug 13 10:02:48 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 10:03:52 2007 +0200 @@ -61,11 +61,11 @@ fi REAL=`cd \`dirname $EMACS\` ; pwd | sed 's|^/tmp_mnt||'`/`basename $EMACS` -BYTECOMP="$REAL -batch -q -no-site-file " +BYTECOMP="$REAL -batch -vanilla " echo "Recompiling in `pwd|sed 's|^/tmp_mnt||'`" echo " with $REAL..." -$EMACS -batch -q -l `pwd`/lisp/prim/cleantree -f batch-remove-old-elc lisp +$EMACS -batch -vanilla -l `pwd`/lisp/prim/cleantree -f batch-remove-old-elc lisp prune_vc="( -name SCCS -o -name RCS -o -name CVS ) -prune -o" @@ -91,7 +91,7 @@ # Only use Mule XEmacs to compile Mule-specific elisp dirs echon "Checking for Mule support..." lisp_prog='(princ (featurep (quote mule)))' -mule_p="`$EMACS -batch -no-site-file -eval \"$lisp_prog\"`" +mule_p="`$EMACS -batch -vanilla -eval \"$lisp_prog\"`" if test "$mule_p" = nil ; then echo No ignore_dirs="$ignore_dirs its egg mule language leim" @@ -109,13 +109,6 @@ echo "Checking the byte compiler..." $BYTECOMP -f batch-byte-recompile-directory lisp/bytecomp -# Byte-compile VM first, because other packages depend on it, -# but it depends on nothing (Kyle is like that). -ignore_dirs="$ignore_dirs vm" -echo "Compiling in lisp/vm"; -(cd lisp/vm && ${MAKE:-make} EMACS=$REAL autoload) -echo "lisp/vm done." - # Prepare for byte-compiling directories with directory-specific instructions make_special_commands='' make_special () { @@ -134,7 +127,8 @@ # make_special auctex some MULE_ELC=tex-jp.elc # fi #make_special cc-mode all -make_special efs x20 +# EFS is now packaged +# make_special efs x20 make_special eos -k # not strictly necessary... ## make_special gnus some # Now this is a package. make_special hyperbole elc
--- a/lisp/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,3 +1,852 @@ +1997-10-30 SL Baur <steve@altair.xemacs.org> + + * vm/vm-vars.el (vm-image-directory): Use locate-data-directory if + it exists. + + * language/european.el: Remove erroneous references to + `Serbo-Croatian'. + * language/cyril-util.el: Ditto. + * leim/quail/cyrillic.el: Ditto. + + * comint.el: reverse previous patch + +1997-10-29 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule/mule-init.el (init-mule): Load locale-start even if lang is + not exactly matched. + + * mule/mule-init.el (auto-language-alist): Modify for new language + environment feature. + (init-mule): Modify for new language environment feature. + +1997-10-29 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/korean.el (setup-korean-environment): Modify for + XEmacs. + + * language/greek.el: Modify setting about language environment. + + * language/european.el: Fix setting for Croatian language + environment. + + * language/vietnamese.el: Fix setting about language environment. + + * language/viet-util.el (setup-vietnamese-environment): Modify for + XEmacs. + + * language/cyril-util.el (setup-cyrillic-iso-environment): Modify + for XEmacs. + (setup-cyrillic-koi8-environment): Modify for XEmacs. + (setup-cyrillic-alternativnyj-environment): Modify for XEmacs. + +1997-10-28 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/hebrew.el (setup-hebrew-environment): Modify for + XEmacs. + + * mule/mule-cmds.el (set-default-coding-systems): New function. + (set-language-info): Fix about menu. + (read-input-method-name, toggle-input-method): Sync with Emacs + 20.2. + + * language/cyril-util.el: Modify header. + + * language/cyril-util.el + (setup-cyrillic-alternativnyj-environment): Modify for XEmacs. + + * language/cyril-util.el: New file; imported from Emacs 20.2. + + * language/japan-util.el (setup-japanese-environment): Use + `set-default-coding-systems'. + + * language/european.el (setup-8-bit-environment): Modify for + XEmacs. + + * language/english.el (setup-english-environment): Use + `set-default-coding-systems'. + + * language/chinese.el: Modify for XEmacs. + + * language/china-util.el (setup-chinese-gb-environment, + setup-chinese-big5-environment): Use `set-default-coding-systems'. + + * mule/mule-files.el (file-coding-system-alist): Fix typo. + +1997-10-28 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * prim/dumped-lisp.el: Abolish Thai support temporary. + + * language/thai.el, language/thai-util.el: Delete Thai specific + files because composite character features don't work in XEmacs. + + * language/japan-util.el: Modify header. + + * language/chinese.el: Abolish `Chinese-CNS' environment + temporary. + + * language/china-util.el: Abolish `setup-chinese-cns-environment' + temporary. + + * language/china-util.el (setup-chinese-big5-environment): Modify + for XEmacs. + + * language/china-util.el (setup-chinese-gb-environment): Modify + for XEmacs. + + * language/chinese.el: Delete set-coding-category-system for big5. + + * language/japan-util.el (setup-japanese-environment): Modify for + XEmacs. + + * language/japanese.el: Delete set-coding-category-system for + shift-jis. + + * language/english.el (setup-english-environment): Modify for + XEmacs. + +1997-10-28 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/auto-autoloads.el: New file. + + * mule/mule-files.el (file-coding-system-alist): Add setting for + TUTORIAL.hr to iso-8859-2. + + * leim/quail/tibetan.el, leim/quail/ethiopic.el, + leim/quail/japanese.el, leim/quail/lao.el, leim/quail/lrt.el, + leim/quail/devanagari.el: Delete broken features temporary. + + * language/tibetan.el, language/indian.el, language/lao-util.el, + language/lao.el, language/tibet-util.el, language/ethio-util.el, + language/ethiopic.el, language/devanagari.el: Delete broken + features temporary. + + * mule/mule-cmds.el (universal-coding-system-argument): New + function; imported from Emacs 20.2. + +1997-10-27 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/korean.el, language/thai.el, language/vietnamese.el, + language/chinese.el, language/japanese.el, language/arabic.el, + language/ethiopic.el: Abolish setting for old language + environment. + + * language/hebrew.el: Modify for XEmacs. + + * Use language/hebrew.el instead of mule/hebrew-hooks.el; abolish + mule/hebrew-hooks.el. + + * mule/mule-misc.el: Abolish old language environment features. + + * mule/mule-init.el: Delete old language environment specific + features temporary. + + * prim/dumped-lisp.el: Use language/hebrew.el instead of + hebrew-hooks.el. + + * mule/mule-cmds.el (describe-language-environment): Modify for + XEmacs because `coding-system-mnemonic' returns string instead of + character in XEmacs. + + * mule/mule-cmds.el: Sync with Emacs 20.2 about language + environment. + + * mule/mule-cmds.el: Don't use `mule-prefix'. + +1997-10-26 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/ethiopic.el (ccl-encode-ethio-font): Modify to sync + with Emacs 20.2. + +1997-10-26 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule-diag.el (list-coding-systems): Modify for XEmacs. + +1997-10-26 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule/mule-files.el (find-coding-system-magic-cookie): Regard top + line magic. + (load): Use `find-file-coding-system-for-read-from-filename'. + + * language/arabic-util.el: Use iso-2022-7bit. + +1997-10-26 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule-diag.el (describe-designation): Moved from mule-debug.el. + (describe-coding-system): Use `describe-designation'. + + * mule-debug.el: Move function `describe-designation' to + mule-diag.el; Abolish function `describe-coding-system' because of + using it in mule-diag.el. + + * mule-coding.el (keyboard-coding-system): New inline function. + (terminal-coding-system): New inline function. + + * mule-cmds.el: Bind `describe-coding-system' to C-h C instead of + `describe-current-coding-system' to sync with Emacs 20.2. + + * mule-diag.el: Abolish `print-designation' because it does not + work in XEmacs. + + (describe-coding-system): Modify for XEmacs. + (print-coding-system-briefly): Modify for XEmacs. + (describe-current-coding-system): Modify for XEmacs. + + * mule-coding.el: Abolish function `coding-system-charset' + (defined as builtin function). + + * mule-diag.el: New file; imported from Emacs 20.2. + + * mule-misc.el (set-buffer-process-coding-system): New function; + imported from mule.el of Emacs 20.2. + + * mule-cmds.el: Bind `set-buffer-process-coding-system' to C-x C-m + p and abolish C-x C-m P. + + * mule-files.el (load): Use `binary' instead of `no-conversion'. + +1997-10-28 Kyle Jones <kyle_jones@wonderworks.com> + + * modes/enriched.el (enriched-face-ans): Use + color-name instead of color-instance-name. + color-instance-name will not handle the specifiers that + are passed as arguments. + +1997-10-28 Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu> + + * prim/find-func.el (find-function-noselect): Fix nil argument + handling and add support for dumped macros. + +1997-10-28 SL Baur <steve@altair.xemacs.org> + + * pcl-cvs/pcl-cvs-xemacs.el: Add `cvs-mode-update-no-prompt' to menu. + From Stig Bjorlykke <stigb@tihlde.hist.no> + +1997-10-28 Didier Verna <verna@inf.enst.fr> + + * packages/man.el (manual-entry): corrected the `when' + form to include 'section' in the buffer name. + +1997-10-28 SL Baur <steve@altair.xemacs.org> + + * prim/packages (packages-find-pacakges): Fix test on + inhibit-package-init + +1997-10-27 Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu> + + * prim/keymap.el (event-apply-modifier): Fix the return type and + scan the function-key-map. + (next-key-event): New function. + (key-sequence-list-description): Ditto. + +1997-10-27 SL Baur <steve@altair.xemacs.org> + + * x11/x-menubar.el: Turn off `popup-menubar-menu' keybinding. + + * prim/dumped-lisp.el (preloaded-file-list): Dump canna-leim and + egg-leim with XEmacs. + + * mule/canna-leim.el: Clean up file for dumping with XEmacs. + * egg/egg-leim.el: Ditto. + +1997-10-27 Stephen J. Turnbull <turnbull@sk.tsukuba.ac.jp> + + * mule/canna-leim.el: Register Canna with LEIM when loaded + + * mule/canna.el (canna): Bind `canna-toggle-japanese-mode' to + "\C-o" only if LEIM is not present + + * egg/egg-leim.el: Registers EGG/Wnn with LEIM when loaded + + * egg/egg.el: Bind `toggle-egg-mode' to "\C-\" only if LEIM is + not present when loaded + +1997-10-27 SL Baur <steve@altair.xemacs.org> + + * prim/about.el: Update entries + +1997-10-26 SL Baur <steve@altair.xemacs.org> + + * prim/startup.el (startup-message-timeout): Startup message + timeout is too short. + + * mule/canna.el (canna): Move canna-toggle-japanese-mode + keybinding to C-\. + + * emulators/edt-mapper.el (edt-lucid-emacs19-p): Test for XEmacs + instead of Lucid in `emacs-version'. + +1997-10-25 SL Baur <steve@altair.xemacs.org> + + * mule/mule-cmds.el: describe-language-support, + describe-language-support-internal removed. + +Fri Aug 8 12:58:00 1997 David Byers <davby@sen2.ida.liu.se> + + * fill.el (fill-region-as-paragraph): When justifying, check for + end-of-buffer at the end of whitespace point is sitting in, and + delete the trailing whitespace if we are on the last line. + +1997-10-24 Hrvoje Niksic <hniksic@srce.hr> + + * prim/about.el (about-finish-buffer): Kill the buffer, when + button documents so. + +1997-10-24 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * pcl-cvs.el (cvs-parse-stderr): Ignore ssh-askpass message. + +1997-10-20 Hrvoje Niksic <hniksic@srce.hr> + + * prim/packages.el (locate-library): Make NOSUFFIX not affect + compression. + +1997-10-24 SL Baur <steve@altair.xemacs.org> + + * modes/c-comment.el: Create c-comment-edit-map. + (c-comment-edit): Fix docstring, use new keymap. + Suggested by Chris Felaco <felaco@iatcmail.ed.ray.com> + + * prim/help-nomule.el (tutorial-supported-languages): Add + Norwegian. + + * prim/simple.el (assoc-ignore-case): Synch with Emacs 20.1. + + * mule/mule-cmds.el (set-language-info): Forgot to set any data + values in language-alist. + (read-multilingual-string): Fix call to `read-string'. + +1997-10-22 Karl M. Hegbloom <karlheg@inetarena.com> + + * packages/backup-dir.el (bkup-backup-directory-info): customized, + with :require so it loads automagicly if you've set it. Docstring + updated to reflect that, and reformatted for easier reading. + + * packages/jka-compr.el (jka-compr-compression-info-list): + Docstring clarification: what does the append flag do? + + * prim/minibuf.el (minibuffer-electric-slash): leave efs prefix + and ~\(blah\)? when / is pressed. + +1997-10-24 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * efs/dired.el (dired-create-files): Get mark-char thing working + again: replace `integerp' by `characterp'. + (dired-add-entry): Ditto. + (dired-add-entry-do-indentation): Ditto. + +1997-10-24 Hrvoje Niksic <hniksic@srce.hr> + + * x11/x-faces.el (*try-oblique-before-italic-fonts*): Customized. + +1997-10-23 SL Baur <steve@altair.xemacs.org> + + * prim/startup.el (command-line-do-help): Add Documentation for + -vanilla and -no-packages. + (command-line-early): Implement them. + + * prim/packages.el (inhibit-package-init): New variable. + (packages-find-packages): Use it. + + + * packages/jka-compr.el (jka-compr-compression-info-list): + Add bzip2 extensions. + From Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu> + +1997-10-22 Karl M. Hegbloom <karlheg@inetarena.com> + + * comint/comint.el (comint-scroll-show-maximum-output): fixups to + docstring, and to :type to allow numbers. + (comint-postoutput-scroll-to-bottom): Added window arg to + `recenter' call to fix the horrid flash and global recentering, + and uncommented the code allowing numeric values for + `comint-scroll-show-maximum-output'. + +1997-10-23 Hrvoje Niksic <hniksic@srce.hr> + + * packages/info.el (Info-mode): Don't initialize faces. + + * packages/info.el: Use `defface' to initialize faces. + +1997-10-23 Karl M. Hegbloom <karlheg@inetarena.com> + + * modes/cperl-mode.el (cperl-here-face): fix the horrible invisible + green default face. + +1997-10-23 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (widget-choose): Acknowledge aborted choice + with a `Canceled' message, even if C-g wasn't pressed explicitly. + +1997-10-23 Per Abrahamsen <abraham@dina.kvl.dk> + + * custom/cus-edit.el (hook): Use `widget-group-match' instead of + `widget-editable-list-match'. + +1997-10-23 SL Baur <steve@altair.xemacs.org> + + * modes/c-comment.el (c-comment-edit): Fixed autoload cookie. + Reformatted Lisp comments. + +1997-10-22 SL Baur <steve@altair.xemacs.org> + + * psgml/psgml-charent.el (sgml-display-char-list-filename): Use + locate-data-directory instead of data-directory. + * psgml.el (sgml-data-directory): Ditto. + +1997-10-20 Jan Vroonhof <vroonhof@math.ethz.ch> + + * extents.c: Renamed shot property to initial-redisplay-function + (extent_fragment_update): Changed the bookkeeping whether an event + has been spawned. The initial-redisplay-function property is no + longer set to nil. + +1997-10-21 SL Baur <steve@altair.xemacs.org> + + * custom/cus-dep.el (Custom-make-dependencies): Ditch the time + stamp. + +1997-10-22 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * comint/gdb.el (gdb-with-core): Fixed autoload cookie. + +1997-10-22 Hrvoje Niksic <hniksic@srce.hr> + + * prim/startup.el (command-line-1): Run term-setup-hook regardless + of `input-pending-p'. + + * custom/cus-edit.el (custom-split-regexp-maybe): Use `split-string'. + + * custom/cus-start.el (custom-start-quote): Synch with + `custom-quote'. + + * prim/subr.el (functionp): Synched docstring with Emacs 20.2. + + * custom/cus-edit.el (custom-quote): Use `keywordp'; use + `car-safe'; don't conditionalize on having `characterp'. + +1997-10-21 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (radio-button): Use "radio0" as inactive + glyph. + (widget-visibility-value-create): Use new semantics of + `widget-glyph-insert'. + + * custom/cus-edit.el (custom-buffer-create-internal): Setup + tag-down-glyphs with list. + (custom-group-value-create): Ditto. + + * custom/wid-edit.el (widget-glyph-click): Check whether the + extent was detached/killed. + (widget-push-button-value-create): Removed crufty XPM contrast + hack. + (widget-default-create): Make the markers point nowhere after + using them. + (widget-default-create): Use `point-min-marker'/`point-max-marker'. + (widget-glyph-find): Disallow list. + (widget-glyph-insert): Allow IMAGE to be a list. + +1997-10-20 Hrvoje Niksic <hniksic@srce.hr> + + * prim/featurep.el (featurep): Handle `not' correctly. + +1997-10-21 SL Baur <steve@altair.xemacs.org> + + * prim/about.el (about-maintainer-glyph): Pictures have been moved + to photos subdirectory. + +1997-10-21 Hrvoje Niksic <hniksic@srce.hr> + + * x11/x-menubar.el (options-menu-saved-forms): Check whether + `pending-delete' is bound before accessing it. + +1997-10-21 SL Baur <steve@altair.xemacs.org> + + * x11/x-menubar.el (default-menubar): Conditionalize games menu. + +1997-10-21 Colin Rafferty <craffert@ml.com> + + * x11/x-menubar.el (default-menubar): Made it use lazy-shot + instead of lazy-lock in "Syntax Highlighting->Lazy". + (options-menu-saved-forms): Made it save lazy-shot instead of + lazy-lock in the options. + +1997-10-21 SL Baur <steve@altair.xemacs.org> + + * mule/mule-help.el (help-with-tutorial): New file. + + * prim/dumped-lisp.el (preloaded-file-list): New entries for + help-nomule and mule-help. + + * prim/help.el: Remove `help-with-tutorial'. + + * prim/help-nomule.el: New file. + +1997-10-19 Hrvoje Niksic <hniksic@srce.hr> + + * prim/subr.el: Moved int-char and char-int definitions from + obsolete.el. + +1997-10-18 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (widget-push-button-value-create): Require + `xpm-button'. + (widget-push-button-value-create): Use :tag-down-glyph and + :tag-inactive-glyph. + (widget-default-create): Use :tag-inactive-glyph. + (widget-button-click): Correctly merge faces. + + * custom/cus-edit.el (custom-variable-action): Don't redraw + magic. + + * custom/wid-edit.el (widget-glyph-insert): Return glyph. + (widget-default-create): Insert :button-prefix and :button-suffix + only if a glyph is not used. + (widget-glyph-click): Respect :mouse-down-action. + (widget-specify-insert): Document for edebug. + (widget-default-create): Use markers to keep track of stuff. + + * custom/cus-edit.el (custom-group-value-create): Ditto. + + * custom/wid-edit.el (widget-default-create): Use :tag-down-glyph. + + * custom/cus-edit.el (custom-group-value-create): Use image. + + * prim/glyphs.el (init-glyphs): Minor fixups. + +1997-10-17 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (widget-field-value-get): Use `cond'. + (default): Use :button-keymap. + (widget-specify-button): Ditto. + (widget-glyph-insert-glyph): Ditto. + (widget-activation-glyph-mapper): Renamed from + `widget-activation-glyphs-mapper'. + + * custom/cus-edit.el (Custom-mode-menu): Go to `Easy + Customization' node. + (boolean): Don't use nested backquotes. + + * custom/wid-edit.el (widget-field-action): Check whether the new + value is valid before using it. + +1997-10-16 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (character): Use [\0-\377] instead of . in + :valid-regexp. + (widget-color-notify): Use `valid-color-name-p'. + (widget-activation-widget-mapper): New function. + (widget-specify-inactive): Use it. + (widget-specify-active): Ditto. + (widget-setup): Ditto. + (radio-button): Added :inactive-glyph spec. + (widget-toggle-value-create): Use it. + (widget-color-sample-face-get): Check for color before setting it. + (widget-color-sample-face-get): Store the face object, not its + name. + +1997-10-18 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * help.el (function-at-point): Use `function-at-point-function'. + (function-at-point-function): New variable, formerly + `find-function-function'. + (describe-function): Use `function-at-point'. + (where-is): Ditto. + + * find-func.el (find-function-read-function): Use + `function-at-point'. + + * packages/info.el (Info-elisp-ref): Use `function-at-point'. + + * packages/hyper-apropos.el (hyper-apropos-read-function-symbol): + Use `function-at-point'. + + * packages/etags.el (emacs-lisp-default-tag): Use + `function-at-point'. + + * prim/obsolete.el (function-called-at-point): Make it + obsolete. + +1997-10-09 Jens-Ulrik Holger Petersen <petersen@kurims.kyoto-u.ac.jp> + + * prim/files.el (switch-to-buffer-other-frame): Remove call to + `select-frame'. + +1997-10-17 SL Baur <steve@altair.xemacs.org> + + * prim/packages.el (packages-find-packages-1): New argument: + `user-package' non-nil when searching user packages. + - Load any autoloads found in user packages. + +1997-10-17 Karl M. Hegbloom <karlheg@inetarena.com> + + * packages/info.el (Info-insert-dir): Also kill the localdir temp + buffers. + +1997-10-17 SL Baur <steve@altair.xemacs.org> + + * utils/facemenu.el: autoload the `facemenu-keymap' properly. + + * mule/mule-cmds.el (read-language-name): Fix typo. + From Didier Verna <verna@inf.enst.fr> + +1997-10-15 Adrian Aichner <aichner@ecf.teradyne.com> + + * utils/build-report.el: Leaving point at begin of composed mail now. + Using mime-edit-content-beginning to determine file-begin of + Installation file. + Introduced the according alias for SEMI/TM compatibility. + + * utils/build-report.el: + Corrected backward search for begin of last configuration in + Installation file. + + * utils/build-report.el: + Incorporated `xemacs-build-report-installation-insert-all' feature + suggested by Didier Verna. + Composing mail parts (with-temp-buffer ...) to simplify implementing + future features. + Eliminated use of mail-mode -specific function `mail-text'. + +1997-10-14 Adrian Aichner <aichner@ecf.teradyne.com> + + * utils/build-report.el: + Incorporated fix for SEMI/TM compatibility suggested by Jens-Ulrik + Holger Petersen <petersen@kurims.kyoto-u.ac.jp>. If SEMI symbols are + not fboundp, alias them to corresponding TM symbols. + +1997-10-13 Adrian Aichner <aichner@ecf.teradyne.com> + + * utils/build-report.el: + Changed to (mime-edit-insert-tag "text" "plain" ...) from + "application" "octet-stream" due to complaint from + Kazuyoshi Furutaka in + Message-Id: <19971013102132V.furutaka@Flux.tokai.jaeri.go.jp> + +1997-10-13 Hrvoje Niksic <hniksic@srce.hr> + + * utils/facemenu.el: Autoload `facemenu-keymap' function definition. + (facemenu-color-defined-p): Nuked. + (facemenu-find-face): Ditto. + (facemenu-region-active-p): Ditto. + (facemenu-sized-face): Declare `prefix'. + (facemenu-read-color): Aliased to `read-color'. + (facemenu-face-attributes): Use `mapvector'. + + * utils/facemenu.el: Customized and synched with FSF 20.2. + +1997-10-17 Hrvoje Niksic <hniksic@srce.hr> + + * cl/cl-macs.el (extent-properties): Remove old setf method. + +1997-10-16 Karl M. Hegbloom <karlheg@inetarena.com> + + * prim/files.el (revert-without-query): changed from boolean to + list of regexp as documented in NEWS and its docstring. + +1997-10-16 SL Baur <steve@altair.xemacs.org> + + * utils/floating-toolbar.el: (TopLevel): Don't unconditionally + require the feature `toolbar' it causes breakage only at + bytecompile time. Don't do any initialization if toolbar support + is not available. + (floating-toolbar): Whine if no run-time toolbar support is + available. + + * custom/wid-edit.el (widget-change-glyphs-mapper): cosmetic changes. + From Hrvoje Niksic <hniksic@srce.hr> + + * prim/glyphs.el (init-glyphs): Use different logo for beta XEmacsen. + From Didier Verna <verna@inf.enst.fr> + +1997-10-15 Hrvoje Niksic <hniksic@srce.hr> + + * cl/cl-macs.el (extent-property): Updated SETF methods for `get' + and `extent-property'. + + * custom/wid-edit.el (widget-field-value-create): Revert to using + two markers. + (widget-setup): Ditto. + (widget-color-sample-face-get): Get only a unique face per widget. + (widget-color-notify): Change the color of the face instead of + creating a new one. + + * packages/add-log.el (add-change-log-entry): Push window + configuration. + (change-log-exit): New function. + (change-log-cancel): Ditto. + (change-log-mode-map): Bind them. + + * custom/wid-edit.el (widget-specify-inactive): Make glyphs look + inactive. + (widget-change-glyphs-mapper): New function. + (widget-glyph-click): Disallow operations on inactive glyphs. + +1997-10-14 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el: (widget-glyph-insert-glyph): Use + `widget-mouse-help' if necessary. + (widget-documentation-string-value-create): Don't coerce help-echo + WIDGET to widget. + (widget-button-keymap): New keymap. + (widget-specify-button): Use it. + (widget-glyph-insert-glyph): Ditto. + (widget-glyph-click): Dispatch events during the loop. + (widget-glyph-click): Use `unwind-protect' to ensure that the + glyph stays in up position. + (widget-keymap): Don't bind buttons and RET. + (widget-button-keymap): Bind mouse buttons and RET. + (widget-field-activate): Use `widget-field-find'. + + * custom/wid-edit.el (widget-button-click): Visually "release" the + button *before* doing the buttonup action. + (widget-button-click): Reworked. + (widget-echo-help): Accept extent. + + * custom/cus-edit.el (custom-face-value-create): Use `make-face'. + + * custom/wid-edit.el (widget-restore-tabable): New function. + (widget-deactivate-widget-extent): New function. + (widget-reactivate-widget-extent): New function. + (widget-specify-inactive): Use `widget-deactivate-widget-extent'. + (widget-setup): Ditto. + (widget-specify-active): Use `widget-reactivate-widget-extent'. + (widget-move): Don't stop within inactive range. + +1997-10-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/japan-util.el: Copied from Emacs 20.2. + + * mule/mule-cmds.el (char-code-property-table): New variable. + (get-char-code-property): New function. + (put-char-code-property): New function. + +1997-10-10 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/vietnamese.el: Use language/viet-util.el instead of + mule/mule-vietnamese.el; abolish mule/mule-vietnamese.el. + +1997-10-09 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule/mule-coding.el: Rename `automatic-conversion' -> + `undecided' to sync with Emacs 20.2; define coding-system + `automatic-conversion' as an alias for `undecided'. + + mule/mule-files.el (buffer-file-coding-system-for-read, + convert-mbox-coding-system, insert-file-contents), + language/japanese.el, language/chinese.el, language/korean.el: + Rename `automatic-conversion' -> `undecided' to sync with Emacs + 20.2. + +1997-10-08 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * language/viet-chars.el: New file; moved from + mule/vietnamese-hooks-1.el. + + * language/vietnamese.el: Merge mule/vietnamese-hooks-2.el; + abolish mule/vietnamese-hooks-2.el. + + * prim/dumped-lisp.el: Use language/viet-chars and + language/vietnamese instead of mule/vietnamese-hooks-{1|2}. + +1997-10-07 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule/mule-misc.el (split-char): New function. + +1997-10-14 SL Baur <steve@altair.xemacs.org> + + * default.el: New file. + * site-start.el: New file. XEmacs starts faster if dummy versions + of these files are found early in the `load-path'. + Suggested by Kyle Jones <kyle_jones@wonderworks.com> + +1997-10-14 Hrvoje Niksic <hniksic@srce.hr> + + * custom/wid-edit.el (widget-field-find): Use `map-extents'. + (widget-transpose-chars): Check for empty fields, and point at + beginning of field. + (widget-documentation-string-value-create): `insert-char' handles + 0 gracefully, so no need to protect. + (widget-specify-inactive): Detach the button extents. + (widget-specify-active): Reattach the button extents. + (widget-make-field-untabable): New function. + (widget-specify-inactive): Make the fields non-tabable; use + `widget-make-field-untabable'. + (widget-type): Revert to defsubst. + +1997-10-13 Adrian Aichner <aichner@ecf.teradyne.com> + + * utils/xemacs-build-report.el: + Switched from (mail ...) to (compose-mail ...) upon suggestion by + Hrvoje Niksic. + Extended xemacs-build-report-keep-regexp. + Changed xemacs-build-report-make-output-file value to beta.err + Shortend and bracketed xemacs-build-report-subject. + Improved (I hope) tm-edit to SEMI aliasing logic. + +1997-10-09 Adrian Aichner <aichner@ecf.teradyne.com> + + * utils/xemacs-build-report.el: + Restored RCS keywords and updated comment for `xemacs-build-report-version'. + + * utils/xemacs-build-report.el: + Separated the Spaghetti code into separate functions to do the following: + xemacs-build-report-insert-header + xemacs-build-report-insert-make-output + xemacs-build-report-insert-installation-file + +1997-10-13 Hrvoje Niksic <hniksic@srce.hr> + + * custom/cus-load.el: Disable gc while loading `custom-load' + files. + (custom-put): Added docstring; ignore PROPERTY. + + * custom/wid-edit.el (widget-previous-button-or-field): If the + point is within a button or field, return the beginning position + of the field. + + * prim/frame.el (frame-list): Use `nconc' instead of `append'. + (set-frame-configuration): Use `mapc'. + (delete-other-frames): Ditto. + + * prim/faces.el: Use the CL macro at top-level. + + * prim/faces.el (face-spec-set-match-display): Use `case'. + (set-face-stipple): Use backquotes. + + * custom/wid-edit.el (widget-glyph-find): Use `laxputf'. + (widget-push-button-value-create): Ditto. + + * custom/cus-face.el (custom-face-attributes): Support + inverse-video for TTY-s. + + * prim/cmdloop.el (keyboard-escape-quit): Abort recursive edit, as + documented. + +1997-10-12 Hrvoje Niksic <hniksic@srce.hr> + + * prim/simple.el (zmacs-deactivate-region): Use `mapc' instead of + `mapcar'. + (zmacs-make-extent-for-region): Ditto. + + * custom/cus-dep.el: Updated comments. + + * custom/cus-edit.el (custom-variable-prompt): Prompt with + `variable'. + +1997-10-12 Karl Hegbloom <karlheg@inetarena.com> + + * custom/cus-edit.el (custom-guess-name-alist): Allow `-hooks' + instead of `hook'. + +1997-10-12 Hrvoje Niksic <hniksic@srce.hr> + + * prim/profile.el (profile-results): Use %-*s format. + (profile-align): Nuked. + + * packages/gnuserv.el (gnuserv-frame-plist): New variable. + (gnuserv-special-frame-function): Use it. + (gnuserv-edit-files): Ditto. + 1997-10-12 SL Baur <steve@altair.xemacs.org> * prim/package-admin.el (package-admin-add-binary-package): @@ -45,6 +894,24 @@ (pretty-print-profiling-info): Ditto. From Kyle Jones <kyle_jones@wonderworks.com> +1997-10-10 Per Abrahamsen <abraham@dina.kvl.dk> + + * custom/wid-edit.el (variable-link): New widget. + (widget-variable-link-action): New function. + (function-link): New widget. + (widget-function-link-action): New function. + +1997-10-10 Karl M. Hegbloom <karlheg@inetarena.com> + + * prim/modeline.el (modeline-minor-mode-menu): menus are toggles + not strings now. + +1997-10-10 SL Baur <steve@altair.xemacs.org> + + * psgml/psgml-html.el (html-quote-region): Grow bounds when performing + substitutions. + From Adrian Aichner <aichner@ecf.teradyne.com> + 1997-10-10 SL Baur <steve@altair.xemacs.org> * utils/highlight-headers.el (highlight-headers-citation-header-regexp):
--- a/lisp/calendar/appt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,744 +0,0 @@ -;;; appt.el --- appointment notification functions. -;; Keywords: calendar - -;;; -*- Mode:Emacs-Lisp -*- -;; Appointment notification functions. -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; 29-nov-89 created by Neil Mager <neilm@juliet.ll.mit.edu>. -;;; 23-feb-91 hacked upon by Jamie Zawinski <jwz@lucid.com>. -;;; 1-apr-91 some more. -;;; 12-jul-95 updated for XEmacs 19.12 by Greg Veres -;;; <gveres@cgl.uwaterloo.ca> -;;; 21-mar-97 better support for fancy diary display by Tomasz J. Cholewo -;;; <t.cholewo@ieee.org> -;;; -;; appt.el - visible and/or audible notification of -;; appointments from ~/diary file generated from -;; Edward M. Reingold's calendar.el. -;; -;; Version 2.1 -;; -;; Comments, corrections, and improvements should be sent to -;; Neil M. Mager -;; Net <neilm@juliet.ll.mit.edu> -;; Voice (617) 981-4803 -;;; -;;; Thanks to Edward M. Reingold for much help and many suggestions, -;;; And to many others for bug fixes and suggestions. -;;; -;;; -;;; This functions in this file will alert the user of a -;;; pending appointment based on their diary file. -;;; -;;; ******* It is necessary to invoke 'display-time' and ******** -;;; ******* 'appt-initialize' for this to work properly. ******** -;;; -;;; A message will be displayed in the mode line of the emacs buffer and (if -;;; the user desires) the terminal will beep and display a message from the -;;; diary in the mini-buffer, or the user may select to have a message -;;; displayed in a new buffer. -;;; -;;; Variables of note: -;;; -;;; appt-issue-message If this variable is nil, then the code in this -;;; file does nothing. -;;; appt-msg-countdown-list Specifies how much warning you want before -;;; appointments. -;;; appt-audible Whether to beep when it's notification-time. -;;; appt-display-mode-line Whether to display a countdown to the next -;;; appointment in the mode-line. -;;; appt-announce-method The function used to do the notifications. -;;; 'appt-window-announce do it in a pop-up window. -;;; 'appt-frame-announce do it in a pop-up frame (v19 only) -;;; 'appt-message-announce do it in the echo area. -;;; 'appt-persistent-message-announce do it in the echo area, but make the -;;; messages not go away at the next keystroke. -;;; appt-display-duration If appt-announce-method is set to the function -;;; 'appt-window-announce, this specifies how many -;;; seconds the pop-up window should stick around. -;;; -;;; In order to use this, create a diary file, and add the following to your -;;; .emacs file: -;;; -;;; (require 'appt) -;;; (display-time) -;;; (appt-initialize) -;;; -;;; If you wish to see a list of appointments, or a full calendar, when emacs -;;; starts up, you can add a call to (diary) or (calendar) after this. -;;; -;;; This is an example of what can be in your diary file: -;;; Monday -;;; 9:30am Coffee break -;;; 12:00pm Lunch -;;; -;;; Based upon the above lines in your .emacs and diary files, the calendar -;;; and/or diary will be displayed when you enter emacs and your appointments -;;; list will automatically be created. You will then be reminded at 9:20am -;;; about your coffee break and at 11:50am to go to lunch. -;;; -;;; In order to interactively add or delete items from today's list, use -;;; Meta-x appt-add and Meta-x appt-delete. (This does not modify your -;;; diary file, so these will be forgotten when you exit emacs.) -;;; -;;; Additionally, the appointments list is recreated automatically at 12:01am -;;; for those who do not logout every day or are programming late. -;;; -;;; You can have special appointments which execute arbitrary code rather than -;;; simply notifying you -- sort of like the unix "cron" facility. The syntax -;;; for this is borrowed from the Calendar's special-date format. If you have -;;; a diary entry like -;;; -;;; Monday -;;; 3:00am %%(save-all-modified-buffers) -;;; -;;; then on monday at 3AM, the function `save-all-modified-buffers' will be -;;; invoked. (Presumably this function is defined in your .emacs file.) -;;; There will be no notification that these "special" appointments are being -;;; triggered, unless the form evaluated produces a notification. -;;; -;;; It is necessary for the entire list after the "%%" to be on one line in -;;; your .diary file -- there may not be embedded newlines in it. This is a -;;; bit of a misfeature. -;;; -;;; This also interacts correctly with Benjamin Pierce's reportmail.el package. -;;; -;;; Brief internal description - Skip this if you are not interested! -;;; -;;; The function appt-initialize invokes 'diary' to get a list of today's -;;; appointments, and parses the lines beginning with date descriptions. -;;; This list is cached away. 'diary' is invoked in such a way so as to -;;; not pop up a window displaying the diary buffer. -;;; -;;; The function appt-check is run from the 'loadst' process (or the 'wakeup' -;;; process in emacs 18.57 or newer) which is started by invoking display-time. -;;; It checks this cached list, and announces as appropriate. At midnight, -;;; appt-initialize is called again to rebuild this list. -;;; -;;; display-time-filter is modified to invoke appt-check. -;;; -;;; TO DO: -;;; -;;; o multiple adjacent appointments are not handled gracefully. If there -;;; is an appointment at 3:30 and another at 3:35, and you have set things -;;; up so that you get a notification twenty minutes before each appt, -;;; then a notification should come at 3:10 for the first appt, and at -;;; 3:15 for the second. Currently, no notifications are generated for an -;;; appointment until all preceding appointments have completely expired. -;;; -;;; o If there are two appointments at the same time, all but the first are -;;; ignored (not announced.) -;;; -;;; o Appointments which are early enough in the morning that their -;;; announcements should begin before midnight are not announced until -;;; midnight. -;;; -;;; o There should be some way to mark certain appointments as "important," -;;; so that you will be harassed about them even after they have expired. - - -(require 'calendar) -(require 'diary-lib) - -(defcustom appt-issue-message t - "*If T, the diary buffer is checked for appointments. For an - appointment warning to be made, the time must be the first thing on - the line." - :type 'boolean - :group 'appt) - -(defcustom appt-msg-countdown-list '(20 15 10 5 3 1) - "*A list of the intervals in minutes before the appointment when - the warnings will be given. That is, if this were the list '(5 3 1), - then a notification would be given five minutes, three minutes, and - one minute before the appointment." - :type '(repeat integer) - :group 'appt) - -(defcustom appt-check-time-syntax nil - "*Whether all diary entries are intended to beging with time specifications. -Appt will beep and issue a warning message when encountering unparsable -lines." - :type 'boolean - :group 'appt) - -(defcustom appt-audible t - "*Controls whether appointment announcements should beep. -Appt uses two sound-types for beeps: `appt' and `appt-final'. -If this is a number, then that many beeps will occur. -If this is a cons, the car is how many beeps, and the cdr is the - delay between them (a float, fraction of a second to sleep.) -See also the variable `appt-msg-countdown-list'" - :type 'boolean - :group 'appt) - -(defcustom appt-display-mode-line t - "*Controls if minutes-to-appointment should be displayed on the mode line." - :type 'boolean - :group 'appt) - -(defcustom appt-announce-method 'appt-window-announce - "*The name of the function used to notify the user of an impending -appointment. This is called with two arguments, the number of minutes -until the appointment, and the appointment description list. - -Reasonable values for this variable are 'appt-window-announce, -'appt-message-announce, or 'appt-persistent-message-announce." - :type 'function - :group 'appt) - - -(defvar appt-time-msg-list nil - "The list of appointments for today. Use appt-add and appt-delete - to add and delete appointments from list. The original list is generated - from the today's diary-entries-list. The number before each time/message - is the time in minutes after midnight.") - -(defconst max-time 1439 - "11:59pm in minutes - number of minutes in a day minus 1.") - -(defconst appt-check-tick -1) - -(defvar appt-disp-frame nil - "If non-nil, frame to display appointments in.") -(defvaralias 'appt-disp-screen 'appt-disp-frame) - - -;;; Announcement methods - -(defun appt-message-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in the minibuffer." - (message (if (eq min-to-app 0) "App't NOW." - (format "App't in %d minute%s -- %s" - min-to-app - (if (eq 1 min-to-app) "" "s") - (car (cdr appt)))))) - - -(defun appt-persistent-message-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in the minibuffer, but have those -messages stay around even if you type something (unlike normal messages)." - (let ((str (if (eq min-to-app 0) - (format "App't NOW -- %s" (car (cdr appt))) - (format "App't in %d minute%s -- %s" - min-to-app - (if (eq 1 min-to-app) "" "s") - (car (cdr appt))))) - (in-echo-area-already (eq (selected-window) (minibuffer-window)))) - (if (not in-echo-area-already) - ;; don't stomp the echo-area-buffer if reading from the minibuffer now. - (save-excursion - (save-window-excursion - (select-window (minibuffer-window)) - (delete-region (point-min) (point-max)) - (insert str)))) - ;; if we're reading from the echo-area, and all we were going to do is - ;; clear the thing, like, don't bother, that's annoying. - (if (and in-echo-area-already (string= "" str)) - nil - (message "%s" str)) - )) - - -(defcustom appt-display-duration 5 - "*The number of seconds an appointment message is displayed in its own - window if appt-announce-method is 'appt-window-announce." - :type 'integer - :group 'appt) - -(defun appt-window-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in a pop-up window. The variable -appt-display-duration controls how long this window should be left up." - (require 'electric) - (save-excursion - (save-window-excursion - ;; Make sure we're not in the minibuffer - ;; before splitting the window. - (if (window-minibuffer-p (selected-window)) - nil - (select-window (frame-lowest-window)) - (split-window)) - (let (appt-disp-buf) - (unwind-protect - (progn - (setq appt-disp-buf (set-buffer (get-buffer-create "*appt-buf*"))) - ;; set the mode-line of the pop-up window - (setq modeline-format - (concat "-------------------- Appointment " - (if (eq min-to-app 0) - "NOW" - (concat "in " min-to-app - (if (eq min-to-app 1) " minute" " minutes"))) - ". (" - (let ((h (string-to-int - (substring (current-time-string) 11 13)))) - (concat (if (> h 12) (- h 12) h) ":" - (substring (current-time-string) 14 16) - (if (< h 12) "am" "pm"))) - ") %-")) - (pop-to-buffer appt-disp-buf) - (insert (car (cdr appt))) - (shrink-window-if-larger-than-buffer - (get-buffer-window appt-disp-buf)) - (set-buffer-modified-p nil) - (sit-for appt-display-duration)) - (and appt-disp-buf (kill-buffer appt-disp-buf))))))) - -(defvar appt-frame-defaults nil) -(defvaralias 'appt-screen-defaults 'appt-frame-defaults) - -(defun appt-frame-announce (min-to-app appt) - "Set appt-announce-method to the name of this function to cause appointment -notifications to be given via messages in a pop-up frame." - (let () - (save-excursion - (set-buffer (get-buffer-create "*appt-buf*")) - (erase-buffer) - ;; set the mode-line of the pop-up window - (setq modeline-format - (concat "-------------------- Appointment " - (if (eq min-to-app 0) - "NOW" - (concat "in " min-to-app - (if (eq min-to-app 1) " minute" " minutes"))) - ". (" - (let ((h (string-to-int - (substring (current-time-string) 11 13)))) - (concat (if (> h 12) (- h 12) h) ":" - (substring (current-time-string) 14 16) - (if (< h 12) "am" "pm"))) - ") %-")) - (insert (car (cdr appt))) - (let ((height (max 10 (min 20 (+ 2 (count-lines (point-min) - (point-max))))))) - ;; If we already have a frame constructed, use it. If not, or it has - ;; been deleted, then make a new one - (if (and appt-disp-frame (frame-live-p appt-disp-frame)) - (let ((s (selected-frame))) - (select-frame appt-disp-frame) - (make-frame-visible appt-disp-frame) - (set-frame-height appt-disp-frame height) - (sit-for 0) - (select-frame s)) - (progn - (setq appt-disp-frame (make-frame)) - (set-frame-height appt-disp-frame height) - ) - ) - ) - ) - ) - ) -(defalias 'appt-screen-announce 'appt-frame-announce) - -;;; To display stuff in the mode line, we use a new variable instead of -;;; just adding stuff to the display-time-string -- this causes less -;;; flicker. - -(defcustom appt-mode-line-string "" - "*The string displayed in the mode line by the appointment package." - :type 'string - :group 'appt) - -(defun appt-display-mode-line (min-to-app) - "Add an appointment annotation to the mode line." - (setq appt-mode-line-string - (if (and appt-display-mode-line min-to-app) - (if (eq 0 min-to-app) - "App't NOW " - (concat "App't in " min-to-app - (if (eq 1 min-to-app) " minute " " minutes "))) - "")) - ;; make sure our variable is visible in global-mode-string. - (cond ((not appt-display-mode-line) nil) - ((null global-mode-string) - (setq global-mode-string (list "" 'appt-mode-line-string))) - ((stringp global-mode-string) - (setq global-mode-string - (list global-mode-string 'appt-mode-line-string))) - ((not (memq 'appt-mode-line-string global-mode-string)) - (setq global-mode-string - (append global-mode-string (list 'appt-mode-line-string))))) - ;; force mode line updates - from time.el - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p)) - (sit-for 0)) - - -;;; Internal stuff - -(defun appt-convert-time (time2conv) - "Convert hour:min[am/pm] format to minutes from midnight." - (cond ((string-match "^[ \t]*midni\\(ght\\|te\\)[ \t]*\\'" time2conv) - 0) - ((string-match "^[ \t]*noon[ \t]*\\'" time2conv) - (* 12 60)) - (t - (let ((hr 0) - (min 0)) - (or (string-match - "\\`[ \t]*\\([0-9][0-9]?\\)[ \t]*\\(:[ \t]*\\([0-9][0-9]\\)\\)?[ \t]*\\(am\\|pm\\)?" - time2conv) - (error "unparsable time \"%s\"" time2conv)) - (setq hr (string-to-int - (substring time2conv - (match-beginning 1) (match-end 1)))) - (if (match-beginning 3) - (setq min (string-to-int - (substring time2conv - (match-beginning 3) (match-end 3))))) - ;; convert the time appointment time into 24 hour time - (if (match-beginning 4) - (progn - (if (or (= hr 0) (> hr 12)) - (error "mixing 12hr and 24 hr time! %s" time2conv)) - (if (string-match "am" - (substring time2conv (match-beginning 4))) - (if (= hr 12) (setq hr 0)) - (if (< hr 12) (setq hr (+ 12 hr)))))) - (if (> min 59) (error "minutes outa bounds - %s" time2conv)) - (+ (* hr 60) min))))) - - -(defun appt-current-time-in-minutes () - "Returns the current time in minutes since midnight." - (let* ((str (current-time-string)) - (hour (string-to-int (substring str 11 13))) - (min (string-to-int (substring str 14 16)))) - (+ (* hour 60) min))) - - -(defun appt-sort-list (appt-list) - (sort (copy-sequence appt-list) - (function (lambda (x y) - (< (car (car x)) (car (car y))))))) - -(defun appt-diary-entries () - "Return an updated list of appointments for today." - (let ((list-diary-entries-hook '(appt-make-list)) - (diary-display-hook 'ignore) - (diary-list-include-blanks nil)) - ;; this will set appt-time-msg-list. - (diary 1) - appt-time-msg-list)) - -(defun appt-initialize () - "Read your `diary-file' and remember today's appointments. Call this from - your .emacs file, or any time you want your .diary file re-read (this happens - automatically at midnight to notice the next day's appointments). - - The time must be at the beginning of a line for it to be put in the - appointments list. - 02/23/89 - 12:00pm lunch - Wednesday - 10:00am group meeting" - (install-display-time-hook) - (let ((n (length (appt-diary-entries)))) - (cond ((= n 0) (message "no appointments today.")) - ((= n 1) (message "1 appointment today.")) - (t (message "%d appointments today." n))))) - -(defun appt-make-list () - "Don't call this directly; call appt-initialize or appt-diary-entries." - (setq appt-time-msg-list nil) - (if diary-entries-list - ;; Cycle through the entry-list (diary-entries-list) looking for - ;; entries beginning with a time. If the entry begins with a time, - ;; add it to the appt-time-msg-list. Then sort the list. - ;; - (let ((entry-list diary-entries-list) - (new-appts '())) - (while (and entry-list - (calendar-date-equal - (calendar-current-date) (car (car entry-list)))) - (let ((time-string (car (cdr (car entry-list))))) - (while (string-match - "\\`[ \t\n]*\\([0-9]?[0-9]\\(:[0-9][0-9]\\)?[ \t]*\\(am\\|pm\\)?\\|noon\\|midnight\\|midnite\\).*$" - time-string) - (let* ((eol (match-end 0)) - (appt-time-string - (substring time-string (match-beginning 1) - (match-end 1))) - (appt-msg-string - (substring time-string (match-end 1) eol)) - (appt-time (list (appt-convert-time appt-time-string)))) - (setq time-string (substring time-string eol) - new-appts (cons (cons appt-time - (list (concat appt-time-string ":" - appt-msg-string))) - new-appts)))) - (if appt-check-time-syntax - (while (string-match "\n*\\([^\n]+\\)$" time-string) - (beep) - (message "Unparsable time: %s" - (substring time-string (match-beginning 1) - (match-end 1))) - (sit-for 3) - (setq time-string (substring time-string (match-end 0))))) - - ) - (setq entry-list (cdr entry-list))) - (setq appt-time-msg-list ; seems we can't nconc this list... - (append (nreverse new-appts) appt-time-msg-list)))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)) - ;; - ;; Get the current time and convert it to minutes from midnight, i.e., - ;; 12:01am = 1, midnight = 0, so that the elements in the list that - ;; are earlier than the present time can be removed. - ;; - (let ((cur-comp-time (appt-current-time-in-minutes)) - (appt-comp-time (car (car (car appt-time-msg-list))))) - (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time (car (car (car appt-time-msg-list))))))) - appt-time-msg-list) - - -(defun appt-beep (&optional final-p) - (cond ((null appt-audible) nil) - ((numberp appt-audible) - (let ((i appt-audible)) - (while (> i 0) (beep) (setq i (1- i))))) - ((consp appt-audible) - (let ((i (car appt-audible)) - (j (cdr appt-audible))) - (if (consp j) (setq j (car j))) - (while (> i 0) - (if (fboundp 'play-sound) - (beep nil (if final-p 'appt-final 'appt)) - (beep)) - (sleep-for j) - (setq i (1- i))))) - (t (beep)))) - - -(defun appt-check () - "Check for an appointment and update the mode line and minibuffer if - desired. Note: the time must be the first thing in the line in the diary - for a warning to be issued. - The format of the time can be either 24 hour or am/pm. Example: - - 02/23/89 - 18:00 Dinner - Thursday - 11:45am Lunch meeting. - - The following variables control the action of the notification: - - appt-issue-message If this variable is nil, then the code in this - file does nothing. - appt-msg-countdown-list Specifies how much warning you want before - appointments. - appt-audible Whether to beep when it's notification-time. - appt-display-mode-line Whether to display a countdown to the next - appointment in the mode-line. - appt-announce-method The function used to do the notifications. - 'appt-window-announce to do it in a pop-up - window, 'appt-message-announce or - 'appt-persistent-message-announce to do it - in the echo-area. - appt-display-duration If appt-announce-method is set to the function - 'appt-window-announce, this specifies how many - seconds the pop-up window should stick around. - - This function is run from the `loadst' or `wakeup' process for display-time. - Therefore, you need to have (display-time) in your .emacs file." - (if appt-issue-message - (let ((min-to-app -1)) - ;; Get the current time and convert it to minutes - ;; from midnight, i.e., 12:01am = 1, midnight = 0. - (let* ((cur-comp-time (appt-current-time-in-minutes)) - ;; If the current time is the same as the tick, just return. - ;; This means that this function has been called more than once - ;; in the current minute, which is not useful. - (shut-up-this-time (= cur-comp-time appt-check-tick)) - (turnover-p (> appt-check-tick cur-comp-time))) - (setq appt-check-tick cur-comp-time) - ;; - ;; If it is now the next day (we have crossed midnight since the last - ;; time this was called) then we should update our appointments to - ;; today's list. Show the diary entries (tjc). - (if turnover-p (diary 1)) - ;; - ;; Get the first time off of the list and calculate the number - ;; of minutes until the appointment. - (if appt-time-msg-list - (let ((appt-comp-time (car (car (car appt-time-msg-list))))) - (setq min-to-app (- appt-comp-time cur-comp-time)) - (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time (car (car (car appt-time-msg-list)))))) - ;; - ;; If we have an appointment between midnight and warning-time - ;; minutes after midnight, we must begin to issue a message - ;; before midnight. Midnight is considered 0 minutes and 11:59pm - ;; is 1439 minutes. Therefore we must recalculate the minutes to - ;; appointment variable. It is equal to the number of minutes - ;; before midnight plus the number of minutes after midnight our - ;; appointment is. - ;; - ;; ## I don't think this does anything -- it would if it were - ;; (for example) a 12:01am appt on the list at 11:55pm, but that - ;; can't ever happen, because the applicable 12:01am appt is for - ;; tomorrow, not today, and we only have today's diary list. - ;; It's not simply a matter of concatenating two days together, - ;; either, because then tuesday's appts would be signalled on - ;; monday. We have to do a real one-day lookahead -- keep a list - ;; of tomorrow's appts, and check it when near midnight. - ;; - (if (and (< appt-comp-time (apply 'max appt-msg-countdown-list)) - (> (+ cur-comp-time (apply 'max appt-msg-countdown-list)) - max-time)) - (setq min-to-app (+ (- (1+ max-time) cur-comp-time)) - appt-comp-time)) - ;; - ;; issue warning if the appointment time is within warning-time - (cond - ;; if there should not be any notifications in the mode-line, - ;; clear it. - ((> min-to-app (apply 'max appt-msg-countdown-list)) - (appt-display-mode-line nil)) - ;; do nothing if this is the second time this minute we've - ;; gotten here, of if we shouldn't be notifying right now. - ((or shut-up-this-time - (and (not (= min-to-app 0)) - (not (memq min-to-app appt-msg-countdown-list)))) - nil) - - ((and (= min-to-app 0) - (string-match "%%(" (nth 1 (car appt-time-msg-list)))) - ;; - ;; If this is a magic evaluating-notification, evaluate it. - ;; these kinds of notifications aren't subject to the - ;; appt-msg-countdown-list. - ;; - (let* ((list-string (substring (nth 1 (car appt-time-msg-list)) - (1- (match-end 0)))) - (form (condition-case () - (read list-string) - (error - (ding) - (message "Appt: error reading from \"%s\"" - (nth 1 (car appt-time-msg-list))) - (sit-for 2) - nil)))) - (eval form))) - - ((and (<= min-to-app (apply 'max appt-msg-countdown-list)) - (>= min-to-app 0)) - ;; - ;; produce a notification. - (appt-beep (= min-to-app 0)) - (funcall appt-announce-method min-to-app - (car appt-time-msg-list)) - ;; update mode line and expire if necessary - (appt-display-mode-line min-to-app) - ;; if it's expired, remove it. - (if (= min-to-app 0) - (setq appt-time-msg-list (cdr appt-time-msg-list)))) - (t - ;; else we're not near any appointment, or there are no - ;; apointments; make sure mode line is clear. - (appt-display-mode-line nil)))) - (appt-display-mode-line nil)))))) - - - -;;; Interactively adding and deleting appointments - -(defun appt-add (new-appt-time new-appt-msg) - "Adds an appointment to the list of appointments for the day at TIME - and issue MESSAGE. The time should be in either 24 hour format or - am/pm format. " - - (interactive "sTime (hh:mm[am/pm]): \nsMessage: ") - (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" new-appt-time) - nil - (error "Unacceptable time-string")) - - (let* ((appt-time-string (concat new-appt-time " " new-appt-msg)) - (appt-time (list (appt-convert-time new-appt-time))) - (time-msg (cons appt-time (list appt-time-string)))) - (setq appt-time-msg-list (append appt-time-msg-list - (list time-msg))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)))) - -(defun appt-delete () - "Deletes an appointment from the list of appointments." - (interactive) - (let* ((tmp-msg-list appt-time-msg-list)) - (while tmp-msg-list - (let* ((element (car tmp-msg-list)) - (prompt-string (concat "Delete " - (prin1-to-string (car (cdr element))) - " from list? ")) - (test-input (y-or-n-p prompt-string))) - (setq tmp-msg-list (cdr tmp-msg-list)) - (if test-input - (setq appt-time-msg-list (delq element appt-time-msg-list))))) - (message ""))) - - -;;; Patching in to existing time code to install our hook. - - -(defvar display-time-hook-installed nil) - -(defun install-display-time-hook () - (unless display-time-hook-installed ; only do this stuff once! - (unless (boundp 'display-time-hook) ; Need to wrapper it. - (defvar display-time-hook nil - "*List of functions to be called when the time is updated on the mode line.") - (let ((old-fn (if (or (featurep 'reportmail) - ;; old reportmail without a provide statement - (and (fboundp 'display-time-filter-18-55) - (fboundp 'display-time-filter-18-57))) - (if (and (featurep 'itimer) ; XEmacs reportmail.el - (fboundp 'display-time-timer-function)) - 'display-time-timer-function - ;; older reportmail, or no timer.el. - (if (string-match "18\\.5[0-5]" (emacs-version)) - 'display-time-filter-18-55 - 'display-time-filter-18-57)) - ;; othewise, time.el - (if (and (featurep 'itimer) - (fboundp 'display-time-function)) ; XEmacs - 'display-time-function - 'display-time-filter)))) - ;; we're about to redefine it... - (fset 'old-display-time-filter (symbol-function old-fn)) - (fset old-fn - (lambda (&rest args) ;; ...here's the revised definition - "Revised version of the original function: this version calls a hook." - (apply 'old-display-time-filter args) - (run-hooks 'display-time-hook))))) - (setq display-time-hook-installed t) - (if (fboundp 'add-hook) - (add-hook 'display-time-hook 'appt-check) - (setq display-time-hook (cons appt-check display-time-hook))) - )) - -(provide 'appt)
--- a/lisp/calendar/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,378 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'calendar-autoloads) (error "Already loaded")) - -;;;### (autoloads nil "cal-dst" "calendar/cal-dst.el") - -(put 'calendar-daylight-savings-starts 'risky-local-variable t) - -(put 'calendar-daylight-savings-ends 'risky-local-variable t) - -;;;*** - -;;;### (autoloads nil "cal-x" "calendar/cal-x.el") - -(defvar calendar-setup 'one-frame "\ -The frame set up of the calendar. -The choices are `one-frame' (calendar and diary together in one separate, -dediciated frame) or `two-frames' (calendar and diary in separate, dedicated -frames); with any other value the current frame is used.") - -;;;*** - -;;;### (autoloads (list-yahrzeit-dates calendar) "calendar" "calendar/calendar.el") - -(defcustom calendar-week-start-day 0 "*The day of the week on which a week in the calendar begins.\n0 means Sunday (default), 1 means Monday, and so on." :type 'integer :group 'calendar) - -(defcustom calendar-offset 0 "*The offset of the principal month from the center of the calendar window.\n0 means the principal month is in the center (default), -1 means on the left,\n+1 means on the right. Larger (or smaller) values push the principal month off\nthe screen." :type 'integer :group 'calendar) - -(defcustom view-diary-entries-initially nil "*Non-nil means display current date's diary entries on entry.\nThe diary is displayed in another window when the calendar is first displayed,\nif the current date is visible. The number of days of diary entries displayed\nis governed by the variable `number-of-diary-entries'." :type 'boolean :group 'diary) - -(defcustom number-of-diary-entries 1 "*Specifies how many days of diary entries are to be displayed initially.\nThis variable affects the diary display when the command M-x diary is used,\nor if the value of the variable `view-diary-entries-initially' is t. For\nexample, if the default value 1 is used, then only the current day's diary\nentries will be displayed. If the value 2 is used, then both the current\nday's and the next day's entries will be displayed.\n\nThe value can also be a vector such as [0 2 2 2 2 4 1]; this value\nsays to display no diary entries on Sunday, the display the entries\nfor the current date and the day after on Monday through Thursday,\ndisplay Friday through Monday's entries on Friday, and display only\nSaturday's entries on Saturday.\n\nThis variable does not affect the diary display with the `d' command\nfrom the calendar; in that case, the prefix argument controls the\nnumber of days of diary entries displayed." :type 'integer :group 'diary) - -(defcustom mark-diary-entries-in-calendar nil "*Non-nil means mark dates with diary entries, in the calendar window.\nThe marking symbol is specified by the variable `diary-entry-marker'." :type 'boolean :group 'diary) - -(defcustom view-calendar-holidays-initially nil "*Non-nil means display holidays for current three month period on entry.\nThe holidays are displayed in another window when the calendar is first\ndisplayed." :type 'boolean :group 'holidays) - -(defcustom mark-holidays-in-calendar nil "*Non-nil means mark dates of holidays in the calendar window.\nThe marking symbol is specified by the variable `calendar-holiday-marker'." :type 'boolean :group 'holidays) - -(defcustom all-hebrew-calendar-holidays nil "*If nil, show only major holidays from the Hebrew calendar.\nThis means only those Jewish holidays that appear on secular calendars.\n\nIf t, show all the holidays that would appear in a complete Hebrew calendar." :type 'boolean :group 'holidays) - -(defcustom all-christian-calendar-holidays nil "*If nil, show only major holidays from the Christian calendar.\nThis means only those Christian holidays that appear on secular calendars.\n\nIf t, show all the holidays that would appear in a complete Christian\ncalendar." :type 'boolean :group 'holidays) - -(defcustom all-islamic-calendar-holidays nil "*If nil, show only major holidays from the Islamic calendar.\nThis means only those Islamic holidays that appear on secular calendars.\n\nIf t, show all the holidays that would appear in a complete Islamic\ncalendar." :type 'boolean :group 'holidays) - -(defcustom calendar-load-hook nil "*List of functions to be called after the calendar is first loaded.\nThis is the place to add key bindings to `calendar-mode-map'." :type 'hook :group 'calendar) - -(defcustom initial-calendar-window-hook nil "*List of functions to be called when the calendar window is first opened.\nThe functions invoked are called after the calendar window is opened, but\nonce opened is never called again. Leaving the calendar with the `q' command\nand reentering it will cause these functions to be called again." :type 'hook :group 'calendar) - -(defcustom today-visible-calendar-hook nil "*List of functions called whenever the current date is visible.\nThis can be used, for example, to replace today's date with asterisks; a\nfunction `calendar-star-date' is included for this purpose:\n (setq today-visible-calendar-hook 'calendar-star-date)\nIt can also be used to mark the current date with `calendar-today-marker';\na function is also provided for this:\n (setq today-visible-calendar-hook 'calendar-mark-today)\n\nThe corresponding variable `today-invisible-calendar-hook' is the list of\nfunctions called when the calendar function was called when the current\ndate is not visible in the window.\n\nOther than the use of the provided functions, the changing of any\ncharacters in the calendar buffer by the hooks may cause the failure of the\nfunctions that move by days and weeks." :type 'hook :group 'calendar) - -(defcustom today-invisible-calendar-hook nil "*List of functions called whenever the current date is not visible.\n\nThe corresponding variable `today-visible-calendar-hook' is the list of\nfunctions called when the calendar function was called when the current\ndate is visible in the window.\n\nOther than the use of the provided functions, the changing of any\ncharacters in the calendar buffer by the hooks may cause the failure of the\nfunctions that move by days and weeks." :type 'hook :group 'calendar) - -(defcustom diary-file "~/diary" "*Name of the file in which one's personal diary of dates is kept.\n\nThe file's entries are lines in any of the forms\n\n MONTH/DAY\n MONTH/DAY/YEAR\n MONTHNAME DAY\n MONTHNAME DAY, YEAR\n DAYNAME\n\nat the beginning of the line; the remainder of the line is the diary entry\nstring for that date. MONTH and DAY are one or two digit numbers, YEAR is\na number and may be written in full or abbreviated to the final two digits.\nIf the date does not contain a year, it is generic and applies to any year.\nDAYNAME entries apply to any date on which is on that day of the week.\nMONTHNAME and DAYNAME can be spelled in full, abbreviated to three\ncharacters (with or without a period), capitalized or not. Any of DAY,\nMONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year,\nrespectively.\n\nThe European style (in which the day precedes the month) can be used\ninstead, if you execute `european-calendar' when in the calendar, or set\n`european-calendar-style' to t in your .emacs file. The European forms are\n\n DAY/MONTH\n DAY/MONTH/YEAR\n DAY MONTHNAME\n DAY MONTHNAME YEAR\n DAYNAME\n\nTo revert to the default American style from the European style, execute\n`american-calendar' in the calendar.\n\nA diary entry can be preceded by the character\n`diary-nonmarking-symbol' (ordinarily `&') to make that entry\nnonmarking--that is, it will not be marked on dates in the calendar\nwindow but will appear in a diary window.\n\nMultiline diary entries are made by indenting lines after the first with\neither a TAB or one or more spaces.\n\nLines not in one the above formats are ignored. Here are some sample diary\nentries (in the default American style):\n\n 12/22/1988 Twentieth wedding anniversary!!\n &1/1. Happy New Year!\n 10/22 Ruth's birthday.\n 21: Payday\n Tuesday--weekly meeting with grad students at 10am\n Supowit, Shen, Bitner, and Kapoor to attend.\n 1/13/89 Friday the thirteenth!!\n &thu 4pm squash game with Lloyd.\n mar 16 Dad's birthday\n April 15, 1989 Income tax due.\n &* 15 time cards due.\n\nIf the first line of a diary entry consists only of the date or day name with\nno trailing blanks or punctuation, then that line is not displayed in the\ndiary window; only the continuation lines is shown. For example, the\nsingle diary entry\n\n 02/11/1989\n Bill Blattner visits Princeton today\n 2pm Cognitive Studies Committee meeting\n 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative'\n 4:00pm Jamie Tappenden\n 7:30pm Dinner at George and Ed's for Alan Ryan\n 7:30-10:00pm dance at Stewart Country Day School\n\nwill appear in the diary window without the date line at the beginning. This\nfacility allows the diary window to look neater, but can cause confusion if\nused with more than one day's entries displayed.\n\nDiary entries can be based on Lisp sexps. For example, the diary entry\n\n %%(diary-block 11 1 1990 11 10 1990) Vacation\n\ncauses the diary entry \"Vacation\" to appear from November 1 through November\n10, 1990. Other functions available are `diary-float', `diary-anniversary',\n`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date',\n`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date',\n`diary-yahrzeit', `diary-sunrise-sunset', `diary-phases-of-moon',\n`diary-parasha', `diary-omer', `diary-rosh-hodesh', and\n`diary-sabbath-candles'. See the documentation for the function\n`list-sexp-diary-entries' for more details.\n\nDiary entries based on the Hebrew and/or the Islamic calendar are also\npossible, but because these are somewhat slow, they are ignored\nunless you set the `nongregorian-diary-listing-hook' and the\n`nongregorian-diary-marking-hook' appropriately. See the documentation\nfor these functions for details.\n\nDiary files can contain directives to include the contents of other files; for\ndetails, see the documentation for the variable `list-diary-entries-hook'." :type 'file :group 'diary) - -(defcustom diary-nonmarking-symbol "&" "*Symbol indicating that a diary entry is not to be marked in the calendar." :type 'string :group 'diary) - -(defcustom hebrew-diary-entry-symbol "H" "*Symbol indicating a diary entry according to the Hebrew calendar." :type 'string :group 'diary) - -(defcustom islamic-diary-entry-symbol "I" "*Symbol indicating a diary entry according to the Islamic calendar." :type 'string :group 'diary) - -(defcustom diary-include-string "#include" "*The string indicating inclusion of another file of diary entries.\nSee the documentation for the function `include-other-diary-files'." :type 'string :group 'diary) - -(defcustom sexp-diary-entry-symbol "%%" "*The string used to indicate a sexp diary entry in diary-file.\nSee the documentation for the function `list-sexp-diary-entries'." :type 'string :group 'diary) - -(defcustom abbreviated-calendar-year t "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD.\nFor the Gregorian calendar; similarly for the Hebrew and Islamic calendars.\nIf this variable is nil, years must be written in full." :type 'boolean :group 'diary) - -(defcustom european-calendar-style nil "*Use the European style of dates in the diary and in any displays.\nIf this variable is t, a date 1/2/1990 would be interpreted as February 1,\n1990. The accepted European date styles are\n\n DAY/MONTH\n DAY/MONTH/YEAR\n DAY MONTHNAME\n DAY MONTHNAME YEAR\n DAYNAME\n\nNames can be capitalized or not, written in full, or abbreviated to three\ncharacters with or without a period." :type 'boolean :group 'diary) - -(defcustom american-date-diary-pattern '((month "/" day "[^/0-9]") (month "/" day "/" year "[^0-9]") (monthname " *" day "[^,0-9]") (monthname " *" day ", *" year "[^0-9]") (dayname "\\W")) "*List of pseudo-patterns describing the American patterns of date used.\nSee the documentation of `diary-date-forms' for an explanation." :type '(repeat (choice (cons :tag "Backup" (const backup) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp)))) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp))))) :group 'diary) - -(defcustom european-date-diary-pattern '((day "/" month "[^/0-9]") (day "/" month "/" year "[^0-9]") (backup day " *" monthname "\\W+\\<[^*0-9]") (day " *" monthname " *" year "[^0-9]") (dayname "\\W")) "*List of pseudo-patterns describing the European patterns of date used.\nSee the documentation of `diary-date-forms' for an explanation." :type '(repeat (choice (cons :tag "Backup" (const backup) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp)))) (repeat (list :inline t :format "%v" (symbol :tag "Keyword") (choice symbol regexp))))) :group 'diary) - -(defcustom european-calendar-display-form '((if dayname (concat dayname ", ")) day " " monthname " " year) "*Pseudo-pattern governing the way a date appears in the European style.\nSee the documentation of calendar-date-display-form for an explanation." :type 'sexp :group 'calendar) - -(defcustom american-calendar-display-form '((if dayname (concat dayname ", ")) monthname " " day ", " year) "*Pseudo-pattern governing the way a date appears in the American style.\nSee the documentation of `calendar-date-display-form' for an explanation." :type 'sexp :group 'calendar) - -(defcustom print-diary-entries-hook 'lpr-buffer "*List of functions called after a temporary diary buffer is prepared.\nThe buffer shows only the diary entries currently visible in the diary\nbuffer. The default just does the printing. Other uses might include, for\nexample, rearranging the lines into order by day and time, saving the buffer\ninstead of deleting it, or changing the function used to do the printing." :type 'hook :group 'diary) - -(defcustom list-diary-entries-hook nil "*List of functions called after diary file is culled for relevant entries.\nIt is to be used for diary entries that are not found in the diary file.\n\nA function `include-other-diary-files' is provided for use as the value of\nthis hook. This function enables you to use shared diary files together\nwith your own. The files included are specified in the diary file by lines\nof the form\n\n #include \"filename\"\n\nThis is recursive; that is, #include directives in files thus included are\nobeyed. You can change the \"#include\" to some other string by changing\nthe variable `diary-include-string'. When you use `include-other-diary-files'\nas part of the list-diary-entries-hook, you will probably also want to use the\nfunction `mark-included-diary-files' as part of `mark-diary-entries-hook'.\n\nFor example, you could use\n\n (setq list-diary-entries-hook\n '(include-other-diary-files sort-diary-entries))\n (setq diary-display-hook 'fancy-diary-display)\n\nin your `.emacs' file to cause the fancy diary buffer to be displayed with\ndiary entries from various included files, each day's entries sorted into\nlexicographic order." :type 'hook :group 'diary) - -(defcustom diary-hook nil "*List of functions called after the display of the diary.\nCan be used for appointment notification." :type 'hook :group 'diary) - -(defcustom diary-display-hook nil "*List of functions that handle the display of the diary.\nIf nil (the default), `simple-diary-display' is used. Use `ignore' for no\ndiary display.\n\nOrdinarily, this just displays the diary buffer (with holidays indicated in\nthe mode line), if there are any relevant entries. At the time these\nfunctions are called, the variable `diary-entries-list' is a list, in order\nby date, of all relevant diary entries in the form of ((MONTH DAY YEAR)\nSTRING), where string is the diary entry for the given date. This can be\nused, for example, a different buffer for display (perhaps combined with\nholidays), or produce hard copy output.\n\nA function `fancy-diary-display' is provided as an alternative\nchoice for this hook; this function prepares a special noneditable diary\nbuffer with the relevant diary entries that has neat day-by-day arrangement\nwith headings. The fancy diary buffer will show the holidays unless the\nvariable `holidays-in-diary-buffer' is set to nil. Ordinarily, the fancy\ndiary buffer will not show days for which there are no diary entries, even\nif that day is a holiday; if you want such days to be shown in the fancy\ndiary buffer, set the variable `diary-list-include-blanks' to t." :type 'hook :group 'diary) - -(defcustom nongregorian-diary-listing-hook nil "*List of functions called for listing diary file and included files.\nAs the files are processed for diary entries, these functions are used to cull\nrelevant entries. You can use either or both of `list-hebrew-diary-entries'\nand `list-islamic-diary-entries'. The documentation for these functions\ndescribes the style of such diary entries." :type 'hook :group 'diary) - -(defcustom mark-diary-entries-hook nil "*List of functions called after marking diary entries in the calendar.\n\nA function `mark-included-diary-files' is also provided for use as the\nmark-diary-entries-hook; it enables you to use shared diary files together\nwith your own. The files included are specified in the diary file by lines\nof the form\n #include \"filename\"\nThis is recursive; that is, #include directives in files thus included are\nobeyed. You can change the \"#include\" to some other string by changing the\nvariable `diary-include-string'. When you use `mark-included-diary-files' as\npart of the mark-diary-entries-hook, you will probably also want to use the\nfunction `include-other-diary-files' as part of `list-diary-entries-hook'." :type 'hook :group 'diary) - -(defcustom nongregorian-diary-marking-hook nil "*List of functions called for marking diary file and included files.\nAs the files are processed for diary entries, these functions are used to cull\nrelevant entries. You can use either or both of `mark-hebrew-diary-entries'\nand `mark-islamic-diary-entries'. The documentation for these functions\ndescribes the style of such diary entries." :type 'hook :group 'diary) - -(defcustom diary-list-include-blanks nil "*If nil, do not include days with no diary entry in the list of diary entries.\nSuch days will then not be shown in the fancy diary buffer, even if they\nare holidays." :type 'boolean :group 'diary) - -(defcustom holidays-in-diary-buffer t "*Non-nil means include holidays in the diary display.\nThe holidays appear in the mode line of the diary buffer, or in the\nfancy diary buffer next to the date. This slows down the diary functions\nsomewhat; setting it to nil makes the diary display faster." :type 'boolean :group 'diary) - -(defcustom general-holidays '((holiday-fixed 1 1 "New Year's Day") (holiday-float 1 1 3 "Martin Luther King Day") (holiday-fixed 2 2 "Ground Hog Day") (holiday-fixed 2 14 "Valentine's Day") (holiday-float 2 1 3 "President's Day") (holiday-fixed 3 17 "St. Patrick's Day") (holiday-fixed 4 1 "April Fool's Day") (holiday-float 5 0 2 "Mother's Day") (holiday-float 5 1 -1 "Memorial Day") (holiday-fixed 6 14 "Flag Day") (holiday-float 6 0 3 "Father's Day") (holiday-fixed 7 4 "Independence Day") (holiday-float 9 1 1 "Labor Day") (holiday-float 10 1 2 "Columbus Day") (holiday-fixed 10 31 "Halloween") (holiday-fixed 11 11 "Veteran's Day") (holiday-float 11 4 4 "Thanksgiving")) "*General holidays. Default value is for the United States.\nSee the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) - -(put 'general-holidays 'risky-local-variable t) - -(defcustom local-holidays nil "*Local holidays.\nSee the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays :group 'local) - -(put 'local-holidays 'risky-local-variable t) - -(defcustom other-holidays nil "*User defined holidays.\nSee the documentation for `calendar-holidays' for details." :type 'sexp :group 'holidays) - -(put 'other-holidays 'risky-local-variable t) - -(defvar hebrew-holidays-1 '((holiday-rosh-hashanah-etc) (if all-hebrew-calendar-holidays (holiday-julian 11 (let* ((m displayed-month) (y displayed-year) (year)) (increment-calendar-month m y -1) (let ((year (extract-calendar-year (calendar-julian-from-absolute (calendar-absolute-from-gregorian (list m 1 y)))))) (if (zerop (% (1+ year) 4)) 22 21))) "\"Tal Umatar\" (evening)")))) - -(put 'hebrew-holidays-1 'risky-local-variable t) - -(defvar hebrew-holidays-2 '((if all-hebrew-calendar-holidays (holiday-hanukkah) (holiday-hebrew 9 25 "Hanukkah")) (if all-hebrew-calendar-holidays (holiday-hebrew 10 (let ((h-year (extract-calendar-year (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (list displayed-month 28 displayed-year)))))) (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year)) 7) 6) 11 10)) "Tzom Teveth")) (if all-hebrew-calendar-holidays (holiday-hebrew 11 15 "Tu B'Shevat")))) - -(put 'hebrew-holidays-2 'risky-local-variable t) - -(defvar hebrew-holidays-3 '((if all-hebrew-calendar-holidays (holiday-hebrew 11 (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y 1) (let* ((h-year (extract-calendar-year (calendar-hebrew-from-absolute (calendar-absolute-from-gregorian (list m (calendar-last-day-of-month m y) y))))) (s-s (calendar-hebrew-from-absolute (if (= (% (calendar-absolute-from-hebrew (list 7 1 h-year)) 7) 6) (calendar-dayname-on-or-before 6 (calendar-absolute-from-hebrew (list 11 17 h-year))) (calendar-dayname-on-or-before 6 (calendar-absolute-from-hebrew (list 11 16 h-year)))))) (day (extract-calendar-day s-s))) day)) "Shabbat Shirah")))) - -(put 'hebrew-holidays-3 'risky-local-variable t) - -(defvar hebrew-holidays-4 '((holiday-passover-etc) (if (and all-hebrew-calendar-holidays (let* ((m displayed-month) (y displayed-year) (year)) (increment-calendar-month m y -1) (let ((year (extract-calendar-year (calendar-julian-from-absolute (calendar-absolute-from-gregorian (list m 1 y)))))) (= 21 (% year 28))))) (holiday-julian 3 26 "Kiddush HaHamah")) (if all-hebrew-calendar-holidays (holiday-tisha-b-av-etc)))) - -(put 'hebrew-holidays-4 'risky-local-variable t) - -(defvar hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2 hebrew-holidays-3 hebrew-holidays-4) "\ -*Jewish holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'hebrew-holidays 'risky-local-variable t) - -(defvar christian-holidays '((if all-christian-calendar-holidays (holiday-fixed 1 6 "Epiphany")) (holiday-easter-etc) (if all-christian-calendar-holidays (holiday-greek-orthodox-easter)) (if all-christian-calendar-holidays (holiday-fixed 8 15 "Assumption")) (if all-christian-calendar-holidays (holiday-advent)) (holiday-fixed 12 25 "Christmas") (if all-christian-calendar-holidays (holiday-julian 12 25 "Eastern Orthodox Christmas"))) "\ -*Christian holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'christian-holidays 'risky-local-variable t) - -(defvar islamic-holidays '((holiday-islamic 1 1 (format "Islamic New Year %d" (let ((m displayed-month) (y displayed-year)) (increment-calendar-month m y 1) (extract-calendar-year (calendar-islamic-from-absolute (calendar-absolute-from-gregorian (list m (calendar-last-day-of-month m y) y))))))) (if all-islamic-calendar-holidays (holiday-islamic 1 10 "Ashura")) (if all-islamic-calendar-holidays (holiday-islamic 3 12 "Mulad-al-Nabi")) (if all-islamic-calendar-holidays (holiday-islamic 7 26 "Shab-e-Mi'raj")) (if all-islamic-calendar-holidays (holiday-islamic 8 15 "Shab-e-Bara't")) (holiday-islamic 9 1 "Ramadan Begins") (if all-islamic-calendar-holidays (holiday-islamic 9 27 "Shab-e Qadr")) (if all-islamic-calendar-holidays (holiday-islamic 10 1 "Id-al-Fitr")) (if all-islamic-calendar-holidays (holiday-islamic 12 10 "Id-al-Adha"))) "\ -*Islamic holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'islamic-holidays 'risky-local-variable t) - -(defvar solar-holidays '((if (fboundp 'atan) (solar-equinoxes-solstices)) (if (progn (require 'cal-dst) t) (funcall 'holiday-sexp calendar-daylight-savings-starts '(format "Daylight Savings Time Begins %s" (if (fboundp 'atan) (solar-time-string (/ calendar-daylight-savings-starts-time (float 60)) calendar-standard-time-zone-name) "")))) (funcall 'holiday-sexp calendar-daylight-savings-ends '(format "Daylight Savings Time Ends %s" (if (fboundp 'atan) (solar-time-string (/ calendar-daylight-savings-ends-time (float 60)) calendar-daylight-time-zone-name) "")))) "\ -*Sun-related holidays. -See the documentation for `calendar-holidays' for details.") - -(put 'solar-holidays 'risky-local-variable t) - -(defvar calendar-holidays (append general-holidays local-holidays other-holidays christian-holidays hebrew-holidays islamic-holidays solar-holidays) "\ -*List of notable days for the command M-x holidays. - -Additional holidays are easy to add to the list, just put them in the list -`other-holidays' in your .emacs file. Similarly, by setting any of -`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays', -`islamic-holidays', or `solar-holidays' to nil in your .emacs file, you can -eliminate unwanted categories of holidays. The intention is that (in the US) -`local-holidays' be set in site-init.el and `other-holidays' be set by the -user. - -Entries on the list are expressions that return (possibly empty) lists of -items of the form ((month day year) string) of a holiday in the in the -three-month period centered around `displayed-month' of `displayed-year'. -Several basic functions are provided for this purpose: - - (holiday-fixed MONTH DAY STRING) is a fixed date on the Gregorian calendar - (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in - MONTH on the Gregorian calendar (0 for Sunday, - etc.); K<0 means count back from the end of the - month. An optional parameter DAY means the Kth - DAYNAME after/before MONTH DAY. - (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar - (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar - (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar - (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression - in the variable `year'; if it evaluates to - a visible date, that's the holiday; if it - evaluates to nil, there's no holiday. STRING - is an expression in the variable `date'. - -For example, to add Bastille Day, celebrated in France on July 14, add - - (holiday-fixed 7 14 \"Bastille Day\") - -to the list. To add Hurricane Supplication Day, celebrated in the Virgin -Islands on the fourth Monday in August, add - - (holiday-float 8 1 4 \"Hurricane Supplication Day\") - -to the list (the last Monday would be specified with `-1' instead of `4'). -To add the last day of Hanukkah to the list, use - - (holiday-hebrew 10 2 \"Last day of Hanukkah\") - -since the Hebrew months are numbered with 1 starting from Nisan, while to -add the Islamic feast celebrating Mohammed's birthday use - - (holiday-islamic 3 12 \"Mohammed's Birthday\") - -since the Islamic months are numbered from 1 starting with Muharram. To -add Thomas Jefferson's birthday, April 2, 1743 (Julian), use - - (holiday-julian 4 2 \"Jefferson's Birthday\") - -To include a holiday conditionally, use the sexp form or a conditional. For -example, to include American presidential elections, which occur on the first -Tuesday after the first Monday in November of years divisible by 4, add - - (holiday-sexp - (if (zerop (% year 4)) - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 year))))))) - \"US Presidential Election\") - -or - - (if (zerop (% displayed-year 4)) - (holiday-fixed 11 - (extract-calendar-day - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 displayed-year))))))) - \"US Presidential Election\")) - -to the list. To include the phases of the moon, add - - (lunar-phases) - -to the holiday list, where `lunar-phases' is an Emacs-Lisp function that -you've written to return a (possibly empty) list of the relevant VISIBLE dates -with descriptive strings such as - - (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... ).") - -(put 'calendar-holidays 'risky-local-variable t) - -(autoload 'calendar "calendar" "\ -Display a three-month calendar in another window. -The three months appear side by side, with the current month in the middle -surrounded by the previous and next months. The cursor is put on today's date. - -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file; appropriate setting -of the variable `view-diary-entries-initially' will cause the diary entries for -the current date to be displayed in another window. The value of the variable -`number-of-diary-entries' controls the number of days of diary entries -displayed upon initial display of the calendar. - -An optional prefix argument ARG causes the calendar displayed to be ARG -months in the future if ARG is positive or in the past if ARG is negative; -in this case the cursor goes on the first day of the month. - -Once in the calendar window, future or past months can be moved into view. -Arbitrary months can be displayed, or the calendar can be scrolled forward -or backward. - -The cursor can be moved forward or backward by one day, one week, one month, -or one year. All of these commands take prefix arguments which, when negative, -cause movement in the opposite direction. For convenience, the digit keys -and the minus sign are automatically prefixes. The window is replotted as -necessary to display the desired date. - -Diary entries can be marked on the calendar or displayed in another window. - -Use M-x describe-mode for details of the key bindings in the calendar window. - -The Gregorian calendar is assumed. - -After loading the calendar, the hooks given by the variable -`calendar-load-hook' are run. This is the place to add key bindings to the -calendar-mode-map. - -After preparing the calendar window initially, the hooks given by the variable -`initial-calendar-window-hook' are run. - -The hooks given by the variable `today-visible-calendar-hook' are run -everytime the calendar window gets scrolled, if the current date is visible -in the window. If it is not visible, the hooks given by the variable -`today-invisible-calendar-hook' are run. Thus, for example, setting -`today-visible-calendar-hook' to 'calendar-star-date will cause today's date -to be replaced by asterisks to highlight it whenever it is in the window." t nil) - -(autoload 'list-yahrzeit-dates "calendar" "\ -List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR. -When called interactively from the calendar window, the date of death is taken -from the cursor position." t nil) - -;;;*** - -;;;### (autoloads (diary) "diary-lib" "calendar/diary-lib.el") - -(autoload 'diary "diary-lib" "\ -Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." t nil) - -;;;*** - -;;;### (autoloads (holidays) "holidays" "calendar/holidays.el") - -(autoload 'holidays "holidays" "\ -Display the holidays for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." t nil) - -;;;*** - -;;;### (autoloads (phases-of-moon) "lunar" "calendar/lunar.el") - -(autoload 'phases-of-moon "lunar" "\ -Display the quarters of the moon for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." t nil) - -;;;*** - -;;;### (autoloads (solar-equinoxes-solstices sunrise-sunset) "solar" "calendar/solar.el") - -(defvar calendar-time-display-form '(12-hours ":" minutes am-pm (if time-zone " (") time-zone (if time-zone ")")) "\ -*The pseudo-pattern that governs the way a time of day is formatted. - -A pseudo-pattern is a list of expressions that can involve the keywords -`12-hours', `24-hours', and `minutes', all numbers in string form, -and `am-pm' and `time-zone', both alphabetic strings. - -For example, the form - - '(24-hours \":\" minutes - (if time-zone \" (\") time-zone (if time-zone \")\")) - -would give military-style times like `21:07 (UTC)'.") - -(defvar calendar-latitude nil "\ -*Latitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + north, - south, such as 40.7 for New York City, or the value -can be a vector [degrees minutes north/south] such as [40 50 north] for New -York City. - -This variable should be set in site-local.el.") - -(defvar calendar-longitude nil "\ -*Longitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + east, - west, such as -73.9 for New York City, or the value -can be a vector [degrees minutes east/west] such as [73 55 west] for New -York City. - -This variable should be set in site-local.el.") - -(defvar calendar-location-name '(let ((float-output-format "%.1f")) (format "%s%s, %s%s" (if (numberp calendar-latitude) (abs calendar-latitude) (+ (aref calendar-latitude 0) (/ (aref calendar-latitude 1) 60.0))) (if (numberp calendar-latitude) (if (> calendar-latitude 0) "N" "S") (if (equal (aref calendar-latitude 2) 'north) "N" "S")) (if (numberp calendar-longitude) (abs calendar-longitude) (+ (aref calendar-longitude 0) (/ (aref calendar-longitude 1) 60.0))) (if (numberp calendar-longitude) (if (> calendar-longitude 0) "E" "W") (if (equal (aref calendar-latitude 2) 'east) "E" "W")))) "\ -*Expression evaluating to name of `calendar-longitude', calendar-latitude'. -For example, \"New York City\". Default value is just the latitude, longitude -pair. - -This variable should be set in site-local.el.") - -(autoload 'sunrise-sunset "solar" "\ -Local time of sunrise and sunset for today. Accurate to +/- 2 minutes. -If called with an optional prefix argument, prompt for date. - -If called with an optional double prefix argument, prompt for longitude, -latitude, time zone, and date, and always use standard time. - -This function is suitable for execution in a .emacs file." t nil) - -(autoload 'solar-equinoxes-solstices "solar" "\ -Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." nil nil) - -;;;*** - -(provide 'calendar-autoloads)
--- a/lisp/calendar/cal-dst.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,335 +0,0 @@ -;;; cal-dst.el --- calendar functions for daylight savings rules. - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Paul Eggert <eggert@twinsun.com> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: daylight savings time, calendar, diary, holidays - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; holiday.el that deal with daylight savings time. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -(defvar calendar-current-time-zone-cache nil - "Cache for result of calendar-current-time-zone.") - -(defvar calendar-system-time-basis - (calendar-absolute-from-gregorian '(1 1 1970)) - "Absolute date of starting date of system clock.") - -(defun calendar-absolute-from-time (x utc-diff) - "Absolute local date of time X; local time is UTC-DIFF seconds from UTC. - -X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the -high and low 16 bits, respectively, of the number of seconds since -1970-01-01 00:00:00 UTC, ignoring leap seconds. - -Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on -absolute date ABS-DATE is the equivalent moment to X." - (let* ((h (car x)) - (xtail (cdr x)) - (l (+ utc-diff (if (numberp xtail) xtail (car xtail)))) - (u (+ (* 512 (mod h 675)) (floor l 128)))) - ;; Overflow is a terrible thing! - (cons (+ calendar-system-time-basis - ;; floor((2^16 h +l) / (60*60*24)) - (* 512 (floor h 675)) (floor u 675)) - ;; (2^16 h +l) mod (60*60*24) - (+ (* (mod u 675) 128) (mod l 128))))) - -(defun calendar-time-from-absolute (abs-date s) - "Time of absolute date ABS-DATE, S seconds after midnight. - -Returns the pair (HIGH . LOW) where HIGH and LOW are the high and low -16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, -ignoring leap seconds, that is the equivalent moment to S seconds after -midnight UTC on absolute date ABS-DATE." - (let* ((a (- abs-date calendar-system-time-basis)) - (u (+ (* 163 (mod a 512)) (floor s 128)))) - ;; Overflow is a terrible thing! - (cons - ;; floor((60*60*24*a + s) / 2^16) - (+ a (* 163 (floor a 512)) (floor u 512)) - ;; (60*60*24*a + s) mod 2^16 - (+ (* 128 (mod u 512)) (mod s 128))))) - -(defun calendar-next-time-zone-transition (time) - "Return the time of the next time zone transition after TIME. -Both TIME and the result are acceptable arguments to current-time-zone. -Return nil if no such transition can be found." - (let* ((base 65536);; 2^16 = base of current-time output - (quarter-multiple 120);; approx = (seconds per quarter year) / base - (time-zone (current-time-zone time)) - (time-utc-diff (car time-zone)) - hi - hi-zone - (hi-utc-diff time-utc-diff) - (quarters '(2 1 3))) - ;; Heuristic: probe the time zone offset in the next three calendar - ;; quarters, looking for a time zone offset different from TIME. - (while (and quarters (eq time-utc-diff hi-utc-diff)) - (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0)) - (setq hi-zone (current-time-zone hi)) - (setq hi-utc-diff (car hi-zone)) - (setq quarters (cdr quarters))) - (and - time-utc-diff - hi-utc-diff - (not (eq time-utc-diff hi-utc-diff)) - ;; Now HI is after the next time zone transition. - ;; Set LO to TIME, and then binary search to increase LO and decrease HI - ;; until LO is just before and HI is just after the time zone transition. - (let* ((tail (cdr time)) - (lo (cons (car time) (if (numberp tail) tail (car tail)))) - probe) - (while - ;; Set PROBE to halfway between LO and HI, rounding down. - ;; If PROBE equals LO, we are done. - (let* ((lsum (+ (cdr lo) (cdr hi))) - (hsum (+ (car lo) (car hi) (/ lsum base))) - (hsumodd (logand 1 hsum))) - (setq probe (cons (/ (- hsum hsumodd) 2) - (/ (+ (* hsumodd base) (% lsum base)) 2))) - (not (equal lo probe))) - ;; Set either LO or HI to PROBE, depending on probe results. - (if (eq (car (current-time-zone probe)) hi-utc-diff) - (setq hi probe) - (setq lo probe))) - hi)))) - -(defun calendar-time-zone-daylight-rules (abs-date utc-diff) - "Return daylight transition rule for ABS-DATE, UTC-DIFF sec offset from UTC. -ABS-DIFF must specify a day that contains a daylight savings transition. -The result has the proper form for calendar-daylight-savings-starts'." - (let* ((date (calendar-gregorian-from-absolute abs-date)) - (weekday (% abs-date 7)) - (m (extract-calendar-month date)) - (d (extract-calendar-day date)) - (y (extract-calendar-year date)) - (last (calendar-last-day-of-month m y)) - (candidate-rules - (append - ;; Day D of month M. - (list (list 'list m d 'year)) - ;; The first WEEKDAY of month M. - (if (< d 8) - (list (list 'calendar-nth-named-day 1 weekday m 'year))) - ;; The last WEEKDAY of month M. - (if (> d (- last 7)) - (list (list 'calendar-nth-named-day -1 weekday m 'year))) - ;; The first WEEKDAY after day J of month M, for D-6 < J <= D. - (let (l) - (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do - (setq l - (cons - (list 'calendar-nth-named-day 1 weekday m 'year j) - l))) - l))) - (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day - (year (1+ y))) - ;; Scan through the next few years until only one rule remains. - (while - (let ((rules candidate-rules) - new-rules) - (while - (let* - ((rule (car rules)) - (date - ;; The following is much faster than - ;; (calendar-absolute-from-gregorian (eval rule)). - (cond ((eq (car rule) 'calendar-nth-named-day) - (eval (cons 'calendar-nth-named-absday (cdr rule)))) - ((eq (car rule) 'calendar-gregorian-from-absolute) - (eval (car (cdr rule)))) - (t (let ((g (eval rule))) - (calendar-absolute-from-gregorian g)))))) - (or (equal - (current-time-zone - (calendar-time-from-absolute date prevday-sec)) - (current-time-zone - (calendar-time-from-absolute (1+ date) prevday-sec))) - (setq new-rules (cons rule new-rules))) - (setq rules (cdr rules)))) - ;; If no rules remain, just use the first candidate rule; - ;; it's wrong in general, but it's right for at least one year. - (setq candidate-rules (if new-rules (nreverse new-rules) - (list (car candidate-rules)))) - (setq year (1+ year)) - (cdr candidate-rules))) - (car candidate-rules))) - -(defun calendar-current-time-zone () - "Return UTC difference, dst offset, names and rules for current time zone. - -Returns (UTC-DIFF DST-OFFSET STD-ZONE DST-ZONE DST-STARTS DST-ENDS -DST-STARTS-TIME DST-ENDS-TIME), based on a heuristic probing of what the -system knows: - -UTC-DIFF is an integer specifying the number of minutes difference between - standard time in the current time zone and Coordinated Universal Time - (Greenwich Mean Time). A negative value means west of Greenwich. -DST-OFFSET is an integer giving the daylight savings time offset in minutes. -STD-ZONE is a string giving the name of the time zone when no seasonal time - adjustment is in effect. -DST-ZONE is a string giving the name of the time zone when there is a seasonal - time adjustment in effect. -DST-STARTS and DST-ENDS are sexps in the variable `year' giving the daylight - savings time start and end rules, in the form expected by - `calendar-daylight-savings-starts'. -DST-STARTS-TIME and DST-ENDS-TIME are integers giving the number of minutes - after midnight that daylight savings time starts and ends. - -If the local area does not use a seasonal time adjustment, STD-ZONE and -DST-ZONE are equal, and all the DST-* integer variables are 0. - -Some operating systems cannot provide all this information to Emacs; in this -case, `calendar-current-time-zone' returns a list containing nil for the data -it can't find." - (or - calendar-current-time-zone-cache - (setq - calendar-current-time-zone-cache - (let* ((t0 (current-time)) - (t0-zone (current-time-zone t0)) - (t0-utc-diff (car t0-zone)) - (t0-name (car (cdr t0-zone)))) - (if (not t0-utc-diff) - ;; Little or no time zone information is available. - (list nil nil t0-name t0-name nil nil nil nil) - (let* ((t1 (calendar-next-time-zone-transition t0)) - (t2 (and t1 (calendar-next-time-zone-transition t1)))) - (if (not t2) - ;; This locale does not have daylight savings time. - (list (/ t0-utc-diff 60) 0 t0-name t0-name nil nil 0 0) - ;; Use heuristics to find daylight savings parameters. - (let* ((t1-zone (current-time-zone t1)) - (t1-utc-diff (car t1-zone)) - (t1-name (car (cdr t1-zone))) - (t1-date-sec (calendar-absolute-from-time t1 t0-utc-diff)) - (t2-date-sec (calendar-absolute-from-time t2 t1-utc-diff)) - (t1-rules (calendar-time-zone-daylight-rules - (car t1-date-sec) t0-utc-diff)) - (t2-rules (calendar-time-zone-daylight-rules - (car t2-date-sec) t1-utc-diff)) - (t1-time (/ (cdr t1-date-sec) 60)) - (t2-time (/ (cdr t2-date-sec) 60))) - (cons - (/ (min t0-utc-diff t1-utc-diff) 60) - (cons - (/ (abs (- t0-utc-diff t1-utc-diff)) 60) - (if (< t0-utc-diff t1-utc-diff) - (list t0-name t1-name t1-rules t2-rules t1-time t2-time) - (list t1-name t0-name t2-rules t1-rules t2-time t1-time) - ))))))))))) - -;;; The following six defvars relating to daylight savings time should NOT be -;;; marked to go into loaddefs.el where they would be evaluated when Emacs is -;;; dumped. These variables' appropriate values depend on the conditions under -;;; which the code is INVOKED; so it's inappropriate to initialize them when -;;; Emacs is dumped---they should be initialized when calendar.el is loaded. -;;; They default to US Eastern time if time zone info is not available. - -(calendar-current-time-zone) - -(defvar calendar-time-zone (or (car calendar-current-time-zone-cache) -300) - "*Number of minutes difference between local standard time at -`calendar-location-name' and Coordinated Universal (Greenwich) Time. For -example, -300 for New York City, -480 for Los Angeles.") - -(defvar calendar-daylight-time-offset - (or (car (cdr calendar-current-time-zone-cache)) 60) - "*Number of minutes difference between daylight savings and standard time. - -If the locale never uses daylight savings time, set this to 0.") - -(defvar calendar-standard-time-zone-name - (or (car (nthcdr 2 calendar-current-time-zone-cache)) "EST") - "*Abbreviated name of standard time zone at `calendar-location-name'. -For example, \"EST\" in New York City, \"PST\" for Los Angeles.") - -(defvar calendar-daylight-time-zone-name - (or (car (nthcdr 3 calendar-current-time-zone-cache)) "EDT") - "*Abbreviated name of daylight-savings time zone at `calendar-location-name'. -For example, \"EDT\" in New York City, \"PDT\" for Los Angeles.") - -;;;###autoload -(put 'calendar-daylight-savings-starts 'risky-local-variable t) -(defvar calendar-daylight-savings-starts - (or (car (nthcdr 4 calendar-current-time-zone-cache)) - (and (not (zerop calendar-daylight-time-offset)) - '(calendar-nth-named-day 1 0 4 year))) - "*Sexp giving the date on which daylight savings time starts. -This is an expression in the variable `year' whose value gives the Gregorian -date in the form (month day year) on which daylight savings time starts. It is -used to determine the starting date of daylight savings time for the holiday -list and for correcting times of day in the solar and lunar calculations. - -For example, if daylight savings time is mandated to start on October 1, -you would set `calendar-daylight-savings-starts' to - - '(10 1 year) - -If it starts on the first Sunday in April, you would set it to - - '(calendar-nth-named-day 1 0 4 year) - -If the locale never uses daylight savings time, set this to nil.") - -;;;###autoload -(put 'calendar-daylight-savings-ends 'risky-local-variable t) -(defvar calendar-daylight-savings-ends - (or (car (nthcdr 5 calendar-current-time-zone-cache)) - (and (not (zerop calendar-daylight-time-offset)) - '(calendar-nth-named-day -1 0 10 year))) - "*Sexp giving the date on which daylight savings time ends. -This is an expression in the variable `year' whose value gives the Gregorian -date in the form (month day year) on which daylight savings time ends. It is -used to determine the starting date of daylight savings time for the holiday -list and for correcting times of day in the solar and lunar calculations. - -For example, if daylight savings time ends on the last Sunday in October: - - '(calendar-nth-named-day -1 0 10 year) - -If the locale never uses daylight savings time, set this to nil.") - -(defvar calendar-daylight-savings-starts-time - (or (car (nthcdr 6 calendar-current-time-zone-cache)) 120) - "*Number of minutes after midnight that daylight savings time starts.") - -(defvar calendar-daylight-savings-ends-time - (or (car (nthcdr 7 calendar-current-time-zone-cache)) - calendar-daylight-savings-starts-time) - "*Number of minutes after midnight that daylight savings time ends.") - -(provide 'cal-dst) - -;;; cal-dst.el ends here
--- a/lisp/calendar/cal-french.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,220 +0,0 @@ -;;; cal-french.el --- calendar functions for the French Revolutionary calendar. - -;; Copyright (C) 1988, 1989, 1992, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: French Revolutionary calendar, calendar, diary - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the French Revolutionary calendar. - -;; Technical details of the French Revolutionary calendar can be found in -;; ``Calendrical Calculations, Part II: Three Historical Calendars'' -;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -(defconst french-calendar-month-name-array - ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" - "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]) - -(defconst french-calendar-day-name-array - ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" - "Octidi" "Nonidi" "Decadi"]) - -(defconst french-calendar-special-days-array - ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense" - "de la Revolution"]) - -(defun french-calendar-leap-year-p (year) - "True if YEAR is a leap year on the French Revolutionary calendar. -For Gregorian years 1793 to 1805, the years of actual operation of the -calendar, uses historical practice based on equinoxes is followed (years 3, 7, -and 11 were leap years; 15 and 20 would have been leap years). For later -years uses the proposed rule of Romme (never adopted)--leap years fall every -four years except century years not divisible 400 and century years that are -multiples of 4000." - (or (memq year '(3 7 11));; Actual practice--based on equinoxes - (memq year '(15 20)) ;; Anticipated practice--based on equinoxes - (and (> year 20) ;; Romme's proposal--never adopted - (zerop (% year 4)) - (not (memq (% year 400) '(100 200 300))) - (not (zerop (% year 4000)))))) - -(defun french-calendar-last-day-of-month (month year) - "Return last day of MONTH, YEAR on the French Revolutionary calendar. -The 13th month is not really a month, but the 5 (6 in leap years) day period of -`sansculottides' at the end of the year." - (if (< month 13) - 30 - (if (french-calendar-leap-year-p year) - 6 - 5))) - -(defun calendar-absolute-from-french (date) - "Compute absolute date from French Revolutionary date DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ (* 365 (1- year));; Days in prior years - ;; Leap days in prior years - (if (< year 20) - (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15) - ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion) - (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20 - (- (/ (1- year) 100)) - (/ (1- year) 400) - (- (/ (1- year) 4000)))) - (* 30 (1- month));; Days in prior months this year - day;; Days so far this month - 654414)));; Days before start of calendar (September 22, 1792). - -(defun calendar-french-from-absolute (date) - "Compute the French Revolutionary equivalent for absolute date DATE. -The result is a list of the form (MONTH DAY YEAR). -The absolute date is the number of days elapsed since the -\(imaginary) Gregorian date Sunday, December 31, 1 BC." - (if (< date 654415) - (list 0 0 0);; pre-French Revolutionary date - (let* ((approx (/ (- date 654414) 366));; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-french (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from Vendemiaire. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-french - (list m - (french-calendar-last-day-of-month m year) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date - (1- (calendar-absolute-from-french (list month 1 year)))))) - (list month day year)))) - -(defun calendar-french-date-string (&optional date) - "String of French Revolutionary date of Gregorian DATE. -Returns the empty string if DATE is pre-French Revolutionary. -Defaults to today's date if DATE is not given." - (let* ((french-date (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (y (extract-calendar-year french-date)) - (m (extract-calendar-month french-date)) - (d (extract-calendar-day french-date))) - (cond - ((< y 1) "") - ((= m 13) (format "Jour %s de l'Année %d de la Revolution" - (aref french-calendar-special-days-array (1- d)) - y)) - (t (format "Decade %s, %s de %s de l'Année %d de la Revolution" - (make-string (1+ (/ (1- d) 10)) ?I) - (aref french-calendar-day-name-array (% (1- d) 10)) - (aref french-calendar-month-name-array (1- m)) - y))))) - -(defun calendar-print-french-date () - "Show the French Revolutionary calendar equivalent of the selected date." - (interactive) - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - (message "Date is pre-French Revolution") - (message f)))) - -(defun calendar-goto-french-date (date &optional noecho) - "Move cursor to French Revolutionary date DATE. -Echo French Revolutionary date unless NOECHO is t." - (interactive - (let* ((year (calendar-read - "Année de la Revolution (>0): " - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))))) - (month-list - (mapcar 'list - (append french-calendar-month-name-array - (if (french-calendar-leap-year-p year) - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array) - (nreverse - (cdr;; we don't want rev. day in a non-leap yr. - (nreverse - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array)))))))) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Mois ou Sansculottide: " - month-list - nil t)) - (calendar-make-alist - month-list - 1 - '(lambda (x) (capitalize (car x))))))) - (decade (if (> month 12) - 1 - (calendar-read - "Décade (1-3): " - '(lambda (x) (memq x '(1 2 3)))))) - (day (if (> month 12) - (- month 12) - (calendar-read - "Jour (1-10): " - '(lambda (x) (and (<= 1 x) (<= x 10)))))) - (month (if (> month 12) 13 month)) - (day (+ day (* 10 (1- decade))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-french date))) - (or noecho (calendar-print-french-date))) - -(defun diary-french-date () - "French calendar equivalent of date diary entry." - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - "Date is pre-French Revolution" - f))) - -(provide 'cal-french) - -;;; cal-french.el ends here
--- a/lisp/calendar/cal-mayan.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,385 +0,0 @@ -;;; cal-mayan.el --- calendar functions for the Mayan calendars. - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Stewart M. Clamen <clamen@cs.cmu.edu> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Mayan calendar, Maya, calendar, diary - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Mayan calendar. It was written jointly by - -;; Stewart M. Clamen School of Computer Science -;; clamen@cs.cmu.edu Carnegie Mellon University -;; 5000 Forbes Avenue -;; Pittsburgh, PA 15213 - -;; and - -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; Comments, improvements, and bug reports should be sent to Reingold. - -;; Technical details of the Mayan calendrical calculations can be found in -;; ``Calendrical Calculations, Part II: Three Historical Calendars'' -;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;;; Code: - -(require 'calendar) - -(defun mayan-adjusted-mod (m n) - "Non-negative remainder of M/N with N instead of 0." - (1+ (mod (1- m) n))) - -(defconst calendar-mayan-days-before-absolute-zero 1137140 - "Number of days of the Mayan calendar epoch before absolute day 0. -According to the Goodman-Martinez-Thompson correlation. This correlation is -not universally accepted, as it still a subject of astro-archeological -research. Using 1232041 will give you Spinden's correlation; using -1142840 will give you Hochleitner's correlation.") - -(defconst calendar-mayan-haab-at-epoch '(8 . 18) - "Mayan haab date at the epoch.") - -(defconst calendar-mayan-haab-month-name-array - ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax" - "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]) - -(defconst calendar-mayan-tzolkin-at-epoch '(4 . 20) - "Mayan tzolkin date at the epoch.") - -(defconst calendar-mayan-tzolkin-names-array - ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc" - "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]) - -(defun calendar-mayan-long-count-from-absolute (date) - "Compute the Mayan long count corresponding to the absolute DATE." - (let ((long-count (+ date calendar-mayan-days-before-absolute-zero))) - (let* ((baktun (/ long-count 144000)) - (remainder (% long-count 144000)) - (katun (/ remainder 7200)) - (remainder (% remainder 7200)) - (tun (/ remainder 360)) - (remainder (% remainder 360)) - (uinal (/ remainder 20)) - (kin (% remainder 20))) - (list baktun katun tun uinal kin)))) - -(defun calendar-mayan-long-count-to-string (mayan-long-count) - "Convert MAYAN-LONG-COUNT into traditional written form." - (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count))) - -(defun calendar-string-to-mayan-long-count (str) - "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums." - (let ((rlc nil) - (c (length str)) - (cc 0)) - (condition-case condition - (progn - (while (< cc c) - (let* ((start (string-match "[0-9]+" str cc)) - (end (match-end 0)) - datum) - (setq datum (read (substring str start end))) - (setq rlc (cons datum rlc)) - (setq cc end))) - (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil))) - (invalid-read-syntax nil)) - (reverse rlc))) - -(defun calendar-mayan-haab-from-absolute (date) - "Convert absolute DATE into a Mayan haab date (a pair)." - (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) - (day-of-haab - (% (+ long-count - (car calendar-mayan-haab-at-epoch) - (* 20 (1- (cdr calendar-mayan-haab-at-epoch)))) - 365)) - (day (% day-of-haab 20)) - (month (1+ (/ day-of-haab 20)))) - (cons day month))) - -(defun calendar-mayan-haab-difference (date1 date2) - "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2." - (mod (+ (* 20 (- (cdr date2) (cdr date1))) - (- (car date2) (car date1))) - 365)) - -(defun calendar-mayan-haab-on-or-before (haab-date date) - "Absolute date of latest HAAB-DATE on or before absolute DATE." - (- date - (% (- date - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) haab-date)) - 365))) - -(defun calendar-next-haab-date (haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-haab-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-haab-on-or-before - haab-date - (+ 365 - (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-previous-haab-date (haab-date &optional noecho) - "Move cursor to previous instance of Mayan HAAB-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-haab-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-haab-on-or-before - haab-date - (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-haab-to-string (haab) - "Convert Mayan haab date (a pair) into its traditional written form." - (let ((month (cdr haab)) - (day (car haab))) - ;; 19th month consists of 5 special days - (if (= month 19) - (format "%d Uayeb" day) - (format "%d %s" - day - (aref calendar-mayan-haab-month-name-array (1- month)))))) - -(defun calendar-mayan-tzolkin-from-absolute (date) - "Convert absolute DATE into a Mayan tzolkin date (a pair)." - (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) - (day (mayan-adjusted-mod - (+ long-count (car calendar-mayan-tzolkin-at-epoch)) - 13)) - (name (mayan-adjusted-mod - (+ long-count (cdr calendar-mayan-tzolkin-at-epoch)) - 20))) - (cons day name))) - -(defun calendar-mayan-tzolkin-difference (date1 date2) - "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2." - (let ((number-difference (- (car date2) (car date1))) - (name-difference (- (cdr date2) (cdr date1)))) - (mod (+ number-difference - (* 13 (mod (* 3 (- number-difference name-difference)) - 20))) - 260))) - -(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date) - "Absolute date of latest TZOLKIN-DATE on or before absolute DATE." - (- date - (% (- date (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - 260))) - -(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to next instance of Mayan TZOLKIN-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-tzolkin-on-or-before - tzolkin-date - (+ 260 - (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to previous instance of Mayan TZOLKIN-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-tzolkin-on-or-before - tzolkin-date - (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-tzolkin-to-string (tzolkin) - "Convert Mayan tzolkin date (a pair) into its traditional written form." - (format "%d %s" - (car tzolkin) - (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin))))) - -(defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date) - "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE. -Latest such date on or before DATE. -Returns nil if such a tzolkin-haab combination is impossible." - (let* ((haab-difference - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) - haab-date)) - (tzolkin-difference - (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - (difference (- tzolkin-difference haab-difference))) - (if (= (% difference 5) 0) - (- date - (mod (- date - (+ haab-difference (* 365 difference))) - 18980)) - nil))) - -(defun calendar-read-mayan-haab-date () - "Prompt for a Mayan haab date" - (let* ((completion-ignore-case t) - (haab-day (calendar-read - "Haab kin (0-19): " - '(lambda (x) (and (>= x 0) (< x 20))))) - (haab-month-list (append calendar-mayan-haab-month-name-array - (and (< haab-day 5) '("Uayeb")))) - (haab-month (cdr - (assoc - (capitalize - (completing-read "Haab uinal: " - (mapcar 'list haab-month-list) - nil t)) - (calendar-make-alist - haab-month-list 1 'capitalize))))) - (cons haab-day haab-month))) - -(defun calendar-read-mayan-tzolkin-date () - "Prompt for a Mayan tzolkin date" - (let* ((completion-ignore-case t) - (tzolkin-count (calendar-read - "Tzolkin kin (1-13): " - '(lambda (x) (and (> x 0) (< x 14))))) - (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) - (tzolkin-name (cdr - (assoc - (capitalize - (completing-read "Tzolkin uinal: " - (mapcar 'list tzolkin-name-list) - nil t)) - (calendar-make-alist - tzolkin-name-list 1 'capitalize))))) - (cons tzolkin-count tzolkin-name))) - -(defun calendar-next-calendar-round-date - (tzolkin-date haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date) - (calendar-read-mayan-haab-date))) - (let ((date (calendar-mayan-tzolkin-haab-on-or-before - tzolkin-date haab-date - (+ 18980 (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))))) - (if (not date) - (error "%s, %s does not exist in the Mayan calendar round" - (calendar-mayan-tzolkin-to-string tzolkin-date) - (calendar-mayan-haab-to-string haab-date)) - (calendar-goto-date (calendar-gregorian-from-absolute date)) - (or noecho (calendar-print-mayan-date))))) - -(defun calendar-previous-calendar-round-date - (tzolkin-date haab-date &optional noecho) - "Move to previous instance of Mayan TZOKLIN-DATE HAAB-DATE combination. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date) - (calendar-read-mayan-haab-date))) - (let ((date (calendar-mayan-tzolkin-haab-on-or-before - tzolkin-date haab-date - (1- (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))))) - (if (not date) - (error "%s, %s does not exist in the Mayan calendar round" - (calendar-mayan-tzolkin-to-string tzolkin-date) - (calendar-mayan-haab-to-string haab-date)) - (calendar-goto-date (calendar-gregorian-from-absolute date)) - (or noecho (calendar-print-mayan-date))))) - -(defun calendar-absolute-from-mayan-long-count (c) - "Compute the absolute date corresponding to the Mayan Long Count C. -Long count is a list (baktun katun tun uinal kin)" - (+ (* (nth 0 c) 144000) ; baktun - (* (nth 1 c) 7200) ; katun - (* (nth 2 c) 360) ; tun - (* (nth 3 c) 20) ; uinal - (nth 4 c) ; kin (days) - (- ; days before absolute date 0 - calendar-mayan-days-before-absolute-zero))) - -(defun calendar-mayan-date-string (&optional date) - "String of Mayan date of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((d (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - (tzolkin (calendar-mayan-tzolkin-from-absolute d)) - (haab (calendar-mayan-haab-from-absolute d)) - (long-count (calendar-mayan-long-count-from-absolute d))) - (format "Long count = %s; tzolkin = %s; haab = %s" - (calendar-mayan-long-count-to-string long-count) - (calendar-mayan-tzolkin-to-string tzolkin) - (calendar-mayan-haab-to-string haab)))) - -(defun calendar-print-mayan-date () - "Show the Mayan long count, tzolkin, and haab equivalents of date." - (interactive) - (message "Mayan date: %s" - (calendar-mayan-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-mayan-long-count-date (date &optional noecho) - "Move cursor to Mayan long count DATE. Echo Mayan date unless NOECHO is t." - (interactive - (let (lc) - (while (not lc) - (let ((datum - (calendar-string-to-mayan-long-count - (read-string "Mayan long count (baktun.katun.tun.uinal.kin): " - (calendar-mayan-long-count-to-string - (calendar-mayan-long-count-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date)))))))) - (if (calendar-mayan-long-count-common-era datum) - (setq lc datum)))) - (list lc))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-absolute-from-mayan-long-count date))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-long-count-common-era (lc) - "T if long count represents date in the Common Era." - (let ((base (calendar-mayan-long-count-from-absolute 1))) - (while (and (not (null base)) (= (car lc) (car base))) - (setq lc (cdr lc) - base (cdr base))) - (or (null lc) (> (car lc) (car base))))) - -(defun diary-mayan-date () - "Show the Mayan long count, haab, and tzolkin dates as a diary entry." - (format "Mayan date: %s" (calendar-mayan-date-string date))) - -(provide 'cal-mayan) - -;;; cal-mayan.el ends here
--- a/lisp/calendar/cal-x.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,180 +0,0 @@ -;;; cal-x.el --- calendar windows in dedicated frames in x-windows - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Modified for XEmacs by: Chuck Thompson <cthomp@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar, dedicated frames, x-windows - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements dedicated frames in x-windows for -;; calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) -(if (not (fboundp 'calendar-basic-setup)) - (fset 'calendar-basic-setup (symbol-function 'calendar))) - -;;;###autoload -(defvar calendar-setup 'one-frame - "The frame set up of the calendar. -The choices are `one-frame' (calendar and diary together in one separate, -dediciated frame) or `two-frames' (calendar and diary in separate, dedicated -frames); with any other value the current frame is used.") - -(defun calendar (&optional arg) - "Choose between the one frame, two frame, or basic calendar displays. -The original function `calendar' has been renamed `calendar-basic-setup'." - (interactive "P") - (cond ((equal calendar-setup 'one-frame) (calendar-one-frame-setup arg)) - ((equal calendar-setup 'two-frames) (calendar-two-frame-setup arg)) - (t (calendar-basic-setup arg)))) - -(defvar calendar-frame nil "Frame in which to display the calendar.") - -(defvar diary-frame nil "Frame in which to display the diary.") - -(defvar diary-frame-parameters - '((name . "Diary") (height . 10) (width . 80) (unsplittable . t) - (font . "6x13") (auto-lower . t) (auto-raise . t) (minibuffer . nil)) - "Parameters of the diary frame, if the diary is in its own frame. -Location and color should be set in .Xdefaults.") - -(defvar calendar-frame-parameters - '((name . "Calendar") (minibuffer . nil) (height . 10) (width . 80) - (auto-raise . t) (auto-lower . t) (font . "6x13") (unsplittable . t) - (vertical-scroll-bars . nil)) - "Parameters of the calendar frame, if the calendar is in a separate frame. -Location and color should be set in .Xdefaults.") - -(defvar calendar-and-diary-frame-parameters - '((name . "Calendar") (height . 28) (width . 80) (minibuffer . nil) - (font . "6x13") (auto-raise . t) (auto-lower . t)) - "Parameters of the frame that displays both the calendar and the diary. -Location and color should be set in .Xdefaults.") - -(defvar calendar-after-frame-setup-hooks nil - "Hooks to be run just after setting up a calendar frame. -Can be used to change frame parameters, such as font, color, location, etc.") - -(defun calendar-not-using-window-system-p () - "Return t if not running under a window system." - (if (fboundp 'device-type) - (not (eq (device-type (selected-device)) 'x)) - (not window-system))) - -(defun calendar-deiconify-frame (frame) - "Deiconify the given frame if it is currently iconified." - (if (string-match "XEmacs" emacs-version) - (if (frame-iconified-p frame) - (deiconify-frame frame)) - (if (eq 'icon (cdr (assoc 'visibility (frame-parameters frame)))) - ;; This isn't necessary going to do what is intended since it - ;; only works with the selected frame. - (iconify-or-deiconify-frame)))) - -(defun calendar-one-frame-setup (&optional arg) - "Start calendar and display it in a dedicated frame together with the diary." - (if (calendar-not-using-window-system-p) - (calendar-basic-setup arg) - (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) - (if (frame-live-p diary-frame) (delete-frame diary-frame)) - (let ((special-display-buffer-names nil) - (view-diary-entries-initially t)) - (save-window-excursion - (save-excursion - (setq calendar-frame - (make-frame calendar-and-diary-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame calendar-frame) - (calendar-deiconify-frame calendar-frame) - (calendar-basic-setup arg) - (set-window-dedicated-p (selected-window) 'calendar) - (set-window-dedicated-p - (display-buffer - (if (not (memq 'fancy-diary-display diary-display-hook)) - (get-file-buffer diary-file) - (if (not (bufferp (get-buffer fancy-diary-buffer))) - (make-fancy-diary-buffer)) - fancy-diary-buffer)) - 'diary)))))) - -(defun calendar-two-frame-setup (&optional arg) - "Start calendar and diary in separate, dedicated frames." - (if (calendar-not-using-window-system-p) - (calendar-basic-setup arg) - (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) - (if (frame-live-p diary-frame) (delete-frame diary-frame)) - (let ((pop-up-windows nil) - (view-diary-entries-initially nil) - (special-display-buffer-names nil)) - (save-window-excursion - (save-excursion (calendar-basic-setup arg)) - (setq calendar-frame (make-frame calendar-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame calendar-frame) - (calendar-deiconify-frame calendar-frame) - (display-buffer calendar-buffer) - (set-window-dedicated-p (selected-window) 'calendar) - (setq diary-frame (make-frame diary-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame diary-frame) - (calendar-deiconify-frame diary-frame) - (save-excursion (diary)) - (set-window-dedicated-p - (display-buffer - (if (not (memq 'fancy-diary-display diary-display-hook)) - (get-file-buffer diary-file) - (if (not (bufferp (get-buffer fancy-diary-buffer))) - (make-fancy-diary-buffer)) - fancy-diary-buffer)) - 'diary))))) - -(defun make-fancy-diary-buffer () - (save-excursion - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (make-local-variable 'mode-line-format) - (calendar-set-mode-line "Diary Entries") - (erase-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t))) - -(if (not (string-match "XEmacs" emacs-version)) - (setq special-display-buffer-names - (append special-display-buffer-names - (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer - fancy-diary-buffer (get-file-buffer diary-file) - calendar-buffer)))) - -(run-hooks 'cal-x-load-hook) - -(provide 'cal-x) - -;;; cal-x.el ends here
--- a/lisp/calendar/cal-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,260 +0,0 @@ -;;; cal-xemacs.el --- calendar functions for menu bar and popup menu support -;;; Original file is cal-menu.el. - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Lara Rios <lrios@coewl.cen.uiuc.edu> -;; Ported to XEmacs by Chuck Thompson <cthomp@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar, popup menus, menu bar - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements menu bar and popup menu support for -;; calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -;;(define-key calendar-mode-map 'button2 'calendar-mouse-2-date-menu) -;;(define-key calendar-mode-map 'button2up 'ignore) - -(defconst calendar-popup-menu-3 - '("Calendar" - ["Scroll forward" scroll-calendar-left-three-months t] - ["Scroll backward" scroll-calendar-right-three-months t] - ["Mark diary entries" mark-diary-entries t] - ["List holidays" list-calendar-holidays t] - ["Mark holidays" mark-calendar-holidays t] - ["Unmark" calendar-unmark t] - ["Lunar phases" calendar-phases-of-moon t] - ["Show diary" show-all-diary-entries t] - ["Exit calendar" exit-calendar t] - )) - -(defun calendar-popup-menu-3 (e) - (interactive "@e") - (popup-menu calendar-popup-menu-3)) -(define-key calendar-mode-map 'button3 'calendar-popup-menu-3) - -(defvar calendar-foobar nil) - -(defun calendar-popup-menu-2 (e) - (interactive "@e") - (setq calendar-foobar (calendar-event-to-date e t)) - (let ((menu (list (format "Menu - %s" (calendar-date-string calendar-foobar) t t) - "-----" - ["Holidays" calendar-mouse-holidays t] - ["Mark date" calendar-mouse-set-mark t] - ["Sunrise/sunset" calendar-mouse-sunrise/sunset t] - ["Other calendars" calendar-mouse-print-dates (calendar-event-to-date e)] - ["Diary entries" calendar-mouse-view-diary-entries t] - ["Insert diary entry" calendar-mouse-insert-diary-entry t] - ["Other Diary file entries" - calendar-mouse-view-other-diary-entries - (calendar-cursor-to-date)] - ))) - (popup-menu menu))) -(define-key calendar-mode-map 'button2 'calendar-popup-menu-2) - -(defconst calendar-scroll-menu - '("Scroll" - ["Forward 1 Month" scroll-calendar-left t] - ["Forward 3 Months" scroll-calendar-left-three-months t] - ["Forward 1 Year" (scroll-calendar-left-three-months 4) t] - ["Backward 1 Month" scroll-calendar-right t] - ["Backward 3 Months" scroll-calendar-right-three-months t] - ["Backward 1 Year" (scroll-calendar-right-three-months 4) t])) - -(defconst calendar-goto-menu - '("Goto" - ["Today" calendar-current-month t] - ["Beginning of week" calendar-beginning-of-week (calendar-cursor-to-date)] - ["End of week" calendar-end-of-week (calendar-cursor-to-date)] - ["Beginning of month" calendar-beginning-of-month (calendar-cursor-to-date)] - ["End of month" calendar-end-of-month (calendar-cursor-to-date)] - ["Beginning of year" calendar-beginning-of-year (calendar-cursor-to-date)] - ["End of year" calendar-end-of-year (calendar-cursor-to-date)] - ["Other date" calendar-goto-date t] - ["ISO date" calendar-goto-iso-date t] - ["Astronomical date" calendar-goto-astro-day-number t] - ["Hebrew date" calendar-goto-hebrew-date t] - ["Islamic date" calendar-goto-islamic-date t] - ["Julian date" calendar-goto-julian-date t] - ("Mayan date" - ["Next Tzolkin" calendar-next-tzolkin-date t] - ["Previous Tzolkin" calendar-previous-tzolkin-date t] - ["Next Haab" calendar-next-haab-date t] - ["Previous Haab" calendar-previous-haab-date t] - ["Next Round" calendar-next-calendar-round-date t] - ["Previous Round" calendar-previous-calendar-round-date t]) - ["French date" calendar-goto-french-date t])) - -(defconst calendar-holidays-menu - '("Holidays" - ["One day" calendar-cursor-holidays (calendar-cursor-to-date)] - ["3 months" list-calendar-holidays t] - ["Mark" mark-calendar-holidays t] - ["Unmark" calendar-unmark t])) - -(defconst calendar-diary-menu - '("Diary" - ["Other file" view-other-diary-entries (calendar-cursor-to-date)] - ["Cursor date" view-diary-entries (calendar-cursor-to-date)] - ["Mark all" mark-diary-entries t] - ["Show all" show-all-diary-entries t] - ["Insert daily"insert-diary-entry t] - ["Insert weekly" insert-weekly-diary-entry (calendar-cursor-to-date)] - ["Insert monthly" insert-monthly-diary-entry (calendar-cursor-to-date)] - ["Insert yearly" insert-yearly-diary-entry (calendar-cursor-to-date)] - ["Insert anniversary" insert-anniversary-diary-entry (calendar-cursor-to-date)] - ["Insert block" insert-block-diary-entry (calendar-cursor-to-date)] - ["Insert cyclic" insert-cyclic-diary-entry (calendar-cursor-to-date)] - ["Insert Islamic" calendar-mouse-insert-islamic-diary-entry (calendar-cursor-to-date)] - ["Insert Hebrew" calendar-mouse-insert-hebrew-diary-entry (calendar-cursor-to-date)])) - -(defun calendar-add-menus () - (set-buffer-menubar (copy-sequence current-menubar)) - (if (assoc "Calendar" current-menubar) - nil - (add-submenu nil '("Calendar")) - (if (not (assoc "Scroll" current-menubar)) - (add-submenu '("Calendar") calendar-scroll-menu)) - (if (not (assoc "Goto" current-menubar)) - (add-submenu '("Calendar") calendar-goto-menu)) - (if (not (assoc "Holidays" current-menubar)) - (add-submenu '("Calendar") calendar-holidays-menu)) - (if (not (assoc "Diary" current-menubar)) - (add-submenu '("Calendar") calendar-diary-menu)) - (if (not (assoc "Moon" current-menubar)) - (add-menu-button '("Calendar") ["Moon" calendar-phases-of-moon t])))) - -(defun calendar-event-to-date (event &optional error) - "Date of last event. -If event is not on a specific date, signals an error if optional parameter -ERROR is t, otherwise just returns nil." - (save-excursion - (goto-char (event-point event)) - (calendar-cursor-to-date error))) - -(defun calendar-mouse-insert-hebrew-diary-entry (event) - "Pop up menu to insert a Hebrew-date diary entry." - (interactive "e") - (let ((menu (list (format "Hebrew insert menu - %s" - (calendar-hebrew-date-string - (calendar-cursor-to-date))) - "-----" - ["One time" insert-hebrew-diary-entry t] - ["Monthly" insert-monthly-hebrew-diary-entry t] - ["Yearly" insert-yearly-hebrew-diary-entry t]))) - (popup-menu menu))) - -(defun calendar-mouse-insert-islamic-diary-entry (event) - "Pop up menu to insert an Islamic-date diary entry." - (interactive "e") - (let ((menu (list (format "Islamic insert menu - %s" - (calendar-islamic-date-string - (calendar-cursor-to-date))) - "-----" - ["One time" insert-islamic-diary-entry t] - ["Monthly" insert-monthly-islamic-diary-entry t] - ["Yearly" insert-yearly-islamic-diary-entry t]))) - (popup-menu menu))) - -(defun calendar-mouse-sunrise/sunset () - "Show sunrise/sunset times for mouse-selected date." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (calendar-sunrise-sunset))) - -(defun calendar-mouse-holidays () - "Show holidays for mouse-selected date." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (calendar-cursor-holidays))) - -(defun calendar-mouse-view-diary-entries () - "View diary entries on mouse-selected date." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (view-diary-entries 1))) - -(defun calendar-mouse-view-other-diary-entries (event) - "View diary entries from alternative file on mouse-selected date." - (interactive "e") - (save-excursion - (calendar-goto-date calendar-foobar) - (call-interactively 'view-other-diary-entries))) - -(defun calendar-mouse-insert-diary-entry (event) - "Insert diary entry for mouse-selected date." - (interactive "e") - (save-excursion - (calendar-goto-date calendar-foobar) - (insert-diary-entry nil))) - -(defun calendar-mouse-set-mark () - "Mark the date under the cursor." - (interactive) - (save-excursion - (calendar-goto-date calendar-foobar) - (setq calendar-foobar nil) - (calendar-set-mark nil))) - -(defun calendar-mouse-print-dates () - "Pop up menu of equivalent dates to mouse selected date." - (interactive) - (let* ((menu (list (format "Date Menu - %s (Gregorian)" - (calendar-date-string calendar-foobar)) - "-----" - (calendar-day-of-year-string calendar-foobar) - (format "ISO date: %s" (calendar-iso-date-string calendar-foobar)) - (format "Julian date: %s" - (calendar-julian-date-string calendar-foobar)) - (format "Astronomical (Julian) date (before noon): %s" - (calendar-astro-date-string calendar-foobar)) - (format "Hebrew date (before sunset): %s" - (calendar-hebrew-date-string calendar-foobar)) - (let ((i (calendar-islamic-date-string calendar-foobar))) - (if (not (string-equal i "")) - (format "Islamic date (before sunset): %s" i))) - (let ((f (calendar-french-date-string calendar-foobar))) - (if (not (string-equal f "")) - (format "French Revolutionary date: %s" f))) - (format "Mayan date: %s" (calendar-mayan-date-string calendar-foobar))))) - (popup-menu menu)) - (setq calendar-foobar nil)) - -(run-hooks 'cal-xemacs-load-hook) - -(provide 'cal-xemacs) - -;;; cal-menu.el ends here
--- a/lisp/calendar/calendar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3063 +0,0 @@ -;;; calendar.el --- Calendar functions. -*-byte-compile-dynamic: t;-*- - -;;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994 Free Software -;;; Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar, Gregorian calendar, Julian calendar, -;; Hebrew calendar, Islamic calendar, ISO calendar, Julian day number, -;; diary, holidays - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements a calendar window. It -;; generates a calendar for the current month, together with the previous -;; and coming months, or for any other three-month period. The calendar -;; can be scrolled forward and backward in the window to show months in -;; the past or future; the cursor can move forward and backward by days, -;; weeks, or months, making it possible, for instance, to jump to the -;; date a specified number of days, weeks, or months from the date under -;; the cursor. The user can display a list of holidays and other notable -;; days for the period shown; the notable days can be marked on the -;; calendar, if desired. The user can also specify that dates having -;; corresponding diary entries (in a file that the user specifies) be -;; marked; the diary entries for any date can be viewed in a separate -;; window. The diary and the notable days can be viewed independently of -;; the calendar. Dates can be translated from the (usual) Gregorian -;; calendar to the day of the year/days remaining in year, to the ISO -;; commercial calendar, to the Julian (old style) calendar, to the Hebrew -;; calendar, to the Islamic calendar, to the French Revolutionary calendar, -;; to the Mayan calendar, and to the astronomical (Julian) day number. -;; When floating point is available, times of sunrise/sunset can be displayed, -;; as can the phases of the moon. Appointment notification for diary entries -;; is available. - -;; The following files are part of the calendar/diary code: - -;; cal-menu.el Menu support -;; cal-x.el X-windows dedicated frame functions -;; diary-lib.el, diary-ins.el Diary functions -;; holidays.el Holiday functions -;; cal-french.el French Revolutionary calendar -;; cal-mayan.el Mayan calendars -;; cal-dst.el Daylight savings time rules -;; solar.el Sunrise/sunset, equinoxes/solstices -;; lunar.el Phases of the moon -;; appt.el Appointment notification - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; GNU Emacs users too numerous to list pointed out a variety of problems -;; with earlier forms of the `infinite' sliding calendar and suggested some -;; of the features included in this package. Especially significant in this -;; regard was the suggestion of mark-diary-entries and view-diary-entries, -;; together ideas for their implementation, by -;; Michael S. Littman Cognitive Science Research Group -;; (201) 829-5155 Bell Communications Research -;; mlittman@wind.bellcore.com 445 South St. Box 1961 (2L-331) -;; Morristown, NJ 07960 - -;; The algorithms for the Hebrew calendar are those of the Rambam (Rabbi Moses -;; Maimonides), from his Mishneh Torah, as implemented by -;; Nachum Dershowitz Department of Computer Science -;; (217) 333-4219 University of Illinois at Urbana-Champaign -;; nachum@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; Technical details of all the calendrical calculations can be found in - -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990), -;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical -;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;; Hard copies of these two papers can be obtained by sending email to -;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and -;; the message BODY containing your mailing address (snail). - -;;; Code: - -(defgroup diary nil - "Diary customization" - :group 'calendar) - -(defgroup holidays nil - "Holidays in calendar" - :group 'calendar) - -(defun calendar-version () - (interactive) - (message "Version 5.3, January 25, 1994")) - -(defgroup appt nil - "Appointment notification" - :tag "Appointments" - :group 'calendar) - - -;;;###autoload -(defcustom calendar-week-start-day 0 - "*The day of the week on which a week in the calendar begins. -0 means Sunday (default), 1 means Monday, and so on." - :type 'integer - :group 'calendar) - -;;;###autoload -(defcustom calendar-offset 0 - "*The offset of the principal month from the center of the calendar window. -0 means the principal month is in the center (default), -1 means on the left, -+1 means on the right. Larger (or smaller) values push the principal month off -the screen." - :type 'integer - :group 'calendar) - -;;;###autoload -(defcustom view-diary-entries-initially nil - "*Non-nil means display current date's diary entries on entry. -The diary is displayed in another window when the calendar is first displayed, -if the current date is visible. The number of days of diary entries displayed -is governed by the variable `number-of-diary-entries'." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom number-of-diary-entries 1 - "*Specifies how many days of diary entries are to be displayed initially. -This variable affects the diary display when the command M-x diary is used, -or if the value of the variable `view-diary-entries-initially' is t. For -example, if the default value 1 is used, then only the current day's diary -entries will be displayed. If the value 2 is used, then both the current -day's and the next day's entries will be displayed. - -The value can also be a vector such as [0 2 2 2 2 4 1]; this value -says to display no diary entries on Sunday, the display the entries -for the current date and the day after on Monday through Thursday, -display Friday through Monday's entries on Friday, and display only -Saturday's entries on Saturday. - -This variable does not affect the diary display with the `d' command -from the calendar; in that case, the prefix argument controls the -number of days of diary entries displayed." - :type 'integer - :group 'diary) - -;;;###autoload -(defcustom mark-diary-entries-in-calendar nil - "*Non-nil means mark dates with diary entries, in the calendar window. -The marking symbol is specified by the variable `diary-entry-marker'." - :type 'boolean - :group 'diary) - -(defcustom diary-entry-marker - (progn - (make-face 'diary-face) - (cond ((face-differs-from-default-p 'diary-face) nil) - (t (set-face-foreground 'diary-face "red" 'global '(x color)) - (set-face-highlight-p 'diary-face t 'global 'tty) - ;; avoid a weird problem when byte-compiling appt.el - ;; in batch mode. - (if (and (not noninteractive) (fboundp 'x-make-font-bold)) - (let ((bfont (x-make-font-bold - (face-font-instance 'default))) - (mono-tag (list 'x 'mono)) - (gray-tag (list 'x 'grayscale))) - (if bfont - (progn - (set-face-font 'diary-face bfont 'global mono-tag) - (set-face-font 'diary-face bfont 'global - gray-tag))))))) - 'diary-face) - "*Used to mark dates that have diary entries. -Can be either a single-character string or a face." - :type '(choice string face) - :group 'diary) - -(defcustom calendar-today-marker - (progn - (make-face 'calendar-today-face) - (if (not (face-differs-from-default-p 'calendar-today-face)) - (set-face-underline-p 'calendar-today-face t)) - 'calendar-today-face) - "*Used to mark today's date. -Can be either a single-character string or a face." - :type '(choice string face) - :group 'calendar) - -(defcustom calendar-holiday-marker - (progn - (make-face 'holiday-face) - (cond ((face-differs-from-default-p 'holiday-face) nil) - (t (let ((color-tag (list 'x 'color)) - (mono-tag (list 'x 'mono)) - (gray-tag (list 'x 'grayscale))) - (set-face-background 'holiday-face [default foreground] 'global - mono-tag) - (set-face-foreground 'holiday-face [default background] 'global - mono-tag) - (set-face-background 'holiday-face [default foreground] 'global - gray-tag) - (set-face-foreground 'holiday-face [default background] 'global - gray-tag) - (set-face-background 'holiday-face "pink" 'global color-tag) - (set-face-reverse-p 'holiday-face t 'global 'tty)))) - 'holiday-face) - "*Used to mark notable dates in the calendar. -Can be either a single-character string or a face." - :type '(choice string face) - :group 'holidays) - -;;;###autoload -(defcustom view-calendar-holidays-initially nil - "*Non-nil means display holidays for current three month period on entry. -The holidays are displayed in another window when the calendar is first -displayed." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom mark-holidays-in-calendar nil - "*Non-nil means mark dates of holidays in the calendar window. -The marking symbol is specified by the variable `calendar-holiday-marker'." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom all-hebrew-calendar-holidays nil - "*If nil, show only major holidays from the Hebrew calendar. -This means only those Jewish holidays that appear on secular calendars. - -If t, show all the holidays that would appear in a complete Hebrew calendar." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom all-christian-calendar-holidays nil - "*If nil, show only major holidays from the Christian calendar. -This means only those Christian holidays that appear on secular calendars. - -If t, show all the holidays that would appear in a complete Christian -calendar." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom all-islamic-calendar-holidays nil - "*If nil, show only major holidays from the Islamic calendar. -This means only those Islamic holidays that appear on secular calendars. - -If t, show all the holidays that would appear in a complete Islamic -calendar." - :type 'boolean - :group 'holidays) - -;;;###autoload -(defcustom calendar-load-hook nil - "*List of functions to be called after the calendar is first loaded. -This is the place to add key bindings to `calendar-mode-map'." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom initial-calendar-window-hook nil - "*List of functions to be called when the calendar window is first opened. -The functions invoked are called after the calendar window is opened, but -once opened is never called again. Leaving the calendar with the `q' command -and reentering it will cause these functions to be called again." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom today-visible-calendar-hook nil - "*List of functions called whenever the current date is visible. -This can be used, for example, to replace today's date with asterisks; a -function `calendar-star-date' is included for this purpose: - (setq today-visible-calendar-hook 'calendar-star-date) -It can also be used to mark the current date with `calendar-today-marker'; -a function is also provided for this: - (setq today-visible-calendar-hook 'calendar-mark-today) - -The corresponding variable `today-invisible-calendar-hook' is the list of -functions called when the calendar function was called when the current -date is not visible in the window. - -Other than the use of the provided functions, the changing of any -characters in the calendar buffer by the hooks may cause the failure of the -functions that move by days and weeks." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom today-invisible-calendar-hook nil - "*List of functions called whenever the current date is not visible. - -The corresponding variable `today-visible-calendar-hook' is the list of -functions called when the calendar function was called when the current -date is visible in the window. - -Other than the use of the provided functions, the changing of any -characters in the calendar buffer by the hooks may cause the failure of the -functions that move by days and weeks." - :type 'hook - :group 'calendar) - -;;;###autoload -(defcustom diary-file "~/diary" - "*Name of the file in which one's personal diary of dates is kept. - -The file's entries are lines in any of the forms - - MONTH/DAY - MONTH/DAY/YEAR - MONTHNAME DAY - MONTHNAME DAY, YEAR - DAYNAME - -at the beginning of the line; the remainder of the line is the diary entry -string for that date. MONTH and DAY are one or two digit numbers, YEAR is -a number and may be written in full or abbreviated to the final two digits. -If the date does not contain a year, it is generic and applies to any year. -DAYNAME entries apply to any date on which is on that day of the week. -MONTHNAME and DAYNAME can be spelled in full, abbreviated to three -characters (with or without a period), capitalized or not. Any of DAY, -MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year, -respectively. - -The European style (in which the day precedes the month) can be used -instead, if you execute `european-calendar' when in the calendar, or set -`european-calendar-style' to t in your .emacs file. The European forms are - - DAY/MONTH - DAY/MONTH/YEAR - DAY MONTHNAME - DAY MONTHNAME YEAR - DAYNAME - -To revert to the default American style from the European style, execute -`american-calendar' in the calendar. - -A diary entry can be preceded by the character -`diary-nonmarking-symbol' (ordinarily `&') to make that entry -nonmarking--that is, it will not be marked on dates in the calendar -window but will appear in a diary window. - -Multiline diary entries are made by indenting lines after the first with -either a TAB or one or more spaces. - -Lines not in one the above formats are ignored. Here are some sample diary -entries (in the default American style): - - 12/22/1988 Twentieth wedding anniversary!! - &1/1. Happy New Year! - 10/22 Ruth's birthday. - 21: Payday - Tuesday--weekly meeting with grad students at 10am - Supowit, Shen, Bitner, and Kapoor to attend. - 1/13/89 Friday the thirteenth!! - &thu 4pm squash game with Lloyd. - mar 16 Dad's birthday - April 15, 1989 Income tax due. - &* 15 time cards due. - -If the first line of a diary entry consists only of the date or day name with -no trailing blanks or punctuation, then that line is not displayed in the -diary window; only the continuation lines is shown. For example, the -single diary entry - - 02/11/1989 - Bill Blattner visits Princeton today - 2pm Cognitive Studies Committee meeting - 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative' - 4:00pm Jamie Tappenden - 7:30pm Dinner at George and Ed's for Alan Ryan - 7:30-10:00pm dance at Stewart Country Day School - -will appear in the diary window without the date line at the beginning. This -facility allows the diary window to look neater, but can cause confusion if -used with more than one day's entries displayed. - -Diary entries can be based on Lisp sexps. For example, the diary entry - - %%(diary-block 11 1 1990 11 10 1990) Vacation - -causes the diary entry \"Vacation\" to appear from November 1 through November -10, 1990. Other functions available are `diary-float', `diary-anniversary', -`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date', -`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date', -`diary-yahrzeit', `diary-sunrise-sunset', `diary-phases-of-moon', -`diary-parasha', `diary-omer', `diary-rosh-hodesh', and -`diary-sabbath-candles'. See the documentation for the function -`list-sexp-diary-entries' for more details. - -Diary entries based on the Hebrew and/or the Islamic calendar are also -possible, but because these are somewhat slow, they are ignored -unless you set the `nongregorian-diary-listing-hook' and the -`nongregorian-diary-marking-hook' appropriately. See the documentation -for these functions for details. - -Diary files can contain directives to include the contents of other files; for -details, see the documentation for the variable `list-diary-entries-hook'." - :type 'file - :group 'diary) - -;;;###autoload -(defcustom diary-nonmarking-symbol "&" - "*Symbol indicating that a diary entry is not to be marked in the calendar." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom hebrew-diary-entry-symbol "H" - "*Symbol indicating a diary entry according to the Hebrew calendar." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom islamic-diary-entry-symbol "I" - "*Symbol indicating a diary entry according to the Islamic calendar." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom diary-include-string "#include" - "*The string indicating inclusion of another file of diary entries. -See the documentation for the function `include-other-diary-files'." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom sexp-diary-entry-symbol "%%" - "*The string used to indicate a sexp diary entry in diary-file. -See the documentation for the function `list-sexp-diary-entries'." - :type 'string - :group 'diary) - -;;;###autoload -(defcustom abbreviated-calendar-year t - "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD. -For the Gregorian calendar; similarly for the Hebrew and Islamic calendars. -If this variable is nil, years must be written in full." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom european-calendar-style nil - "*Use the European style of dates in the diary and in any displays. -If this variable is t, a date 1/2/1990 would be interpreted as February 1, -1990. The accepted European date styles are - - DAY/MONTH - DAY/MONTH/YEAR - DAY MONTHNAME - DAY MONTHNAME YEAR - DAYNAME - -Names can be capitalized or not, written in full, or abbreviated to three -characters with or without a period." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom american-date-diary-pattern - '((month "/" day "[^/0-9]") - (month "/" day "/" year "[^0-9]") - (monthname " *" day "[^,0-9]") - (monthname " *" day ", *" year "[^0-9]") - (dayname "\\W")) - "*List of pseudo-patterns describing the American patterns of date used. -See the documentation of `diary-date-forms' for an explanation." - :type '(repeat (choice (cons :tag "Backup" - (const backup) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp)))) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp))))) - :group 'diary) - -;;;###autoload -(defcustom european-date-diary-pattern - '((day "/" month "[^/0-9]") - (day "/" month "/" year "[^0-9]") - (backup day " *" monthname "\\W+\\<[^*0-9]") - (day " *" monthname " *" year "[^0-9]") - (dayname "\\W")) - "*List of pseudo-patterns describing the European patterns of date used. -See the documentation of `diary-date-forms' for an explanation." - :type '(repeat (choice (cons :tag "Backup" - (const backup) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp)))) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp))))) - :group 'diary) - -(defcustom diary-date-forms - (if european-calendar-style - european-date-diary-pattern - american-date-diary-pattern) - "*List of pseudo-patterns describing the forms of date used in the diary. -The patterns on the list must be MUTUALLY EXCLUSIVE and must should not match -any portion of the diary entry itself, just the date component. - -A pseudo-pattern is a list of regular expressions and the keywords `month', -`day', `year', `monthname', and `dayname'. The keyword `monthname' will -match the name of the month, capitalized or not, or its three-letter -abbreviation, followed by a period or not; it will also match `*'. -Similarly, `dayname' will match the name of the day, capitalized or not, or -its three-letter abbreviation, followed by a period or not. The keywords -`month', `day', and `year' will match those numerical values, preceded by -arbitrarily many zeros; they will also match `*'. - -The matching of the diary entries with the date forms is done with the -standard syntax table from Fundamental mode, but with the `*' changed so -that it is a word constituent. - -If, to be mutually exclusive, a pseudo-pattern must match a portion of the -diary entry itself, the first element of the pattern MUST be `backup'. This -directive causes the date recognizer to back up to the beginning of the -current word of the diary entry, so in no case can the pattern match more than -a portion of the first word of the diary entry." - :type '(repeat (choice (cons :tag "Backup" - (const backup) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp)))) - (repeat (list :inline t :format "%v" - (symbol :tag "Keyword") - (choice symbol regexp))))) - :group 'diary) - -;;;###autoload -(defcustom european-calendar-display-form - '((if dayname (concat dayname ", ")) day " " monthname " " year) - "*Pseudo-pattern governing the way a date appears in the European style. -See the documentation of calendar-date-display-form for an explanation." - :type 'sexp - :group 'calendar) - -;;;###autoload -(defcustom american-calendar-display-form - '((if dayname (concat dayname ", ")) monthname " " day ", " year) - "*Pseudo-pattern governing the way a date appears in the American style. -See the documentation of `calendar-date-display-form' for an explanation." - :type 'sexp - :group 'calendar) - -(defcustom calendar-date-display-form - (if european-calendar-style - european-calendar-display-form - american-calendar-display-form) - "*Pseudo-pattern governing the way a date appears. - -Used by the function `calendar-date-string', a pseudo-pattern is a list of -expressions that can involve the keywords `month', `day', and `year', all -numbers in string form, and `monthname' and `dayname', both alphabetic -strings. For example, the ISO standard would use the pseudo- pattern - - '(year \"-\" month \"-\" day) - -while a typical American form would be - - '(month \"/\" day \"/\" (substring year -2)) - -and - - '((format \"%9s, %9s %2s, %4s\" dayname monthname day year)) - -would give the usual American style in fixed-length fields. - -See the documentation of the function `calendar-date-string'." - :type 'sexp - :group 'calendar) - -(defun european-calendar () - "Set the interpretation and display of dates to the European style." - (interactive) - (setq european-calendar-style t) - (setq calendar-date-display-form european-calendar-display-form) - (setq diary-date-forms european-date-diary-pattern) - (update-calendar-mode-line)) - -(defun american-calendar () - "Set the interpretation and display of dates to the American style." - (interactive) - (setq european-calendar-style nil) - (setq calendar-date-display-form american-calendar-display-form) - (setq diary-date-forms american-date-diary-pattern) - (update-calendar-mode-line)) - -;;;###autoload -(defcustom print-diary-entries-hook 'lpr-buffer - "*List of functions called after a temporary diary buffer is prepared. -The buffer shows only the diary entries currently visible in the diary -buffer. The default just does the printing. Other uses might include, for -example, rearranging the lines into order by day and time, saving the buffer -instead of deleting it, or changing the function used to do the printing." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom list-diary-entries-hook nil - "*List of functions called after diary file is culled for relevant entries. -It is to be used for diary entries that are not found in the diary file. - -A function `include-other-diary-files' is provided for use as the value of -this hook. This function enables you to use shared diary files together -with your own. The files included are specified in the diary file by lines -of the form - - #include \"filename\" - -This is recursive; that is, #include directives in files thus included are -obeyed. You can change the \"#include\" to some other string by changing -the variable `diary-include-string'. When you use `include-other-diary-files' -as part of the list-diary-entries-hook, you will probably also want to use the -function `mark-included-diary-files' as part of `mark-diary-entries-hook'. - -For example, you could use - - (setq list-diary-entries-hook - '(include-other-diary-files sort-diary-entries)) - (setq diary-display-hook 'fancy-diary-display) - -in your `.emacs' file to cause the fancy diary buffer to be displayed with -diary entries from various included files, each day's entries sorted into -lexicographic order." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom diary-hook nil - "*List of functions called after the display of the diary. -Can be used for appointment notification." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom diary-display-hook nil - "*List of functions that handle the display of the diary. -If nil (the default), `simple-diary-display' is used. Use `ignore' for no -diary display. - -Ordinarily, this just displays the diary buffer (with holidays indicated in -the mode line), if there are any relevant entries. At the time these -functions are called, the variable `diary-entries-list' is a list, in order -by date, of all relevant diary entries in the form of ((MONTH DAY YEAR) -STRING), where string is the diary entry for the given date. This can be -used, for example, a different buffer for display (perhaps combined with -holidays), or produce hard copy output. - -A function `fancy-diary-display' is provided as an alternative -choice for this hook; this function prepares a special noneditable diary -buffer with the relevant diary entries that has neat day-by-day arrangement -with headings. The fancy diary buffer will show the holidays unless the -variable `holidays-in-diary-buffer' is set to nil. Ordinarily, the fancy -diary buffer will not show days for which there are no diary entries, even -if that day is a holiday; if you want such days to be shown in the fancy -diary buffer, set the variable `diary-list-include-blanks' to t." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom nongregorian-diary-listing-hook nil - "*List of functions called for listing diary file and included files. -As the files are processed for diary entries, these functions are used to cull -relevant entries. You can use either or both of `list-hebrew-diary-entries' -and `list-islamic-diary-entries'. The documentation for these functions -describes the style of such diary entries." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom mark-diary-entries-hook nil - "*List of functions called after marking diary entries in the calendar. - -A function `mark-included-diary-files' is also provided for use as the -mark-diary-entries-hook; it enables you to use shared diary files together -with your own. The files included are specified in the diary file by lines -of the form - #include \"filename\" -This is recursive; that is, #include directives in files thus included are -obeyed. You can change the \"#include\" to some other string by changing the -variable `diary-include-string'. When you use `mark-included-diary-files' as -part of the mark-diary-entries-hook, you will probably also want to use the -function `include-other-diary-files' as part of `list-diary-entries-hook'." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom nongregorian-diary-marking-hook nil - "*List of functions called for marking diary file and included files. -As the files are processed for diary entries, these functions are used to cull -relevant entries. You can use either or both of `mark-hebrew-diary-entries' -and `mark-islamic-diary-entries'. The documentation for these functions -describes the style of such diary entries." - :type 'hook - :group 'diary) - -;;;###autoload -(defcustom diary-list-include-blanks nil - "*If nil, do not include days with no diary entry in the list of diary entries. -Such days will then not be shown in the fancy diary buffer, even if they -are holidays." - :type 'boolean - :group 'diary) - -;;;###autoload -(defcustom holidays-in-diary-buffer t - "*Non-nil means include holidays in the diary display. -The holidays appear in the mode line of the diary buffer, or in the -fancy diary buffer next to the date. This slows down the diary functions -somewhat; setting it to nil makes the diary display faster." - :type 'boolean - :group 'diary) - -(defvar calendar-mark-ring nil) - -;;;###autoload -(defcustom general-holidays - '((holiday-fixed 1 1 "New Year's Day") - (holiday-float 1 1 3 "Martin Luther King Day") - (holiday-fixed 2 2 "Ground Hog Day") - (holiday-fixed 2 14 "Valentine's Day") - (holiday-float 2 1 3 "President's Day") - (holiday-fixed 3 17 "St. Patrick's Day") - (holiday-fixed 4 1 "April Fool's Day") - (holiday-float 5 0 2 "Mother's Day") - (holiday-float 5 1 -1 "Memorial Day") - (holiday-fixed 6 14 "Flag Day") - (holiday-float 6 0 3 "Father's Day") - (holiday-fixed 7 4 "Independence Day") - (holiday-float 9 1 1 "Labor Day") - (holiday-float 10 1 2 "Columbus Day") - (holiday-fixed 10 31 "Halloween") - (holiday-fixed 11 11 "Veteran's Day") - (holiday-float 11 4 4 "Thanksgiving")) - "*General holidays. Default value is for the United States. -See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) - -;;;###autoload -(put 'general-holidays 'risky-local-variable t) - -;;;###autoload -(defcustom local-holidays nil - "*Local holidays. -See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays - :group 'local) - -;;;###autoload -(put 'local-holidays 'risky-local-variable t) -;;;###autoload -(defcustom other-holidays nil - "*User defined holidays. -See the documentation for `calendar-holidays' for details." - :type 'sexp - :group 'holidays) - -;;;###autoload -(put 'other-holidays 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-1 - '((holiday-rosh-hashanah-etc) - (if all-hebrew-calendar-holidays - (holiday-julian - 11 - (let* ((m displayed-month) - (y displayed-year) - (year)) - (increment-calendar-month m y -1) - (let ((year (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m 1 y)))))) - (if (zerop (% (1+ year) 4)) - 22 - 21))) "\"Tal Umatar\" (evening)")))) - -;;;###autoload -(put 'hebrew-holidays-1 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-2 - '((if all-hebrew-calendar-holidays - (holiday-hanukkah) - (holiday-hebrew 9 25 "Hanukkah")) - (if all-hebrew-calendar-holidays - (holiday-hebrew - 10 - (let ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 28 displayed-year)))))) - (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year)) - 7) - 6) - 11 10)) - "Tzom Teveth")) - (if all-hebrew-calendar-holidays - (holiday-hebrew 11 15 "Tu B'Shevat")))) - -;;;###autoload -(put 'hebrew-holidays-2 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-3 - '((if all-hebrew-calendar-holidays - (holiday-hebrew - 11 - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list m - (calendar-last-day-of-month m y) - y))))) - (s-s - (calendar-hebrew-from-absolute - (if (= - (% (calendar-absolute-from-hebrew - (list 7 1 h-year)) - 7) - 6) - (calendar-dayname-on-or-before - 6 (calendar-absolute-from-hebrew - (list 11 17 h-year))) - (calendar-dayname-on-or-before - 6 (calendar-absolute-from-hebrew - (list 11 16 h-year)))))) - (day (extract-calendar-day s-s))) - day)) - "Shabbat Shirah")))) -;;;###autoload -(put 'hebrew-holidays-3 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays-4 - '((holiday-passover-etc) - (if (and all-hebrew-calendar-holidays - (let* ((m displayed-month) - (y displayed-year) - (year)) - (increment-calendar-month m y -1) - (let ((year (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m 1 y)))))) - (= 21 (% year 28))))) - (holiday-julian 3 26 "Kiddush HaHamah")) - (if all-hebrew-calendar-holidays - (holiday-tisha-b-av-etc)))) -;;;###autoload -(put 'hebrew-holidays-4 'risky-local-variable t) - -;;;###autoload -(defvar hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2 - hebrew-holidays-3 hebrew-holidays-4) - "*Jewish holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'hebrew-holidays 'risky-local-variable t) - -;;;###autoload -(defvar christian-holidays - '((if all-christian-calendar-holidays - (holiday-fixed 1 6 "Epiphany")) - (holiday-easter-etc) - (if all-christian-calendar-holidays - (holiday-greek-orthodox-easter)) - (if all-christian-calendar-holidays - (holiday-fixed 8 15 "Assumption")) - (if all-christian-calendar-holidays - (holiday-advent)) - (holiday-fixed 12 25 "Christmas") - (if all-christian-calendar-holidays - (holiday-julian 12 25 "Eastern Orthodox Christmas"))) - "*Christian holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'christian-holidays 'risky-local-variable t) - -;;;###autoload -(defvar islamic-holidays - '((holiday-islamic - 1 1 - (format "Islamic New Year %d" - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list - m (calendar-last-day-of-month m y) y))))))) - (if all-islamic-calendar-holidays - (holiday-islamic 1 10 "Ashura")) - (if all-islamic-calendar-holidays - (holiday-islamic 3 12 "Mulad-al-Nabi")) - (if all-islamic-calendar-holidays - (holiday-islamic 7 26 "Shab-e-Mi'raj")) - (if all-islamic-calendar-holidays - (holiday-islamic 8 15 "Shab-e-Bara't")) - (holiday-islamic 9 1 "Ramadan Begins") - (if all-islamic-calendar-holidays - (holiday-islamic 9 27 "Shab-e Qadr")) - (if all-islamic-calendar-holidays - (holiday-islamic 10 1 "Id-al-Fitr")) - (if all-islamic-calendar-holidays - (holiday-islamic 12 10 "Id-al-Adha"))) - "*Islamic holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'islamic-holidays 'risky-local-variable t) - -;;;###autoload -(defvar solar-holidays - '((if (fboundp 'atan) - (solar-equinoxes-solstices)) - (if (progn - (require 'cal-dst) - t) - (funcall - 'holiday-sexp - calendar-daylight-savings-starts - '(format "Daylight Savings Time Begins %s" - (if (fboundp 'atan) - (solar-time-string - (/ calendar-daylight-savings-starts-time (float 60)) - calendar-standard-time-zone-name) - "")))) - (funcall - 'holiday-sexp - calendar-daylight-savings-ends - '(format "Daylight Savings Time Ends %s" - (if (fboundp 'atan) - (solar-time-string - (/ calendar-daylight-savings-ends-time (float 60)) - calendar-daylight-time-zone-name) - "")))) - "*Sun-related holidays. -See the documentation for `calendar-holidays' for details.") - -;;;###autoload -(put 'solar-holidays 'risky-local-variable t) - -;;;###autoload -(defvar calendar-holidays - (append general-holidays local-holidays other-holidays - christian-holidays hebrew-holidays islamic-holidays - solar-holidays) - "*List of notable days for the command M-x holidays. - -Additional holidays are easy to add to the list, just put them in the list -`other-holidays' in your .emacs file. Similarly, by setting any of -`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays', -`islamic-holidays', or `solar-holidays' to nil in your .emacs file, you can -eliminate unwanted categories of holidays. The intention is that (in the US) -`local-holidays' be set in site-init.el and `other-holidays' be set by the -user. - -Entries on the list are expressions that return (possibly empty) lists of -items of the form ((month day year) string) of a holiday in the in the -three-month period centered around `displayed-month' of `displayed-year'. -Several basic functions are provided for this purpose: - - (holiday-fixed MONTH DAY STRING) is a fixed date on the Gregorian calendar - (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in - MONTH on the Gregorian calendar (0 for Sunday, - etc.); K<0 means count back from the end of the - month. An optional parameter DAY means the Kth - DAYNAME after/before MONTH DAY. - (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar - (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar - (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar - (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression - in the variable `year'; if it evaluates to - a visible date, that's the holiday; if it - evaluates to nil, there's no holiday. STRING - is an expression in the variable `date'. - -For example, to add Bastille Day, celebrated in France on July 14, add - - (holiday-fixed 7 14 \"Bastille Day\") - -to the list. To add Hurricane Supplication Day, celebrated in the Virgin -Islands on the fourth Monday in August, add - - (holiday-float 8 1 4 \"Hurricane Supplication Day\") - -to the list (the last Monday would be specified with `-1' instead of `4'). -To add the last day of Hanukkah to the list, use - - (holiday-hebrew 10 2 \"Last day of Hanukkah\") - -since the Hebrew months are numbered with 1 starting from Nisan, while to -add the Islamic feast celebrating Mohammed's birthday use - - (holiday-islamic 3 12 \"Mohammed's Birthday\") - -since the Islamic months are numbered from 1 starting with Muharram. To -add Thomas Jefferson's birthday, April 2, 1743 (Julian), use - - (holiday-julian 4 2 \"Jefferson's Birthday\") - -To include a holiday conditionally, use the sexp form or a conditional. For -example, to include American presidential elections, which occur on the first -Tuesday after the first Monday in November of years divisible by 4, add - - (holiday-sexp - (if (zerop (% year 4)) - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 year))))))) - \"US Presidential Election\") - -or - - (if (zerop (% displayed-year 4)) - (holiday-fixed 11 - (extract-calendar-day - (calendar-gregorian-from-absolute - (1+ (calendar-dayname-on-or-before - 1 (+ 6 (calendar-absolute-from-gregorian - (list 11 1 displayed-year))))))) - \"US Presidential Election\")) - -to the list. To include the phases of the moon, add - - (lunar-phases) - -to the holiday list, where `lunar-phases' is an Emacs-Lisp function that -you've written to return a (possibly empty) list of the relevant VISIBLE dates -with descriptive strings such as - - (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... ).") - -;;;###autoload -(put 'calendar-holidays 'risky-local-variable t) - -(defconst calendar-buffer "*Calendar*" - "Name of the buffer used for the calendar.") - -(defconst holiday-buffer "*Holidays*" - "Name of the buffer used for the displaying the holidays.") - -(defconst fancy-diary-buffer "*Fancy Diary Entries*" - "Name of the buffer used for the optional fancy display of the diary.") - -(defconst lunar-phases-buffer "*Phases of Moon*" - "Name of the buffer used for the lunar phases.") - -(defmacro increment-calendar-month (mon yr n) - "Move the variables MON and YR to the month and year by N months. -Forward if N is positive or backward if N is negative." - (` (let (( macro-y (+ (* (, yr) 12) (, mon) -1 (, n) ))) - (setq (, mon) (1+ (% macro-y 12) )) - (setq (, yr) (/ macro-y 12))))) - -(defmacro calendar-for-loop (var from init to final do &rest body) - "Execute a for loop." - (` (let (( (, var) (1- (, init)) )) - (while (>= (, final) (setq (, var) (1+ (, var)))) - (,@ body))))) - -(defmacro calendar-sum (index initial condition expression) - "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION." - (` (let (( (, index) (, initial)) - (sum 0)) - (while (, condition) - (setq sum (+ sum (, expression) )) - (setq (, index) (1+ (, index)))) - sum))) - -;; The following are in-line for speed; they can be called thousands of times -;; when looking up holidays or processing the diary. Here, for example, are -;; the numbers of calls to calendar/diary/holiday functions in preparing the -;; fancy diary display, for a moderately complex diary file, with functions -;; used instead of macros. There were a total of 10000 such calls: -;; -;; 1934 extract-calendar-month -;; 1852 extract-calendar-year -;; 1819 extract-calendar-day -;; 845 calendar-leap-year-p -;; 837 calendar-day-number -;; 775 calendar-absolute-from-gregorian -;; 346 calendar-last-day-of-month -;; 286 hebrew-calendar-last-day-of-month -;; 188 hebrew-calendar-leap-year-p -;; 180 hebrew-calendar-elapsed-days -;; 163 hebrew-calendar-last-month-of-year -;; 66 calendar-date-compare -;; 65 hebrew-calendar-days-in-year -;; 60 calendar-absolute-from-julian -;; 50 calendar-absolute-from-hebrew -;; 43 calendar-date-equal -;; 38 calendar-gregorian-from-absolute -;; . -;; . -;; . -;; -;; The use of these seven macros eliminates the overhead of 92% of the function -;; calls; it's faster this way. - -(defsubst extract-calendar-month (date) - "Extract the month part of DATE which has the form (month day year)." - (car date)) - -(defsubst extract-calendar-day (date) - "Extract the day part of DATE which has the form (month day year)." - (car (cdr date))) - -(defsubst extract-calendar-year (date) - "Extract the year part of DATE which has the form (month day year)." - (car (cdr (cdr date)))) - -(defsubst calendar-leap-year-p (year) - "Returns t if YEAR is a Gregorian leap year." - (and (zerop (% year 4)) - (or (not (zerop (% year 100))) - (zerop (% year 400))))) - -;; The foregoing is a bit faster, but not as clear as the following: -;; -;;(defsubst calendar-leap-year-p (year) -;; "Returns t if YEAR is a Gregorian leap year." -;; (or -;; (and (= (% year 4) 0) -;; (/= (% year 100) 0)) -;; (= (% year 400) 0))) - -(defsubst calendar-last-day-of-month (month year) - "The last day in MONTH during YEAR." - (if (and (= month 2) (calendar-leap-year-p year)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - -;; An explanation of the calculation can be found in PascAlgorithms by -;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. - -(defsubst calendar-day-number (date) - "Return the day number within the year of the date DATE. -For example, (calendar-day-number '(1 1 1987)) returns the value 1, -while (calendar-day-number '(12 31 1980)) returns 366." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (day-of-year (+ day (* 31 (1- month))))) - (if (> month 2) - (progn - (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) - (if (calendar-leap-year-p year) - (setq day-of-year (1+ day-of-year))))) - day-of-year)) - -(defsubst calendar-absolute-from-gregorian (date) - "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let ((prior-years (1- (extract-calendar-year date)))) - (+ (calendar-day-number date);; Days this year - (* 365 prior-years);; + Days in prior years - (/ prior-years 4);; + Julian leap years - (- (/ prior-years 100));; - century years - (/ prior-years 400))));; + Gregorian leap years - -;;;###autoload -(defun calendar (&optional arg) - "Display a three-month calendar in another window. -The three months appear side by side, with the current month in the middle -surrounded by the previous and next months. The cursor is put on today's date. - -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file; appropriate setting -of the variable `view-diary-entries-initially' will cause the diary entries for -the current date to be displayed in another window. The value of the variable -`number-of-diary-entries' controls the number of days of diary entries -displayed upon initial display of the calendar. - -An optional prefix argument ARG causes the calendar displayed to be ARG -months in the future if ARG is positive or in the past if ARG is negative; -in this case the cursor goes on the first day of the month. - -Once in the calendar window, future or past months can be moved into view. -Arbitrary months can be displayed, or the calendar can be scrolled forward -or backward. - -The cursor can be moved forward or backward by one day, one week, one month, -or one year. All of these commands take prefix arguments which, when negative, -cause movement in the opposite direction. For convenience, the digit keys -and the minus sign are automatically prefixes. The window is replotted as -necessary to display the desired date. - -Diary entries can be marked on the calendar or displayed in another window. - -Use M-x describe-mode for details of the key bindings in the calendar window. - -The Gregorian calendar is assumed. - -After loading the calendar, the hooks given by the variable -`calendar-load-hook' are run. This is the place to add key bindings to the -calendar-mode-map. - -After preparing the calendar window initially, the hooks given by the variable -`initial-calendar-window-hook' are run. - -The hooks given by the variable `today-visible-calendar-hook' are run -everytime the calendar window gets scrolled, if the current date is visible -in the window. If it is not visible, the hooks given by the variable -`today-invisible-calendar-hook' are run. Thus, for example, setting -`today-visible-calendar-hook' to 'calendar-star-date will cause today's date -to be replaced by asterisks to highlight it whenever it is in the window." - (interactive "P") - (set-buffer (get-buffer-create calendar-buffer)) - (calendar-mode) - (let* ((pop-up-windows t) - (split-height-threshold 1000) - (date (if arg - (calendar-read-date t) - (calendar-current-date))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date))) - (pop-to-buffer calendar-buffer) - (increment-calendar-month month year (- calendar-offset)) - (generate-calendar-window month year) - (if (and view-diary-entries-initially (calendar-date-is-visible-p date)) - (view-diary-entries - (if (vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date)) - number-of-diary-entries)))) - (let* ((diary-buffer (get-file-buffer diary-file)) - (diary-window (if diary-buffer (get-buffer-window diary-buffer))) - (split-height-threshold (if diary-window 2 1000))) - (if view-calendar-holidays-initially - (list-calendar-holidays))) - (run-hooks 'initial-calendar-window-hook)) - -(autoload 'view-diary-entries "diary-lib" - "Prepare and display a buffer with diary entries. -Searches your diary file for entries that match ARG days starting with -the date indicated by the cursor position in the displayed three-month -calendar." - t) - -(autoload 'calendar-sunrise-sunset "solar" - "Local time of sunrise and sunset for date under cursor." - t) - -(autoload 'calendar-phases-of-moon "lunar" - "Create a buffer of the phases of the moon for the current calendar window." - t) - -(autoload 'calendar-print-french-date "cal-french" - "Show the French Revolutionary calendar equivalent of the date under the cursor." - t) - -(autoload 'calendar-goto-french-date "cal-french" - "Move cursor to French Revolutionary date." - t) - -(autoload 'calendar-french-date-string "cal-french" - "String of French Revolutionary date of Gregorian DATE." - t) - -(autoload 'calendar-mayan-date-string "cal-mayan" - "String of Mayan date of Gregorian DATE." - t) - -(autoload 'calendar-print-mayan-date "cal-mayan" - "Show the Mayan long count, Tzolkin, and Haab equivalents of the date under the cursor." - t) - -(autoload 'calendar-goto-mayan-long-count-date "cal-mayan" - "Move cursor to Mayan long count date." - t) - -(autoload 'calendar-next-haab-date "cal-mayan" - "Move cursor to next instance of Mayan Haab date." - t) - -(autoload 'calendar-previous-haab-date "cal-mayan" - "Move cursor to previous instance of Mayan Haab date." - t) - -(autoload 'calendar-next-tzolkin-date "cal-mayan" - "Move cursor to next instance of Mayan Tzolkin date." - t) - -(autoload 'calendar-previous-tzolkin-date "cal-mayan" - "Move cursor to previous instance of Mayan Tzolkin date." - t) - -(autoload 'calendar-next-calendar-round-date "cal-mayan" - "Move cursor to next instance of Mayan Haab/Tzoklin combination." - t) - -(autoload 'calendar-previous-calendar-round-date "cal-mayan" - "Move cursor to previous instance of Mayan Haab/Tzoklin combination." - t) - -(autoload 'show-all-diary-entries "diary-lib" - "Show all of the diary entries in the diary file. -This function gets rid of the selective display of the diary file so that -all entries, not just some, are visible. If there is no diary buffer, one -is created." - t) - -(autoload 'mark-diary-entries "diary-lib" - "Mark days in the calendar window that have diary entries. -Each entry in diary file visible in the calendar window is marked." - t) - -(autoload 'insert-diary-entry "diary-ins" - "Insert a diary entry for the date indicated by point." - t) - -(autoload 'insert-weekly-diary-entry "diary-ins" - "Insert a weekly diary entry for the day of the week indicated by point." - t) - - -(autoload 'insert-monthly-diary-entry "diary-ins" - "Insert a monthly diary entry for the day of the month indicated by point." - t) - -(autoload 'insert-yearly-diary-entry "diary-ins" - "Insert an annual diary entry for the day of the year indicated by point." - t) - -(autoload 'insert-anniversary-diary-entry "diary-ins" - "Insert an anniversary diary entry for the date indicated by point." - t) - -(autoload 'insert-block-diary-entry "diary-ins" - "Insert a block diary entry for the dates indicated by point and mark." - t) - -(autoload 'insert-cyclic-diary-entry "diary-ins" - "Insert a cyclic diary entry starting at the date indicated by point." - t) - -(autoload 'insert-hebrew-diary-entry "diary-ins" - "Insert a diary entry for the Hebrew date corresponding to the date -indicated by point." - t) - -(autoload 'insert-monthly-hebrew-diary-entry "diary-ins" - "Insert a monthly diary entry for the day of the Hebrew month corresponding -to the date indicated by point." - t) - -(autoload 'insert-yearly-hebrew-diary-entry "diary-ins" - "Insert an annual diary entry for the day of the Hebrew year corresponding -to the date indicated by point." - t) - -(autoload 'insert-islamic-diary-entry "diary-ins" - "Insert a diary entry for the Islamic date corresponding to the date -indicated by point." - t) - -(autoload 'insert-monthly-islamic-diary-entry "diary-ins" - "Insert a monthly diary entry for the day of the Islamic month corresponding -to the date indicated by point." - t) - -(autoload 'insert-yearly-islamic-diary-entry "diary-ins" - "Insert an annual diary entry for the day of the Islamic year corresponding -to the date indicated by point." - t) - -(autoload 'list-calendar-holidays "holidays" - "Create a buffer containing the holidays for the current calendar window. -The holidays are those in the list `calendar-notable-days'. Returns t if any -holidays are found, nil if not." - t) - -(autoload 'mark-calendar-holidays "holidays" - "Mark notable days in the calendar window." - t) - -(autoload 'calendar-cursor-holidays "holidays" - "Find holidays for the date specified by the cursor in the calendar window." - t) - -(defun generate-calendar-window (&optional mon yr) - "Generate the calendar window for the current date. -Or, for optional MON, YR." - (let* ((buffer-read-only nil) - (today (calendar-current-date)) - (month (extract-calendar-month today)) - (day (extract-calendar-day today)) - (year (extract-calendar-year today)) - (today-visible - (or (not mon) - (let ((offset (calendar-interval mon yr month year))) - (and (<= offset 1) (>= offset -1))))) - (day-in-week (calendar-day-of-week today))) - (update-calendar-mode-line) - (if mon - (generate-calendar mon yr) - (generate-calendar month year)) - (calendar-cursor-to-visible-date - (if today-visible today (list displayed-month 1 displayed-year))) - (set-buffer-modified-p nil) - (or (one-window-p t) - (/= (frame-width) (window-width)) - (shrink-window (- (window-height) 9))) - (sit-for 0) - (and mark-holidays-in-calendar - (mark-calendar-holidays) - (sit-for 0)) - (unwind-protect - (if mark-diary-entries-in-calendar (mark-diary-entries)) - (if today-visible - (run-hooks 'today-visible-calendar-hook) - (run-hooks 'today-invisible-calendar-hook))))) - -(defun generate-calendar (month year) - "Generate a three-month Gregorian calendar centered around MONTH, YEAR." - (if (< (+ month (* 12 (1- year))) 2) - (error "Months before February, 1 AD are not available.")) - (setq displayed-month month) - (setq displayed-year year) - (erase-buffer) - (increment-calendar-month month year -1) - (calendar-for-loop i from 0 to 2 do - (generate-calendar-month month year (+ 5 (* 25 i))) - (increment-calendar-month month year 1))) - -(defun generate-calendar-month (month year indent) - "Produce a calendar for MONTH, YEAR on the Gregorian calendar. -The calendar is inserted in the buffer starting at the line on which point -is currently located, but indented INDENT spaces. The indentation is done -from the first character on the line and does not disturb the first INDENT -characters on the line." - (let* ((blank-days;; at start of month - (mod - (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7)) - (last (calendar-last-day-of-month month year))) - (goto-char (point-min)) - (calendar-insert-indented - (calendar-string-spread - (list "" (format "%s %d" (calendar-month-name month) year) "") ? 20) - indent t) - (calendar-insert-indented "" indent);; Go to proper spot - (calendar-for-loop i from 0 to 6 do - (insert (substring (aref calendar-day-name-array - (mod (+ calendar-week-start-day i) 7)) - 0 2)) - (insert " ")) - (calendar-insert-indented "" 0 t);; Force onto following line - (calendar-insert-indented "" indent);; Go to proper spot - ;; Add blank days before the first of the month - (calendar-for-loop i from 1 to blank-days do (insert " ")) - ;; Put in the days of the month - (calendar-for-loop i from 1 to last do - (insert (format "%2d " i)) - (put-text-property (- (point) (if (< i 10) 2 3)) (1- (point)) - 'highlight t) - (and (zerop (mod (+ i blank-days) 7)) - (/= i last) - (calendar-insert-indented "" 0 t) ;; Force onto following line - (calendar-insert-indented "" indent)))));; Go to proper spot - -(defun calendar-insert-indented (string indent &optional newline) - "Insert STRING at column INDENT. -If the optional parameter NEWLINE is t, leave point at start of next line, -inserting a newline if there was no next line; otherwise, leave point after -the inserted text. Value is always t." - ;; Try to move to that column. - (move-to-column indent) - ;; If line is too short, indent out to that column. - (if (< (current-column) indent) - (indent-to indent)) - (insert string) - ;; Advance to next line, if requested. - (if newline - (progn - (end-of-line) - (if (eobp) - (newline) - (forward-line 1)))) - t) - -(defun redraw-calendar () - "Redraw the calendar display." - (interactive) - (let ((cursor-date (calendar-cursor-to-date))) - (generate-calendar-window displayed-month displayed-year) - (calendar-cursor-to-visible-date cursor-date))) - -(defvar calendar-debug-sexp nil - "*Turn debugging on when evaluating a sexp in the diary or holiday list.") - -(defvar calendar-mode-map nil) -(if calendar-mode-map - nil - (setq calendar-mode-map (make-sparse-keymap)) - (calendar-for-loop i from 0 to 9 do - (define-key calendar-mode-map (int-to-string i) 'digit-argument)) - (let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph - 'mark-defun 'mark-whole-buffer 'mark-page - 'downcase-region 'upcase-region 'kill-region - 'copy-region-as-kill 'capitalize-region 'write-region))) - (while l - (substitute-key-definition (car l) 'calendar-not-implemented - calendar-mode-map) - (setq l (cdr l)))) - (define-key calendar-mode-map "-" 'negative-argument) - (define-key calendar-mode-map "\C-x>" 'scroll-calendar-right) - (define-key calendar-mode-map '[prior] 'scroll-calendar-right-three-months) - (define-key calendar-mode-map "\M-v" 'scroll-calendar-right-three-months) - (define-key calendar-mode-map "\C-x<" 'scroll-calendar-left) - (define-key calendar-mode-map '[next] 'scroll-calendar-left-three-months) - (define-key calendar-mode-map "\C-v" 'scroll-calendar-left-three-months) - (define-key calendar-mode-map "\C-b" 'calendar-backward-day) - (define-key calendar-mode-map "\C-p" 'calendar-backward-week) - (define-key calendar-mode-map "\M-{" 'calendar-backward-month) - (define-key calendar-mode-map "\C-x[" 'calendar-backward-year) - (define-key calendar-mode-map "\C-f" 'calendar-forward-day) - (define-key calendar-mode-map "\C-n" 'calendar-forward-week) - (define-key calendar-mode-map '[left] 'calendar-backward-day) - (define-key calendar-mode-map '[up] 'calendar-backward-week) - (define-key calendar-mode-map '[right] 'calendar-forward-day) - (define-key calendar-mode-map '[down] 'calendar-forward-week) - (define-key calendar-mode-map "\M-}" 'calendar-forward-month) - (define-key calendar-mode-map "\C-x]" 'calendar-forward-year) - (define-key calendar-mode-map "\C-a" 'calendar-beginning-of-week) - (define-key calendar-mode-map "\C-e" 'calendar-end-of-week) - (define-key calendar-mode-map "\M-a" 'calendar-beginning-of-month) - (define-key calendar-mode-map "\M-e" 'calendar-end-of-month) - (define-key calendar-mode-map "\M-<" 'calendar-beginning-of-year) - (define-key calendar-mode-map "\M->" 'calendar-end-of-year) - (define-key calendar-mode-map "\C-@" 'calendar-set-mark) - ;; Many people are used to typing C-SPC and getting C-@. - (define-key calendar-mode-map "\C- " 'calendar-set-mark) - (define-key calendar-mode-map "\C-x\C-x" 'calendar-exchange-point-and-mark) - (define-key calendar-mode-map "\M-=" 'calendar-count-days-region) - (define-key calendar-mode-map "gd" 'calendar-goto-date) - (define-key calendar-mode-map "gj" 'calendar-goto-julian-date) - (define-key calendar-mode-map "ga" 'calendar-goto-astro-day-number) - (define-key calendar-mode-map "gh" 'calendar-goto-hebrew-date) - (define-key calendar-mode-map "gi" 'calendar-goto-islamic-date) - (define-key calendar-mode-map "gc" 'calendar-goto-iso-date) - (define-key calendar-mode-map "gf" 'calendar-goto-french-date) - (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date) - (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date) - (define-key calendar-mode-map "gmnc" 'calendar-next-calendar-round-date) - (define-key calendar-mode-map "gmph" 'calendar-previous-haab-date) - (define-key calendar-mode-map "gmnh" 'calendar-next-haab-date) - (define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date) - (define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date) - (define-key calendar-mode-map "S" 'calendar-sunrise-sunset) - (define-key calendar-mode-map "M" 'calendar-phases-of-moon) - (define-key calendar-mode-map " " 'scroll-other-window) - (define-key calendar-mode-map "\C-c\C-l" 'redraw-calendar) - (define-key calendar-mode-map "." 'calendar-goto-today) - (define-key calendar-mode-map "o" 'calendar-other-month) - (define-key calendar-mode-map "q" 'exit-calendar) - (define-key calendar-mode-map "a" 'list-calendar-holidays) - (define-key calendar-mode-map "h" 'calendar-cursor-holidays) - (define-key calendar-mode-map "x" 'mark-calendar-holidays) - (define-key calendar-mode-map "u" 'calendar-unmark) - (define-key calendar-mode-map "m" 'mark-diary-entries) - (define-key calendar-mode-map "d" 'view-diary-entries) - (define-key calendar-mode-map "D" 'view-other-diary-entries) - (define-key calendar-mode-map "s" 'show-all-diary-entries) - (define-key calendar-mode-map "pd" 'calendar-print-day-of-year) - (define-key calendar-mode-map "pc" 'calendar-print-iso-date) - (define-key calendar-mode-map "pj" 'calendar-print-julian-date) - (define-key calendar-mode-map "pa" 'calendar-print-astro-day-number) - (define-key calendar-mode-map "ph" 'calendar-print-hebrew-date) - (define-key calendar-mode-map "pi" 'calendar-print-islamic-date) - (define-key calendar-mode-map "pf" 'calendar-print-french-date) - (define-key calendar-mode-map "pm" 'calendar-print-mayan-date) - (define-key calendar-mode-map "id" 'insert-diary-entry) - (define-key calendar-mode-map "iw" 'insert-weekly-diary-entry) - (define-key calendar-mode-map "im" 'insert-monthly-diary-entry) - (define-key calendar-mode-map "iy" 'insert-yearly-diary-entry) - (define-key calendar-mode-map "ia" 'insert-anniversary-diary-entry) - (define-key calendar-mode-map "ib" 'insert-block-diary-entry) - (define-key calendar-mode-map "ic" 'insert-cyclic-diary-entry) - (define-key calendar-mode-map "ihd" 'insert-hebrew-diary-entry) - (define-key calendar-mode-map "ihm" 'insert-monthly-hebrew-diary-entry) - (define-key calendar-mode-map "ihy" 'insert-yearly-hebrew-diary-entry) - (define-key calendar-mode-map "iid" 'insert-islamic-diary-entry) - (define-key calendar-mode-map "iim" 'insert-monthly-islamic-diary-entry) - (define-key calendar-mode-map "iiy" 'insert-yearly-islamic-diary-entry) - (define-key calendar-mode-map "?" 'calendar-goto-info-node)) - -(defun describe-calendar-mode () - "Create a help buffer with a brief description of the calendar-mode." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ - (format - "Calendar Mode:\nFor a complete description, type %s\n%s\n" - (substitute-command-keys - "\\<calendar-mode-map>\\[describe-mode] from within the calendar") - (substitute-command-keys "\\{calendar-mode-map}"))) - (save-excursion - (set-buffer standard-output) - (help-mode)) - (print-help-return-message))) - -;; Calendar mode is suitable only for specially formatted data. -(put 'calendar-mode 'mode-class 'special) - -(defvar calendar-mode-line-format - (list - (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-left]") - "Calendar" - (substitute-command-keys "\\<calendar-mode-map>\\[calendar-goto-info-node] info/\\[calendar-other-month] other/\\[calendar-goto-today] today") - '(calendar-date-string (calendar-current-date) t) - (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-right]")) - "The mode line of the calendar buffer.") - -(defun calendar-goto-info-node () - "Go to the info node for the calendar." - (interactive) - (require 'info) - (let ((where (Info-find-emacs-command-nodes 'calendar))) - (if (not where) - (error "Couldn't find documentation for the calendar.") - (save-window-excursion (info)) - (pop-to-buffer "*info*") - (Info-find-node (car (car where)) (car (cdr (car where))))))) - -(defun calendar-mode () - "A major mode for the calendar window. - -For a complete description, type \ -\\<calendar-mode-map>\\[calendar-goto-info-node] from within the calendar. - -\\<calendar-mode-map>\\{calendar-mode-map}" - - (kill-all-local-variables) - (setq major-mode 'calendar-mode) - (setq mode-name "Calendar") - (use-local-map calendar-mode-map) - (setq buffer-read-only t) - (setq indent-tabs-mode nil) - (update-calendar-mode-line) - (if (and (string-match "XEmacs" emacs-version) current-menubar) - (progn - (require 'cal-xemacs) - (calendar-add-menus) - (make-variable-buffer-local 'scroll-on-clipped-lines) - (setq scroll-on-clipped-lines nil))) - (make-local-variable 'calendar-mark-ring) - (make-local-variable 'displayed-month);; Month in middle of window. - (make-local-variable 'displayed-year));; Year in middle of window. - -(defun calendar-string-spread (strings char length) - "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH -There must be at least 2 strings. The effect is like mapconcat but the -separating pieces are as balanced as possible. Each item of STRINGS is -evaluated before concatenation so it can actually be an expression that -evaluates to a string. If LENGTH is too short, the STRINGS are just -concatenated and the result truncated." -;; The algorithm is based on equation (3.25) on page 85 of Concrete -;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik, -;; Addison-Wesley, Reading, MA, 1989 - (let* ((strings (mapcar 'eval strings)) - (n (- length (length (apply 'concat strings)))) - (m (1- (length strings))) - (s (car strings)) - (strings (cdr strings)) - (i 0)) - (while strings - (setq s (concat s - (make-string (max 0 (/ (+ n i) m)) char) - (car strings))) - (setq i (1+ i)) - (setq strings (cdr strings))) - (substring s 0 length))) - -(defun update-calendar-mode-line () - "Update the calendar mode line with the current date and date style." - (if (bufferp (get-buffer calendar-buffer)) - (save-excursion - (set-buffer calendar-buffer) - (setq mode-line-format - (calendar-string-spread - calendar-mode-line-format ? (frame-width)))))) - -(defun calendar-window-list () - "List of all calendar-related windows." - (let ((calendar-buffers (calendar-buffer-list)) - list) - (walk-windows '(lambda (w) - (if (memq (window-buffer w) calendar-buffers) - (setq list (cons w list)))) - nil t) - list)) - -(defun calendar-buffer-list () - "List of all calendar-related buffers." - (let* ((diary-buffer (get-file-buffer diary-file)) - (buffers (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer - fancy-diary-buffer diary-buffer calendar-buffer)) - (buffer-list nil) - b) - (while buffers - (setq b (car buffers)) - (setq b (cond ((stringp b) (get-buffer b)) - ((bufferp b) b) - (t nil))) - (if b (setq buffer-list (cons b buffer-list))) - (setq buffers (cdr buffers))) - buffer-list)) - -(defun exit-calendar () - "Get out of the calendar window and hide it and related buffers." - (interactive) - (let* ((diary-buffer (get-file-buffer diary-file))) - (if (and diary-buffer (buffer-modified-p diary-buffer) - (not - (yes-or-no-p - "Diary modified; do you really want to exit the calendar? "))) - (error) - ;; Need to do this multiple times because one time can replace some - ;; calendar-related buffers with other calendar-related buffers - (mapcar (lambda (x) - (mapcar 'calendar-hide-window (calendar-window-list))) - (calendar-window-list))))) - -(defun calendar-hide-window (window) - "Hide WINDOW if it is calendar-related." - (let ((buffer (if (window-live-p window) (window-buffer window)))) - (if (memq buffer (calendar-buffer-list)) - (cond - ((and window-system - (eq 'icon (cdr (assoc 'visibility - (frame-parameters - (window-frame window)))))) - nil) - ((and window-system (window-dedicated-p window)) - (iconify-frame (window-frame window))) - ((not (and (select-window window) (one-window-p window))) - (delete-window window)) - (t (set-buffer buffer) - (bury-buffer)))))) - -(defun calendar-goto-today () - "Reposition the calendar window so the current date is visible." - (interactive) - (let ((today (calendar-current-date)));; The date might have changed. - (if (not (calendar-date-is-visible-p today)) - (generate-calendar-window) - (update-calendar-mode-line) - (calendar-cursor-to-visible-date today)))) - -(defun calendar-forward-month (arg) - "Move the cursor forward ARG months. -Movement is backward if ARG is negative." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((cursor-date (calendar-cursor-to-date t)) - (month (extract-calendar-month cursor-date)) - (day (extract-calendar-day cursor-date)) - (year (extract-calendar-year cursor-date))) - (increment-calendar-month month year arg) - (let ((last (calendar-last-day-of-month month year))) - (if (< last day) - (setq day last))) - ;; Put the new month on the screen, if needed, and go to the new date. - (let ((new-cursor-date (list month day year))) - (if (not (calendar-date-is-visible-p new-cursor-date)) - (calendar-other-month month year)) - (calendar-cursor-to-visible-date new-cursor-date)))) - -(defun calendar-forward-year (arg) - "Move the cursor forward by ARG years. -Movement is backward if ARG is negative." - (interactive "p") - (calendar-forward-month (* 12 arg))) - -(defun calendar-backward-month (arg) - "Move the cursor backward by ARG months. -Movement is forward if ARG is negative." - (interactive "p") - (calendar-forward-month (- arg))) - -(defun calendar-backward-year (arg) - "Move the cursor backward ARG years. -Movement is forward is ARG is negative." - (interactive "p") - (calendar-forward-month (* -12 arg))) - -(defun scroll-calendar-left (arg) - "Scroll the displayed calendar left by ARG months. -If ARG is negative the calendar is scrolled right. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let ((old-date (calendar-cursor-to-date)) - (today (calendar-current-date))) - (if (/= arg 0) - (progn - (increment-calendar-month displayed-month displayed-year arg) - (generate-calendar-window displayed-month displayed-year) - (calendar-cursor-to-visible-date - (cond - ((calendar-date-is-visible-p old-date) old-date) - ((calendar-date-is-visible-p today) today) - (t (list displayed-month 1 displayed-year)))))))) - -(defun scroll-calendar-right (arg) - "Scroll the displayed calendar window right by ARG months. -If ARG is negative the calendar is scrolled left. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (scroll-calendar-left (- arg))) - -(defun scroll-calendar-left-three-months (arg) - "Scroll the displayed calendar window left by 3*ARG months. -If ARG is negative the calendar is scrolled right. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (scroll-calendar-left (* 3 arg))) - -(defun scroll-calendar-right-three-months (arg) - "Scroll the displayed calendar window right by 3*ARG months. -If ARG is negative the calendar is scrolled left. Maintains the relative -position of the cursor with respect to the calendar as well as possible." - (interactive "p") - (scroll-calendar-left (* -3 arg))) - -(defun calendar-current-date () - "Returns the current date in a list (month day year)." - (let ((s (current-time-string))) - (list (length (member (substring s 4 7) - '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul" - "Jun" "May" "Apr" "Mar" "Feb" "Jan"))) - (string-to-number (substring s 8 10)) - (string-to-number (substring s 20 24))))) - -(defun calendar-cursor-to-date (&optional error) - "Returns a list (month day year) of current cursor position. -If cursor is not on a specific date, signals an error if optional parameter -ERROR is t, otherwise just returns nil." - ;; #### This check is to avoid a race condition created by - ;; pop-to-buffer's call to other-window interacting with the 19.13 - ;; changes allowing that to be in another frame. - (if (not (number-or-marker-p displayed-month)) - nil - (let* ((segment (/ (current-column) 25)) - (month (% (+ displayed-month segment -1) 12)) - (month (if (= 0 month) 12 month)) - (year - (cond - ((and (= 12 month) (= segment 0)) (1- displayed-year)) - ((and (= 1 month) (= segment 2)) (1+ displayed-year)) - (t displayed-year)))) - (if (and (looking-at "[0-9]") - (< 2 (count-lines (point-min) (point)))) - (save-excursion - (re-search-backward "[^0-9]") - (list month - (string-to-int (buffer-substring (1+ (point)) (+ 4 (point)))) - year)) - (if (looking-at "\\*") - (save-excursion - (re-search-backward "[^*]") - (if (looking-at ".\\*\\*") - (list month calendar-starred-day year) - (if error (error "Not on a date!")))) - (if error (error "Not on a date!"))))))) - -(defun calendar-cursor-to-nearest-date () - "Move the cursor to the closest date. -The position of the cursor is unchanged if it is already on a date. -Returns the list (month day year) giving the cursor position." - (let ((date (calendar-cursor-to-date)) - (column (current-column))) - (if date - date - (if (> 3 (count-lines (point-min) (point))) - (progn - (goto-line 3) - (move-to-column column))) - (if (not (looking-at "[0-9]")) - (if (and (not (looking-at " *$")) - (or (< column 25) - (and (> column 27) - (< column 50)) - (and (> column 52) - (< column 75)))) - (progn - (re-search-forward "[0-9]" nil t) - (backward-char 1)) - (re-search-backward "[0-9]" nil t))) - (calendar-cursor-to-date)))) - -(defun calendar-forward-day (arg) - "Move the cursor forward ARG days. -Moves backward if ARG is negative." - (interactive "p") - (if (/= 0 arg) - (let* - ((cursor-date (calendar-cursor-to-date)) - (cursor-date (if cursor-date - cursor-date - (if (> arg 0) (setq arg (1- arg))) - (calendar-cursor-to-nearest-date))) - (new-cursor-date - (calendar-gregorian-from-absolute - (+ (calendar-absolute-from-gregorian cursor-date) arg))) - (new-display-month (extract-calendar-month new-cursor-date)) - (new-display-year (extract-calendar-year new-cursor-date))) - ;; Put the new month on the screen, if needed, and go to the new date. - (if (not (calendar-date-is-visible-p new-cursor-date)) - (calendar-other-month new-display-month new-display-year)) - (calendar-cursor-to-visible-date new-cursor-date)))) - -(defun calendar-backward-day (arg) - "Move the cursor back ARG days. -Moves forward if ARG is negative." - (interactive "p") - (calendar-forward-day (- arg))) - -(defun calendar-forward-week (arg) - "Move the cursor forward ARG weeks. -Moves backward if ARG is negative." - (interactive "p") - (calendar-forward-day (* arg 7))) - -(defun calendar-backward-week (arg) - "Move the cursor back ARG weeks. -Moves forward if ARG is negative." - (interactive "p") - (calendar-forward-day (* arg -7))) - -(defun calendar-beginning-of-week (arg) - "Move the cursor back ARG calendar-week-start-day's." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) - (calendar-backward-day - (if (= day calendar-week-start-day) - (* 7 arg) - (+ (mod (- day calendar-week-start-day) 7) - (* 7 (1- arg))))))) - -(defun calendar-end-of-week (arg) - "Move the cursor forward ARG calendar-week-start-day+6's." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) - (calendar-forward-day - (if (= day (mod (1- calendar-week-start-day) 7)) - (* 7 arg) - (+ (- 6 (mod (- day calendar-week-start-day) 7)) - (* 7 (1- arg))))))) - -(defun calendar-beginning-of-month (arg) - "Move the cursor backward ARG month beginnings." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (if (= day 1) - (calendar-backward-month arg) - (calendar-cursor-to-visible-date (list month 1 year)) - (calendar-backward-month (1- arg))))) - -(defun calendar-end-of-month (arg) - "Move the cursor forward ARG month ends." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (last-day (calendar-last-day-of-month month year))) - (if (/= day last-day) - (progn - (calendar-cursor-to-visible-date (list month last-day year)) - (setq arg (1- arg)))) - (increment-calendar-month month year arg) - (let ((last-day (list - month - (calendar-last-day-of-month month year) - year))) - (if (not (calendar-date-is-visible-p last-day)) - (calendar-other-month month year) - (calendar-cursor-to-visible-date last-day))))) - -(defun calendar-beginning-of-year (arg) - "Move the cursor backward ARG year beginnings." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (jan-first (list 1 1 year))) - (if (and (= day 1) (= 1 month)) - (calendar-backward-month (* 12 arg)) - (if (and (= arg 1) - (calendar-date-is-visible-p jan-first)) - (calendar-cursor-to-visible-date jan-first) - (calendar-other-month 1 (- year (1- arg))))))) - -(defun calendar-end-of-year (arg) - "Move the cursor forward ARG year beginnings." - (interactive "p") - (calendar-cursor-to-nearest-date) - (let* ((date (calendar-cursor-to-date)) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (dec-31 (list 12 31 year))) - (if (and (= day 31) (= 12 month)) - (calendar-forward-month (* 12 arg)) - (if (and (= arg 1) - (calendar-date-is-visible-p dec-31)) - (calendar-cursor-to-visible-date dec-31) - (calendar-other-month 12 (- year (1- arg))) - (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))) - -;; The following version of calendar-gregorian-from-absolute is preferred for -;; reasons of clarity, BUT it's much slower than the version that follows it. - -;;(defun calendar-gregorian-from-absolute (date) -;; "Compute the list (month day year) corresponding to the absolute DATE. -;;The absolute date is the number of days elapsed since the (imaginary) -;;Gregorian date Sunday, December 31, 1 BC." -;; (let* ((approx (/ date 366));; Approximation from below. -;; (year ;; Search forward from the approximation. -;; (+ approx -;; (calendar-sum y approx -;; (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y)))) -;; 1))) -;; (month ;; Search forward from January. -;; (1+ (calendar-sum m 1 -;; (> date -;; (calendar-absolute-from-gregorian -;; (list m (calendar-last-day-of-month m year) year))) -;; 1))) -;; (day ;; Calculate the day by subtraction. -;; (- date -;; (1- (calendar-absolute-from-gregorian (list month 1 year)))))) -;; (list month day year))) - -(defun calendar-gregorian-from-absolute (date) - "Compute the list (month day year) corresponding to the absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." -;; See the footnote on page 384 of ``Calendrical Calculations, Part II: -;; Three Historical Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. -;; Clamen, Software--Practice and Experience, Volume 23, Number 4 -;; (April, 1993), pages 383-404 for an explanation. - (let* ((d0 (1- date)) - (n400 (/ d0 146097)) - (d1 (% d0 146097)) - (n100 (/ d1 36524)) - (d2 (% d1 36524)) - (n4 (/ d2 1461)) - (d3 (% d2 1461)) - (n1 (/ d3 365)) - (day (1+ (% d3 365))) - (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1))) - (if (or (= n100 4) (= n1 4)) - (list 12 31 year) - (let ((year (1+ year)) - (month 1)) - (while (let ((mdays (calendar-last-day-of-month month year))) - (and (< mdays day) - (setq day (- day mdays)))) - (setq month (1+ month))) - (list month day year))))) - -(defun calendar-cursor-to-visible-date (date) - "Move the cursor to DATE that is on the screen." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (first-of-month-weekday (calendar-day-of-week (list month 1 year)))) - (goto-line (+ 3 - (/ (+ day -1 - (mod - (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7)) - 7))) - (move-to-column (+ 6 - (* 25 - (1+ (calendar-interval - displayed-month displayed-year month year))) - (* 3 (mod - (- (calendar-day-of-week date) - calendar-week-start-day) - 7)))))) - -(defun calendar-other-month (month year) - "Display a three-month calendar centered around MONTH and YEAR." - (interactive (calendar-read-date 'noday)) - (if (and (= month displayed-month) - (= year displayed-year)) - nil - (let ((old-date (calendar-cursor-to-date)) - (today (calendar-current-date))) - (generate-calendar-window month year) - (calendar-cursor-to-visible-date - (cond - ((calendar-date-is-visible-p old-date) old-date) - ((calendar-date-is-visible-p today) today) - (t (list month 1 year))))))) - -(defun calendar-set-mark (arg) - "Mark the date under the cursor, or jump to marked date. -With no prefix argument, push current date onto marked date ring. -With argument, jump to mark, pop it, and put point at end of ring." - (interactive "P") - (let ((date (calendar-cursor-to-date t))) - (if (null arg) - (progn - (setq calendar-mark-ring (cons date calendar-mark-ring)) - ;; Since the top of the mark ring is the marked date in the - ;; calendar, the mark ring in the calendar is one longer than - ;; in other buffers to get the same effect. - (if (> (length calendar-mark-ring) (1+ mark-ring-max)) - (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil)) - (message "Mark set")) - (if (null calendar-mark-ring) - (error "No mark set in this buffer") - (calendar-goto-date (car calendar-mark-ring)) - (setq calendar-mark-ring - (cdr (nconc calendar-mark-ring (list date)))))))) - -(defun calendar-exchange-point-and-mark () - "Exchange the current cursor position with the marked date." - (interactive) - (let ((mark (car calendar-mark-ring)) - (date (calendar-cursor-to-date t))) - (if (null mark) - (error "No mark set in this buffer") - (setq calendar-mark-ring (cons date (cdr calendar-mark-ring))) - (calendar-goto-date mark)))) - -(defun calendar-count-days-region () - "Count the number of days (inclusive) between point and the mark." - (interactive) - (let* ((days (- (calendar-absolute-from-gregorian - (calendar-cursor-to-date t)) - (calendar-absolute-from-gregorian - (or (car calendar-mark-ring) - (error "No mark set in this buffer"))))) - (days (1+ (if (> days 0) days (- days))))) - (message "Region has %d day%s (inclusive)" - days (if (> days 1) "s" "")))) - -(defun calendar-not-implemented () - "Not implemented." - (interactive) - (error "%s not available in the calendar" - (global-key-binding (this-command-keys)))) - -(defun calendar-read (prompt acceptable &optional initial-contents) - "Return an object read from the minibuffer. -Prompt with the string PROMPT and use the function ACCEPTABLE to decide if -entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS -is a string to insert in the minibuffer before reading." - (let ((value (read-minibuffer prompt initial-contents))) - (while (not (funcall acceptable value)) - (setq value (read-minibuffer prompt initial-contents))) - value)) - -(defun calendar-read-date (&optional noday) - "Prompt for Gregorian date. Returns a list (month day year). -If optional NODAY is t, does not ask for day, but just returns -(month nil year); if NODAY is any other non-nil value the value returned is -(month year) " - (let* ((year (calendar-read - "Year (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year - (calendar-current-date))))) - (month-array calendar-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Month name: " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last (calendar-last-day-of-month month year))) - (if noday - (if (eq noday t) - (list month nil year) - (list month year)) - (list month - (calendar-read (format "Day (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))) - year)))) - -(defun calendar-goto-date (date) - "Move cursor to DATE." - (interactive (list (calendar-read-date))) - (let ((month (extract-calendar-month date)) - (year (extract-calendar-year date))) - (if (not (calendar-date-is-visible-p date)) - (calendar-other-month - (if (and (= month 1) (= year 1)) - 2 - month) - year))) - (calendar-cursor-to-visible-date date)) - -(defun calendar-goto-julian-date (date &optional noecho) - "Move cursor to Julian DATE; echo Julian date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Julian calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - today)))))) - (month-array calendar-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Julian calendar month name: " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last - (if (and (zerop (% year 4)) (= month 2)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - (day (calendar-read - (format "Julian calendar day (%d-%d): " - (if (and (= year 1) (= month 1)) 3 1) last) - '(lambda (x) - (and (< (if (and (= year 1) (= month 1)) 2 0) x) - (<= x last)))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-julian date))) - (or noecho (calendar-print-julian-date))) - -(defun calendar-goto-hebrew-date (date &optional noecho) - "Move cursor to Hebrew DATE; echo Hebrew date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Hebrew calendar year (>3760): " - '(lambda (x) (> x 3760)) - (int-to-string - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian today)))))) - (month-array (if (hebrew-calendar-leap-year-p year) - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Hebrew calendar month name: " - (mapcar 'list (append month-array nil)) - (if (= year 3761) - '(lambda (x) - (let ((m (cdr - (assoc - (car x) - (calendar-make-alist - month-array))))) - (< 0 - (calendar-absolute-from-hebrew - (list m - (hebrew-calendar-last-day-of-month - m year) - year)))))) - - t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last (hebrew-calendar-last-day-of-month month year)) - (first (if (and (= year 3761) (= month 10)) - 18 1)) - (day (calendar-read - (format "Hebrew calendar day (%d-%d): " - first last) - '(lambda (x) (and (<= first x) (<= x last)))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew date))) - (or noecho (calendar-print-hebrew-date))) - -(defun calendar-goto-islamic-date (date &optional noecho) - "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Islamic calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian today)))))) - (month-array calendar-islamic-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Islamic calendar month name: " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist month-array 1 'capitalize)))) - (last (islamic-calendar-last-day-of-month month year)) - (day (calendar-read - (format "Islamic calendar day (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic date))) - (or noecho (calendar-print-islamic-date))) - -(defun calendar-goto-iso-date (date &optional noecho) - "Move cursor to ISO DATE; echo ISO date unless NOECHO is t." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "ISO calendar year (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year today)))) - (no-weeks (extract-calendar-month - (calendar-iso-from-absolute - (1- - (calendar-dayname-on-or-before - 1 (calendar-absolute-from-gregorian - (list 1 4 (1+ year)))))))) - (week (calendar-read - (format "ISO calendar week (1-%d): " no-weeks) - '(lambda (x) (and (> x 0) (<= x no-weeks))))) - (day (calendar-read - "ISO day (1-7): " - '(lambda (x) (and (<= 1 x) (<= x 7)))))) - (list (list week day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-iso date))) - (or noecho (calendar-print-iso-date))) - -(defun calendar-interval (mon1 yr1 mon2 yr2) - "The number of months difference between MON1, YR1 and MON2, YR2." - (+ (* 12 (- yr2 yr1)) - (- mon2 mon1))) - -(defun calendar-day-name (date) - "Returns a string with the name of the day of the week of DATE." - (aref calendar-day-name-array (calendar-day-of-week date))) - -(defvar calendar-day-name-array - ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]) - -(defvar calendar-month-name-array - ["January" "February" "March" "April" "May" "June" - "July" "August" "September" "October" "November" "December"]) - -(defun calendar-make-alist (sequence &optional start-index filter) - "Make an assoc list corresponding to SEQUENCE. -Start at index 1, unless optional START-INDEX is provided. -If FILTER is provided, apply it to each item in the list." - (let ((index (if start-index (1- start-index) 0))) - (mapcar - '(lambda (x) - (setq index (1+ index)) - (cons (if filter (funcall filter x) x) - index)) - (append sequence nil)))) - -(defun calendar-month-name (month) - "The name of MONTH." - (aref calendar-month-name-array (1- month))) - -(defun calendar-day-of-week (date) - "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc." - (% (calendar-absolute-from-gregorian date) 7)) - -(defun calendar-unmark () - "Delete all diary/holiday marks/highlighting from the calendar." - (interactive) - (setq mark-holidays-in-calendar nil) - (setq mark-diary-entries-in-calendar nil) - (redraw-calendar)) - -(defun calendar-date-is-visible-p (date) - "Returns t if DATE is legal and is visible in the calendar window." - (let ((gap (calendar-interval - displayed-month displayed-year - (extract-calendar-month date) (extract-calendar-year date)))) - (and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap)))) - -(defun calendar-date-is-legal-p (date) - "Returns t if DATE is a legal date." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (and (<= 1 month) (<= month 12) - (<= 1 day) (<= day (calendar-last-day-of-month month year)) - (<= 1 year)))) - -(defun calendar-date-equal (date1 date2) - "Returns t if the DATE1 and DATE2 are the same." - (and - (= (extract-calendar-month date1) (extract-calendar-month date2)) - (= (extract-calendar-day date1) (extract-calendar-day date2)) - (= (extract-calendar-year date1) (extract-calendar-year date2)))) - -(defun mark-visible-calendar-date (date &optional mark) - "Mark DATE in the calendar window with MARK. -MARK is either a single-character string or a face. -MARK defaults to diary-entry-marker." - (if (calendar-date-is-legal-p date) - (save-excursion - (set-buffer calendar-buffer) - (calendar-cursor-to-visible-date date) - (let ((mark (or mark diary-entry-marker))) - (if (stringp mark) - (let ((buffer-read-only nil)) - (forward-char 1) - (delete-char 1) - (insert mark) - (forward-char -2)) - - (set-extent-property (make-extent (1- (point)) (1+ (point))) - 'face mark)))))) - -(defun calendar-star-date () - "Replace the date under the cursor in the calendar window with asterisks. -This function can be used with the today-visible-calendar-hook run after the -calendar window has been prepared." - (let ((buffer-read-only nil)) - (make-variable-buffer-local 'calendar-starred-day) - (forward-char 1) - (setq calendar-starred-day - (string-to-int - (buffer-substring (point) (- (point) 2)))) - (delete-char -2) - (insert "**") - (backward-char 1) - (set-buffer-modified-p nil))) - -(defun calendar-mark-today () - "Mark the date under the cursor in the calendar window. -The date is marked with calendar-today-marker. This function can be used with -the today-visible-calendar-hook run after the calendar window has been -prepared." - (mark-visible-calendar-date - (calendar-cursor-to-date) - calendar-today-marker)) - -(defun calendar-date-compare (date1 date2) - "Returns t if DATE1 is before DATE2, nil otherwise. -The actual dates are in the car of DATE1 and DATE2." - (< (calendar-absolute-from-gregorian (car date1)) - (calendar-absolute-from-gregorian (car date2)))) - -(defun calendar-date-string (date &optional abbreviate nodayname) - "A string form of DATE, driven by the variable `calendar-date-display-form'. -An optional parameter ABBREVIATE, when t, causes the month and day names to be -abbreviated to three characters. An optional parameter NODAYNAME, when t, -omits the name of the day of the week." - (let* ((dayname - (if nodayname - nil - (if abbreviate - (substring (calendar-day-name date) 0 3) - (calendar-day-name date)))) - (month (extract-calendar-month date)) - (monthname - (if abbreviate - (substring - (calendar-month-name month) 0 3) - (calendar-month-name month))) - (day (int-to-string (extract-calendar-day date))) - (month (int-to-string month)) - (year (int-to-string (extract-calendar-year date)))) - (mapconcat 'eval calendar-date-display-form ""))) - -(defun calendar-dayname-on-or-before (dayname date) - "Returns the absolute date of the DAYNAME on or before absolute DATE. -DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on. - -Note: Applying this function to d+6 gives us the DAYNAME on or after an -absolute day d. Similarly, applying it to d+3 gives the DAYNAME nearest to -absolute date d, applying it to d-1 gives the DAYNAME previous to absolute -date d, and applying it to d+7 gives the DAYNAME following absolute date d." - (- date (% (- date dayname) 7))) - -(defun calendar-nth-named-absday (n dayname month year &optional day) - "The absolute date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. -A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0, -return the Nth DAYNAME before MONTH DAY, YEAR (inclusive). -If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive). - -If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." - (if (> n 0) - (+ (* 7 (1- n)) - (calendar-dayname-on-or-before - dayname - (+ 6 (calendar-absolute-from-gregorian - (list month (or day 1) year))))) - (+ (* 7 (1+ n)) - (calendar-dayname-on-or-before - dayname - (calendar-absolute-from-gregorian - (list month - (or day (calendar-last-day-of-month month year)) - year)))))) - -(defun calendar-nth-named-day (n dayname month year &optional day) - "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. -A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0, -return the Nth DAYNAME before MONTH DAY, YEAR (inclusive). -If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive). - -If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." - (calendar-gregorian-from-absolute - (calendar-nth-named-absday n dayname month year day))) - -(defun calendar-day-of-year-string (&optional date) - "String of day number of year of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((d (or date (calendar-current-date))) - (year (extract-calendar-year d)) - (day (calendar-day-number d)) - (days-remaining (- (calendar-day-number (list 12 31 year)) day))) - (format "Day %d of %d; %d day%s remaining in the year" - day year days-remaining (if (= days-remaining 1) "" "s")))) - -(defun calendar-print-day-of-year () - "Show day number in year/days remaining in year for date under the cursor." - (interactive) - (message (calendar-day-of-year-string (calendar-cursor-to-date t)))) - -(defun calendar-absolute-from-iso (date) - "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The `ISO year' corresponds approximately to the Gregorian year, but -weeks start on Monday and end on Sunday. The first week of the ISO year is -the first such week in which at least 4 days are in a year. The ISO -commercial DATE has the form (week day year) in which week is in the range -1..52 and day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = -Sunday). The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let* ((week (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ (calendar-dayname-on-or-before - 1 (+ 3 (calendar-absolute-from-gregorian (list 1 1 year)))) - (* 7 (1- week)) - (if (= day 0) 6 (1- day))))) - -(defun calendar-iso-from-absolute (date) - "Compute the `ISO commercial date' corresponding to the absolute DATE. -The ISO year corresponds approximately to the Gregorian year, but weeks -start on Monday and end on Sunday. The first week of the ISO year is the -first such week in which at least 4 days are in a year. The ISO commercial -date has the form (week day year) in which week is in the range 1..52 and -day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = Sunday). The -absolute date is the number of days elapsed since the (imaginary) Gregorian -date Sunday, December 31, 1 BC." - (let* ((approx (extract-calendar-year - (calendar-gregorian-from-absolute (- date 3)))) - (year (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-iso (list 1 1 (1+ y)))) - 1)))) - (list - (1+ (/ (- date (calendar-absolute-from-iso (list 1 1 year))) 7)) - (% date 7) - year))) - -(defun calendar-iso-date-string (&optional date) - "String of ISO date of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((d (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - (day (% d 7)) - (iso-date (calendar-iso-from-absolute d))) - (format "Day %s of week %d of %d" - (if (zerop day) 7 day) - (extract-calendar-month iso-date) - (extract-calendar-year iso-date)))) - -(defun calendar-print-iso-date () - "Show equivalent ISO date for the date under the cursor." - (interactive) - (message "ISO date: %s" - (calendar-iso-date-string (calendar-cursor-to-date t)))) - -(defun calendar-julian-from-absolute (date) - "Compute the Julian (month day year) corresponding to the absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((approx (/ (+ date 2) 366));; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-julian (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from January. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-julian - (list m - (if (and (= m 2) (= (% year 4) 0)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] - (1- m))) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date (1- (calendar-absolute-from-julian (list month 1 year)))))) - (list month day year))) - -(defun calendar-absolute-from-julian (date) - "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. -The Gregorian date Sunday, December 31, 1 BC is imaginary." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ (calendar-day-number date) - (if (and (= (% year 100) 0) - (/= (% year 400) 0) - (> month 2)) - 1 0);; Correct for Julian but not Gregorian leap year. - (* 365 (1- year)) - (/ (1- year) 4) - -2))) - -(defun calendar-julian-date-string (&optional date) - "String of Julian date of Gregorian DATE. -Defaults to today's date if DATE is not given. -Driven by the variable `calendar-date-display-form'." - (calendar-date-string - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - nil t)) - -(defun calendar-print-julian-date () - "Show the Julian calendar equivalent of the date under the cursor." - (interactive) - (message "Julian date: %s" - (calendar-julian-date-string (calendar-cursor-to-date t)))) - -(defun islamic-calendar-leap-year-p (year) - "Returns t if YEAR is a leap year on the Islamic calendar." - (memq (% year 30) - (list 2 5 7 10 13 16 18 21 24 26 29))) - -(defun islamic-calendar-last-day-of-month (month year) - "The last day in MONTH during YEAR on the Islamic calendar." - (cond - ((memq month (list 1 3 5 7 9 11)) 30) - ((memq month (list 2 4 6 8 10)) 29) - (t (if (islamic-calendar-leap-year-p year) 30 29)))) - -(defun islamic-calendar-day-number (date) - "Return the day number within the year of the Islamic date DATE." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date))) - (+ (* 30 (/ month 2)) - (* 29 (/ (1- month) 2)) - day))) - -(defun calendar-absolute-from-islamic (date) - "Absolute date of Islamic DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (y (% year 30)) - (leap-years-in-cycle - (cond - ((< y 3) 0) ((< y 6) 1) ((< y 8) 2) ((< y 11) 3) ((< y 14) 4) - ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9) - (t 10)))) - (+ (islamic-calendar-day-number date);; days so far this year - (* (1- year) 354) ;; days in all non-leap years - (* 11 (/ year 30)) ;; leap days in complete cycles - leap-years-in-cycle ;; leap days this cycle - 227014))) ;; days before start of calendar - -(defun calendar-islamic-from-absolute (date) - "Compute the Islamic date (month day year) corresponding to absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (if (< date 227015) - (list 0 0 0);; pre-Islamic date - (let* ((approx (/ (- date 227014) 355));; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-islamic - (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from Muharram. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-islamic - (list m - (islamic-calendar-last-day-of-month - m year) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date - (1- (calendar-absolute-from-islamic (list month 1 year)))))) - (list month day year)))) - -(defvar calendar-islamic-month-name-array - ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II" - "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"]) - -(defun calendar-islamic-date-string (&optional date) - "String of Islamic date before sunset of Gregorian DATE. -Returns the empty string if DATE is pre-Islamic. -Defaults to today's date if DATE is not given. -Driven by the variable `calendar-date-display-form'." - (let ((calendar-month-name-array calendar-islamic-month-name-array) - (islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date)))))) - (if (< (extract-calendar-year islamic-date) 1) - "" - (calendar-date-string islamic-date nil t)))) - -(defun calendar-print-islamic-date () - "Show the Islamic calendar equivalent of the date under the cursor." - (interactive) - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - (message "Date is pre-Islamic") - (message "Islamic date (until sunset): %s" i)))) - -(defun calendar-hebrew-from-absolute (date) - "Compute the Hebrew date (month day year) corresponding to absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((greg-date (calendar-gregorian-from-absolute date)) - (month (aref [9 10 11 12 1 2 3 4 7 7 7 8] - (1- (extract-calendar-month greg-date)))) - (day) - (year (+ 3760 (extract-calendar-year greg-date)))) - (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))) - (setq year (1+ year))) - (let ((length (hebrew-calendar-last-month-of-year year))) - (while (> date - (calendar-absolute-from-hebrew - (list month - (hebrew-calendar-last-day-of-month month year) - year))) - (setq month (1+ (% month length))))) - (setq day (1+ - (- date (calendar-absolute-from-hebrew (list month 1 year))))) - (list month day year))) - -(defun hebrew-calendar-leap-year-p (year) - "t if YEAR is a Hebrew calendar leap year." - (< (% (1+ (* 7 year)) 19) 7)) - -(defun hebrew-calendar-last-month-of-year (year) - "The last month of the Hebrew calendar YEAR." - (if (hebrew-calendar-leap-year-p year) - 13 - 12)) - -(defun hebrew-calendar-last-day-of-month (month year) - "The last day of MONTH in YEAR." - (if (or (memq month (list 2 4 6 10 13)) - (and (= month 12) (not (hebrew-calendar-leap-year-p year))) - (and (= month 8) (not (hebrew-calendar-long-heshvan-p year))) - (and (= month 9) (hebrew-calendar-short-kislev-p year))) - 29 - 30)) - -(defun hebrew-calendar-elapsed-days (year) - "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR." - (let* ((months-elapsed - (+ (* 235 (/ (1- year) 19));; Months in complete cycles so far. - (* 12 (% (1- year) 19)) ;; Regular months in this cycle - (/ (1+ (* 7 (% (1- year) 19))) 19)));; Leap months this cycle - (parts-elapsed (+ 204 (* 793 (% months-elapsed 1080)))) - (hours-elapsed (+ 5 - (* 12 months-elapsed) - (* 793 (/ months-elapsed 1080)) - (/ parts-elapsed 1080))) - (parts ;; Conjunction parts - (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080))) - (day ;; Conjunction day - (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24))) - (alternative-day - (if (or (>= parts 19440) ;; If the new moon is at or after midday, - (and (= (% day 7) 2);; ...or is on a Tuesday... - (>= parts 9924) ;; at 9 hours, 204 parts or later... - (not (hebrew-calendar-leap-year-p year)));; of a - ;; common year, - (and (= (% day 7) 1);; ...or is on a Monday... - (>= parts 16789) ;; at 15 hours, 589 parts or later... - (hebrew-calendar-leap-year-p (1- year))));; at the end - ;; of a leap year - ;; Then postpone Rosh HaShanah one day - (1+ day) - ;; Else - day))) - (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday - (memq (% alternative-day 7) (list 0 3 5)) - ;; Then postpone it one (more) day and return - (1+ alternative-day) - ;; Else return - alternative-day))) - -(defun hebrew-calendar-days-in-year (year) - "Number of days in Hebrew YEAR." - (- (hebrew-calendar-elapsed-days (1+ year)) - (hebrew-calendar-elapsed-days year))) - -(defun hebrew-calendar-long-heshvan-p (year) - "t if Heshvan is long in Hebrew YEAR." - (= (% (hebrew-calendar-days-in-year year) 10) 5)) - -(defun hebrew-calendar-short-kislev-p (year) - "t if Kislev is short in Hebrew YEAR." - (= (% (hebrew-calendar-days-in-year year) 10) 3)) - -(defun calendar-absolute-from-hebrew (date) - "Absolute date of Hebrew DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date))) - (+ day ;; Days so far this month. - (if (< month 7);; before Tishri - ;; Then add days in prior months this year before and after Nisan - (+ (calendar-sum - m 7 (<= m (hebrew-calendar-last-month-of-year year)) - (hebrew-calendar-last-day-of-month m year)) - (calendar-sum - m 1 (< m month) - (hebrew-calendar-last-day-of-month m year))) - ;; Else add days in prior months this year - (calendar-sum - m 7 (< m month) - (hebrew-calendar-last-day-of-month m year))) - (hebrew-calendar-elapsed-days year);; Days in prior years. - -1373429))) ;; Days elapsed before absolute date 1. - -(defvar calendar-hebrew-month-name-array-common-year - ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" - "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]) - -(defvar calendar-hebrew-month-name-array-leap-year - ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" - "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]) - -(defun calendar-hebrew-date-string (&optional date) - "String of Hebrew date before sunset of Gregorian DATE. -Defaults to today's date if DATE is not given. -Driven by the variable `calendar-date-display-form'." - (let* ((hebrew-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (calendar-month-name-array - (if (hebrew-calendar-leap-year-p (extract-calendar-year hebrew-date)) - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year))) - (calendar-date-string hebrew-date nil t))) - -(defun calendar-print-hebrew-date () - "Show the Hebrew calendar equivalent of the date under the cursor." - (interactive) - (message "Hebrew date (until sunset): %s" - (calendar-hebrew-date-string (calendar-cursor-to-date t)))) - -(defun hebrew-calendar-yahrzeit (death-date year) - "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR." - (let* ((death-day (extract-calendar-day death-date)) - (death-month (extract-calendar-month death-date)) - (death-year (extract-calendar-year death-date))) - (cond - ;; If it's Heshvan 30 it depends on the first anniversary; if - ;; that was not Heshvan 30, use the day before Kislev 1. - ((and (= death-month 8) - (= death-day 30) - (not (hebrew-calendar-long-heshvan-p (1+ death-year)))) - (1- (calendar-absolute-from-hebrew (list 9 1 year)))) - ;; If it's Kislev 30 it depends on the first anniversary; if - ;; that was not Kislev 30, use the day before Teveth 1. - ((and (= death-month 9) - (= death-day 30) - (hebrew-calendar-short-kislev-p (1+ death-year))) - (1- (calendar-absolute-from-hebrew (list 10 1 year)))) - ;; If it's Adar II, use the same day in last month of - ;; year (Adar or Adar II). - ((= death-month 13) - (calendar-absolute-from-hebrew - (list (hebrew-calendar-last-month-of-year year) death-day year))) - ;; If it's the 30th in Adar I and year is not a leap year - ;; (so Adar has only 29 days), use the last day in Shevat. - ((and (= death-day 30) - (= death-month 12) - (not (hebrew-calendar-leap-year-p year))) - (calendar-absolute-from-hebrew (list 11 30 year))) - ;; In all other cases, use the normal anniversary of the date of death. - (t (calendar-absolute-from-hebrew - (list death-month death-day year)))))) - -(defun calendar-set-mode-line (str) - "Set mode line to STR, centered, surrounded by dashes." - (setq mode-line-format - (calendar-string-spread (list "" str "") ?- (frame-width)))) - -;;;###autoload -(defun list-yahrzeit-dates (death-date start-year end-year) - "List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR. -When called interactively from the calendar window, the date of death is taken -from the cursor position." - (interactive - (let* ((death-date - (if (equal (current-buffer) (get-buffer calendar-buffer)) - (calendar-cursor-to-date) - (let* ((today (calendar-current-date)) - (year (calendar-read - "Year of death (>0): " - '(lambda (x) (> x 0)) - (int-to-string (extract-calendar-year today)))) - (month-array calendar-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Month of death (name): " - (mapcar 'list (append month-array nil)) - nil t)) - (calendar-make-alist - month-array 1 'capitalize)))) - (last (calendar-last-day-of-month month year)) - (day (calendar-read - (format "Day of death (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))))) - (list month day year)))) - (death-year (extract-calendar-year death-date)) - (start-year (calendar-read - (format "Starting year of Yahrzeit table (>%d): " - death-year) - '(lambda (x) (> x death-year)) - (int-to-string (1+ death-year)))) - (end-year (calendar-read - (format "Ending year of Yahrzeit table (>=%d): " - start-year) - '(lambda (x) (>= x start-year))))) - (list death-date start-year end-year))) - (message "Computing yahrzeits...") - (let* ((yahrzeit-buffer "*Yahrzeits*") - (h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian death-date))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (set-buffer (get-buffer-create yahrzeit-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line - (format "Yahrzeit dates for %s = %s" - (calendar-date-string death-date) - (let ((calendar-month-name-array - (if (hebrew-calendar-leap-year-p h-year) - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year))) - (calendar-date-string h-date nil t)))) - (erase-buffer) - (goto-char (point-min)) - (calendar-for-loop i from start-year to end-year do - (insert - (calendar-date-string - (calendar-gregorian-from-absolute - (hebrew-calendar-yahrzeit - h-date - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer yahrzeit-buffer) - (message "Computing yahrzeits...done"))) - -(defun calendar-astro-date-string (&optional date) - "String of astronomical (Julian) day number of afternoon of Gregorian DATE. -Defaults to today's date if DATE is not given." - (int-to-string - (+ 1721425 (calendar-absolute-from-gregorian - (or date (calendar-current-date)))))) - -(defun calendar-print-astro-day-number () - "Show astronomical (Julian) day number of afternoon on date shown by cursor." - (interactive) - (message - "Astronomical (Julian) day number after noon UTC: %s" - (calendar-astro-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-astro-day-number (daynumber &optional noecho) - "Move cursor to astronomical (Julian) DAYNUMBER. -Echo astronomical (Julian) day number unless NOECHO is t." - (interactive (list (calendar-read - "Astronomical (Julian) day number (>1721425): " - '(lambda (x) (> x 1721425))))) - (calendar-goto-date (calendar-gregorian-from-absolute (- daynumber 1721425))) - (or noecho (calendar-print-astro-day-number))) - -(run-hooks 'calendar-load-hook) - -(provide 'calendar) - -;;; calendar.el ends here
--- a/lisp/calendar/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Sep 27 08:13:36 1997 - -;;; Code: - -(custom-put 'holidays 'custom-loads '("calendar")) -(custom-put 'calendar 'custom-loads '("calendar")) -(custom-put 'local 'custom-loads '("calendar")) -(custom-put 'diary 'custom-loads '("calendar")) -(custom-put 'appt 'custom-loads '("appt")) - -;;; custom-load.el ends here
--- a/lisp/calendar/diary-ins.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,251 +0,0 @@ -;;; diary-ins.el --- calendar functions for adding diary entries. - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: diary, calendar - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the diary insertion features as -;; described in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'diary-lib) - -(defun make-diary-entry (string &optional nonmarking file) - "Insert a diary entry STRING which may be NONMARKING in FILE. -If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." - (find-file-other-window - (substitute-in-file-name (if file file diary-file))) - (goto-char (point-max)) - (insert - (if (bolp) "" "\n") - (if nonmarking diary-nonmarking-symbol "") - string " ")) - -(defun insert-diary-entry (arg) - "Insert a diary entry for the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t) - arg)) - -(defun insert-weekly-diary-entry (arg) - "Insert a weekly diary entry for the day of the week indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-day-name (calendar-cursor-to-date t)) - arg)) - -(defun insert-monthly-diary-entry (arg) - "Insert a monthly diary entry for the day of the month indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " * ") - '("* " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-yearly-diary-entry (arg) - "Insert an annual diary entry for the day of the year indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-anniversary-diary-entry (arg) - "Insert an anniversary diary entry for the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-anniversary %s)" - sexp-diary-entry-symbol - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-block-diary-entry (arg) - "Insert a block diary entry for the days between the point and marked date. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year))) - (cursor (calendar-cursor-to-date t)) - (mark (or (car calendar-mark-ring) - (error "No mark set in this buffer"))) - (start) - (end)) - (if (< (calendar-absolute-from-gregorian mark) - (calendar-absolute-from-gregorian cursor)) - (setq start mark - end cursor) - (setq start cursor - end mark)) - (make-diary-entry - (format "%s(diary-block %s %s)" - sexp-diary-entry-symbol - (calendar-date-string start nil t) - (calendar-date-string end nil t)) - arg))) - -(defun insert-cyclic-diary-entry (arg) - "Insert a cyclic diary entry starting at the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-cyclic %d %s)" - sexp-diary-entry-symbol - (calendar-read "Repeat every how many days: " - '(lambda (x) (> x 0))) - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-hebrew-diary-entry (arg) - "Insert a diary entry. -For the Hebrew date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-hebrew-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Hebrew month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-hebrew-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Hebrew year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-islamic-diary-entry (arg) - "Insert a diary entry. -For the Islamic date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-islamic-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Islamic month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-islamic-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Islamic year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(provide 'diary-ins) - -;;; diary-ins.el ends here
--- a/lisp/calendar/diary-lib.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1938 +0,0 @@ -;;; diary-lib.el --- diary functions. - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the diary features as described -;; in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(require 'calendar) - -;;;###autoload -(defun diary (&optional arg) - "Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." - (interactive "P") - (let ((d-file (substitute-in-file-name diary-file)) - (date (calendar-current-date))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries - date - (cond - (arg (prefix-numeric-value arg)) - ((vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date))) - (t number-of-diary-entries))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-diary-entries (arg) - "Prepare and display a buffer with diary entries. -Searches the file named in `diary-file' for entries that -match ARG days starting with the date indicated by the cursor position -in the displayed three-month calendar." - (interactive "p") - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries (calendar-cursor-to-date t) arg) - (error "Diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-other-diary-entries (arg diary-file) - "Prepare and display buffer of diary entries from an alternative diary file. -Prompts for a file name and searches that file for entries that match ARG -days starting with the date indicated by the cursor position in the displayed -three-month calendar." - (interactive - (list (cond ((null current-prefix-arg) 1) - ((listp current-prefix-arg) (car current-prefix-arg)) - (t current-prefix-arg)) - (setq diary-file (read-file-name "Enter diary file name: " - default-directory nil t)))) - (view-diary-entries arg)) - -(autoload 'check-calendar-holidays "holidays" - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'calendar-holiday-list "holidays" - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'diary-french-date "cal-french" - "French calendar equivalent of date diary entry." - t) - -(autoload 'diary-mayan-date "cal-mayan" - "Mayan calendar equivalent of date diary entry." - t) - -(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t) - -(autoload 'diary-sunrise-sunset "solar" - "Local time of sunrise and sunset as a diary entry." - t) - -(autoload 'diary-sabbath-candles "solar" - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - t) - -(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) - "The syntax table used when parsing dates in the diary file. -It is the standard syntax table used in Fundamental mode, but with the -syntax of `*' changed to be a word constituent.") - -(modify-syntax-entry ?* "w" diary-syntax-table) - -(defun list-diary-entries (date number) - "Create and display a buffer containing the relevant lines in diary-file. -The arguments are DATE and NUMBER; the entries selected are those -for NUMBER days starting with date DATE. The other entries are hidden -using selective display. - -Returns a list of all relevant diary entries found, if any, in order by date. -The list entries have the form ((month day year) string). If the variable -`diary-list-include-blanks' is t, this list includes a dummy diary entry -\(consisting of the empty string) for a date with no diary entries. - -After the list is prepared, the hooks `nongregorian-diary-listing-hook', -`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run. -These hooks have the following distinct roles: - - `nongregorian-diary-listing-hook' can cull dates from the diary - and each included file. Usually used for Hebrew or Islamic - diary entries in files. Applied to *each* file. - - `list-diary-entries-hook' adds or manipulates diary entries from - external sources. Used, for example, to include diary entries - from other files or to sort the diary entries. Invoked *once* only, - before the display hook is run. - - `diary-display-hook' does the actual display of information. If this is - nil, simple-diary-display will be used. Use add-hook to set this to - fancy-diary-display, if desired. If you want no diary display, use - add-hook to set this to ignore. - - `diary-hook' is run last. This can be used for an appointment - notification function." - - (if (< 0 number) - (let* ((original-date date);; save for possible use in the hooks - (old-diary-syntax-table) - (diary-entries-list) - (date-string (calendar-date-string date)) - (d-file (substitute-in-file-name diary-file))) - (message "Preparing diary...") - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t)))) - (setq selective-display t) - (setq selective-display-ellipses nil) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (unwind-protect - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (mark (regexp-quote diary-nonmarking-symbol))) - (goto-char (1- (point-max))) - (if (not (looking-at "\^M\\|\n")) - (progn - (forward-char 1) - (insert-string "\^M"))) - (goto-char (point-min)) - (if (not (looking-at "\^M\\|\n")) - (insert-string "\^M")) - (subst-char-in-region (point-min) (point-max) ?\n ?\^M t) - (calendar-for-loop i from 1 to number do - (let ((d diary-date-forms) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (entry-found (list-sexp-diary-entries date))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name date) "\\|" - (substring (calendar-day-name date) 0 3) ".?")) - (monthname - (concat - "\\*\\|" - (calendar-month-name month) "\\|" - (substring (calendar-month-name month) 0 3) ".?")) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (setq entry-found t) - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start - (point) ?\^M ?\n t) - (add-to-diary-list - date (buffer-substring entry-start (point))))))) - (setq d (cdr d))) - (or entry-found - (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date ""))))) - (setq date - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian date)))) - (setq entry-found nil))) - (set-buffer-modified-p diary-modified)) - (set-syntax-table old-diary-syntax-table)) - (goto-char (point-min)) - (run-hooks 'nongregorian-diary-listing-hook - 'list-diary-entries-hook) - (if diary-display-hook - (run-hooks 'diary-display-hook) - (simple-diary-display)) - (run-hooks 'diary-hook) - diary-entries-list)))) - -(defun include-other-diary-files () - "Include the diary entries from other diary files with those of diary-file. -This function is suitable for use in `list-diary-entries-hook'; -it enables you to use shared diary files together with your own. -The files included are specified in the diaryfile by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (diary-list-include-blanks nil) - (list-diary-entries-hook 'include-other-diary-files) - (diary-display-hook 'ignore) - (diary-hook nil)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (unwind-protect - (setq diary-entries-list - (append diary-entries-list - (list-diary-entries original-date number))) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun simple-diary-display () - "Display the diary buffer if there are any relevant entries or holidays." - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string)) - (calendar-set-mode-line - (concat "Diary for " date-string - (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) - (display-buffer (get-file-buffer d-file)) - (message "Preparing diary...done")))) - -(defun fancy-diary-display () - "Prepare a diary buffer with relevant entries in a fancy, noneditable form. -This function is provided for optional use as the `diary-display-hook'." - (save-excursion;; Turn off selective-display in the diary file's buffer. - (set-buffer (get-file-buffer (substitute-in-file-name diary-file))) - (let ((diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (kill-local-variable 'mode-line-format) - (set-buffer-modified-p diary-modified))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string))) - (save-excursion;; Prepare the fancy diary buffer. - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (setq modeline-buffer-identification '("Diary Entries")) - (erase-buffer) - (let ((entry-list diary-entries-list) - (holiday-list) - (holiday-list-last-month 1) - (holiday-list-last-year 1) - (date (list 0 0 0))) - (while entry-list - (if (not (calendar-date-equal date (car (car entry-list)))) - (progn - (setq date (car (car entry-list))) - (and holidays-in-diary-buffer - (calendar-date-compare - (list (list holiday-list-last-month - (calendar-last-day-of-month - holiday-list-last-month - holiday-list-last-year) - holiday-list-last-year)) - (list date)) - ;; We need to get the holidays for the next 3 months. - (setq holiday-list-last-month - (extract-calendar-month date)) - (setq holiday-list-last-year - (extract-calendar-year date)) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1) - (setq holiday-list - (let ((displayed-month holiday-list-last-month) - (displayed-year holiday-list-last-year)) - (calendar-holiday-list))) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1)) - (let* ((date-string (calendar-date-string date)) - (date-holiday-list - (let ((h holiday-list) - (d)) - ;; Make a list of all holidays for date. - (while h - (if (calendar-date-equal date (car (car h))) - (setq d (append d (cdr (car h))))) - (setq h (cdr h))) - d))) - (insert (if (= (point) (point-min)) "" ?\n) date-string) - (if date-holiday-list (insert ": ")) - (let ((l (current-column))) - (insert (mapconcat 'identity date-holiday-list - (concat "\n" (make-string l ? ))))) - (let ((l (current-column))) - (insert ?\n (make-string l ?=) ?\n))))) - (if (< 0 (length (car (cdr (car entry-list))))) - (insert (car (cdr (car entry-list))) ?\n)) - (setq entry-list (cdr entry-list)))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (setq buffer-read-only t) - (display-buffer fancy-diary-buffer) - (message "Preparing diary...done")))) - -(defun print-diary-entries () - "Print a hard copy of the diary display. - -If the simple diary display is being used, prepare a temp buffer with the -visible lines of the diary buffer, add a heading line composed from the mode -line, print the temp buffer, and destroy it. - -If the fancy diary display is being used, just print the buffer. - -The hooks given by the variable `print-diary-entries-hook' are called to do -the actual printing." - (interactive) - (if (bufferp (get-buffer fancy-diary-buffer)) - (save-excursion - (set-buffer (get-buffer fancy-diary-buffer)) - (run-hooks 'print-diary-entries-hook)) - (let ((diary-buffer - (get-file-buffer (substitute-in-file-name diary-file)))) - (if diary-buffer - (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) - (heading)) - (save-excursion - (set-buffer diary-buffer) - (setq heading - (if (not (stringp mode-line-format)) - "All Diary Entries" - (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) - (substring mode-line-format - (match-beginning 1) (match-end 1)))) - (copy-to-buffer temp-buffer (point-min) (point-max)) - (set-buffer temp-buffer) - (while (re-search-forward "\^M.*$" nil t) - (replace-match "")) - (goto-char (point-min)) - (insert heading "\n" - (make-string (length heading) ?=) "\n") - (run-hooks 'print-diary-entries-hook) - (kill-buffer temp-buffer))) - (error "You don't have a diary buffer!"))))) - -(defun show-all-diary-entries () - "Show all of the diary entries in the diary file. -This function gets rid of the selective display of the diary file so that -all entries, not just some, are visible. If there is no diary buffer, one -is created." - (interactive) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (let ((diary-buffer (get-file-buffer d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t))) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (make-local-variable 'mode-line-format) - (setq mode-line-format default-mode-line-format) - (display-buffer (current-buffer)) - (set-buffer-modified-p diary-modified)))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun diary-name-pattern (string-array &optional fullname) - "Convert an STRING-ARRAY, an array of strings to a pattern. -The pattern will match any of the strings, either entirely or abbreviated -to three characters. An abbreviated form will match with or without a period; -If the optional FULLNAME is t, abbreviations will not match, just the full -name." - (let ((pattern "")) - (calendar-for-loop i from 0 to (1- (length string-array)) do - (setq pattern - (concat - pattern - (if (string-equal pattern "") "" "\\|") - (aref string-array i) - (if fullname - "" - (concat - "\\|" - (substring (aref string-array i) 0 3) ".?"))))) - pattern)) - -(defun mark-diary-entries () - "Mark days in the calendar window that have diary entries. -Each entry in the diary file visible in the calendar window is marked. -After the entries are marked, the hooks `nongregorian-diary-marking-hook' and -`mark-diary-entries-hook' are run." - (interactive) - (setq mark-diary-entries-in-calendar t) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (message "Marking diary entries...") - (set-buffer (find-file-noselect d-file t)) - (let ((d diary-date-forms) - (old-diary-syntax-table)) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-month-name-array) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-current-date))) - (y (+ (string-to-int y-str) - (* 100 - (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize - (substring mm-name 0 3)) - (calendar-make-alist - calendar-month-name-array - 1 - '(lambda (x) (substring x 0 3))) - ))))) - (mark-calendar-date-pattern mm dd yy)))) - (setq d (cdr d)))) - (mark-sexp-diary-entries) - (run-hooks 'nongregorian-diary-marking-hook - 'mark-diary-entries-hook) - (set-syntax-table old-diary-syntax-table) - (message "Marking diary entries...done"))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun mark-sexp-diary-entries () - "Mark days in the calendar window that have sexp diary entries. -Each entry in the diary file (or included files) visible in the calendar window -is marked. See the documentation for the function `list-sexp-diary-entries'." - (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "(")) - (m) - (y) - (first-date) - (last-date)) - (save-excursion - (set-buffer calendar-buffer) - (setq m displayed-month) - (setq y displayed-year)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (calendar-for-loop date from first-date to last-date do - (if (diary-sexp-entry sexp entry - (calendar-gregorian-from-absolute date)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date)))))))) - -(defun mark-included-diary-files () - "Mark the diary entries from other diary files with those of the diary file. -This function is suitable for use as the `mark-diary-entries-hook'; it enables -you to use shared diary files together with your own. The files included are -specified in the diary-file by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring (match-beginning 2) (match-end 2)))) - (mark-diary-entries-hook 'mark-included-diary-files)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (progn - (mark-diary-entries) - (kill-buffer (get-file-buffer diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun mark-calendar-days-named (dayname) - "Mark all dates in the calendar window that are day DAYNAME of the week. -0 means all Sundays, 1 means all Mondays, and so on." - (save-excursion - (set-buffer calendar-buffer) - (let ((prev-month displayed-month) - (prev-year displayed-year) - (succ-month displayed-month) - (succ-year displayed-year) - (last-day) - (day)) - (increment-calendar-month succ-month succ-year 1) - (increment-calendar-month prev-month prev-year -1) - (setq day (calendar-absolute-from-gregorian - (calendar-nth-named-day 1 dayname prev-month prev-year))) - (setq last-day (calendar-absolute-from-gregorian - (calendar-nth-named-day -1 dayname succ-month succ-year))) - (while (<= day last-day) - (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) - (setq day (+ day 7)))))) - -(defun mark-calendar-date-pattern (month day year) - "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (calendar-for-loop i from 0 to 2 do - (mark-calendar-month m y month day year) - (increment-calendar-month m y 1))))) - -(defun mark-calendar-month (month year p-month p-day p-year) - "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. -A value of 0 in any position of the pattern is a wildcard." - (if (or (and (= month p-month) - (or (= p-year 0) (= year p-year))) - (and (= p-month 0) - (or (= p-year 0) (= year p-year)))) - (if (= p-day 0) - (calendar-for-loop - i from 1 to (calendar-last-day-of-month month year) do - (mark-visible-calendar-date (list month i year))) - (mark-visible-calendar-date (list month p-day year))))) - -(defun sort-diary-entries () - "Sort the list of diary entries by time of day." - (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) - -(defun diary-entry-compare (e1 e2) - "Returns t if E1 is earlier than E2." - (or (calendar-date-compare e1 e2) - (and (calendar-date-equal (car e1) (car e2)) - (< (diary-entry-time (car (cdr e1))) - (diary-entry-time (car (cdr e2))))))) - -(defun diary-entry-time (s) - "Time at the beginning of the string S in a military-style integer. -For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized. -The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm, -and XX:XXam or XX:XXpm." - (cond ((string-match;; Military time - "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s) - (+ (* 100 (string-to-int - (substring s (match-beginning 1) (match-end 1)))) - (string-to-int (substring s (match-beginning 2) (match-end 2))))) - ((string-match;; Hour only XXam or XXpm - "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (if (string-equal "a" - (substring s (match-beginning 2) (match-end 2))) - 0 1200))) - ((string-match;; Hour and minute XX:XXam or XX:XXpm - "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (string-to-int (substring s (match-beginning 2) (match-end 2))) - (if (string-equal "a" - (substring s (match-beginning 3) (match-end 3))) - 0 1200))) - (t -9999)));; Unrecognizable - -(defun list-hebrew-diary-entries () - "Add any Hebrew date entries from the diary file to `diary-entries-list'. -Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol' -\(normally an `H'). The same diary date forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. If a Hebrew date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (hdate (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month hdate)) - (day (extract-calendar-day hdate)) - (year (extract-calendar-year hdate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-hebrew-diary-entries () - "Mark days in the calendar window that have Hebrew date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol -\(normally an `H'). The same diary-date-forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. Hebrew date diary entries that begin with a -diary-nonmarking symbol will not be marked in the calendar. This function -is provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-hebrew-month-name-array-leap-year t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq - mm - (cdr - (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-hebrew-month-name-array-leap-year)))))) - (mark-hebrew-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-hebrew-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Hebrew date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (if (memq displayed-month;; This test is only to speed things up a - (list ;; bit; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 - (calendar-last-day-of-month m2 y2) - y2))) - (hebrew-start - (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((h-date (calendar-hebrew-from-absolute date)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (and (or (zerop month) - (= month h-month)) - (or (zerop day) - (= day h-day)) - (or (zerop year) - (= year h-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(defun list-sexp-diary-entries (date) - "Add sexp entries for DATE from the diary file to `diary-entries-list'. -Also, Make them visible in the diary file. Returns t if any entries were -found. - -Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally -`%%'). The form of a sexp diary entry is - - %%(SEXP) ENTRY - -Both ENTRY and DATE are globally available when the SEXP is evaluated. If the -SEXP yields the value nil, the diary entry does not apply. If it yields a -non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a -string, that string will be the diary entry in the fancy diary display. - -For example, the following diary entry will apply to the 21st of the month -if it is a weekday and the Friday before if the 21st is on a weekend: - - &%%(let ((dayname (calendar-day-of-week date)) - (day (extract-calendar-day date))) - (or - (and (= day 21) (memq dayname '(1 2 3 4 5))) - (and (memq day '(19 20)) (= dayname 5))) - ) UIUC pay checks deposited - -A number of built-in functions are available for this type of diary entry: - - %%(diary-float MONTH DAYNAME N) text - Entry will appear on the Nth DAYNAME of MONTH. - (DAYNAME=0 means Sunday, 1 means Monday, and so on; - if N is negative it counts backward from the end of - the month. MONTH can be a list of months, a single - month, or t to specify all months. - - %%(diary-block M1 D1 Y1 M2 D2 Y2) text - Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2, - inclusive. (If `european-calendar-style' is t, the - order of the parameters should be changed to D1, M1, Y1, - D2, M2, Y2.) - - %%(diary-countdown BEFORE AFTER M1 D1 Y1) text - Entry will appear on dates between BEFORE days before - and AFTER days after specified date. (If - `european-calendar-style' is t, the order of the - parameters should be changed to BEFORE, AFTER, D1, M1, - Y1.) - - %%(diary-anniversary MONTH DAY YEAR) text - Entry will appear on anniversary dates of MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of years since the MONTH DAY, YEAR and %s will be replaced - by the ordinal ending of that number (that is, `st', `nd', - `rd' or `th', as appropriate. The anniversary of February - 29 is considered to be March 1 in a non-leap year. - - %%(diary-cyclic N MONTH DAY YEAR) text - Entry will appear every N days, starting MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to N, DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of repetitions since the MONTH DAY, YEAR and %s will - be replaced by the ordinal ending of that number (that is, - `st', `nd', `rd' or `th', as appropriate. - - %%(diary-day-of-year) - Diary entries giving the day of the year and the number of - days remaining in the year will be made every day. Note - that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-iso-date) - Diary entries giving the corresponding ISO commercial date - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - - %%(diary-french-date) - Diary entries giving the corresponding French Revolutionary - date will be made every day. Note that since there is no - text, it makes sense only if the fancy diary display is used. - - %%(diary-islamic-date) - Diary entries giving the corresponding Islamic date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-hebrew-date) - Diary entries giving the corresponding Hebrew date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-astro-day-number) Diary entries giving the corresponding - astronomical (Julian) day number will be made every day. - Note that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-julian-date) Diary entries giving the corresponding - Julian date will be made every day. Note that since - there is no text, it makes sense only if the fancy diary - display is used. - - %%(diary-sunrise-sunset) - Diary entries giving the local times of sunrise and sunset - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-phases-of-moon) - Diary entries giving the times of the phases of the moon - will be when appropriate. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-yahrzeit MONTH DAY YEAR) text - Text is assumed to be the name of the person; the date is - the date of death on the *civil* calendar. The diary entry - will appear on the proper Hebrew-date anniversary and on the - day before. (If `european-calendar-style' is t, the order - of the parameters should be changed to DAY, MONTH, YEAR.) - - %%(diary-rosh-hodesh) - Diary entries will be made on the dates of Rosh Hodesh on - the Hebrew calendar. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-parasha) - Diary entries giving the weekly parasha will be made on - every Saturday. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-omer) - Diary entries giving the omer count will be made every day - from Passover to Shavuoth. Note that since there is no text, - it makes sense only if the fancy diary display is used. - -Marking these entries is *extremely* time consuming, so these entries are -best if they are nonmarking." - (let* ((mark (regexp-quote diary-nonmarking-symbol)) - (sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) - (entry-found)) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (let ((diary-entry (diary-sexp-entry sexp entry date))) - (if diary-entry - (subst-char-in-region line-start (point) ?\^M ?\n t)) - (add-to-diary-list date diary-entry) - (setq entry-found (or entry-found diary-entry))))) - entry-found)) - -(defun diary-sexp-entry (sexp entry date) - "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) - (condition-case nil - (eval (car (read-from-string sexp))) - (error - (beep) - (message "Bad sexp at line %d in %s: %s" - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (goto-char (point-min)) - (let ((lines 1)) - (while (re-search-forward "\n\\|\^M" nil t) - (setq lines (1+ lines))) - lines))) - diary-file sexp) - (sleep-for 2)))))) - (if (stringp result) - result - (if result - entry - nil)))) - -(defun diary-block (m1 d1 y1 m2 d2 y2) - "Block diary entry. -Entry applies if date is between two dates. Order of the parameters is -M1, D1, Y1, M2, D2, Y2 if `european-calendar-style' is nil, and -D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t." - (let ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (date2 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d2 m2 y2) - (list m2 d2 y2)))) - (d (calendar-absolute-from-gregorian date))) - (if (and (<= date1 d) (<= d date2)) - entry))) - -(defun diary-countdown (before after m1 d1 y1) - "Countdown diary entry. -Entry applies if date is between BEFORE days before and AFTER days after -specified date. Order of the parameters is BEFORE, AFTER, M1, D1, Y1 if -`european-calendar-style' is nil, and BEFORE, AFTER, D1, M1, Y1 if -`european-calendar-style' is t." - (let* ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (d (calendar-absolute-from-gregorian date)) - (diff (- d date1))) - (cond - ((and (<= (- before) diff) (< diff 0)) - (concat (format "It is %d day%s before " - (- diff) (if (= diff -1) "" "s")) entry)) - ((= diff 0) (concat (format "TODAY: " diff) entry)) - ((and (<= diff after) (> diff 0)) - (concat (format "It is %d day%s after " - diff (if (= diff 1) "" "s")) entry)) - (t nil)))) - -(defun diary-float (month dayname n) - "Floating diary entry--entry applies if date is the nth dayname of month. -Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant -t, or an integer. The constant t means all months. If N is negative, count -backward from the end of the month." - (let ((m (extract-calendar-month date)) - (y (extract-calendar-year date))) - (if (and - (or (and (listp month) (memq m month)) - (equal m month) - (eq month t)) - (calendar-date-equal date (calendar-nth-named-day n dayname m y))) - entry))) - -(defun diary-anniversary (month day year) - "Anniversary diary entry. -Entry applies if date is the anniversary of MONTH, DAY, YEAR if -`european-calendar-style' is nil, and DAY, MONTH, YEAR if -`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the -%d will be replaced by the number of years since the MONTH DAY, YEAR and the -%s will be replaced by the ordinal ending of that number (that is, `st', `nd', -`rd' or `th', as appropriate. The anniversary of February 29 is considered -to be March 1 in non-leap years." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (y (extract-calendar-year date)) - (diff (- y year))) - (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) - (setq m 3 - d 1)) - (if (and (> diff 0) (calendar-date-equal (list m d y) date)) - (format entry diff (diary-ordinal-suffix diff))))) - -(defun diary-cyclic (n month day year) - "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR. -If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR. -ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of -years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal -ending of that number (that is, `st', `nd', `rd' or `th', as appropriate." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (diff (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian - (list m d year)))) - (cycle (/ diff n))) - (if (and (>= diff 0) (zerop (% diff n))) - (format entry cycle (diary-ordinal-suffix cycle))))) - -(defun diary-ordinal-suffix (n) - "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)" - (if (or (memq (% n 100) '(11 12 13)) - (< 3 (% n 10))) - "th" - (aref ["th" "st" "nd" "rd"] (% n 10)))) - -(defun diary-day-of-year () - "Day of year and number of days remaining in the year of date diary entry." - (calendar-day-of-year-string date)) - -(defun diary-iso-date () - "ISO calendar equivalent of date diary entry." - (format "ISO date: %s" (calendar-iso-date-string date))) - -(defun diary-islamic-date () - "Islamic calendar equivalent of date diary entry." - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - "Date is pre-Islamic" - (format "Islamic date (until sunset): %s" i)))) - -(defun diary-hebrew-date () - "Hebrew calendar equivalent of date diary entry." - (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date))) - -(defun diary-julian-date () - "Julian calendar equivalent of date diary entry." - (format "Julian date: %s" (calendar-julian-date-string date))) - -(defun diary-astro-day-number () - "Astronomical (Julian) day number diary entry." - (format "Astronomical (Julian) day number %s" - (calendar-astro-date-string date))) - -(defun diary-omer () - "Omer count diary entry. -Entry applies if date is within 50 days after Passover." - (let* ((passover - (calendar-absolute-from-hebrew - (list 1 15 (+ (extract-calendar-year date) 3760)))) - (omer (- (calendar-absolute-from-gregorian date) passover)) - (week (/ omer 7)) - (day (% omer 7))) - (if (and (> omer 0) (< omer 50)) - (format "Day %d%s of the omer (until sunset)" - omer - (if (zerop week) - "" - (format ", that is, %d week%s%s" - week - (if (= week 1) "" "s") - (if (zerop day) - "" - (format " and %d day%s" - day (if (= day 1) "" "s"))))))))) - -(defun diary-yahrzeit (death-month death-day death-year) - "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before. -Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed -to be the name of the person. Date of death is on the *civil* calendar; -although the date of death is specified by the civil calendar, the proper -Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the -order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR." - (let* ((h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (if european-calendar-style - (list death-day death-month death-year) - (list death-month death-day death-year))))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (d (calendar-absolute-from-gregorian date)) - (yr (extract-calendar-year (calendar-hebrew-from-absolute d))) - (diff (- yr h-year)) - (y (hebrew-calendar-yahrzeit h-date yr))) - (if (and (> diff 0) (or (= y d) (= y (1+ d)))) - (format "Yahrzeit of %s%s: %d%s anniversary" - entry - (if (= y d) "" " (evening)") - diff - (cond ((= (% diff 10) 1) "st") - ((= (% diff 10) 2) "nd") - ((= (% diff 10) 3) "rd") - (t "th")))))) - -(defun diary-rosh-hodesh () - "Rosh Hodesh diary entry. -Entry applies if date is Rosh Hodesh, the day before, or the Saturday before." - (let* ((d (calendar-absolute-from-gregorian date)) - (h-date (calendar-hebrew-from-absolute d)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (leap-year (hebrew-calendar-leap-year-p h-year)) - (last-day (hebrew-calendar-last-day-of-month h-month h-year)) - (h-month-names - (if leap-year - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (this-month (aref h-month-names (1- h-month))) - (h-yesterday (extract-calendar-day - (calendar-hebrew-from-absolute (1- d))))) - (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) - (format - "Rosh Hodesh %s" - (if (= h-day 30) - (format - "%s (first day)" - ;; next month must be in the same year since this - ;; month can't be the last month of the year since - ;; it has 30 days - (aref h-month-names h-month)) - (if (= h-yesterday 30) - (format "%s (second day)" this-month) - this-month))) - (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim - (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s)" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)) - (aref calendar-day-name-array (- 29 h-day)))) - ((and (< h-day 30) (> h-day 22) (= 30 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s-%s)" - (aref h-month-names h-month) - (if (= h-day 29) - "tomorrow" - (aref calendar-day-name-array (- 29 h-day))) - (aref calendar-day-name-array - (% (- 30 h-day) 7))))) - (if (and (= h-day 29) (/= h-month 6)) - (format "Erev Rosh Hodesh %s" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)))))))) - -(defun diary-parasha () - "Parasha diary entry--entry applies if date is a Saturday." - (let ((d (calendar-absolute-from-gregorian date))) - (if (= (% d 7) 6);; Saturday - (let* - ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute d))) - (rosh-hashannah - (calendar-absolute-from-hebrew (list 7 1 h-year))) - (passover - (calendar-absolute-from-hebrew (list 1 15 h-year))) - (rosh-hashannah-day - (aref calendar-day-name-array (% rosh-hashannah 7))) - (passover-day - (aref calendar-day-name-array (% passover 7))) - (long-h (hebrew-calendar-long-heshvan-p h-year)) - (short-k (hebrew-calendar-short-kislev-p h-year)) - (type (cond ((and long-h (not short-k)) "complete") - ((and (not long-h) short-k) "incomplete") - (t "regular"))) - (year-format - (symbol-value - (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah - rosh-hashannah-day type passover-day)))) - (first-saturday;; of Hebrew year - (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah))) - (saturday;; which Saturday of the Hebrew year - (/ (- d first-saturday) 7)) - (parasha (aref year-format saturday))) - (if parasha - (format - "Parashat %s" - (if (listp parasha);; Israel differs from diaspora - (if (car parasha) - (format "%s (diaspora), %s (Israel)" - (hebrew-calendar-parasha-name (car parasha)) - (hebrew-calendar-parasha-name (cdr parasha))) - (format "%s (Israel)" - (hebrew-calendar-parasha-name (cdr parasha)))) - (hebrew-calendar-parasha-name parasha)))))))) - -(defun add-to-diary-list (date string) - "Add the entry (DATE STRING) to `diary-entries-list'. -Do nothing if DATE or STRING is nil." - (and date string - (setq diary-entries-list - (append diary-entries-list (list (list date string)))))) - -(defvar hebrew-calendar-parashiot-names -["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" - "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" - "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" - "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" - "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" - "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" - "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" - "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" - "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] - "The names of the parashiot in the Torah.") - -;; The seven ordinary year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Sunday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have -29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Saturday-complete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Tuesday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-complete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Thursday-regular-Saturday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23 - 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30) - (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48 - 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-complete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Sunday.") - -;; The seven leap year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Saturday-complete-Thursday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-complete-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-incomplete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both -have 29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Thursday-complete-Tuesday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both -have 30 days), and has Passover start on Tuesday.") - -(defun hebrew-calendar-parasha-name (p) - "Name(s) corresponding to parasha P." - (if (arrayp p);; combined parasha - (format "%s/%s" - (aref hebrew-calendar-parashiot-names (aref p 0)) - (aref hebrew-calendar-parashiot-names (aref p 1))) - (aref hebrew-calendar-parashiot-names p))) - -(defun list-islamic-diary-entries () - "Add any Islamic date entries from the diary file to `diary-entries-list'. -Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol' -\(normally an `I'). The same diary date forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. If an Islamic date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (idate (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month idate)) - (day (extract-calendar-day idate)) - (year (extract-calendar-year idate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-islamic-month-name-array) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-islamic-diary-entries () - "Mark days in the calendar window that have Islamic date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol -\(normally an `I'). The same diary-date-forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. Islamic date diary entries that begin with a -diary-nonmarking-symbol will not be marked in the calendar. This function is -provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-islamic-month-name-array t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-islamic-month-name-array)))))) - (mark-islamic-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-islamic-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Islamic date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day y))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((i-date (calendar-islamic-from-absolute date)) - (i-month (extract-calendar-month i-date)) - (i-day (extract-calendar-day i-date)) - (i-year (extract-calendar-year i-date))) - (and (or (zerop month) - (= month i-month)) - (or (zerop day) - (= day i-day)) - (or (zerop year) - (= year i-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(provide 'diary-lib) - -;;; diary-lib.el ends here
--- a/lisp/calendar/holidays.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,629 +0,0 @@ -;;; holidays.el --- holiday functions for the calendar package - -;;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: holidays, calendar - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the holiday features as described -;; in calendar.el. - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990), -;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical -;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), -;; pages 383-404. - -;; Hard copies of these two papers can be obtained by sending email to -;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and -;; the message BODY containing your mailing address (snail). - -;;; Code: - -(require 'calendar) - -(autoload 'solar-equinoxes-solstices "solar" - "Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." - t) - -;;;###autoload -(defun holidays (&optional arg) - "Display the holidays for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." - (interactive "P") - (save-excursion - (let* ((completion-ignore-case t) - (date (if arg - (calendar-read-date t) - (calendar-current-date))) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (list-calendar-holidays)))) - -(defun check-calendar-holidays (date) - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list calendar-holidays." - (let* ((displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date)) - (h (calendar-holiday-list)) - (holiday-list)) - (while h - (if (calendar-date-equal date (car (car h))) - (setq holiday-list (append holiday-list (cdr (car h))))) - (setq h (cdr h))) - holiday-list)) - -(defun calendar-cursor-holidays () - "Find holidays for the date specified by the cursor in the calendar window." - (interactive) - (message "Checking holidays...") - (let* ((date (calendar-cursor-to-date t)) - (date-string (calendar-date-string date)) - (holiday-list (check-calendar-holidays date)) - (holiday-string (mapconcat 'identity holiday-list "; ")) - (msg (format "%s: %s" date-string holiday-string))) - (if (not holiday-list) - (message "No holidays known for %s" date-string) - (if (<= (length msg) (frame-width)) - (message msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "Checking holidays...done"))))) - -(defun mark-calendar-holidays () - "Mark notable days in the calendar window." - (interactive) - (setq mark-holidays-in-calendar t) - (message "Marking holidays...") - (let ((holiday-list (calendar-holiday-list))) - (while holiday-list - (mark-visible-calendar-date - (car (car holiday-list)) calendar-holiday-marker) - (setq holiday-list (cdr holiday-list)))) - (message "Marking holidays...done")) - -(defun list-calendar-holidays () - "Create a buffer containing the holidays for the current calendar window. -The holidays are those in the list calendar-notable-days. Returns t if any -holidays are found, nil if not." - (interactive) - (message "Looking up holidays...") - (let ((holiday-list (calendar-holiday-list)) - (m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (if (not holiday-list) - (progn - (message "Looking up holidays...none found") - nil) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (calendar-set-mode-line - (if (= y1 y2) - (format "Notable Dates from %s to %s, %d%%-" - (calendar-month-name m1) (calendar-month-name m2) y2) - (format "Notable Dates from %s, %d to %s, %d%%-" - (calendar-month-name m1) y1 (calendar-month-name m2) y2))) - (erase-buffer) - (insert - (mapconcat - '(lambda (x) (concat (calendar-date-string (car x)) - ": " (car (cdr x)))) - holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "Looking up holidays...done") - t))) - -(defun calendar-holiday-list () - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list calendar-holidays." - (let ((p calendar-holidays) - (holiday-list)) - (while p - (let* ((holidays - (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car p))) - (condition-case nil - (eval (car p)) - (error (beep) - (message "Bad holiday list item: %s" (car p)) - (sleep-for 2)))))) - (if holidays - (setq holiday-list (append holidays holiday-list)))) - (setq p (cdr p))) - (setq holiday-list (sort holiday-list 'calendar-date-compare)))) - -;; Below are the functions that calculate the dates of holidays; these -;; are eval'ed in the function calendar-holiday-list. If you -;; write other such functions, be sure to imitate the style used below. -;; Remember that each function must return a list of items of the form -;; ((month day year) string) of VISIBLE dates in the calendar window. - -(defun holiday-fixed (month day string) - "Holiday on MONTH, DAY (Gregorian) called STRING. -If MONTH, DAY is visible, the value returned is the list (((MONTH DAY year) -STRING)). Returns nil if it is not visible in the current calendar window." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (- 11 month)) - (if (> m 9) - (list (list (list month day y) string))))) - -(defun holiday-float (month dayname n string &optional day) - "Holiday on MONTH, DAYNAME (Nth occurrence, Gregorian) called STRING. -If the Nth DAYNAME in MONTH is visible, the value returned is the list -\(((MONTH DAY year) STRING)). - -If N<0, count backward from the end of MONTH. - -An optional parameter DAY means the Nth DAYNAME after/before MONTH DAY. - -Returns nil if it is not visible in the current calendar window." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (- 11 month)) - (if (> m 9) - (list (list (calendar-nth-named-day n dayname month y day) string))))) - -(defun holiday-julian (month day string) - "Holiday on MONTH, DAY (Julian) called STRING. -If MONTH, DAY (Julian) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) y2))) - (julian-start (calendar-julian-from-absolute start-date)) - (julian-end (calendar-julian-from-absolute end-date)) - (julian-y1 (extract-calendar-year julian-start)) - (julian-y2 (extract-calendar-year julian-end))) - (setq year (if (< 10 month) julian-y1 julian-y2)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-julian - (list month day year))))) - (if (calendar-date-is-visible-p date) - (list (list date string))))))) - -(defun holiday-islamic (month day string) - "Holiday on MONTH, DAY (Islamic) called STRING. -If MONTH, DAY (Islamic) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic (list month day y))))) - (if (calendar-date-is-visible-p date) - (list (list date string)))))))) - -(defun holiday-hebrew (month day string) - "Holiday on MONTH, DAY (Hebrew) called STRING. -If MONTH, DAY (Hebrew) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (if (memq displayed-month;; This test is only to speed things up a bit; - (list ;; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) y2))) - (hebrew-start (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (list (list date string)))))))) - -(defun holiday-sexp (sexp string) - "Sexp holiday for dates in the calendar window. -SEXP is an expression in variable `year' evaluates to `date'. - -STRING is an expression in `date' that evaluates to the holiday description -of `date'. - -If `date' is visible in the calendar window, the holiday STRING is on that -date. If date is nil, or if the date is not visible, there is no holiday." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (filter-visible-calendar-holidays - (append - (let* ((year y) - (date (eval sexp)) - (string (if date (eval string)))) - (list (list date string))) - (let* ((year (1+ y)) - (date (eval sexp)) - (string (if date (eval string)))) - (list (list date string))))))) - -(defun holiday-advent () - "Date of Advent, if visible in calendar window." - (let ((year displayed-year) - (month displayed-month)) - (increment-calendar-month month year -1) - (let ((advent (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 - (calendar-absolute-from-gregorian - (list 12 3 year)))))) - (if (calendar-date-is-visible-p advent) - (list (list advent "Advent")))))) - -(defun holiday-easter-etc () - "List of dates related to Easter, as visible in calendar window." - (if (and (> displayed-month 5) (not all-christian-calendar-holidays)) - nil;; Ash Wednesday, Good Friday, and Easter are not visible. - (let* ((century (1+ (/ displayed-year 100))) - (shifted-epact ;; Age of moon for April 5... - (% (+ 14 (* 11 (% displayed-year 19));; ...by Nicaean rule - (- ;; ...corrected for the Gregorian century rule - (/ (* 3 century) 4)) - (/ ;; ...corrected for Metonic cycle inaccuracy. - (+ 5 (* 8 century)) 25) - (* 30 century));; Keeps value positive. - 30)) - (adjusted-epact ;; Adjust for 29.5 day month. - (if (or (= shifted-epact 0) - (and (= shifted-epact 1) (< 10 (% displayed-year 19)))) - (1+ shifted-epact) - shifted-epact)) - (paschal-moon ;; Day after the full moon on or after March 21. - (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) - adjusted-epact)) - (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-easter) - "Easter Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 2)) - "Good Friday") - (list (calendar-gregorian-from-absolute (- abs-easter 46)) - "Ash Wednesday"))) - (optional - (list - (list (calendar-gregorian-from-absolute (- abs-easter 63)) - "Septuagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 56)) - "Sexagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 49)) - "Shrove Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 48)) - "Shrove Monday") - (list (calendar-gregorian-from-absolute (- abs-easter 47)) - "Shrove Tuesday") - (list (calendar-gregorian-from-absolute (- abs-easter 14)) - "Passion Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 7)) - "Palm Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 3)) - "Maundy Thursday") - (list (calendar-gregorian-from-absolute (+ abs-easter 35)) - "Rogation Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 39)) - "Ascension Day") - (list (calendar-gregorian-from-absolute (+ abs-easter 49)) - "Pentecost (Whitsunday)") - (list (calendar-gregorian-from-absolute (+ abs-easter 50)) - "Whitmunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 56)) - "Trinity Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 60)) - "Corpus Christi"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-christian-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-greek-orthodox-easter () - "Date of Easter according to the rule of the Council of Nicaea." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((julian-year - (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))))) - (shifted-epact ;; Age of moon for April 5. - (% (+ 14 - (* 11 (% julian-year 19))) - 30)) - (paschal-moon ;; Day after full moon on or after March 21. - (- (calendar-absolute-from-julian (list 4 19 julian-year)) - shifted-epact)) - (nicaean-easter;; Sunday following the Paschal moon - (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 (+ paschal-moon 7))))) - (if (calendar-date-is-visible-p nicaean-easter) - (list (list nicaean-easter "Pascha (Greek Orthodox Easter)")))))) - -(defun holiday-rosh-hashanah-etc () - "List of dates related to Rosh Hashanah, as visible in calendar window." - (if (or (< displayed-month 8) - (> displayed-month 11)) - nil;; None of the dates is visible - (let* ((abs-r-h (calendar-absolute-from-hebrew - (list 7 1 (+ displayed-year 3761)))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-r-h) - (format "Rosh HaShanah %d" (+ 3761 displayed-year))) - (list (calendar-gregorian-from-absolute (+ abs-r-h 9)) - "Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 14)) - "Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 21)) - "Shemini Atzeret") - (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) - "Simchat Torah"))) - (optional - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-r-h 4))) - "Selichot (night)") - (list (calendar-gregorian-from-absolute (1- abs-r-h)) - "Erev Rosh HaShannah") - (list (calendar-gregorian-from-absolute (1+ abs-r-h)) - "Rosh HaShanah (second day)") - (list (calendar-gregorian-from-absolute - (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2))) - "Tzom Gedaliah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ 7 abs-r-h))) - "Shabbat Shuvah") - (list (calendar-gregorian-from-absolute (+ abs-r-h 8)) - "Erev Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 13)) - "Erev Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 15)) - "Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 16)) - "Hol Hamoed Sukkot (first day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 17)) - "Hol Hamoed Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 18)) - "Hol Hamoed Sukkot (third day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 19)) - "Hol Hamoed Sukkot (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) - "Hoshannah Rabbah"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-hebrew-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-hanukkah () - "List of dates related to Hanukkah, as visible in calendar window." - (if (memq displayed-month;; This test is only to speed things up a bit; - '(10 11 12 1 2));; it works fine without the test too. - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((h-y (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))))) - (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y)))) - (filter-visible-calendar-holidays - (list - (list (calendar-gregorian-from-absolute (1- abs-h)) - "Erev Hanukkah") - (list (calendar-gregorian-from-absolute abs-h) - "Hanukkah (first day)") - (list (calendar-gregorian-from-absolute (1+ abs-h)) - "Hanukkah (second day)") - (list (calendar-gregorian-from-absolute (+ abs-h 2)) - "Hanukkah (third day)") - (list (calendar-gregorian-from-absolute (+ abs-h 3)) - "Hanukkah (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 4)) - "Hanukkah (fifth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 5)) - "Hanukkah (sixth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 6)) - "Hanukkah (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-h 7)) - "Hanukkah (eighth day)"))))))) - -(defun holiday-passover-etc () - "List of dates related to Passover, as visible in calendar window." - (if (< 7 displayed-month) - nil;; None of the dates is visible - (let* ((abs-p (calendar-absolute-from-hebrew - (list 1 15 (+ displayed-year 3760)))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-p) - "Passover") - (list (calendar-gregorian-from-absolute (+ abs-p 50)) - "Shavuot"))) - (optional - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 43))) - "Shabbat Shekalim") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 30))) - "Shabbat Zachor") - (list (calendar-gregorian-from-absolute - (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31))) - "Fast of Esther") - (list (calendar-gregorian-from-absolute (- abs-p 31)) - "Erev Purim") - (list (calendar-gregorian-from-absolute (- abs-p 30)) - "Purim") - (list (calendar-gregorian-from-absolute - (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29))) - "Shushan Purim") - (list (calendar-gregorian-from-absolute - (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7)) - "Shabbat Parah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 14))) - "Shabbat HaHodesh") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (1- abs-p))) - "Shabbat HaGadol") - (list (calendar-gregorian-from-absolute (1- abs-p)) - "Erev Passover") - (list (calendar-gregorian-from-absolute (1+ abs-p)) - "Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 2)) - "Hol Hamoed Passover (first day)") - (list (calendar-gregorian-from-absolute (+ abs-p 3)) - "Hol Hamoed Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 4)) - "Hol Hamoed Passover (third day)") - (list (calendar-gregorian-from-absolute (+ abs-p 5)) - "Hol Hamoed Passover (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 6)) - "Passover (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-p 7)) - "Passover (eighth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 12)) - "Yom HaShoah") - (list (calendar-gregorian-from-absolute - (if (zerop (% abs-p 7)) - (+ abs-p 18) - (if (= (% abs-p 7) 6) - (+ abs-p 19) - (+ abs-p 20)))) - "Yom HaAtzma'ut") - (list (calendar-gregorian-from-absolute (+ abs-p 33)) - "Lag BaOmer") - (list (calendar-gregorian-from-absolute (+ abs-p 43)) - "Yom Yerushalim") - (list (calendar-gregorian-from-absolute (+ abs-p 49)) - "Erev Shavuot") - (list (calendar-gregorian-from-absolute (+ abs-p 51)) - "Shavuot (second day)"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-hebrew-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-tisha-b-av-etc () - "List of dates around Tisha B'Av, as visible in calendar window." - (if (or (< displayed-month 5) - (> displayed-month 9)) - nil;; None of the dates is visible - (let* ((abs-t-a (calendar-absolute-from-hebrew - (list 5 9 (+ displayed-year 3760))))) - - (filter-visible-calendar-holidays - (list - (list (calendar-gregorian-from-absolute - (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21))) - "Tzom Tammuz") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 abs-t-a)) - "Shabbat Hazon") - (list (calendar-gregorian-from-absolute - (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a)) - "Tisha B'Av") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ abs-t-a 7))) - "Shabbat Nahamu")))))) - -(defun filter-visible-calendar-holidays (l) - "Return a list of all visible holidays of those on L." - (let ((visible) - (p l)) - (while p - (and (car (car p)) - (calendar-date-is-visible-p (car (car p))) - (setq visible (append (list (car p)) visible))) - (setq p (cdr p))) - visible)) - -(provide 'holidays) - -;;; holidays.el ends here
--- a/lisp/calendar/lunar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,252 +0,0 @@ -;;; lunar.el --- calendar functions for phases of the moon. - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: moon, lunar phases, calendar, diary - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements lunar phases for calendar.el and -;; diary.el. - -;; Based on ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus, -;; Willmann-Bell, Inc., 1985. -;; -;; WARNING: The calculations will be accurate only to within a few minutes. - -;; The author would be delighted to have an astronomically more sophisticated -;; person rewrite the code for the lunar calculations in this file! - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(if (fboundp 'atan) - (require 'lisp-float-type) - (error "Lunar calculations impossible since floating point is unavailable.")) - -(require 'solar) - -(defun lunar-phase-list (month year) - "List of lunar phases for three months starting with Gregorian MONTH, YEAR." - (let ((end-month month) - (end-year year) - (start-month month) - (start-year year)) - (increment-calendar-month end-month end-year 3) - (increment-calendar-month start-month start-year -1) - (let* ((end-date (list (list end-month 1 end-year))) - (start-date (list (list start-month - (calendar-last-day-of-month - start-month start-year) - start-year))) - (index (* 4 - (truncate - (* 12.3685 - (+ year - ( / (calendar-day-number (list month 1 year)) - 366.0) - -1900))))) - (new-moon (lunar-phase index)) - (list)) - (while (calendar-date-compare new-moon end-date) - (if (calendar-date-compare start-date new-moon) - (setq list (append list (list new-moon)))) - (setq index (1+ index)) - (setq new-moon (lunar-phase index))) - list))) - -(defun lunar-phase (index) - "Local date and time of lunar phase INDEX. -Integer below INDEX/4 gives the lunation number, counting from Jan 1, 1900; -remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, -3 last quarter." - (let* ((phase (mod index 4)) - (index (/ index 4.0)) - (time (/ index 1236.85)) - (date (+ (calendar-absolute-from-gregorian '(1 0.5 1900)) - 0.75933 - (* 29.53058868 index) - (* 0.0001178 time time) - (* -0.000000155 time time time) - (* 0.00033 - (solar-sin-degrees (+ 166.56 - (* 132.87 time) - (* -0.009173 time time)))))) - (sun-anomaly (mod - (+ 359.2242 - (* 29.105356 index) - (* -0.0000333 time time) - (* -0.00000347 time time time)) - 360.0)) - (moon-anomaly (mod - (+ 306.0253 - (* 385.81691806 index) - (* 0.0107306 time time) - (* 0.00001236 time time time)) - 360.0)) - (moon-lat (mod - (+ 21.2964 - (* 390.67050646 index) - (* -0.0016528 time time) - (* -0.00000239 time time time)) - 360.0)) - (adjustment - (if (memq phase '(0 2)) - (+ (* (- 0.1734 (* 0.000393 time)) - (solar-sin-degrees sun-anomaly)) - (* 0.0021 (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.4068 (solar-sin-degrees moon-anomaly)) - (* 0.0161 (solar-sin-degrees (* 2 moon-anomaly))) - (* -0.0004 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.0104 (solar-sin-degrees (* 2 moon-lat))) - (* -0.0051 (solar-sin-degrees (+ sun-anomaly moon-anomaly))) - (* -0.0074 (solar-sin-degrees (- sun-anomaly moon-anomaly))) - (* 0.0004 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly))) - (* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly))) - (* -0.0006 (solar-sin-degrees - (+ (* 2 moon-lat) moon-anomaly))) - (* 0.0010 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly))) - (* 0.0005 (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly)))) - (+ (* (- 0.1721 (* 0.0004 time)) - (solar-sin-degrees sun-anomaly)) - (* 0.0021 (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.6280 (solar-sin-degrees moon-anomaly)) - (* 0.0089 (solar-sin-degrees (* 2 moon-anomaly))) - (* -0.0004 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.0079 (solar-sin-degrees (* 2 moon-lat))) - (* -0.0119 (solar-sin-degrees (+ sun-anomaly moon-anomaly))) - (* -0.0047 (solar-sin-degrees (- sun-anomaly moon-anomaly))) - (* 0.0003 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly))) - (* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly))) - (* -0.0006 (solar-sin-degrees (+ (* 2 moon-lat) moon-anomaly))) - (* 0.0021 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly))) - (* 0.0003 (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly))) - (* 0.0004 (solar-sin-degrees - (- sun-anomaly (* 2 moon-anomaly)))) - (* -0.0003 (solar-sin-degrees - (+ (* 2 sun-anomaly) moon-anomaly)))))) - (adj (+ 0.0028 - (* -0.0004 (solar-cosine-degrees - sun-anomaly)) - (* 0.0003 (solar-cosine-degrees - moon-anomaly)))) - (adjustment (cond ((= phase 1) (+ adjustment adj)) - ((= phase 2) (- adjustment adj)) - (t adjustment))) - (date (+ date adjustment)) - (date (+ date (/ (- calendar-time-zone - (solar-ephemeris-correction - (extract-calendar-year - (calendar-gregorian-from-absolute - (truncate date))))) - 60.0 24.0))) - (time (* 24 (- date (truncate date)))) - (date (calendar-gregorian-from-absolute (truncate date))) - (adj (solar-adj-time-for-dst date time))) - (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) - -(defun lunar-phase-name (phase) - "Name of lunar PHASE. -0 = new moon, 1 = first quarter, 2 = full moon, 3 = last quarter." - (cond ((= 0 phase) "New Moon") - ((= 1 phase) "First Quarter Moon") - ((= 2 phase) "Full Moon") - ((= 3 phase) "Last Quarter Moon"))) - -(defun calendar-phases-of-moon () - "Create a buffer with the lunar phases for the current calendar window." - (interactive) - (message "Computing phases of the moon...") - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (set-buffer (get-buffer-create lunar-phases-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line - (if (= y1 y2) - (format "Phases of the Moon from %s to %s, %d%%-" - (calendar-month-name m1) (calendar-month-name m2) y2) - (format "Phases of the Moon from %s, %d to %s, %d%%-" - (calendar-month-name m1) y1 (calendar-month-name m2) y2))) - (erase-buffer) - (insert - (mapconcat - '(lambda (x) - (let ((date (car x)) - (time (car (cdr x))) - (phase (car (cdr (cdr x))))) - (concat (calendar-date-string date) - ": " - (lunar-phase-name phase) - " " - time))) - (lunar-phase-list m1 y1) "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer lunar-phases-buffer) - (message "Computing phases of the moon...done"))) - -;;;###autoload -(defun phases-of-moon (&optional arg) - "Display the quarters of the moon for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." - (interactive "P") - (save-excursion - (let* ((date (if arg - (calendar-read-date t) - (calendar-current-date))) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (calendar-phases-of-moon)))) - -(defun diary-phases-of-moon () - "Moon phases diary entry." - (let* ((index (* 4 - (truncate - (* 12.3685 - (+ (extract-calendar-year date) - ( / (calendar-day-number date) - 366.0) - -1900))))) - (phase (lunar-phase index))) - (while (calendar-date-compare phase (list date)) - (setq index (1+ index)) - (setq phase (lunar-phase index))) - (if (calendar-date-equal (car phase) date) - (concat (lunar-phase-name (car (cdr (cdr phase)))) " " - (car (cdr phase)))))) - -(provide 'lunar) - -;;; lunar.el ends here
--- a/lisp/calendar/solar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,588 +0,0 @@ -;;; solar.el --- calendar functions for solar events. - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: sunrise, sunset, equinox, solstice, calendar, diary, -;; holidays - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el, -;; diary.el, and holiday.el that deal with times of day, sunrise/sunset, and -;; eqinoxes/solstices. - -;; Based on the ``Almanac for Computers 1984,'' prepared by the Nautical -;; Almanac Office, United States Naval Observatory, Washington, 1984 and -;; on ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus, -;; Willmann-Bell, Inc., 1985. -;; -;; WARNINGS: -;; 1. SUNRISE/SUNSET calculations will be accurate only to +/- 2 minutes. -;; Locations should be between +/- 65 degrees of latitude. -;; Dates should be in the latter half of the 20th century. -;; -;; 2. Equinox/solstice times will be accurate only to +/- 15 minutes. - -;; The author would be delighted to have an astronomically more sophisticated -;; person rewrite the code for the solar calculations in this file! - -;; Comments, corrections, and improvements should be sent to -;; Edward M. Reingold Department of Computer Science -;; (217) 333-6733 University of Illinois at Urbana-Champaign -;; reingold@cs.uiuc.edu 1304 West Springfield Avenue -;; Urbana, Illinois 61801 - -;;; Code: - -(if (fboundp 'atan) - (require 'lisp-float-type) - (error "Solar/lunar calculations impossible since floating point is unavailable.")) - -(require 'cal-dst) - -;;;###autoload -(defvar calendar-time-display-form - '(12-hours ":" minutes am-pm - (if time-zone " (") time-zone (if time-zone ")")) - "*The pseudo-pattern that governs the way a time of day is formatted. - -A pseudo-pattern is a list of expressions that can involve the keywords -`12-hours', `24-hours', and `minutes', all numbers in string form, -and `am-pm' and `time-zone', both alphabetic strings. - -For example, the form - - '(24-hours \":\" minutes - (if time-zone \" (\") time-zone (if time-zone \")\")) - -would give military-style times like `21:07 (UTC)'.") - -;;;###autoload -(defvar calendar-latitude nil - "*Latitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + north, - south, such as 40.7 for New York City, or the value -can be a vector [degrees minutes north/south] such as [40 50 north] for New -York City. - -This variable should be set in site-local.el.") - -;;;###autoload -(defvar calendar-longitude nil - "*Longitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + east, - west, such as -73.9 for New York City, or the value -can be a vector [degrees minutes east/west] such as [73 55 west] for New -York City. - -This variable should be set in site-local.el.") - -(defsubst calendar-latitude () - "Convert calendar-latitude to a signed decimal fraction, if needed." - (if (numberp calendar-latitude) - calendar-latitude - (let ((lat (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0)))) - (if (equal (aref calendar-latitude 2) 'north) - lat - (- lat))))) - -(defsubst calendar-longitude () - "Convert calendar-longitude to a signed decimal fraction, if needed." - (if (numberp calendar-longitude) - calendar-longitude - (let ((long (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0)))) - (if (equal (aref calendar-longitude 2) 'east) - long - (- long))))) - -;;;###autoload -(defvar calendar-location-name - '(let ((float-output-format "%.1f")) - (format "%s%s, %s%s" - (if (numberp calendar-latitude) - (abs calendar-latitude) - (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0))) - (if (numberp calendar-latitude) - (if (> calendar-latitude 0) "N" "S") - (if (equal (aref calendar-latitude 2) 'north) "N" "S")) - (if (numberp calendar-longitude) - (abs calendar-longitude) - (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0))) - (if (numberp calendar-longitude) - (if (> calendar-longitude 0) "E" "W") - (if (equal (aref calendar-latitude 2) 'east) "E" "W")))) - "*Expression evaluating to name of `calendar-longitude', calendar-latitude'. -For example, \"New York City\". Default value is just the latitude, longitude -pair. - -This variable should be set in site-local.el.") - -(defvar solar-n-hemi-seasons - '("Vernal Equinox" "Summer Solstice" "Autumnal Equinox" "Winter Solstice") - "List of season changes for the northern hemisphere.") - -(defvar solar-s-hemi-seasons - '("Autumnal Equinox" "Winter Solstice" "Vernal Equinox" "Summer Solstice") - "List of season changes for the southern hemisphere.") - -(defun solar-setup () - "Prompt user for latitude, longitude, and time zone." - (beep) - (if (not calendar-longitude) - (setq calendar-longitude - (solar-get-number - "Enter longitude (decimal fraction; + east, - west): "))) - (if (not calendar-latitude) - (setq calendar-latitude - (solar-get-number - "Enter latitude (decimal fraction; + north, - south): "))) - (if (not calendar-time-zone) - (setq calendar-time-zone - (solar-get-number - "Enter difference from Coordinated Universal Time (in minutes): ")))) - -(defun solar-get-number (prompt) - "Return a number from the minibuffer, prompting with PROMPT. -Returns nil if nothing was entered." - (let ((x (read-string prompt ""))) - (if (not (string-equal x "")) - (string-to-int x)))) - -(defsubst solar-sin-degrees (x) - (sin (degrees-to-radians x))) - -(defsubst solar-cosine-degrees (x) - (cos (degrees-to-radians x))) - -(defun solar-tangent-degrees (x) - (tan (degrees-to-radians x))) - -(defun solar-xy-to-quadrant (x y) - "Determines the quadrant of the point X, Y." - (if (> x 0) - (if (> y 0) 1 4) - (if (> y 0) 2 3))) - -(defun solar-degrees-to-quadrant (angle) - "Determines the quadrant of ANGLE." - (1+ (floor (mod angle 360) 90))) - -(defun solar-arctan (x quad) - "Arctangent of X in quadrant QUAD." - (let ((deg (radians-to-degrees (atan x)))) - (cond ((equal quad 2) (+ deg 180)) - ((equal quad 3) (+ deg 180)) - ((equal quad 4) (+ deg 360)) - (t deg)))) - -(defun solar-arccos (x) - (let ((y (sqrt (- 1 (* x x))))) - (solar-arctan (/ y x) (solar-xy-to-quadrant x y)))) - -(defun solar-arcsin (y) - (let ((x (sqrt (- 1 (* y y))))) - (solar-arctan (/ y x) (solar-xy-to-quadrant x y)))) - -(defconst solar-earth-inclination 23.441884 - "Inclination of earth's equator to its solar orbit in degrees.") - -(defconst solar-cos-inclination (solar-cosine-degrees solar-earth-inclination) - "Cosine of earth's inclination.") - -(defconst solar-sin-inclination (solar-sin-degrees solar-earth-inclination) - "Sine of earth's inclination.") - -(defconst solar-earth-orbit-eccentricity 0.016718 - "Eccentricity of orbit of the earth around the sun.") - -(defsubst solar-degrees-to-hours (deg) - (/ deg 15.0)) - -(defsubst solar-hours-to-days (hour) - (/ hour 24.0)) - -(defun solar-longitude-of-sun (day) - "Longitude of the sun at DAY in the year." - (let ((mean-anomaly (- (* 0.9856 day) 3.289))) - (mod (+ mean-anomaly - (* 1.916 (solar-sin-degrees mean-anomaly)) - (* 0.020 (solar-sin-degrees (* 2 mean-anomaly))) - 282.634) - 360))) - -(defun solar-right-ascension (longitude) - "Right ascension of the sun, given its LONGITUDE." - (solar-degrees-to-hours - (solar-arctan - (* solar-cos-inclination (solar-tangent-degrees longitude)) - (solar-degrees-to-quadrant longitude)))) - -(defun solar-declination (longitude) - "Declination of the sun, given its LONGITUDE." - (solar-arcsin - (* solar-sin-inclination - (solar-sin-degrees longitude)))) - -(defun solar-sunrise (date) - "Calculates the *standard* time of sunrise for Gregorian DATE. -Calculation is for location given by `calendar-latitude' and -`calendar-longitude'. - -Returns a decimal fraction of hours. Returns nil if the sun does not rise at -that location on that day." - (let* ((day-of-year (calendar-day-number date)) - (approx-sunrise - (+ day-of-year - (solar-hours-to-days - (- 6 (solar-degrees-to-hours (calendar-longitude)))))) - (solar-longitude-of-sun-at-sunrise - (solar-longitude-of-sun approx-sunrise)) - (solar-right-ascension-at-sunrise - (solar-right-ascension solar-longitude-of-sun-at-sunrise)) - (solar-declination-at-sunrise - (solar-declination solar-longitude-of-sun-at-sunrise)) - (cos-local-sunrise - (/ (- (solar-cosine-degrees (+ 90 (/ 50.0 60.0))) - (* (solar-sin-degrees solar-declination-at-sunrise) - (solar-sin-degrees (calendar-latitude)))) - (* (solar-cosine-degrees solar-declination-at-sunrise) - (solar-cosine-degrees (calendar-latitude)))))) - (if (<= (abs cos-local-sunrise) 1);; otherwise, no sunrise that day - (let* ((local-sunrise (solar-degrees-to-hours - (- 360 (solar-arccos cos-local-sunrise)))) - (local-mean-sunrise - (mod (- (+ local-sunrise solar-right-ascension-at-sunrise) - (+ (* 0.065710 approx-sunrise) - 6.622)) - 24))) - (+ (- local-mean-sunrise (solar-degrees-to-hours (calendar-longitude))) - (/ calendar-time-zone 60.0)))))) - -(defun solar-sunset (date) - "Calculates the *standard* time of sunset for Gregorian DATE. -Calculation is for location given by `calendar-latitude' and -`calendar-longitude'. - -Returns a decimal fractions of hours. Returns nil if the sun does not set at -that location on that day." - (let* ((day-of-year (calendar-day-number date)) - (approx-sunset - (+ day-of-year - (solar-hours-to-days - (- 18 (solar-degrees-to-hours (calendar-longitude)))))) - (solar-longitude-of-sun-at-sunset - (solar-longitude-of-sun approx-sunset)) - (solar-right-ascension-at-sunset - (solar-right-ascension solar-longitude-of-sun-at-sunset)) - (solar-declination-at-sunset - (solar-declination solar-longitude-of-sun-at-sunset)) - (cos-local-sunset - (/ (- (solar-cosine-degrees (+ 90 (/ 50.0 60.0))) - (* (solar-sin-degrees solar-declination-at-sunset) - (solar-sin-degrees (calendar-latitude)))) - (* (solar-cosine-degrees solar-declination-at-sunset) - (solar-cosine-degrees (calendar-latitude)))))) - (if (<= (abs cos-local-sunset) 1);; otherwise, no sunset that day - (let* ((local-sunset (solar-degrees-to-hours - (solar-arccos cos-local-sunset))) - (local-mean-sunset - (mod (- (+ local-sunset solar-right-ascension-at-sunset) - (+ (* 0.065710 approx-sunset) 6.622)) - 24))) - (+ (- local-mean-sunset (solar-degrees-to-hours (calendar-longitude))) - (/ calendar-time-zone 60.0)))))) - -(defun solar-adj-time-for-dst (date time &optional style) - "Adjust decimal fraction standard TIME on DATE to account for dst. -Returns a list (date adj-time zone) where `date' and `time' are the values -adjusted for `zone'; here `date' is a list (month day year), `time' is a -decimal fraction time, and `zone' is a string. - -Optional parameter STYLE forces the result time to be standard time when its -value is 'standard and daylight savings time (if available) when its value is -'daylight. - -Conversion to daylight savings time is done according to -`calendar-daylight-savings-starts', `calendar-daylight-savings-ends', -`calendar-daylight-savings-starts-time', -`calendar-daylight-savings-ends-time', and -`calendar-daylight-savings-offset'." - - (let* ((year (extract-calendar-year date)) - (rounded-abs-date (+ (calendar-absolute-from-gregorian date) - (/ (round (* 60 time)) 60.0 24.0))) - (dst-starts (and calendar-daylight-savings-starts - (+ (calendar-absolute-from-gregorian - (eval calendar-daylight-savings-starts)) - (/ calendar-daylight-savings-starts-time - 60.0 24.0)))) - (dst-ends (and calendar-daylight-savings-ends - (+ (calendar-absolute-from-gregorian - (eval calendar-daylight-savings-ends)) - (/ (- calendar-daylight-savings-ends-time - calendar-daylight-time-offset) - 60.0 24.0)))) - (dst (and (not (eq style 'standard)) - (or (eq style 'daylight) - (and dst-starts dst-ends - (or (and (< dst-starts dst-ends);; northern hemi. - (<= dst-starts rounded-abs-date) - (< rounded-abs-date dst-ends)) - (and (< dst-ends dst-starts);; southern hemi. - (or (< rounded-abs-date dst-ends) - (<= dst-starts rounded-abs-date))))) - (and dst-starts (not dst-ends) - (<= dst-starts rounded-abs-date)) - (and dst-ends (not dst-starts) - (< rounded-abs-date dst-ends))))) - (time-zone (if dst - calendar-daylight-time-zone-name - calendar-standard-time-zone-name)) - (time (+ rounded-abs-date - (if dst (/ calendar-daylight-time-offset 24.0 60.0) 0)))) - (list (calendar-gregorian-from-absolute (truncate time)) - (* 24.0 (- time (truncate time))) - time-zone))) - -(defun solar-time-string (time time-zone) - "Printable form for decimal fraction TIME on DATE. -Format used is given by `calendar-time-display-form'." - (let* ((time (round (* 60 time))) - (24-hours (/ time 60)) - (minutes (format "%02d" (% time 60))) - (12-hours (format "%d" (1+ (% (+ 24-hours 11) 12)))) - (am-pm (if (>= 24-hours 12) "pm" "am")) - (24-hours (format "%02d" 24-hours))) - (mapconcat 'eval calendar-time-display-form ""))) - -(defun solar-sunrise-sunset (date) - "String giving local times of sunrise and sunset on Gregorian DATE." - (let* ((rise (solar-sunrise date)) - (adj-rise (if rise (solar-adj-time-for-dst date rise))) - (set (solar-sunset date)) - (adj-set (if set (solar-adj-time-for-dst date set)))) - (format "%s, %s at %s" - (if (and rise (calendar-date-equal date (car adj-rise))) - (concat "Sunrise " (apply 'solar-time-string (cdr adj-rise))) - "No sunrise") - (if (and set (calendar-date-equal date (car adj-set))) - (concat "sunset " (apply 'solar-time-string (cdr adj-set))) - "no sunset") - (eval calendar-location-name)))) - -(defun solar-apparent-longitude-of-sun (date) - "Apparent longitude of the sun on Gregorian DATE." - (let* ((time (/ (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian '(1 0.5 1900))) - 36525)) - (l (+ 279.69668 - (* 36000.76892 time) - (* 0.0003025 time time))) - (m (+ 358.47583 - (* 35999.04975 time) - (* -0.000150 time time) - (* -0.0000033 time time time))) - (c (+ (* (+ 1.919460 - (* -0.004789 time) - (* -0.000014 time time)) - (solar-sin-degrees m)) - (* (+ 0.020094 - (* -0.000100 time)) - (solar-sin-degrees (* 2 m))) - (* 0.000293 - (solar-sin-degrees (* 3 m))))) - (L (+ l c)) - (omega (+ 259.18 - (* -1934.142 time))) - (app (+ L - -0.00569 - (* -0.00479 - (solar-sin-degrees omega))))) - app)) - -(defun solar-ephemeris-correction (year) - "Difference in minutes between Ephemeris time and UTC in YEAR. -Value is only an approximation." - (let ((T (/ (- year 1900) 100.0))) - (+ 0.41 (* 1.2053 T) (* 0.4992 T T)))) - -(defun solar-equinoxes/solstices (k year) - "Date of equinox/solstice K for YEAR. K=0, spring equinox; K=1, summer -solstice; K=2, fall equinox; K=3, winter solstice. Accurate to within -several minutes." - (let ((date (list (+ 3 (* k 3)) 21 year)) - app - (correction 1000)) - (while (> correction 0.00001) - (setq app (mod (solar-apparent-longitude-of-sun date) 360)) - (setq correction (* 58 (solar-sin-degrees (- (* k 90) app)))) - (setq date (list (extract-calendar-month date) - (+ (extract-calendar-day date) correction) - year))) - (list (extract-calendar-month date) - (+ (extract-calendar-day date) (/ calendar-time-zone 60.0 24.0) - (- (/ (solar-ephemeris-correction year) 60.0 24.0))) - year))) - -;;;###autoload -(defun sunrise-sunset (&optional arg) - "Local time of sunrise and sunset for today. Accurate to +/- 2 minutes. -If called with an optional prefix argument, prompt for date. - -If called with an optional double prefix argument, prompt for longitude, -latitude, time zone, and date, and always use standard time. - -This function is suitable for execution in a .emacs file." - (interactive "p") - (or arg (setq arg 1)) - (if (and (< arg 16) - (not (and calendar-latitude calendar-longitude calendar-time-zone))) - (solar-setup)) - (let* ((calendar-longitude - (if (< arg 16) calendar-longitude - (solar-get-number - "Enter longitude (decimal fraction; + east, - west): "))) - (calendar-latitude - (if (< arg 16) calendar-latitude - (solar-get-number - "Enter latitude (decimal fraction; + north, - south): "))) - (calendar-time-zone - (if (< arg 16) calendar-time-zone - (solar-get-number - "Enter difference from Coordinated Universal Time (in minutes): "))) - (calendar-location-name - (if (< arg 16) calendar-location-name - (let ((float-output-format "%.1f")) - (format "%s%s, %s%s" - (if (numberp calendar-latitude) - (abs calendar-latitude) - (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0))) - (if (numberp calendar-latitude) - (if (> calendar-latitude 0) "N" "S") - (if (equal (aref calendar-latitude 2) 'north) "N" "S")) - (if (numberp calendar-longitude) - (abs calendar-longitude) - (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0))) - (if (numberp calendar-longitude) - (if (> calendar-longitude 0) "E" "W") - (if (equal (aref calendar-latitude 2) 'east) - "E" "W")))))) - (calendar-standard-time-zone-name - (if (< arg 16) calendar-standard-time-zone-name - (cond ((= calendar-time-zone 0) "UTC") - ((< calendar-time-zone 0) - (format "UTC%dmin" calendar-time-zone)) - (t (format "UTC+%dmin" calendar-time-zone))))) - (calendar-daylight-savings-starts - (if (< arg 16) calendar-daylight-savings-starts)) - (calendar-daylight-savings-ends - (if (< arg 16) calendar-daylight-savings-ends)) - (date (if (< arg 4) (calendar-current-date) (calendar-read-date))) - (date-string (calendar-date-string date t)) - (time-string (solar-sunrise-sunset date)) - (msg (format "%s: %s" date-string time-string)) - (one-window (one-window-p t))) - (if (<= (length msg) (frame-width)) - (message msg) - (with-output-to-temp-buffer "*temp*" - (princ (concat date-string "\n" time-string))) - (message (substitute-command-keys - (if one-window - (if pop-up-windows - "Type \\[delete-other-windows] to remove temp window." - "Type \\[switch-to-buffer] RET to remove temp window.") - "Type \\[switch-to-buffer-other-window] RET to restore old contents of temp window.")))))) - -(defun calendar-sunrise-sunset () - "Local time of sunrise and sunset for date under cursor. -Accurate to +/- 2 minutes." - (interactive) - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (let ((date (calendar-cursor-to-date t))) - (message "%s: %s" - (calendar-date-string date t t) - (solar-sunrise-sunset date)))) - -(defun diary-sunrise-sunset () - "Local time of sunrise and sunset as a diary entry. -Accurate to +/- 2 minutes." - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (solar-sunrise-sunset date)) - -(defun diary-sabbath-candles () - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (if (= (% (calendar-absolute-from-gregorian date) 7) 5);; Friday - (let* ((sunset (solar-sunset date)) - (light (if sunset - (solar-adj-time-for-dst - date - (- sunset (/ 18.0 60.0)))))) - (if (and light (calendar-date-equal date (car light))) - (format "%s Sabbath candle lighting" - (apply 'solar-time-string (cdr light))))))) - -;;;###autoload -(defun solar-equinoxes-solstices () - "Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (cond ((= 1 (% m 3)) -1) - ((= 2 (% m 3)) 1) - (t 0))) - (let* ((calendar-standard-time-zone-name - (if calendar-time-zone calendar-standard-time-zone-name "UTC")) - (calendar-daylight-savings-starts - (if calendar-time-zone calendar-daylight-savings-starts)) - (calendar-daylight-savings-ends - (if calendar-time-zone calendar-daylight-savings-ends)) - (calendar-time-zone (if calendar-time-zone calendar-time-zone 0)) - (k (1- (/ m 3))) - (date (solar-equinoxes/solstices k y)) - (s-hemi (and calendar-latitude (< (calendar-latitude) 0))) - (day (extract-calendar-day date)) - (adj (solar-adj-time-for-dst - (list (extract-calendar-month date) - (truncate day) - (extract-calendar-year date)) - (* 24 (- day (truncate day)))))) - (list (list (car adj) - (format "%s %s" - (nth k (if s-hemi solar-s-hemi-seasons - solar-n-hemi-seasons)) - (apply 'solar-time-string (cdr adj)))))))) - -(provide 'solar) - -;;; solar.el ends here
--- a/lisp/cc-mode/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/cc-mode/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,9 +1,8 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:06 1997 ;;; Code: -(custom-put 'c 'custom-loads '("cc-vars")) +(custom-add-loads 'c '("cc-vars")) ;;; custom-load.el ends here
--- a/lisp/cl/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/cl/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,5 +1,7 @@ ;;; DO NOT MODIFY THIS FILE (if (featurep 'cl-autoloads) (error "Already loaded")) + +(provide 'cl-autoloads) ;;;### (autoloads (compiler-macroexpand define-compiler-macro ignore-errors assert check-type typep deftype cl-struct-setf-expander defstruct define-modify-macro callf2 callf letf* letf rotatef shiftf remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method declare the locally multiple-value-setq multiple-value-bind lexical-let* lexical-let symbol-macrolet macrolet labels flet progv psetq do-all-symbols do-symbols dotimes dolist do* do loop return-from return block etypecase typecase ecase case load-time-value eval-when destructuring-bind function* defmacro* defun* gentemp gensym cl-compile-time-init) "cl-macs" "cl/cl-macs.el") @@ -327,5 +329,3 @@ (autoload 'compiler-macroexpand "cl-macs" nil nil nil) ;;;*** - -(provide 'cl-autoloads)
--- a/lisp/cl/cl-macs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/cl/cl-macs.el Mon Aug 13 10:03:52 2007 +0200 @@ -1599,7 +1599,7 @@ (defsetf elt (seq n) (store) (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) (list 'aset seq n store))) -(defsetf get put) +(defsetf get (x y &optional d) (store) (list 'put x y store)) (defsetf get* (x y &optional d) (store) (list 'put x y store)) (defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) @@ -1643,8 +1643,8 @@ (defsetf extent-data set-extent-data) ; obsolete (defsetf extent-face set-extent-face) (defsetf extent-priority set-extent-priority) -;; XEmacs change -(defsetf extent-property set-extent-property) +(defsetf extent-property (x y &optional d) (arg) + (list 'set-extent-property x y arg)) (defsetf extent-end-position (ext) (store) (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) store) store))
--- a/lisp/comint/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -47,7 +47,7 @@ ;;;*** -;;;### (autoloads (gdb) "gdb" "comint/gdb.el") +;;;### (autoloads (gdb-with-core gdb) "gdb" "comint/gdb.el") (defvar gdb-command-name "gdb" "\ Pathname for executing gdb.") @@ -58,6 +58,9 @@ and source-file directory for GDB. If you wish to change this, use the GDB commands `cd DIR' and `directory'." t nil) +(autoload 'gdb-with-core "gdb" "\ +Debug a program using a corefile." t nil) + ;;;*** ;;;### (autoloads (gdbsrc) "gdbsrc" "comint/gdbsrc.el")
--- a/lisp/comint/comint.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/comint.el Mon Aug 13 10:03:52 2007 +0200 @@ -228,7 +228,8 @@ See also `comint-read-input-ring' and `comint-write-input-ring'. This variable is buffer-local, and is a good thing to set in mode hooks." - :type 'boolean + :type '(choice (const :tag "None" nil) + (file)) :group 'comint) (defcustom comint-scroll-to-bottom-on-input nil @@ -262,14 +263,21 @@ (const others)) :group 'comint) -;; XEmacs - Default this to nil: this is just horrible -(defcustom comint-scroll-show-maximum-output nil +(defcustom comint-scroll-show-maximum-output t "*Controls how interpreter output causes window to scroll. If non-nil, then show the maximum output when the window is scrolled. +You may set this to an integer number of lines to keep shown, or a +floating point percentage of the window size to keep filled. +A negative number expresses a distance from the bottom, as when using +a prefix argument with `recenter' (bound to `\\[recenter]'). + See variable `comint-scroll-to-bottom-on-output' and function `comint-postoutput-scroll-to-bottom'. This variable is buffer-local." - :type 'boolean + :type '(choice (const :tag "Off" nil) + (const :tag "On" t) + (integer :tag "Number of lines" 20) + (number :tag "Decimal Percent of window" .85)) :group 'comint) (defcustom comint-buffer-maximum-size 1024 @@ -1584,14 +1592,15 @@ (set-window-point window (point-max)) (recenter ;; XEmacs - lemacs addition -;; (cond ((integerp comint-scroll-show-maximum-output) -;; comint-scroll-show-maximum-output) -;; ((floatp comint-scroll-show-maximum-output) -;; (floor (* (window-height window) -;; comint-scroll-show-maximum-output) -;; 1)) -;; (t -;; -1)) + (cond ((integerp comint-scroll-show-maximum-output) + comint-scroll-show-maximum-output) + ((floatp comint-scroll-show-maximum-output) + (floor (* (window-height window) + comint-scroll-show-maximum-output) + 1)) + (t + -1)) + window ))) )))) nil t))))
--- a/lisp/comint/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,20 +1,19 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Oct 4 18:11:23 1997 ;;; Code: -(custom-put 'ssh 'custom-loads '("ssh")) -(custom-put 'telnet 'custom-loads '("telnet")) -(custom-put 'shell 'custom-loads '("shell")) -(custom-put 'comint-completion 'custom-loads '("comint")) -(custom-put 'comint 'custom-loads '("comint-xemacs" "comint" "telnet")) -(custom-put 'rlogin 'custom-loads '("rlogin")) -(custom-put 'shell-faces 'custom-loads '("shell")) -(custom-put 'shell-directories 'custom-loads '("shell")) -(custom-put 'comint-source 'custom-loads '("comint")) -(custom-put 'processes 'custom-loads '("background" "comint" "rlogin" "shell" "ssh")) -(custom-put 'background 'custom-loads '("background")) -(custom-put 'unix 'custom-loads '("rlogin" "shell" "ssh")) +(custom-add-loads 'ssh '("ssh")) +(custom-add-loads 'telnet '("telnet")) +(custom-add-loads 'shell '("shell")) +(custom-add-loads 'comint-completion '("comint")) +(custom-add-loads 'comint '("comint-xemacs" "comint" "telnet")) +(custom-add-loads 'rlogin '("rlogin")) +(custom-add-loads 'shell-faces '("shell")) +(custom-add-loads 'shell-directories '("shell")) +(custom-add-loads 'comint-source '("comint")) +(custom-add-loads 'processes '("background" "comint" "rlogin" "shell" "ssh")) +(custom-add-loads 'background '("background")) +(custom-add-loads 'unix '("rlogin" "shell" "ssh")) ;;; custom-load.el ends here
--- a/lisp/comint/gdb.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/comint/gdb.el Mon Aug 13 10:03:52 2007 +0200 @@ -331,7 +331,7 @@ (gdb-mode) (gdb-set-buffer))) -;;;####autoload +;;;###autoload (defun gdb-with-core (file corefile) "Debug a program using a corefile." (interactive "fProgram to debug: \nfCore file to use: ")
--- a/lisp/custom/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -138,7 +138,7 @@ (autoload 'customize-menu-create "cus-edit" "\ Return a customize menu for customization group SYMBOL. -If optional NAME is given, use that as the name of the menu. +If optional NAME is given, use that as the name of the menu. Otherwise the menu will be named `Customize'. The format is suitable for use with `easy-menu-define'." nil nil) @@ -186,7 +186,7 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil." nil nil) (autoload 'widget-create "wid-edit" "\ -Create widget of TYPE. +Create widget of TYPE. The optional ARGS are additional keyword arguments." nil nil) (autoload 'widget-delete "wid-edit" "\
--- a/lisp/custom/cus-dep.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-dep.el Mon Aug 13 10:03:52 2007 +0200 @@ -33,7 +33,7 @@ ;; This file generates the custom-load files, loaded by cus-load.el. ;; The only entry point is `Custom-make-dependencies'. -;; It works so that it scans all the `.el' files in a directory, and +;; It works by scanning all the `.el' files in a directory, and ;; evaluates any `defcustom', `defgroup', or `defface' expression that ;; it finds. The symbol changed by this expression is stored to a ;; hash table as the hash key, file name being the value. @@ -50,14 +50,20 @@ ;; custom-loads around, and have them loaded by `cus-load.el' (as ;; invoked by `cus-edit.el'). -;; A trivial, but crucial optimization is that if cusload-file exists, +;; A trivial, but useful optimization is that if cusload-file exists, ;; and no .el files in the directory are newer than cusload-file, it ;; will not be generated. This means that the directories where ;; nothing has changed will be skipped. -;; The `custom-put' function, generated by this file, is a specialized -;; form of `put' that deals with lists, eliminating the duplicates. -;; For instance: +;; The `custom-put' function, used by files generated by +;; `Custom-make-dependencies', is a specialized function that updates +;; a property (which must be a list of strings) with a new list of +;; strings, eliminating the duplicates. As it also adds an +;; appropriate entry to a custom hash-table, *do not* use it outside +;; of custom. Its inner workings can change anytime, without prior +;; notice. `custom-put' is defined in `cus-load.el'. + +;; Example: ;; (custom-put 'foo 'custom-loads '("bar" "baz")) ;; (get 'foo 'custom-loads) @@ -83,6 +89,10 @@ ;; cus-start.el, too. (defconst cusload-base-file "custom-load.el") +;; Be very careful when changing this function. It looks easy to +;; understand, but is in fact very easy to break. Be sure to read and +;; understand the commentary above! + ;;;###autoload (defun Custom-make-dependencies (&optional subdirs) "Extract custom dependencies from .el files in SUBDIRS. @@ -106,7 +116,7 @@ (princ (format "Processing %s\n" dir)) (let ((cusload-file (expand-file-name cusload-base-file dir)) (files (directory-files dir t "\\`[^=].*\\.el\\'"))) - ;; A trivial optimization: if no files in the directory is + ;; A trivial optimization: if no file in the directory is ;; newer than custom-load.el, no need to do anything! (if (and (file-exists-p cusload-file) (dolist (file files t) @@ -121,15 +131,17 @@ (goto-char (point-min)) (let ((name (file-name-sans-extension (file-name-nondirectory file)))) - (condition-case nil - (while (re-search-forward - "^(defcustom\\|^(defface\\|^(defgroup" - nil t) - (beginning-of-line) - (let ((expr (read (current-buffer)))) - (eval expr) - (setf (gethash (nth 1 expr) hash) name))) - (error nil))))) + ;; Search for defcustom/defface/defgroup + ;; expressions, and evaluate them. + (ignore-errors + (while (re-search-forward + "^(defcustom\\|^(defface\\|^(defgroup" + nil t) + (beginning-of-line) + (let ((expr (read (current-buffer)))) + (eval expr) + ;; Hash the file of the affected symbol. + (setf (gethash (nth 1 expr) hash) name))))))) (cond ((zerop (hash-table-count hash)) (princ "(No customization dependencies") @@ -142,8 +154,7 @@ (with-temp-file cusload-file (insert ";;; " cusload-base-file " --- automatically extracted custom dependencies\n" - "\n;; Created by " (user-full-name) " on " - (current-time-string) "\n\n;;; Code:\n\n") + "\n\n;;; Code:\n\n") (mapatoms (lambda (sym) (let ((members (get sym 'custom-group)) @@ -157,8 +168,8 @@ (member where found)) (if found (insert " ") - (insert "(custom-put '" (symbol-name sym) - " 'custom-loads '(")) + (insert "(custom-add-loads '" + (symbol-name sym) " '(")) (prin1 where (current-buffer)) (push where found))) (when found
--- a/lisp/custom/cus-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-edit.el Mon Aug 13 10:03:52 2007 +0200 @@ -28,7 +28,7 @@ ;;; Commentary: ;; ;; This file implements the code to create and edit customize buffers. -;; +;; ;; See `custom.el'. ;; No commands should have names starting with `custom-' because @@ -235,7 +235,7 @@ (defgroup customize '((widgets custom-group)) "Customization of the Customization support." :link '(custom-manual "(custom)Top") - :link '(url-link :tag "Development Page" + :link '(url-link :tag "Development Page" "http://www.dina.kvl.dk/~abraham/custom/") :prefix "custom-" :group 'help) @@ -347,30 +347,22 @@ (defun custom-quote (sexp) "Quote SEXP iff it is not self quoting." (if (or (memq sexp '(t nil)) - (and (symbolp sexp) - (eq (aref (symbol-name sexp) 0) ?:)) - (and (listp sexp) - (memq (car sexp) '(lambda))) + (keywordp sexp) + (eq (car-safe sexp) 'lambda) (stringp sexp) (numberp sexp) - (and (fboundp 'characterp) - (characterp sexp))) + (characterp sexp)) sexp (list 'quote sexp))) (defun custom-split-regexp-maybe (regexp) "If REGEXP is a string, split it to a list at `\\|'. -You can get the original back with from the result with: +You can get the original back with from the result with: (mapconcat 'identity result \"\\|\") IF REGEXP is not a string, return it unchanged." (if (stringp regexp) - (let ((start 0) - all) - (while (string-match "\\\\|" regexp start) - (setq all (cons (substring regexp start (match-beginning 0)) all) - start (match-end 0))) - (nreverse (cons (substring regexp start) all))) + (split-string regexp "\\\\|") regexp)) (defun custom-variable-prompt () @@ -380,9 +372,9 @@ (let ((v (variable-at-point)) (enable-recursive-minibuffers t) val) - (setq val (completing-read + (setq val (completing-read (if (symbolp v) - (format "Customize option: (default %s) " v) + (format "Customize variable: (default %s) " v) "Customize variable: ") obarray (lambda (symbol) (and (boundp symbol) @@ -409,7 +401,7 @@ WIDGET is the widget to apply the filter entries of MENU on." (let ((result nil) current name action filter) - (while menu + (while menu (setq current (car menu) name (nth 0 current) action (nth 1 current) @@ -459,13 +451,13 @@ (while prefixes (setq prefix (car prefixes)) (if (search-forward prefix (+ (point) (length prefix)) t) - (progn + (progn (setq prefixes nil) (delete-region (point-min) (point))) (setq prefixes (cdr prefixes)))))) (subst-char-in-region (point-min) (point-max) ?- ?\ t) (capitalize-region (point-min) (point-max)) - (unless no-suffix + (unless no-suffix (goto-char (point-max)) (insert "...")) (buffer-string))))) @@ -491,7 +483,7 @@ (defcustom custom-guess-name-alist '(("-p\\'" boolean) - ("-hook\\'" hook) + ("-hooks?\\'" hook) ("-face\\'" face) ("-file\\'" file) ("-function\\'" function) @@ -500,10 +492,10 @@ ("-alist\\'" (repeat (cons sexp sexp)))) "Alist of (MATCH TYPE). -MATCH should be a regexp matching the name of a symbol, and TYPE should +MATCH should be a regexp matching the name of a symbol, and TYPE should be a widget suitable for editing the value of that symbol. The TYPE of the first entry where MATCH matches the name of the symbol will be -used. +used. This is used for guessing the type of variables not declared with customize." @@ -526,7 +518,7 @@ (defun custom-guess-type (symbol) "Guess a widget suitable for editing the value of SYMBOL. -This is done by matching SYMBOL with `custom-guess-name-alist' and +This is done by matching SYMBOL with `custom-guess-name-alist' and if that fails, the doc string with `custom-guess-doc-alist'." (let ((name (symbol-name symbol)) (names custom-guess-name-alist) @@ -540,7 +532,7 @@ (unless found (let ((doc (documentation-property symbol 'variable-documentation)) (docs custom-guess-doc-alist)) - (when doc + (when doc (while docs (setq current (car docs) docs (cdr docs)) @@ -651,7 +643,7 @@ children)) (custom-save-all)) -(defvar custom-reset-menu +(defvar custom-reset-menu '(("Current" . Custom-reset-current) ("Saved" . Custom-reset-saved) ("Standard Settings" . Custom-reset-standard)) @@ -741,10 +733,10 @@ it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value." +`:prompt-value' property of that widget will be used for reading the value." (interactive (custom-prompt-variable "Set variable: " "Set %s to value: ")) - + (set var val)) ;;;###autoload @@ -761,7 +753,7 @@ it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " +`:prompt-value' property of that widget will be used for reading the value. " (interactive (custom-prompt-variable "Set variable: " "Set customized value for %s to: ")) (funcall (or (get var 'custom-set) 'set-default) var val) @@ -780,7 +772,7 @@ it were the arg to `interactive' (which see) to interactively read the value. If VARIABLE has a `custom-type' property, it must be a widget and the -`:prompt-value' property of that widget will be used for reading the value. " +`:prompt-value' property of that widget will be used for reading the value. " (interactive (custom-prompt-variable "Set and ave variable: " "Set and save value for %s as: ")) (funcall (or (get var 'custom-set) 'set-default) var val) @@ -853,7 +845,7 @@ (defun customize-face (&optional symbol) "Customize SYMBOL, which should be a face name or nil. If SYMBOL is nil, customize all faces." - (interactive (list (completing-read "Customize face: (default all) " + (interactive (list (completing-read "Customize face: (default all) " obarray 'find-face))) (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) (custom-buffer-create (custom-sort-items @@ -873,7 +865,7 @@ ;;;###autoload (defun customize-face-other-window (&optional symbol) "Show customization buffer for FACE in other window." - (interactive (list (completing-read "Customize face: " + (interactive (list (completing-read "Customize face: " obarray 'find-face))) (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) () @@ -881,7 +873,7 @@ (setq symbol (intern symbol))) (unless (symbolp symbol) (error "Should be a symbol %S" symbol)) - (custom-buffer-create-other-window + (custom-buffer-create-other-window (list (list symbol 'custom-face)) (format "*Customize Face: %s*" (custom-unlispify-tag-name symbol))))) @@ -1014,7 +1006,7 @@ (custom-buffer-create-internal options description) (select-window window))) -(defcustom custom-reset-button-menu nil +(defcustom custom-reset-button-menu t "If non-nil, only show a single reset button in customize buffers. This button will have a menu with all three reset operations." :type 'boolean @@ -1031,7 +1023,7 @@ (widget-insert ".\n\ Type RET or click button2 on an active field to invoke its action. Invoke ") - (widget-create 'info-link + (widget-create 'info-link :tag "Help" :help-echo "Read the online help" "(XEmacs)Easy Customization") @@ -1040,6 +1032,7 @@ (widget-insert "Operate on everything in this buffer:\n ") (widget-create 'push-button :tag "Set" + :tag-glyph '("set-up" "set-down") :help-echo "\ Make your editing in this buffer take effect for this session" :action (lambda (widget &optional event) @@ -1047,6 +1040,7 @@ (widget-insert " ") (widget-create 'push-button :tag "Save" + :tag-glyph '("save-up" "save-down") :help-echo "\ Make your editing in this buffer take effect for future Emacs sessions" :action (lambda (widget &optional event) @@ -1056,6 +1050,7 @@ (widget-insert " ") (widget-create 'push-button :tag "Reset" + :tag-glyph '("reset-up" "reset-down") :help-echo "Show a menu with reset operations" :mouse-down-action (lambda (&rest junk) t) :action (lambda (widget &optional event) @@ -1081,12 +1076,13 @@ (widget-insert " ") (widget-create 'push-button :tag "Done" + :tag-glyph '("done-up" "done-down") :help-echo "Bury the buffer" :action (lambda (widget &optional event) (bury-buffer))) (widget-insert "\n\n") (message "Creating customization items...") - (setq custom-options + (setq custom-options (if (= (length options) 1) (mapcar (lambda (entry) (widget-create (nth 1 entry) @@ -1139,31 +1135,31 @@ (switch-to-buffer (get-buffer-create name))) (custom-mode) (widget-insert "\ -Square brackets show active fields; type RET or click mouse-2 +Square brackets show active fields; type RET or click button2 on an active field to invoke its action. Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n") (if custom-browse-only-groups (widget-insert "\ Invoke the [Group] button below to edit that item in another window.\n\n") - (widget-insert "Invoke the ") - (widget-create 'item + (widget-insert "Invoke the ") + (widget-create 'item :format "%t" :tag "[Group]" :tag-glyph "folder") (widget-insert ", ") - (widget-create 'item + (widget-create 'item :format "%t" :tag "[Face]" :tag-glyph "face") (widget-insert ", and ") - (widget-create 'item + (widget-create 'item :format "%t" :tag "[Option]" :tag-glyph "option") (widget-insert " buttons below to edit that item in another window.\n\n")) (let ((custom-buffer-style 'tree)) - (widget-create 'custom-group + (widget-create 'custom-group :custom-last t :custom-state 'unknown :tag (custom-unlispify-tag-name group) @@ -1219,7 +1215,7 @@ "Insert PREFIX. On XEmacs convert it to line graphics." ;; ### Unfinished. (if nil ; (string-match "XEmacs" emacs-version) - (progn + (progn (insert "*") (while (not (string-equal prefix "")) (let ((entry (substring prefix 0 3))) @@ -1278,21 +1274,21 @@ "Face used when the customize item is not defined for customization." :group 'custom-magic-faces) -(defface custom-modified-face '((((class color)) +(defface custom-modified-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t :bold))) "Face used when the customize item has been modified." :group 'custom-magic-faces) -(defface custom-set-face '((((class color)) +(defface custom-set-face '((((class color)) (:foreground "blue" :background "white")) (t (:italic t))) "Face used when the customize item has been set." :group 'custom-magic-faces) -(defface custom-changed-face '((((class color)) +(defface custom-changed-face '((((class color)) (:foreground "white" :background "blue")) (t (:italic t))) @@ -1308,8 +1304,8 @@ (unknown "?" italic "\ unknown, you should not see this.") (hidden "-" default "\ -hidden, invoke \"Show\" in the previous line to show." "\ -group now hidden, invoke \"Show\", above, to show contents.") +hidden, invoke \"Show\" button in the previous line to show." "\ +group now hidden, invoke the above \"Show\" button to show contents.") (invalid "x" custom-invalid-face "\ the value displayed for this %c is invalid and cannot be set.") (modified "*" custom-modified-face "\ @@ -1331,7 +1327,7 @@ this %c is unchanged from its standard setting." "\ visible group members are all at standard settings.")) "Alist of customize option states. -Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where +Each entry is of the form (STATE MAGIC FACE ITEM-DESC [ GROUP-DESC ]), where STATE is one of the following symbols: @@ -1340,7 +1336,7 @@ `unknown' For internal use, should never occur. `hidden' - This item is not being displayed. + This item is not being displayed. `invalid' This item is modified, but has an invalid form. `modified' @@ -1402,7 +1398,7 @@ (defun widget-magic-mouse-down-action (widget &optional event) ;; Non-nil unless hidden. - (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) + (not (eq (widget-get (widget-get (widget-get widget :parent) :parent) :custom-state) 'hidden))) @@ -1421,7 +1417,7 @@ (form (widget-get parent :custom-form)) children) (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text) - (setq text (concat (match-string 1 text) + (setq text (concat (match-string 1 text) (symbol-name category) (match-string 2 text)))) (when (and custom-magic-show @@ -1433,14 +1429,16 @@ (> (widget-get parent :custom-level) 1)))) (insert-char ?\ (* custom-buffer-indent (widget-get parent :custom-level)))) - (push (widget-create-child-and-convert - widget 'choice-item + (push (widget-create-child-and-convert + widget 'choice-item :help-echo "Change the state of this item" :format (if hidden "%t" "%[%t%]") :button-prefix 'widget-push-button-prefix :button-suffix 'widget-push-button-suffix :mouse-down-action 'widget-magic-mouse-down-action - :tag "State") + :tag "State" + ;;:tag-glyph (or hidden '("state-up" "state-down")) + ) children) (insert ": ") (let ((start (point))) @@ -1462,9 +1460,9 @@ (when custom-magic-show (let ((indent (widget-get parent :indent))) (when indent - (insert-char ? indent)))) - (push (widget-create-child-and-convert - widget 'choice-item + (insert-char ?\ indent)))) + (push (widget-create-child-and-convert + widget 'choice-item :mouse-down-action 'widget-magic-mouse-down-action :button-face face :button-prefix "" @@ -1521,7 +1519,7 @@ (defun custom-convert-widget (widget) ;; Initialize :value and :tag from :args in WIDGET. (let ((args (widget-get widget :args))) - (when args + (when args (widget-put widget :value (widget-apply widget :value-to-internal (car args))) (widget-put widget :tag (custom-unlispify-tag-name (car args))) @@ -1549,7 +1547,7 @@ (custom-redraw-magic widget)) (when (and (>= pos from) (<= pos to)) (condition-case nil - (progn + (progn (if (> column 0) (goto-line line) (goto-line (1+ line))) @@ -1558,9 +1556,9 @@ (defun custom-redraw-magic (widget) "Redraw WIDGET state with current settings." - (while widget + (while widget (let ((magic (widget-get widget :custom-magic))) - (cond (magic + (cond (magic (widget-value-set magic (widget-value magic)) (when (setq widget (widget-get widget :group)) (custom-group-state-update widget))) @@ -1584,7 +1582,7 @@ (defun custom-load-symbol (symbol) "Load all dependencies for SYMBOL." (unless custom-load-recursion - (let ((custom-load-recursion t) + (let ((custom-load-recursion t) (loads (get symbol 'custom-loads)) load) (while loads @@ -1625,6 +1623,7 @@ (setq found t))) ((assoc load load-history)) ((assoc (locate-library load) load-history) + ;; #### WTF??? (message nil)) (t (setq found t)))) @@ -1642,7 +1641,7 @@ (error "There are unset changes")) ((eq state 'hidden) (widget-put widget :custom-state 'unknown)) - (t + (t (widget-put widget :documentation-shown nil) (widget-put widget :custom-state 'hidden))) (custom-redraw widget) @@ -1676,7 +1675,7 @@ (if many (insert ", and ") (insert " and "))) - (t + (t (insert ", ")))) (widget-put widget :buttons buttons)))) @@ -1694,8 +1693,8 @@ (let ((entry (assq name (get group 'custom-group)))) (when (eq (nth 1 entry) type) (insert " ") - (push (widget-create-child-and-convert - widget 'custom-group-link + (push (widget-create-child-and-convert + widget 'custom-group-link :tag (custom-unlispify-tag-name group) group) buttons) @@ -1742,7 +1741,7 @@ (defun custom-variable-type (symbol) "Return a widget suitable for editing the value of SYMBOL. -If SYMBOL has a `custom-type' property, use that. +If SYMBOL has a `custom-type' property, use that. Otherwise, look up symbol in `custom-guess-type-alist'." (let* ((type (or (get symbol 'custom-type) (and (not (get symbol 'standard-value)) @@ -1794,14 +1793,14 @@ (widget-put widget :buttons buttons)) ((eq state 'hidden) ;; Indicate hidden value. - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'item :format "%{%t%}: " :sample-face 'custom-variable-tag-face :tag tag :parent widget) buttons) - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Show the value of this option" :action 'custom-toggle-parent @@ -1818,15 +1817,15 @@ (t (custom-quote (widget-get conv :value)))))) (insert (symbol-name symbol) ": ") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide the value of this option" :action 'custom-toggle-parent t) buttons) (insert " ") - (push (widget-create-child-and-convert - widget 'sexp + (push (widget-create-child-and-convert + widget 'sexp :button-face 'custom-variable-button-face :format "%v" :tag (symbol-name symbol) @@ -1842,7 +1841,7 @@ (setq tag-format (substring format 0 (match-end 0))) (setq value-format (substring format (match-end 0))) (push (widget-create-child-and-convert - widget 'item + widget 'item :format tag-format :action 'custom-tag-action :help-echo "Change value of this option" @@ -1852,14 +1851,14 @@ tag) buttons) (insert " ") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide the value of this option" :action 'custom-toggle-parent t) - buttons) + buttons) (push (widget-create-child-and-convert - widget type + widget type :format value-format :value value) children)))) @@ -1876,7 +1875,7 @@ (widget-put widget :custom-magic magic) (push magic buttons)) ;; Update properties. - (widget-put widget :custom-form form) + (widget-put widget :custom-form form) (widget-put widget :buttons buttons) (widget-put widget :children children) ;; Insert documentation. @@ -1926,7 +1925,7 @@ (t 'rogue)))) (widget-put widget :custom-state state))) -(defvar custom-variable-menu +(defvar custom-variable-menu '(("Set for Current Session" custom-variable-set (lambda (widget) (eq (widget-get widget :custom-state) 'modified))) @@ -1948,7 +1947,7 @@ (memq (widget-get widget :custom-state) '(modified set changed saved rogue))))) ("---" ignore ignore) - ("Don't show as Lisp expression" custom-variable-edit + ("Don't show as Lisp expression" custom-variable-edit (lambda (widget) (eq (widget-get widget :custom-form) 'lisp))) ("Show as Lisp expression" custom-variable-edit-lisp @@ -1968,7 +1967,8 @@ (custom-toggle-hide widget) (unless (eq (widget-get widget :custom-state) 'modified) (custom-variable-state-set widget)) - (custom-redraw-magic widget) + ;; Redrawing magic also depresses the state glyph. + ;(custom-redraw-magic widget) (let* ((completion-ignore-case t) (answer (widget-choose (concat "Operation on " (custom-unlispify-tag-name @@ -2075,10 +2075,10 @@ :extra-offset 12 :button-args '(:help-echo "Control whether this attribute have any effect") :args (mapcar (lambda (att) - (list 'group + (list 'group :inline t :sibling-args (widget-get (nth 1 att) :sibling-args) - (list 'const :format "" :value (nth 0 att)) + (list 'const :format "" :value (nth 0 att)) (nth 1 att))) custom-face-attributes)) @@ -2176,7 +2176,7 @@ :custom-reset-standard 'custom-face-reset-standard :custom-menu 'custom-face-menu-create) -(define-widget 'custom-face-all 'editable-list +(define-widget 'custom-face-all 'editable-list "An editable list of display specifications and attributes." :entry-format "%i %d %v" :insert-button-args '(:help-echo "Insert new display specification here") @@ -2195,7 +2195,7 @@ "Non-nil if VALUE is an unselected display specification." (not (face-spec-set-match-display value (selected-frame)))) -(define-widget 'custom-face-selected 'group +(define-widget 'custom-face-selected 'group "Edit the attributes of the selected display in a face specification." :args '((repeat :format "" :inline t @@ -2236,7 +2236,7 @@ ;; Sample. (and (not (find-face symbol)) ;; XEmacs cannot display uninitialized faces. - (copy-face 'custom-face-empty symbol)) + (make-face symbol)) (push (widget-create-child-and-convert widget 'item :format "(%{%t%})" :sample-face symbol @@ -2244,7 +2244,7 @@ buttons) ;; Visibility. (insert " ") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide or show this face" :action 'custom-toggle-parent @@ -2275,14 +2275,14 @@ (spec (or (get symbol 'saved-face) (get symbol 'face-defface-spec) ;; Attempt to construct it. - (list (list t (face-custom-attributes-get + (list (list t (face-custom-attributes-get symbol (selected-frame)))))) (form (widget-get widget :custom-form)) (indent (widget-get widget :indent)) (edit (widget-create-child-and-convert widget (cond ((and (eq form 'selected) - (widget-apply custom-face-selected + (widget-apply custom-face-selected :match spec)) (when indent (insert-char ?\ indent)) 'custom-face-selected) @@ -2290,7 +2290,7 @@ (widget-apply custom-face-all :match spec)) 'custom-face-all) - (t + (t (when indent (insert-char ?\ indent)) 'sexp)) :value spec))) @@ -2298,7 +2298,7 @@ (widget-put widget :children (list edit))) (message "Creating face editor...done")))))) -(defvar custom-face-menu +(defvar custom-face-menu '(("Set for Current Session" custom-face-set) ("Save for Future Sessions" custom-face-save) ("Reset to Saved" custom-face-reset-saved @@ -2351,7 +2351,7 @@ 'saved) ((get symbol 'face-defface-spec) 'standard) - (t + (t 'rogue))))) (defun custom-face-action (widget &optional event) @@ -2463,7 +2463,7 @@ (mapcar (lambda (face) (list (symbol-name face))) (face-list)) - nil nil nil + nil nil nil 'face-history))) (unless (zerop (length answer)) (widget-value-set widget (intern answer)) @@ -2480,14 +2480,14 @@ value)) :match (lambda (widget value) (or (symbolp value) - (widget-editable-list-match widget value))) + (widget-group-match widget value))) :convert-widget 'custom-hook-convert-widget :tag "Hook") (defun custom-hook-convert-widget (widget) ;; Handle `:custom-options'. (let* ((options (widget-get widget :options)) - (other `(editable-list :inline t + (other `(editable-list :inline t :entry-format "%i %d%v" (function :format " %v"))) (args (if options @@ -2603,7 +2603,7 @@ (or members (custom-unloaded-widget-p widget))) (custom-browse-insert-prefix prefix) (push (widget-create-child-and-convert - widget 'custom-browse-visibility + widget 'custom-browse-visibility ;; :tag-glyph "plus" :tag "+") buttons) @@ -2620,7 +2620,7 @@ (insert "[ ]-- ") ;; (widget-glyph-insert nil "[ ]" "empty") ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") @@ -2629,24 +2629,24 @@ (custom-browse-insert-prefix prefix) (custom-load-widget widget) (if (zerop (length members)) - (progn + (progn (custom-browse-insert-prefix prefix) (insert "[ ]-- ") ;; (widget-glyph-insert nil "[ ]" "empty") ;; (widget-glyph-insert nil "-- " "horizontal") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") (widget-put widget :buttons buttons)) - (push (widget-create-child-and-convert - widget 'custom-browse-visibility + (push (widget-create-child-and-convert + widget 'custom-browse-visibility ;; :tag-glyph "minus" :tag "-") buttons) (insert "-\\ ") ;; (widget-glyph-insert nil "-\\ " "top") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'custom-browse-group-tag) buttons) (insert " " tag "\n") @@ -2683,19 +2683,25 @@ (unless (eq custom-buffer-style 'links) (insert-char ?\ (* custom-buffer-indent (1- level))) (insert "-- ")) + ;; Create link indicator. + (when (eq custom-buffer-style 'links) + (insert " ") + (push (widget-create-child-and-convert + widget 'custom-group-link + :tag "Open" + :tag-glyph '("open-up" "open-down") + symbol) + buttons) + (insert " ")) ;; Create tag. (let ((begin (point))) (insert tag) (widget-specify-sample widget begin (point))) - (insert " group: ") - ;; Create link/visibility indicator. - (if (eq custom-buffer-style 'links) - (push (widget-create-child-and-convert - widget 'custom-group-link - :tag "Open" - symbol) - buttons) - (push (widget-create-child-and-convert + (insert " group") + ;; Create visibility indicator. + (unless (eq custom-buffer-style 'links) + (insert ": ") + (push (widget-create-child-and-convert widget 'custom-group-visibility :help-echo "Show members of this group" :action 'custom-toggle-parent @@ -2738,7 +2744,7 @@ ;; Create visibility indicator. (unless (eq custom-buffer-style 'links) (insert "--------") - (push (widget-create-child-and-convert + (push (widget-create-child-and-convert widget 'visibility :help-echo "Hide members of this group" :action 'custom-toggle-parent @@ -2747,13 +2753,13 @@ (insert " ")) ;; Create more dashes. ;; Use 76 instead of 75 to compensate for the temporary "<" - ;; added by `widget-insert'. + ;; added by `widget-insert'. (insert-char ?- (- 76 (current-column) (* custom-buffer-indent level))) (insert "\\\n") ;; Create magic button. (let ((magic (widget-create-child-and-convert - widget 'custom-magic + widget 'custom-magic :indent 0 nil))) (widget-put widget :custom-magic magic) @@ -2768,7 +2774,7 @@ (when (eq level 1) (insert-char ?\ custom-buffer-indent) (custom-add-parent-links widget))) - (custom-add-see-also widget + (custom-add-see-also widget (make-string (* custom-buffer-indent level) ?\ )) ;; Members. @@ -2815,7 +2821,7 @@ (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level))) (insert "/\n"))))) -(defvar custom-group-menu +(defvar custom-group-menu '(("Set for Current Session" custom-group-set (lambda (widget) (eq (widget-get widget :custom-state) 'modified))) @@ -3023,10 +3029,10 @@ (mapatoms (lambda (symbol) (let ((face (get symbol 'customized-face)) (value (get symbol 'customized-value))) - (when face + (when face (put symbol 'saved-face face) (put symbol 'customized-face nil)) - (when value + (when value (put symbol 'saved-value value) (put symbol 'customized-value nil))))) ;; We really should update all custom buffers here. @@ -3068,10 +3074,10 @@ ;; Add checkboxes to boolean variable entries. (widget-put (get 'boolean 'widget-type) :custom-menu (lambda (widget symbol) - (vector (custom-unlispify-menu-entry symbol) - `(customize-variable ',symbol) - ':style 'toggle - ':selected symbol))) + `[,(custom-unlispify-menu-entry symbol) + (customize-variable ',symbol) + :style toggle + :selected ,symbol])) ;; XEmacs can create menus dynamically. (defun custom-group-menu-create (widget symbol) @@ -3116,7 +3122,7 @@ ;;;###autoload (defun customize-menu-create (symbol &optional name) "Return a customize menu for customization group SYMBOL. -If optional NAME is given, use that as the name of the menu. +If optional NAME is given, use that as the name of the menu. Otherwise the menu will be named `Customize'. The format is suitable for use with `easy-menu-define'." (unless name @@ -3153,7 +3159,7 @@ (if button (widget-button-click event))))) -(easy-menu-define Custom-mode-menu +(easy-menu-define Custom-mode-menu custom-mode-map "Menu used in customization buffers." `("Custom" @@ -3163,7 +3169,7 @@ ["Reset to Current" Custom-reset-current t] ["Reset to Saved" Custom-reset-saved t] ["Reset to Standard Settings" Custom-reset-standard t] - ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) + ["Info" (Info-goto-node "(xemacs)Easy Customization") t])) (defun Custom-goto-parent () "Go to the parent group listed at the top of this buffer. @@ -3183,7 +3189,8 @@ (defun custom-state-buffer-message (widget) (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified) - (message "To install your edits, invoke [State] and choose the Set operation"))) + (message + "To install your edits, invoke [State] and choose the Set operation"))) (defun custom-mode () "Major mode for editing customization buffers.
--- a/lisp/custom/cus-face.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-face.el Mon Aug 13 10:03:52 2007 +0200 @@ -74,10 +74,11 @@ :value "" :help-echo "Set background color.") set-face-background face-background-name) -;; (:inverse-video (boolean :tag "Inverse" -;; :help-echo "\ -;;Control whether the text should be inverted.") -;; custom-inverse-face custom-face-inverse) + ;; #### Should make it work on X + (:inverse-video (boolean :tag "Inverse" + :help-echo "\ +Control whether the text should be inverted. Works only on TTY-s") + set-face-reverse-p face-reverse-p) (:stipple (editable-field :format "Stipple: %v" :help-echo "Name of background bitmap file.") set-face-background-pixmap custom-face-stipple) @@ -214,25 +215,6 @@ (fontobj (font-create-object font))) (font-family fontobj))) -;;(defun custom-reverse-face (face value &optional frame) -;; "Swap the foreground and background colors of face FACE. -;;If the colors are not specified in the face, use the default colors." -;; (interactive (list (read-face-name "Reverse face: "))) -;; (when value -;; (if (eq (frame-type) 'tty) -;; (set-face-reverse-p face value frame) -;; (let ((fg (face-foreground-instance face frame)) -;; (bg (face-background-instance face frame))) -;; (set-face-foreground face bg frame) -;; (set-face-background face fg frame))))) - -;;(defun custom-face-reverse (face &optional frame) -;; "Returns non-nil if the face is reverse." -;; (if (eq (frame-type) 'tty) -;; (face-reverse-p face frame) -;; ;;; ### Implement me -;; )) - ;;; Initializing. ;;;###autoload
--- a/lisp/custom/cus-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/cus-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -35,19 +35,35 @@ (require 'custom) -(defun custom-put (symbol property list) - (let ((loads (get symbol property))) + +(defun custom-add-loads (symbol list) + "Update the custom-loads list of a symbol. +This works by adding the elements from LIST to the SYMBOL's +`custom-loads' property, avoiding duplicates. Also, SYMBOL is +added to `custom-group-hash-table'." + (let ((loads (get symbol 'custom-loads))) (dolist (el list) (unless (member el loads) (setq loads (nconc loads (list el))))) - (put symbol property loads) + (put symbol 'custom-loads loads) (puthash symbol t custom-group-hash-table))) +;; custom-add-loads was named custom-put (and accepted different +;; arguments) during the 20.3 beta cycle. Support it for +;; compatibility. +(defun custom-put (symbol ignored list) + (custom-add-loads symbol list)) +(make-obsolete 'custom-put 'custom-add-loads) + + (message "Loading customization dependencies...") -(mapc (lambda (dir) - (load (expand-file-name "custom-load" dir) t t)) - load-path) +;; Garbage-collection seems to be very intensive here, and it slows +;; things down. Nuke it. +(let ((gc-cons-threshold 10000000)) + (mapc (lambda (dir) + (load (expand-file-name "custom-load" dir) t t)) + load-path)) (message "Loading customization dependencies...done")
--- a/lisp/custom/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,37 +1,36 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:08 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("wid-edit")) -(custom-put 'custom-buffer 'custom-loads '("cus-edit")) -(custom-put 'custom-faces 'custom-loads '("cus-edit")) -(custom-put 'widgets 'custom-loads '("wid-browse" "wid-edit")) -(custom-put 'environment 'custom-loads '("cus-edit")) -(custom-put 'custom-menu 'custom-loads '("cus-edit")) -(custom-put 'internal 'custom-loads '("cus-edit")) -(custom-put 'hypermedia 'custom-loads '("wid-edit")) -(custom-put 'applications 'custom-loads '("cus-edit")) -(custom-put 'help 'custom-loads '("cus-edit")) -(custom-put 'widget-browse 'custom-loads '("wid-browse")) -(custom-put 'widget-documentation 'custom-loads '("wid-edit")) -(custom-put 'customize 'custom-loads '("cus-edit" "wid-edit")) -(custom-put 'custom-browse 'custom-loads '("cus-edit")) -(custom-put 'abbrev 'custom-loads '("cus-edit")) -(custom-put 'programming 'custom-loads '("cus-edit")) -(custom-put 'widget-button 'custom-loads '("wid-edit")) -(custom-put 'files 'custom-loads '("cus-edit")) -(custom-put 'external 'custom-loads '("cus-edit")) -(custom-put 'development 'custom-loads '("cus-edit")) -(custom-put 'widget-faces 'custom-loads '("wid-edit")) -(custom-put 'languages 'custom-loads '("cus-edit")) -(custom-put 'custom-magic-faces 'custom-loads '("cus-edit")) -(custom-put 'faces 'custom-loads '("cus-edit" "wid-edit")) -(custom-put 'emacs 'custom-loads '("cus-edit")) -(custom-put 'processes 'custom-loads '("cus-edit")) -(custom-put 'wp 'custom-loads '("cus-edit")) -(custom-put 'editing 'custom-loads '("cus-edit")) -(custom-put 'i18n 'custom-loads '("cus-edit")) +(custom-add-loads 'extensions '("wid-edit")) +(custom-add-loads 'custom-buffer '("cus-edit")) +(custom-add-loads 'custom-faces '("cus-edit")) +(custom-add-loads 'widgets '("wid-browse" "wid-edit")) +(custom-add-loads 'environment '("cus-edit")) +(custom-add-loads 'custom-menu '("cus-edit")) +(custom-add-loads 'internal '("cus-edit")) +(custom-add-loads 'hypermedia '("wid-edit")) +(custom-add-loads 'applications '("cus-edit")) +(custom-add-loads 'help '("cus-edit")) +(custom-add-loads 'widget-browse '("wid-browse")) +(custom-add-loads 'widget-documentation '("wid-edit")) +(custom-add-loads 'customize '("cus-edit" "wid-edit")) +(custom-add-loads 'custom-browse '("cus-edit")) +(custom-add-loads 'abbrev '("cus-edit")) +(custom-add-loads 'programming '("cus-edit")) +(custom-add-loads 'widget-button '("wid-edit")) +(custom-add-loads 'files '("cus-edit")) +(custom-add-loads 'external '("cus-edit")) +(custom-add-loads 'development '("cus-edit")) +(custom-add-loads 'widget-faces '("wid-edit")) +(custom-add-loads 'languages '("cus-edit")) +(custom-add-loads 'custom-magic-faces '("cus-edit")) +(custom-add-loads 'faces '("cus-edit" "wid-edit")) +(custom-add-loads 'emacs '("cus-edit")) +(custom-add-loads 'processes '("cus-edit")) +(custom-add-loads 'wp '("cus-edit")) +(custom-add-loads 'editing '("cus-edit")) +(custom-add-loads 'i18n '("cus-edit")) ;;; custom-load.el ends here
--- a/lisp/custom/wid-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/custom/wid-edit.el Mon Aug 13 10:03:52 2007 +0200 @@ -37,18 +37,12 @@ (autoload 'pp-to-string "pp") (autoload 'finder-commentary "finder" nil t) -(defun widget-event-point (event) - "Character position of the end of event if that exists, or nil." - (if (mouse-event-p event) - (event-point event) - nil)) - ;;; Customization. (defgroup widgets nil "Customization support for the Widget Library." :link '(custom-manual "(widget)Top") - :link '(url-link :tag "Development Page" + :link '(url-link :tag "Development Page" "http://www.dina.kvl.dk/~abraham/custom/") :link '(emacs-library-link :tag "Lisp File" "widget.el") :prefix "widget-" @@ -98,7 +92,7 @@ (((class grayscale color) (background dark)) (:background "dim gray")) - (t + (t (:italic t))) "Face used for editable fields." :group 'widget-faces) @@ -110,7 +104,7 @@ ; (((class grayscale color) ; (background dark)) ; (:background "dim gray")) -; (t +; (t ; (:italic t))) ; "Face used for editable fields spanning only a single line." ; :group 'widget-faces) @@ -200,7 +194,7 @@ (cons title (mapcar (lambda (x) (if (stringp x) - (vector x nil nil) + (vector x nil nil) (vector (car x) (list (car x)) t))) items))))) (setq val (and val @@ -249,7 +243,8 @@ (lookup-key overriding-terminal-local-map (read-key-sequence (concat title ": ") t))))) (message "") - (when (eq value 'keyboard-quit) + (when (or (eq value 'keyboard-quit) + (null value)) (error "Canceled")) value)) (t @@ -265,8 +260,8 @@ ;;; Widget text specifications. -;; -;; These functions are for specifying text properties. +;; +;; These functions are for specifying text properties. (defcustom widget-field-add-space t ;; Setting this to nil might be available, once some problems are resolved. @@ -282,7 +277,7 @@ (> emacs-major-version 19)) (not (string-match "XEmacs" emacs-version))) "Non-nil means use `before-change-functions' to track editable fields. -This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. +This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. Using before hooks also means that the :notify function can't know the new value." :type 'boolean @@ -305,14 +300,14 @@ (help-echo (widget-get widget :help-echo)) (extent (make-extent from to))) (unless (or (stringp help-echo) (null help-echo)) - (setq help-echo 'widget-mouse-help)) + (setq help-echo 'widget-mouse-help)) (widget-put widget :field-extent extent) (and (or (not widget-field-add-space) (widget-get widget :size)) (set-extent-property extent 'end-closed t)) (set-extent-property extent 'detachable nil) (set-extent-property extent 'field widget) - (set-extent-property extent 'tabable t) + (set-extent-property extent 'button-or-field t) (set-extent-property extent 'keymap map) (set-extent-property extent 'face face) (set-extent-property extent 'balloon-help help-echo) @@ -322,17 +317,19 @@ "Specify button for WIDGET between FROM and TO." (let ((face (widget-apply widget :button-face-get)) (help-echo (widget-get widget :help-echo)) - (extent (make-extent from to))) + (extent (make-extent from to)) + (map (widget-get widget :button-keymap))) (widget-put widget :button-extent extent) (unless (or (null help-echo) (stringp help-echo)) (setq help-echo 'widget-mouse-help)) (set-extent-property extent 'start-open t) (set-extent-property extent 'button widget) - (set-extent-property extent 'tabable t) + (set-extent-property extent 'button-or-field t) (set-extent-property extent 'mouse-face widget-mouse-face) (set-extent-property extent 'balloon-help help-echo) (set-extent-property extent 'help-echo help-echo) - (set-extent-property extent 'face face))) + (set-extent-property extent 'face face) + (set-extent-property extent 'keymap map))) (defun widget-mouse-help (extent) "Find mouse help string for button in extent." @@ -378,51 +375,112 @@ (delete-region (1- (point-max)) (point-max)) (goto-char (point-max)))))) +(put 'widget-specify-insert 'edebug-form-spec '(&rest form)) + + +;;; Inactive Widgets. + (defface widget-inactive-face '((((class grayscale color) (background dark)) (:foreground "light gray")) (((class grayscale color) (background light)) (:foreground "dim gray")) - (t + (t (:italic t))) "Face used for inactive widgets." :group 'widget-faces) +;; For inactiveness to work on complex structures, it is not +;; sufficient to keep track of whether a button/field/glyph is +;; inactive or not -- we must know how many time it was deactivated +;; (inactiveness level). Successive deactivations of the same button +;; increment its inactive-count, and activations decrement it. When +;; inactive-count reaches 0, the button/field/glyph is reactivated. + +(defun widget-activation-widget-mapper (extent action) + "Activate or deactivate EXTENT's widget (button or field). +Suitable for use with `map-extents'." + (ecase action + (:activate + (decf (extent-property extent :inactive-count)) + (when (zerop (extent-property extent :inactive-count)) + (set-extent-properties + extent (extent-property extent :inactive-plist)) + (set-extent-property extent :inactive-plist nil))) + (:deactivate + (incf (extent-property extent :inactive-count 0)) + ;; Store a plist of old properties, which will be fed to + ;; `set-extent-properties'. + (unless (extent-property extent :inactive-plist) + (set-extent-property + extent :inactive-plist + (list 'mouse-face (extent-property extent 'mouse-face) + 'help-echo (extent-property extent 'help-echo) + 'keymap (extent-property extent 'keymap))) + (set-extent-properties + extent '(mouse-face nil help-echo nil keymap nil))))) + nil) + +(defun widget-activation-glyph-mapper (extent action) + (let ((activate-p (if (eq action :activate) t nil))) + (if activate-p + (decf (extent-property extent :inactive-count)) + (incf (extent-property extent :inactive-count 0))) + (when (or (and activate-p + (zerop (extent-property extent :inactive-count))) + (and (not activate-p) + (not (zerop (extent-property extent :inactive-count))))) + (let* ((glyph-widget (extent-property extent 'glyph-widget)) + (up-glyph (widget-get glyph-widget :glyph-up)) + (inactive-glyph (widget-get glyph-widget :glyph-inactive)) + (new-glyph (if activate-p up-glyph inactive-glyph))) + ;; Check that the new glyph exists, and differs from the + ;; default one. + (and up-glyph inactive-glyph (not (eq up-glyph inactive-glyph)) + ;; Check if the glyph is already installed. + (not (eq (extent-end-glyph extent) new-glyph)) + ;; Change it. + (set-extent-end-glyph extent new-glyph))))) + nil) + (defun widget-specify-inactive (widget from to) "Make WIDGET inactive for user modifications." (unless (widget-get widget :inactive) (let ((extent (make-extent from to))) - (set-extent-property extent 'start-open t) - (set-extent-property extent 'face 'widget-inactive-face) - ;; This is disabled, as it makes the mouse cursor change shape. - ;(set-extent-property extent 'mouse-face 'widget-inactive-face) - ;; ...actually, in XEmacs, we can easily choose our own pointer - ;; shapes. However, the mouse-face of the "inner" extent will - ;; still be drawn. - (set-extent-property extent 'detachable t) - (set-extent-property extent 'priority 100) - (set-extent-property extent 'read-only 't) - (widget-put widget :inactive extent)))) - -;; We don't have modification functions, so this is unused. -;(defun widget-overlay-inactive (&rest junk) -; "Ignoring the arguments, signal an error." -; (unless inhibit-read-only -; (error "Attempt to modify inactive widget"))) - + ;; It is no longer necessary for the extent to be read-only, as + ;; the inactive editable fields now lose their keymaps. + (set-extent-properties + extent '(start-open t face widget-inactive-face + detachable t priority 2001 widget-inactive t)) + (widget-put widget :inactive extent)) + ;; Deactivate the buttons and fields within the range. In some + ;; cases, the fields are not yet setup at the time this function + ;; is called. Those fields are deactivated explicitly by + ;; `widget-setup'. + (map-extents 'widget-activation-widget-mapper + nil from to :deactivate nil 'button-or-field) + ;; Deactivate glyphs. + (map-extents 'widget-activation-glyph-mapper + nil from to :deactivate nil 'glyph-widget))) (defun widget-specify-active (widget) "Make WIDGET active for user modifications." (let ((inactive (widget-get widget :inactive))) (when inactive + ;; Reactivate the buttons and fields covered by the extent. + (map-extents 'widget-activation-widget-mapper + inactive nil nil :activate nil 'button-or-field) + ;; Reactivate the glyphs. + (map-extents 'widget-activation-glyph-mapper + inactive nil nil :activate nil 'end-glyph) (delete-extent inactive) (widget-put widget :inactive nil)))) ;;; Widget Properties. -(defun widget-type (widget) +(defsubst widget-type (widget) "Return the type of WIDGET, a symbol." (car widget)) @@ -448,13 +506,13 @@ missing nil)) ((setq tmp (car widget)) (setq widget (get tmp 'widget-type))) - (t + (t (setq missing nil)))) value))) (defun widget-get-indirect (widget property) "In WIDGET, get the value of PROPERTY. -If the value is a symbol, return its binding. +If the value is a symbol, return its binding. Otherwise, just return the value." (let ((value (widget-get widget property))) (if (symbolp value) @@ -583,9 +641,13 @@ xbm, gif, jpg, or png) located in `widget-glyph-directory', or in one of the data directories. It can also be a valid image instantiator, in which case it will be - used to make the glyph, with an additional TAG string fallback. -If IMAGE is a list, it will be given unchanged to `make-glyph'." - (cond ((not (and image widget-glyph-enable)) + used to make the glyph, with an additional TAG string fallback." + (cond ((not (and image widget-glyph-enable + ;; We don't use glyphs on TTY consoles, although we + ;; could. However, glyph faces aren't yet working + ;; properly, and movement through glyphs is + ;; unintuitive. + (console-on-window-system-p))) ;; We don't want to use glyphs. nil) ((glyphp image) @@ -601,6 +663,9 @@ (formats widget-image-conversion) file) (while (and formats (not file)) + ;; This dance is necessary, because XEmacs signals an + ;; error when it encounters an unrecognized image + ;; format. (when (valid-image-instantiator-format-p (caar formats)) (setq file (locate-file image dirlist (mapconcat 'identity (cdar formats) @@ -613,16 +678,12 @@ (let ((glyph (make-glyph `([,(caar formats) :file ,file] [string :data ,tag])))) ;; Cache the glyph - (setq widget-glyph-cache - (lax-plist-put widget-glyph-cache image glyph)) + (laxputf widget-glyph-cache image glyph) ;; ...and return it glyph))))) ((valid-instantiator-p image 'image) ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) (make-glyph `(,image [string :data ,tag]))) - ((consp image) - ;; This could be virtually anything. Let `make-glyph' sort it out. - (make-glyph image)) (t ;; Oh well. nil))) @@ -634,18 +695,30 @@ `widget-glyph-directory', or anything else allowed by `widget-glyph-find'. -Optional arguments DOWN and INACTIVE is used instead of IMAGE when the -glyph is pressed or inactive, respectively. - -Instead of an instantiator, you can also use a list of instantiators, -or whatever `make-glyph' will accept. However, in that case you must -provide the fallback TAG as a part of the instantiator yourself." +If IMAGE is a list, it will be taken as a list of (UP DOWN INACTIVE) +glyphs. The down and inactive glyphs are shown when glyph is pressed +or inactive, respectively. + +The optional DOWN and INACTIVE arguments are deprecated, and exist +only because of compatibility." + ;; Convert between IMAGE being a list, etc. Must use `psetq', + ;; because otherwise change to `image' screws up the rest. + (psetq image (or (and (consp image) + (car image)) + image) + down (or (and (consp image) + (nth 1 image)) + down) + inactive (or (and (consp image) + (nth 2 image)) + inactive)) (let ((glyph (widget-glyph-find image tag))) - (if glyph + (if glyph (widget-glyph-insert-glyph widget glyph (widget-glyph-find down tag) (widget-glyph-find inactive tag)) - (insert tag)))) + (insert tag)) + glyph)) (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) "In WIDGET, insert GLYPH. @@ -653,12 +726,19 @@ glyphs used when the widget is pushed and inactive, respectively." (insert "*") (let ((extent (make-extent (point) (1- (point)))) - (help-echo (and widget (widget-get widget :help-echo)))) - (set-extent-property extent 'widget widget) + (help-echo (and widget (widget-get widget :help-echo))) + (map (and widget (widget-get widget :button-keymap)))) + (set-extent-property extent 'glyph-widget widget) + ;; It would be fun if we could make this extent atomic, so it + ;; doesn't mess with cursor motion. But atomic-extents library is + ;; currently a mess, so I'd rather not use it. (set-extent-property extent 'invisible t) (set-extent-property extent 'start-open t) (set-extent-property extent 'end-open t) + (set-extent-property extent 'keymap map) (set-extent-end-glyph extent glyph) + (unless (or (stringp help-echo) (null help-echo)) + (setq help-echo 'widget-mouse-help)) (when help-echo (set-extent-property extent 'balloon-help help-echo) (set-extent-property extent 'help-echo help-echo))) @@ -689,7 +769,7 @@ ;;;###autoload (defun widget-create (type &rest args) - "Create widget of TYPE. + "Create widget of TYPE. The optional ARGS are additional keyword arguments." (let ((widget (apply 'widget-convert type args))) (widget-apply widget :create) @@ -736,10 +816,10 @@ (widget-apply widget :delete)) (defun widget-convert (type &rest args) - "Convert TYPE to a widget without inserting it in the buffer. + "Convert TYPE to a widget without inserting it in the buffer. The optional ARGS are additional keyword arguments." ;; Don't touch the type. - (let* ((widget (if (symbolp type) + (let* ((widget (if (symbolp type) (list type) (copy-sequence type))) (current widget) @@ -765,10 +845,10 @@ (setq widget (funcall convert-widget widget)))) (setq type (get (car type) 'widget-type))) ;; Finally set the keyword args. - (while keys + (while keys (let ((next (nth 0 keys))) (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) - (progn + (progn (widget-put widget next (nth 1 keys)) (setq keys (nthcdr 2 keys))) (setq keys nil)))) @@ -846,16 +926,12 @@ "Keymap containing useful binding for buffers containing widgets. Recommended as a parent keymap for modes using widgets.") -(unless widget-keymap +(unless widget-keymap (setq widget-keymap (make-sparse-keymap)) (define-key widget-keymap [tab] 'widget-forward) (define-key widget-keymap [(shift tab)] 'widget-backward) (define-key widget-keymap [(meta tab)] 'widget-backward) - (define-key widget-keymap [backtab] 'widget-backward) - ;;Glyph support. - (define-key widget-keymap [button1] 'widget-button1-click) - (define-key widget-keymap [button2] 'widget-button-click) - (define-key widget-keymap "\C-m" 'widget-button-press)) + (define-key widget-keymap [backtab] 'widget-backward)) (defvar widget-global-map global-map "Keymap used for events the widget does not handle themselves.") @@ -864,7 +940,7 @@ (defvar widget-field-keymap nil "Keymap used inside an editable field.") -(unless widget-field-keymap +(unless widget-field-keymap (setq widget-field-keymap (make-sparse-keymap)) (set-keymap-parents widget-field-keymap global-map) (define-key widget-field-keymap "\C-k" 'widget-kill-line) @@ -879,24 +955,38 @@ (defvar widget-text-keymap nil "Keymap used inside a text field.") -(unless widget-text-keymap +(unless widget-text-keymap (setq widget-text-keymap (make-sparse-keymap)) (set-keymap-parents widget-field-keymap global-map) (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) (define-key widget-text-keymap "\C-e" 'widget-end-of-line) (define-key widget-text-keymap "\C-t" 'widget-transpose-chars)) +(defvar widget-button-keymap nil + "Keymap used inside a button.") + +(unless widget-button-keymap + (setq widget-button-keymap (make-sparse-keymap)) + (set-keymap-parents widget-button-keymap widget-keymap) + (define-key widget-button-keymap "\C-m" 'widget-button-press) + (define-key widget-button-keymap [button2] 'widget-button-click) + ;; Ideally, button3 within a button should invoke a button-specific + ;; menu. + (define-key widget-button-keymap [button3] 'widget-button-click) + ;;Glyph support. + (define-key widget-button-keymap [button1] 'widget-button1-click)) + (defun widget-field-activate (pos &optional event) "Invoke the ediable field at point." (interactive "@d") - (let ((field (get-char-property pos 'field))) + (let ((field (widget-field-find pos))) (if field (widget-apply-action field event) (call-interactively (lookup-key widget-global-map (this-command-keys)))))) -(defface widget-button-pressed-face +(defface widget-button-pressed-face '((((class color)) (:foreground "red")) (t @@ -904,6 +994,11 @@ "Face used for pressed buttons." :group 'widget-faces) +(defun widget-event-point (event) + "Character position of the mouse event, or nil." + (and (mouse-event-p event) + (event-point event))) + (defun widget-button-click (event) "Invoke button below mouse pointer." (interactive "@e") @@ -915,56 +1010,46 @@ (if button (let* ((extent (widget-get button :button-extent)) (face (extent-property extent 'face)) - (mouse-face (extent-property extent 'mouse-face))) + (mouse-face (extent-property extent 'mouse-face)) + (help-echo (extent-property extent 'help-echo))) (unwind-protect (progn - (set-extent-property extent 'face - 'widget-button-pressed-face) - (set-extent-property extent 'mouse-face - 'widget-button-pressed-face) + ;; Merge relevant faces, and make the result mouse-face. + (let ((merge `(widget-button-pressed-face ,mouse-face))) + (nconc merge (if (listp face) + face (list face))) + (setq merge (delete-if-not 'find-face merge)) + (set-extent-property extent 'mouse-face merge)) (unless (widget-apply button :mouse-down-action event) - (while (not (button-release-event-p event)) - (setq event (next-event) - pos (widget-event-point event)) - (if (and pos - (eq (get-char-property pos 'button) - button)) - (progn - (set-extent-property extent 'face - 'widget-button-pressed-face) - (set-extent-property extent 'mouse-face - 'widget-button-pressed-face)) - (set-extent-property extent 'face face) - (set-extent-property extent - 'mouse-face mouse-face)))) - (when (and pos - (eq (get-char-property pos 'button) button)) + ;; Wait for button release. + (while (not (button-release-event-p + (setq event (next-event)))) + (dispatch-event event))) + ;; Disallow mouse-face and help-echo. + (set-extent-property extent 'mouse-face nil) + (set-extent-property extent 'help-echo nil) + (setq pos (widget-event-point event)) + (unless (eq (current-buffer) (extent-object extent)) + ;; Barf if dispatch-event tripped us by + ;; changing buffer. + (error "Buffer changed during mouse motion")) + ;; Do the associated action. + (when (and pos (extent-in-region-p extent pos pos)) (widget-apply-action button event))) - (set-extent-property extent 'face face) - (set-extent-property extent 'mouse-face mouse-face))) - (let ((up t) - command) - ;; Find the global command to run, and check whether it - ;; is bound to an up event. - (cond ((setq command ;down event - (lookup-key widget-global-map [button2])) - (setq up nil)) - ((setq command ;up event - (lookup-key widget-global-map [button2up])))) - (when up - ;; Don't execute up events twice. - (while (not (button-release-event-p event)) - (setq event (next-event)))) - (when command - (call-interactively command)))))) + ;; Unwinding: fully release the button. + (set-extent-property extent 'mouse-face mouse-face) + (set-extent-property extent 'help-echo help-echo))) + ;; This should not happen! + (error "`widget-button-click' called outside button")))) (t - (message "You clicked somewhere weird.")))) + (message "You clicked somewhere weird")))) (defun widget-button1-click (event) "Invoke glyph below mouse pointer." (interactive "@e") (if (event-glyph event) (widget-glyph-click event) + ;; Should somehow avoid this. (let ((command (lookup-key widget-global-map (this-command-keys)))) (and (commandp command) (call-interactively command))))) @@ -973,28 +1058,55 @@ "Handle click on a glyph." (let* ((glyph (event-glyph event)) (extent (event-glyph-extent event)) - (widget (extent-property extent 'widget)) + (widget (extent-property extent 'glyph-widget)) (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph)) (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph)) (last event)) - ;; Wait for the release. - (while (not (button-release-event-p last)) - (if (eq extent (event-glyph-extent last)) - (set-extent-property extent 'end-glyph down-glyph) - (set-extent-property extent 'end-glyph up-glyph)) - (setq last (next-event event))) - ;; Release glyph. - (when down-glyph - (set-extent-property extent 'end-glyph up-glyph)) - ;; Apply widget action. - (when (eq extent (event-glyph-extent last)) - (let ((widget (extent-property (event-glyph-extent event) 'widget))) - (cond ((null widget) - (message "You clicked on a glyph.")) - ((not (widget-apply widget :active)) - (message "This glyph is inactive.")) - (t - (widget-apply-action widget event))))))) + (unless (widget-apply widget :active) + (error "This widget is inactive")) + (let ((current-glyph 'down)) + ;; We always know what glyph is drawn currently, to avoid + ;; unnecessary extent changes. Is this any noticable gain? + (unwind-protect + (progn + ;; Press the glyph. + (set-extent-end-glyph extent down-glyph) + ;; Redisplay (shouldn't be needed, but...) + (sit-for 0) + (unless (widget-apply widget :mouse-down-action event) + ;; Wait for the release. + (while (not (button-release-event-p last)) + (unless (button-press-event-p last) + (dispatch-event last)) + (when (motion-event-p last) + ;; Update glyphs on mouse motion. + (if (eq extent (event-glyph-extent last)) + (unless (eq current-glyph 'down) + (set-extent-end-glyph extent down-glyph) + (setq current-glyph 'down)) + (unless (eq current-glyph 'up) + (set-extent-end-glyph extent up-glyph) + (setq current-glyph 'up)))) + (setq last (next-event event)))) + (unless (eq (current-buffer) (extent-object extent)) + ;; Barf if dispatch-event tripped us by changing buffer. + (error "Buffer changed during mouse motion")) + ;; Apply widget action. + (when (eq extent (event-glyph-extent last)) + (let ((widget (extent-property (event-glyph-extent event) + 'glyph-widget))) + (cond ((null widget) + (message "You clicked on a glyph")) + ((not (widget-apply widget :active)) + (error "This glyph is inactive")) + (t + (widget-apply-action widget event)))))) + ;; Release the glyph. + (and (eq current-glyph 'down) + ;; The extent might have been detached or deleted + (extent-live-p extent) + (not (extent-detached-p extent)) + (set-extent-end-glyph extent up-glyph)))))) (defun widget-button-press (pos &optional event) "Invoke button at POS." @@ -1015,7 +1127,8 @@ (if widget (let ((order (widget-get widget :tab-order))) (if order - (if last-tab (and (= order (if backwardp (1- last-tab) + (if last-tab (and (= order (if backwardp + (1- last-tab) (1+ last-tab))) widget) (and (> order 0) widget)) @@ -1039,10 +1152,11 @@ (lambda (ext ignore) ext) nil (if at-point (extent-end-position at-point) pos) - nil nil 'start-open 'tabable))) + nil nil 'start-open 'button-or-field))) (and extent (extent-start-position extent)))) +;; This is too slow in buffers with many buttons (W3). (defun widget-previous-button-or-field (pos) "Find the previous button, or field, and return its start position, or nil. Internal function, don't use it outside `wid-edit'." @@ -1051,10 +1165,13 @@ (map-extents (lambda (ext ignore) (if (eq ext at-point) - previous-extent + ;; We reached the extent we were on originally + (if (= pos (extent-start-position at-point)) + previous-extent + (setq previous-extent at-point)) (setq previous-extent ext) nil)) - nil nil pos nil 'start-open 'tabable) + nil nil pos nil 'start-open 'button-or-field) (and previous-extent (extent-start-position previous-extent)))) @@ -1070,7 +1187,8 @@ (if nextpos (progn (goto-char nextpos) - (when (widget-tabable-at nil last-tab t) + (when (and (not (get-char-property nextpos 'widget-inactive)) + (widget-tabable-at nil last-tab t)) (incf arg) (setq found t last-tab (widget-get (widget-at (point)) @@ -1086,7 +1204,8 @@ (if nextpos (progn (goto-char nextpos) - (when (widget-tabable-at nil last-tab) + (when (and (not (get-char-property nextpos 'widget-inactive)) + (widget-tabable-at nil last-tab)) (decf arg) (setq found t last-tab (widget-get (widget-at (point)) @@ -1154,14 +1273,19 @@ (goto-char end) (skip-chars-backward " \t\n" start) (point))))) - (if (and last-non-space - (= last-non-space (1+ start))) - ;; 1-character field - nil - (when (and (null arg) - (= last-non-space (point))) - (forward-char -1)) - (transpose-chars arg)))) + (cond ((and last-non-space + (or (= last-non-space start) + (= last-non-space (1+ start)))) + ;; empty or one-character field + nil) + ((= (point) start) + ;; at the beginning of the field -- we would get an error here. + (error "Cannot transpose at beginning of field")) + (t + (when (and (null arg) + (= last-non-space (point))) + (forward-char -1)) + (transpose-chars arg))))) (defcustom widget-complete-field (lookup-key global-map "\M-\t") "Default function to call for completion inside fields." @@ -1199,11 +1323,17 @@ (setq field (car widget-field-new) widget-field-new (cdr widget-field-new) widget-field-list (cons field widget-field-list)) - (let ((extent (widget-get field :field-extent))) + (let ((from (car (widget-get field :field-extent))) + (to (cdr (widget-get field :field-extent)))) (widget-specify-field field - (extent-start-position extent) - (extent-end-position extent)) - (delete-extent extent)))) + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil)) + ;; If the field is placed within the inactive zone, deactivate it. + (let ((extent (widget-get field :field-extent))) + (when (get-char-property (extent-start-position extent) + 'widget-inactive) + (widget-activation-widget-mapper extent :deactivate))))) (widget-clear-undo) (widget-add-change)) @@ -1237,32 +1367,45 @@ (defun widget-field-find (pos) "Return the field at POS. Unlike (get-char-property POS 'field) this, works with empty fields too." - (let ((fields widget-field-list) - field found) - (while fields - (setq field (car fields) - fields (cdr fields)) - (let ((start (widget-field-start field)) - (end (widget-field-end field))) - (when (and (<= start pos) (<= pos end)) - (when found - (debug "Overlapping fields")) - (setq found field)))) - found)) + (let ((field-extent (map-extents (lambda (extent ignore) + extent) + nil pos pos nil nil 'field))) + (and field-extent + (extent-property field-extent 'field)))) + +;; Old version, without `map-extents'. +;(defun widget-field-find (pos) +; (let ((fields widget-field-list) +; field found) +; (while fields +; (setq field (car fields) +; fields (cdr fields)) +; (let ((start (widget-field-start field)) +; (end (widget-field-end field))) +; (when (and (<= start pos) (<= pos end)) +; (when found +; (debug "Overlapping fields")) +; (setq found field)))) +; found)) (defun widget-before-change (from to) - ;; This is how, for example, a variable changes its state to `modified'. - ;; when it is being edited. + ;; Barf if the text changed is outside the editable fields. (unless inhibit-read-only (let ((from-field (widget-field-find from)) (to-field (widget-field-find to))) - (cond ((not (eq from-field to-field)) + (cond ((or (null from-field) + (null to-field)) + ;; Either end of change is not within a field. + (add-hook 'post-command-hook 'widget-add-change nil t) + (error "Attempt to change text outside editable field")) + ((not (eq from-field to-field)) + ;; The change begins in one fields, and ends in another one. (add-hook 'post-command-hook 'widget-add-change nil t) (error "Change should be restricted to a single field")) - ((null from-field) - (add-hook 'post-command-hook 'widget-add-change nil t) - (error "Attempt to change text outside editable field")) (widget-field-use-before-change + ;; #### Bletch! This loses because XEmacs get confused + ;; if before-change-functions change the contents of + ;; buffer before from/to. (condition-case nil (widget-apply from-field :notify from-field) (error (debug "Before Change")))))))) @@ -1277,6 +1420,9 @@ (defun widget-after-change (from to old) ;; Adjust field size and text properties. + + ;; Also, notify the widgets (so, for example, a variable changes its + ;; state to `modified'. when it is being edited.) (condition-case nil (let ((field (widget-field-find from)) (other (widget-field-find to))) @@ -1285,7 +1431,7 @@ (debug "Change in different fields")) (let ((size (widget-get field :size)) (secret (widget-get field :secret))) - (when size + (when size (let ((begin (widget-field-start field)) (end (widget-field-end field))) (cond ((< (- end begin) size) @@ -1309,7 +1455,7 @@ (when secret (let ((begin (widget-field-start field)) (end (widget-field-end field))) - (when size + (when size (while (and (> end begin) (eq (char-after (1- end)) ?\ )) (setq end (1- end)))) @@ -1325,7 +1471,7 @@ ;;; Widget Functions ;; -;; These functions are used in the definition of multiple widgets. +;; These functions are used in the definition of multiple widgets. (defun widget-parent-action (widget &optional event) "Tell :parent of WIDGET to handle the :action. @@ -1357,11 +1503,11 @@ (defun widget-value-convert-widget (widget) "Initialize :value from :args in WIDGET." (let ((args (widget-get widget :args))) - (when args + (when args (widget-put widget :value (car args)) ;; Don't convert :value here, as this is done in `widget-convert'. ;; (widget-put widget :value (widget-apply widget - ;; :value-to-internal (car args))) + ;; :value-to-internal (car args))) (widget-put widget :args nil))) widget) @@ -1377,13 +1523,14 @@ :value-to-external (lambda (widget value) value) :button-prefix 'widget-button-prefix :button-suffix 'widget-button-suffix - :complete 'widget-default-complete + :complete 'widget-default-complete :create 'widget-default-create :indent nil :offset 0 :format-handler 'widget-default-format-handler - :button-face-get 'widget-default-button-face-get - :sample-face-get 'widget-default-sample-face-get + :button-face-get 'widget-default-button-face-get + :sample-face-get 'widget-default-sample-face-get + :button-keymap widget-button-keymap :delete 'widget-default-delete :value-set 'widget-default-value-set :value-inline 'widget-default-value-inline @@ -1407,24 +1554,25 @@ "Create WIDGET at point in the current buffer." (widget-specify-insert (let ((from (point)) - button-begin button-end + button-begin button-end button-glyph sample-begin sample-end doc-begin doc-end value-pos) (insert (widget-get widget :format)) (goto-char from) - ;; Parse escapes in format. + ;; Parse escapes in format. Coding this in C would speed up + ;; things *a lot*. (while (re-search-forward "%\\(.\\)" nil t) (let ((escape (aref (match-string 1) 0))) (replace-match "" t t) (cond ((eq escape ?%) (insert "%")) ((eq escape ?\[) - (setq button-begin (point)) - (insert (widget-get-indirect widget :button-prefix))) + (setq button-begin (point-marker)) + (set-marker-insertion-type button-begin nil)) ((eq escape ?\]) - (insert (widget-get-indirect widget :button-suffix)) - (setq button-end (point))) + (setq button-end (point-marker)) + (set-marker-insertion-type button-end nil)) ((eq escape ?\{) (setq sample-begin (point))) ((eq escape ?\}) @@ -1434,10 +1582,12 @@ (insert "\n") (insert-char ?\ (widget-get widget :indent)))) ((eq escape ?t) - (let ((glyph (widget-get widget :tag-glyph)) - (tag (widget-get widget :tag))) - (cond (glyph - (widget-glyph-insert widget (or tag "image") glyph)) + (let* ((tag (widget-get widget :tag)) + (glyph (widget-get widget :tag-glyph))) + (cond (glyph + (setq button-glyph + (widget-glyph-insert + widget (or tag "Image") glyph))) (tag (insert tag)) (t @@ -1455,12 +1605,21 @@ ((eq escape ?v) (if (and button-begin (not button-end)) (widget-apply widget :value-create) - (setq value-pos (point)))) + (setq value-pos (point-marker)))) (t (widget-apply widget :format-handler escape))))) ;; Specify button, sample, and doc, and insert value. - (and button-begin button-end - (widget-specify-button widget button-begin button-end)) + (when (and button-begin button-end) + (unless button-glyph + (goto-char button-begin) + (insert (widget-get-indirect widget :button-prefix)) + (goto-char button-end) + (set-marker-insertion-type button-end t) + (insert (widget-get-indirect widget :button-suffix))) + (widget-specify-button widget button-begin button-end) + ;; Is this necessary? + (set-marker button-begin nil) + (set-marker button-end nil)) (and sample-begin sample-end (widget-specify-sample widget sample-begin sample-end)) (and doc-begin doc-end @@ -1468,8 +1627,8 @@ (when value-pos (goto-char value-pos) (widget-apply widget :value-create))) - (let ((from (copy-marker (point-min))) - (to (copy-marker (point-max)))) + (let ((from (point-min-marker)) + (to (point-max-marker))) (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) @@ -1483,7 +1642,7 @@ (let* ((doc-property (widget-get widget :documentation-property)) (doc-try (cond ((widget-get widget :doc)) ((symbolp doc-property) - (documentation-property + (documentation-property (widget-get widget :value) doc-property)) (t @@ -1496,7 +1655,7 @@ (when doc-text (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) ;; The `*' in the beginning is redundant. (when (eq (aref doc-text 0) ?*) (setq doc-text (substring doc-text 1))) @@ -1505,14 +1664,14 @@ (setq doc-text (substring doc-text 0 (match-beginning 0)))) (push (widget-create-child-and-convert widget 'documentation-string - :indent (cond ((numberp doc-indent ) + :indent (cond ((numberp doc-indent) doc-indent) ((null doc-indent) nil) (t 0)) doc-text) buttons)))) - (t + (t (error "Unknown escape `%c'" escape))) (widget-put widget :buttons buttons))) @@ -1565,17 +1724,17 @@ (- old-pos to 1) (- old-pos from))))) ;;??? Bug: this ought to insert the new value before deleting the old one, - ;; so that markers on either side of the value automatically + ;; so that markers on either side of the value automatically ;; stay on the same side. -- rms. (save-excursion (goto-char (widget-get widget :from)) (widget-apply widget :delete) (widget-put widget :value value) (widget-apply widget :create)) - (if offset - (if (< offset 0) - (goto-char (+ (widget-get widget :to) offset 1)) - (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) + (when offset + (if (< offset 0) + (goto-char (+ (widget-get widget :to) offset 1)) + (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) (defun widget-default-value-inline (widget) ;; Wrap value in a list unless it is inline. @@ -1593,7 +1752,7 @@ "Return t iff this widget active (user modifiable)." (and (not (widget-get widget :inactive)) (let ((parent (widget-get widget :parent))) - (or (null parent) + (or (null parent) (widget-apply parent :active))))) (defun widget-default-deactivate (widget) @@ -1710,15 +1869,15 @@ ((and widget-push-button-gui (console-on-window-system-p)) (unless gui-glyphs - (let ((gui (make-gui-button tag 'widget-gui-action widget))) + (let* ((gui-button-shadow-thickness 1) + (gui (make-gui-button tag 'widget-gui-action widget))) (setq gui-glyphs (list (make-glyph `(,(nth 0 (aref gui 1)) [string :data ,text])) (make-glyph `(,(nth 1 (aref gui 1)) [string :data ,text])) (make-glyph `(,(nth 2 (aref gui 1)) [string :data ,text])))) - (setq widget-push-button-cache - (lax-plist-put widget-push-button-cache tag gui-glyphs)))) + (laxputf widget-push-button-cache tag gui-glyphs))) (widget-glyph-insert-glyph widget (nth 0 gui-glyphs) (nth 1 gui-glyphs) (nth 2 gui-glyphs))) (t @@ -1744,7 +1903,7 @@ "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix - :help-echo "Follow the link." + :help-echo "Follow the link" :format "%[%t%]") ;;; The `info-link' Widget. @@ -1769,7 +1928,7 @@ :action 'widget-url-link-action) (defun widget-url-link-help-echo (widget) - (concat "Go to <URL:" (widget-value widget) ">")) + (concat "Visit <URL:" (widget-value widget) ">")) (defun widget-url-link-action (widget &optional event) "Open the url specified by WIDGET." @@ -1874,15 +2033,27 @@ (defun widget-field-action (widget &optional event) ;; Edit the value in the minibuffer. - (let ((invalid (widget-apply widget :validate))) - (let ((prompt (concat (widget-apply widget :menu-tag-get) ": ")) - (value (unless invalid - (widget-value widget)))) - (let ((answer (widget-apply widget :prompt-value prompt value invalid))) - (widget-value-set widget answer))) - (widget-apply widget :notify widget event) - (widget-setup)) - (run-hook-with-args 'widget-edit-functions widget)) + (let* ((invalid (widget-apply widget :validate)) + (prompt (concat (widget-apply widget :menu-tag-get) ": ")) + (value (unless invalid + (widget-value widget))) + (answer (widget-apply widget :prompt-value prompt value invalid))) + (unless (equal value answer) + ;; This is a hack. We can't properly validate the widget + ;; because validation requires the new value to be in the field. + ;; However, widget-field-value-create will not function unless + ;; the new value matches. So, we check whether the thing + ;; matches, and if it does, use either the real or a dummy error + ;; message. + (unless (widget-apply widget :match answer) + (let ((error-message (or (widget-get widget :type-error) + "Invalid field contents"))) + (widget-put widget :error error-message) + (error error-message))) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup)) + (run-hook-with-args 'widget-edit-functions widget))) ;(defun widget-field-action (widget &optional event) ; ;; Move to next field. @@ -1903,23 +2074,24 @@ (let ((size (widget-get widget :size)) (value (widget-get widget :value)) (from (point)) - ;; This used to make `field-overlay' a cons of two markers, - ;; and revert them to a real overlay in `widget-setup', - ;; because you can't change overlay insertion type. However, - ;; we can do that with extents. - extent) + ;; This is changed to a real extent in `widget-setup'. We + ;; need the end points to behave differently until + ;; `widget-setup' is called. Should probably be replaced with + ;; a genuine extent, but some things break, then. + (extent (cons (make-marker) (make-marker)))) + (widget-put widget :field-extent extent) (insert value) (and size (< (length value) size) (insert-char ?\ (- size (length value)))) (unless (memq widget widget-field-list) (push widget widget-field-new)) - (setq extent (make-extent from (point))) - (set-extent-property extent 'end-open t) - (widget-put widget :field-extent extent) + (move-marker (cdr extent) (point)) + (set-marker-insertion-type (cdr extent) nil) (when (null size) (insert ?\n)) - (set-extent-property extent 'start-open t))) + (move-marker (car extent) from) + (set-marker-insertion-type (car extent) t))) (defun widget-field-value-delete (widget) ;; Remove the widget from the list of active editing fields. @@ -1937,24 +2109,25 @@ (size (widget-get widget :size)) (secret (widget-get widget :secret)) (old (current-buffer))) - (if (and from to) - (progn - (set-buffer buffer) - (while (and size - (not (zerop size)) - (> to from) - (eq (char-after (1- to)) ?\ )) - (setq to (1- to))) - (let ((result (buffer-substring-no-properties from to))) - (when secret - (let ((index 0)) - (while (< (+ from index) to) - (aset result index - (get-char-property (+ from index) 'secret)) - (incf index)))) - (set-buffer old) - result)) - (widget-get widget :value)))) + (cond + ((and from to) + (set-buffer buffer) + (while (and size + (not (zerop size)) + (> to from) + (eq (char-after (1- to)) ?\ )) + (setq to (1- to))) + (let ((result (buffer-substring-no-properties from to))) + (when secret + (let ((index 0)) + (while (< (+ from index) to) + (aset result index + (get-char-property (+ from index) 'secret)) + (incf index)))) + (set-buffer old) + result)) + (t + (widget-get widget :value))))) (defun widget-field-match (widget value) ;; Match any string. @@ -2078,7 +2251,7 @@ choices))) (widget-choose tag (reverse choices) event)))) (when current - (widget-value-set widget + (widget-value-set widget (widget-apply current :value-to-external (widget-get current :value))) (widget-setup) @@ -2128,12 +2301,12 @@ (defun widget-toggle-value-create (widget) ;; Insert text representing the `on' and `off' states. (if (widget-value widget) - (widget-glyph-insert widget - (widget-get widget :on) + (widget-glyph-insert widget + (widget-get widget :on) (widget-get widget :on-glyph)) - (widget-glyph-insert widget - (widget-get widget :off) - (widget-get widget :off-glyph)))) + (widget-glyph-insert widget + (widget-get widget :off) + (widget-get widget :off-glyph)))) (defun widget-toggle-action (widget &optional event) ;; Toggle value. @@ -2184,7 +2357,7 @@ ;; Insert all values (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) (args (widget-get widget :args))) - (while args + (while args (widget-checklist-add-item widget (car args) (assq (car args) alist)) (setq args (cdr args))) (widget-put widget :children (nreverse (widget-get widget :children))))) @@ -2194,8 +2367,8 @@ ;; If the item is checked, CHOSEN is a cons whose cdr is the value. (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-specify-insert + (insert-char ?\ (widget-get widget :indent))) + (widget-specify-insert (let* ((children (widget-get widget :children)) (buttons (widget-get widget :buttons)) (button-args (or (widget-get type :sibling-args) @@ -2227,7 +2400,7 @@ (t (widget-create-child-value widget type (car (cdr chosen))))))) - (t + (t (error "Unknown escape `%c'" escape))))) ;; Update properties. (and button child (widget-put child :button button)) @@ -2267,14 +2440,14 @@ found) (while vals (let ((answer (widget-checklist-match-up args vals))) - (cond (answer + (cond (answer (let ((match (widget-match-inline answer vals))) (setq found (cons (cons answer (car match)) found) vals (cdr match) args (delq answer args)))) (greedy (setq vals (cdr vals))) - (t + (t (setq vals nil))))) found)) @@ -2293,7 +2466,7 @@ ;; The values of all selected items. (let ((children (widget-get widget :children)) child result) - (while children + (while children (setq child (car children) children (cdr children)) (if (widget-value (widget-get child :button)) @@ -2334,7 +2507,7 @@ :button-suffix "" :button-prefix "" :on "(*)" - :on-glyph "radio1" + :on-glyph '("radio1" nil "radio0") :off "( )" :off-glyph "radio0") @@ -2366,7 +2539,7 @@ ;; Insert all values (let ((args (widget-get widget :args)) arg) - (while args + (while args (setq arg (car args) args (cdr args)) (widget-radio-add-item widget arg)))) @@ -2376,8 +2549,8 @@ ;; (setq type (widget-convert type)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-specify-insert + (insert-char ?\ (widget-get widget :indent))) + (widget-specify-insert (let* ((value (widget-get widget :value)) (children (widget-get widget :children)) (buttons (widget-get widget :buttons)) @@ -2397,7 +2570,7 @@ (insert "%")) ((eq escape ?b) (setq button (apply 'widget-create-child-and-convert - widget 'radio-button + widget 'radio-button :value (not (null chosen)) button-args))) ((eq escape ?v) @@ -2405,14 +2578,14 @@ (widget-create-child-value widget type value) (widget-create-child widget type))) - (unless chosen + (unless chosen (widget-apply child :deactivate))) - (t + (t (error "Unknown escape `%c'" escape))))) ;; Update properties. (when chosen (widget-put widget :choice type)) - (when button + (when button (widget-put child :button button) (widget-put widget :buttons (nconc buttons (list button)))) (when child @@ -2465,8 +2638,8 @@ (match (and (not found) (widget-apply current :match value)))) (widget-value-set button match) - (if match - (progn + (if match + (progn (widget-value-set current value) (widget-apply current :activate)) (widget-apply current :deactivate)) @@ -2509,12 +2682,12 @@ (define-widget 'insert-button 'push-button "An insert button for the `editable-list' widget." :tag "INS" - :help-echo "Insert a new item into the list at this position." + :help-echo "Insert a new item into the list at this position" :action 'widget-insert-button-action) (defun widget-insert-button-action (widget &optional event) ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) + (widget-apply (widget-get widget :parent) :insert-before (widget-get widget :widget))) ;;; The `delete-button' Widget. @@ -2522,12 +2695,12 @@ (define-widget 'delete-button 'push-button "A delete button for the `editable-list' widget." :tag "DEL" - :help-echo "Delete this item from the list." + :help-echo "Delete this item from the list" :action 'widget-delete-button-action) (defun widget-delete-button-action (widget &optional event) ;; Ask the parent to insert a new item. - (widget-apply (widget-get widget :parent) + (widget-apply (widget-get widget :parent) :delete-at (widget-get widget :widget))) ;;; The `editable-list' Widget. @@ -2559,11 +2732,11 @@ (let ((widget-push-button-gui widget-editable-list-gui)) (cond ((eq escape ?i) (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (apply 'widget-create-child-and-convert + (insert-char ?\ (widget-get widget :indent))) + (apply 'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) - (t + (t (widget-default-format-handler widget escape))))) (defun widget-editable-list-value-create (widget) @@ -2617,11 +2790,11 @@ (inhibit-read-only t) before-change-functions after-change-functions) - (cond (before + (cond (before (goto-char (widget-get before :entry-from))) (t (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create + (let ((child (widget-editable-list-entry-create widget nil nil))) (when (< (widget-get child :entry-from) (widget-get widget :from)) (set-marker (widget-get widget :from) @@ -2667,10 +2840,10 @@ (let ((type (nth 0 (widget-get widget :args))) (widget-push-button-gui widget-editable-list-gui) child delete insert) - (widget-specify-insert + (widget-specify-insert (save-excursion (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) (insert (widget-get widget :entry-format))) ;; Parse % escapes in format. (while (re-search-forward "%\\(.\\)" nil t) @@ -2688,13 +2861,13 @@ (widget-get widget :delete-button-args)))) ((eq escape ?v) (if conv - (setq child (widget-create-child-value + (setq child (widget-create-child-value widget type value)) (setq child (widget-create-child widget type)))) - (t + (t (error "Unknown escape `%c'" escape))))) - (widget-put widget - :buttons (cons delete + (widget-put widget + :buttons (cons delete (cons insert (widget-get widget :buttons)))) (let ((entry-from (copy-marker (point-min))) @@ -2732,7 +2905,7 @@ value (cdr answer)) (and (eq (preceding-char) ?\n) (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) + (insert-char ?\ (widget-get widget :indent))) (push (cond ((null answer) (widget-create-child widget arg)) ((widget-get arg :inline) @@ -2793,8 +2966,8 @@ widget-push-button-suffix)) (setq off "")) (if (widget-value widget) - (widget-glyph-insert widget on "down" "down-pushed") - (widget-glyph-insert widget off "right" "right-pushed")))) + (widget-glyph-insert widget on '("down" "down-pushed")) + (widget-glyph-insert widget off '("right" "right-pushed"))))) ;;; The `documentation-link' Widget. ;; @@ -2865,7 +3038,7 @@ (widget-put widget :buttons buttons))) (let ((indent (widget-get widget :indent))) (when (and indent (not (zerop indent))) - (save-excursion + (save-excursion (save-restriction (narrow-to-region from to) (goto-char (point-min)) @@ -2896,24 +3069,17 @@ (push (widget-create-child-and-convert widget 'visibility :help-echo (lambda (widget) - ;; This can get called directly from - ;; default-mouse-motion-handler, with an - ;; extent argument. - (and (extentp widget) - (setq - widget (widget-at - (extent-start-position widget)))) (concat (if (widget-value widget) "Hide" "Show") - " the rest of the documentation.")) + " the rest of the documentation")) :off "More" :action 'widget-parent-action shown) buttons) (when shown (setq start (point)) - (when (and indent (not (zerop indent))) + (when indent (insert-char ?\ indent)) (insert after) (widget-documentation-link-add widget start (point))) @@ -2925,7 +3091,7 @@ (defun widget-documentation-string-action (widget &rest ignore) ;; Toggle documentation. (let ((parent (widget-get widget :parent))) - (widget-put parent :documentation-shown + (widget-put parent :documentation-shown (not (widget-get parent :documentation-shown)))) ;; Redraw. (widget-value-set widget (widget-value widget))) @@ -2982,15 +3148,15 @@ (defun widget-regexp-validate (widget) "Check that the value of WIDGET is a valid regexp." - (let ((val (widget-value widget))) + (let ((value (widget-value widget))) (condition-case data (prog1 nil - (string-match val "")) + (string-match value "")) (error (widget-put widget :error (error-message-string data)) widget)))) (define-widget 'file 'string - "A file widget. + "A file widget. It will read a file name from the minibuffer when invoked." :complete-function 'widget-file-complete :prompt-value 'widget-file-prompt-value @@ -3050,7 +3216,7 @@ ;;; (widget-apply widget :notify widget event))) (define-widget 'directory 'file - "A directory widget. + "A directory widget. It will read a directory name from the minibuffer when invoked." :tag "Directory") @@ -3078,7 +3244,7 @@ (defun widget-symbol-prompt-internal (widget prompt initial history) ;; Read file from minibuffer. - (let ((answer (completing-read prompt obarray + (let ((answer (completing-read prompt obarray (widget-get widget :prompt-match) nil initial history))) (if (and (stringp answer) @@ -3251,12 +3417,12 @@ "A character." :tag "Character" :value 0 - :size 1 + :size 1 :format "%{%t%}: %v\n" - :valid-regexp "\\`.\\'" + :valid-regexp "\\`[\0-\377]\\'" :error "This field should contain a single character" :value-to-internal (lambda (widget value) - (if (stringp value) + (if (stringp value) value (char-to-string value))) :value-to-external (lambda (widget value) @@ -3279,7 +3445,7 @@ :value-to-internal (lambda (widget value) (append value nil)) :value-to-external (lambda (widget value) (vconcat value))) -(defun widget-vector-match (widget value) +(defun widget-vector-match (widget value) (and (vectorp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) @@ -3294,7 +3460,7 @@ :value-to-external (lambda (widget value) (cons (car value) (cadr value)))) -(defun widget-cons-match (widget value) +(defun widget-cons-match (widget value) (and (consp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) @@ -3308,7 +3474,7 @@ :prompt-value 'widget-choice-prompt-value) (defun widget-choice-prompt-value (widget prompt value unbound) - "Make a choice." + "Make a choice." (let ((args (widget-get widget :args)) (completion-ignore-case (widget-get widget :case-fold)) current choices old) @@ -3381,7 +3547,7 @@ ;;; The `color' Widget. -(define-widget 'color 'editable-field +(define-widget 'color 'editable-field "Choose a color name (with sample)." :format "%[%t%]: %v (%{sample%})\n" :size 10 @@ -3403,7 +3569,7 @@ ((null completion) (error "Can't find completion for \"%s\"" prefix)) ((not (string-equal prefix completion)) - (insert-and-inherit (substring completion (length prefix)))) + (insert (substring completion (length prefix)))) (t (message "Making completion list...") (let ((list (all-completions prefix list nil))) @@ -3412,13 +3578,17 @@ (message "Making completion list...done"))))) (defun widget-color-sample-face-get (widget) - (let* ((value (condition-case nil - (widget-value widget) - (error (widget-get widget :value)))) - (symbol (intern (concat "fg:" value)))) - (prog1 symbol - (or (find-face symbol) - (set-face-foreground (make-face symbol) value))))) + (or (widget-get widget :sample-face) + (let ((color (widget-value widget)) + (face (make-face (gensym "sample-face-") nil t))) + ;; Use the face object, not its name, to prevent lossage if gc + ;; happens before applying the face. + (widget-put widget :sample-face face) + (and color + (not (equal color "")) + (valid-color-name-p color) + (set-face-foreground face color)) + face))) (defvar widget-color-choice-list nil) ;; Variable holding the possible colors. @@ -3441,10 +3611,14 @@ (defun widget-color-notify (widget child &optional event) "Update the sample, and notify the parent." - (set-extent-property (widget-get widget :sample-extent) - 'face (widget-apply widget :sample-face-get)) + (let* ((face (widget-apply widget :sample-face-get)) + (color (widget-value widget))) + (if (valid-color-name-p color) + (set-face-foreground face color) + (remove-face-property face 'foreground))) (widget-default-notify widget child event)) +;; Is this a misnomer? (defun widget-at (pos) "The button or field at POS." (or (get-char-property pos 'button) @@ -3454,11 +3628,10 @@ "Display the help echo for widget at POS." (let* ((widget (widget-at pos)) (help-echo (and widget (widget-get widget :help-echo)))) - (cond ((stringp help-echo) - (message "%s" help-echo)) - ((and (functionp help-echo) - (stringp (setq help-echo (funcall help-echo widget)))) - (message "%s" help-echo))))) + (and (functionp help-echo) + (setq help-echo (funcall help-echo widget))) + (when (stringp help-echo) + (display-message 'no-log help-echo)))) ;;; The End:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/default.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,1 @@ +;; default.el --- Site-wide file run after User's init file is run.
--- a/lisp/edebug/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/edebug/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,10 +1,9 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Sep 27 08:13:42 1997 ;;; Code: -(custom-put 'lisp 'custom-loads '("edebug")) -(custom-put 'edebug 'custom-loads '("edebug")) +(custom-add-loads 'lisp '("edebug")) +(custom-add-loads 'edebug '("edebug")) ;;; custom-load.el ends here
--- a/lisp/ediff/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -# -# Makefile for compiling and installing EDIFF -# - -# -------- USER MAY NEED TO CHANGE THESE --------------------- -# To compile under XEmacs, uncomment XEmacs-specific versions of the -# variables VERSION, EMACS, DATADIR and comment out the Emacs-specific -# versions. - -VERSION = 20.0 -EMACS = emacs-$(VERSION) -#VERSION = 20.3 -#EMACS = xemacs-$(VERSION) -PREFIX = /usr/local -DATADIR = $(PREFIX)/share -#DATADIR = $(PREFIX)/lib -LISPDIR = $(DATADIR)/emacs/site-lisp -INFODIR = $(PREFIX)/info -ETCDIR = $(DATADIR)/emacs/$(VERSION)/etc -COMPDIR = - -# --------- YOU PROBABLY DON'T WANT TO CHANGE THESE ---------------- -TeX = tex -TEXINDEX = texindex -MAKEINFO = makeinfo -INSTALL = install - -# --------- ONLY AUTHORIZED PERSONNEL BEYOND THIS POINT!!! ------------ -EDIFF = ediff-init.el ediff-help.el ediff-diff.el ediff-merg.el \ - ediff-wind.el ediff-util.el ediff-mult.el ediff-vers.el \ - ediff-ptch.el ediff.el ediff-hook.el ediff-tbar.el -EDIFFelc = $(COMPDIR)ediff-init.elc \ - $(COMPDIR)ediff-help.elc \ - $(COMPDIR)ediff-diff.elc \ - $(COMPDIR)ediff-merg.elc \ - $(COMPDIR)ediff-wind.elc \ - $(COMPDIR)ediff-util.elc \ - $(COMPDIR)ediff-mult.elc \ - $(COMPDIR)ediff-vers.elc \ - $(COMPDIR)ediff-ptch.elc \ - $(COMPDIR)ediff.elc \ - $(COMPDIR)ediff-hook.elc \ - $(COMPDIR)ediff-tbar.elc - -COMPILE_ARGS = -batch -f batch-byte-compile - - -all: hello elc goodbye dvi info - -elc: $(EDIFFelc) - -goodbye: - @echo "" - @echo "" - @echo "" - @echo " The above compiler warnings were normal -- don't panic!" - @echo "" - @echo " Please report bugs via M-x ediff-submit-report" - @echo "" - @echo "" - @echo "" - -hello: - @echo "" - @echo "" - @echo "Byte compiling using Emacs" - @echo "Use make EMACS=xemacs to compile under XEmacs" - @echo "" - @echo "" - @echo " The following compiler warnings are normal -- don't panic!" - @echo "" - @echo "" - @echo "" - -$(COMPDIR)ediff-init.elc: ediff-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-init.el - -$(COMPDIR)ediff-help.elc: ediff-help.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-help.el - -$(COMPDIR)ediff-hook.elc: ediff-hook.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-hook.el - -$(COMPDIR)ediff-tbar.elc: ediff-tbar.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-tbar.el - -$(COMPDIR)ediff-diff.elc: ediff-init.el ediff-diff.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-diff.el - -$(COMPDIR)ediff-merg.elc: ediff-init.el ediff-merg.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-merg.el - -$(COMPDIR)ediff-mult.elc: ediff-init.el ediff-mult.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-mult.el - -$(COMPDIR)ediff-vers.elc: ediff-init.el ediff-vers.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-vers.el - -$(COMPDIR)ediff-ptch.elc: ediff-init.el ediff-ptch.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-ptch.el - -$(COMPDIR)ediff.elc: ediff-init.el ediff.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff.el - -$(COMPDIR)ediff-util.elc: ediff-init.el ediff-util.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-util.el - -$(COMPDIR)ediff-wind.elc: ediff-init.el ediff-wind.el - @echo "" - $(EMACS) $(COMPILE_ARGS) ediff-wind.el - -ediff.dvi: ediff.texi - @echo "" - @echo "" - @echo "Making ediff.dvi --- a Printable Version of the Ediff Manual"; - @echo "" - $(TeX) ediff.texi - @echo "" - @echo "Indexing " - $(TEXINDEX) ediff.cp - $(TEXINDEX) ediff.fn - $(TEXINDEX) ediff.pg - $(TEXINDEX) ediff.vr - @echo "" - @echo "Texing Again"; - $(TeX) ediff.texi - @echo "" - -ediff: ediff.texi - @echo "" - @echo "" - @echo "Making Info Files for the Ediff Manual" - @echo "" - $(MAKEINFO) ediff.texi - @echo "Info done" - -dvi: ediff.dvi - -info: ediff - -install: all - $(INSTALL) -m444 $(EDIFF) $(LISPDIR) - $(INSTALL) -m644 ediff*.elc $(LISPDIR) - $(INSTALL) -m644 ediff.dvi $(ETCDIR) - $(INSTALL) -m444 ediff ediff-? $(INFODIR) - @echo "" - @echo "Please move ediff.texi to emacs-distribution-directory/man/" - @echo "" - -clean: - rm -f ediff*.elc *~ core - -distclean: clean - -realclean: clean - rm -f *.dvi ../info/ediff ../info/ediff-? - rm -f ediff.aux ediff.cp ediff.cps ediff.fn ediff.fns ediff.ky \ - ediff.kys ediff.log ediff.pg ediff.pgs ediff.toc ediff.tp \ - ediff.tps ediff.vr ediff.vrs
--- a/lisp/ediff/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ -**** EDIFF -- a comprehensive interface to diff for Emacs 19 and XEmacs 19 - -**** This version of Ediff requires *at least* Emacs 19.34 or XEmacs 19.14 - -This directory: - -README -- This file -Makefile -- Automated installation file -ediff.texi -- Manual in Texinfo format -ediff, ediff-? -- The Info files -ediff.dvi -- Manual in DVI format - -ediff.el -- Ediff Emacs Lisp code -ediff-init.el -- Ediff Emacs Lisp code -ediff-help.el -- Ediff Emacs Lisp code -ediff-wind.el -- Ediff Emacs Lisp code -ediff-util.el -- Ediff Emacs Lisp code -ediff-diff.el -- Ediff Emacs Lisp code -ediff-merg.el -- Ediff Emacs Lisp code -ediff-mult.el -- Ediff Emacs Lisp code -ediff-vers.el -- Ediff Emacs Lisp code -ediff-ptch.el -- Ediff Emacs Lisp code -ediff-tbar.el -- Ediff Emacs Lisp code -- for XEmacs only -ediff-hook.el -- Ediff Emacs Lisp code -toolbar/ -- Ediff toolbar icons -- for XEmacs only - - -To install Ediff do: - - uncompress ediff.tar.Z - tar xf ediff.tar - - -Then do the following: - -1. To compile Lisp: - - make (or 'make all') - -2. You can also type - - make install - - to do what "make all" does plus it will copy the files ediff*.elc - into a suitable Lisp directory. - - To make this happen, you will most likely have to change the PREFIX - variable in Makefile and, possibly, one or more of these variables: - - DATADIR, LISPDIR, INFODIR, ETCDIR, and VERSION - - if they don't point to the right directories in your installation. - You also need to have a write permission for all directories - mentioned in LISPDIR, INFODIR, and ETCDIR. - -3. XEmacs users must invoke `make' with the parameter EMACS=xemacs - or whatever name is used to invoke XEmacs (some sites still use xemacs - for Emacs 18). An even better thing would be to edit Makefile directly - as indicated in the comments there. - -4. Under XEmacs, copy the icons in the `toolbar' directory into - the-directory-where-xemacs-installed/etc/toolbar/ - -Normally, all Ediff menus and autoloads are already defined in Emacs, so you -don't need to define anything in your .emacs to run Ediff. -However, if it was announced that this distribution of Ediff contains -new features, you may need to put - -(require 'ediff-hook) - -in your .emacs to take advantage of these new features. This doesn't load -Ediff, but readies Emacs for the things to come. When this version of -Ediff gets installed in the standard Emacs distribution, you can remove -the above require-statement (but leaving it in does no harm).
--- a/lisp/ediff/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'ediff-autoloads) (error "Already loaded")) - -;;;### (autoloads (ediff-show-registry) "ediff-mult" "ediff/ediff-mult.el") - -(autoload 'ediff-show-registry "ediff-mult" "\ -Display Ediff's registry." t nil) - -(defalias 'eregistry 'ediff-show-registry) - -;;;*** - -;;;### (autoloads (ediff-toggle-use-toolbar ediff-toggle-multiframe) "ediff-util" "ediff/ediff-util.el") - -(autoload 'ediff-toggle-multiframe "ediff-util" "\ -Switch from multiframe display to single-frame display and back. -To change the default, set the variable `ediff-window-setup-function', -which see." t nil) - -(autoload 'ediff-toggle-use-toolbar "ediff-util" "\ -Enable or disable Ediff toolbar. -Works only in versions of Emacs that support toolbars. -To change the default, set the variable `ediff-use-toolbar-p', which see." t nil) - -;;;*** - -;;;### (autoloads (ediff-documentation ediff-version ediff-revision ediff-patch-buffer ediff-patch-file run-ediff-from-cvs-buffer ediff-merge-revisions-with-ancestor ediff-merge-revisions ediff-merge-buffers-with-ancestor ediff-merge-buffers ediff-merge-files-with-ancestor ediff-merge-files ediff-regions-linewise ediff-regions-wordwise ediff-windows-linewise ediff-windows-wordwise ediff-merge-directory-revisions-with-ancestor ediff-merge-directory-revisions ediff-merge-directories-with-ancestor ediff-merge-directories ediff-directories3 ediff-directory-revisions ediff-directories ediff-buffers3 ediff-buffers ediff-files3 ediff-files) "ediff" "ediff/ediff.el") - -(autoload 'ediff-files "ediff" "\ -Run Ediff on a pair of files, FILE-A and FILE-B." t nil) - -(autoload 'ediff-files3 "ediff" "\ -Run Ediff on three files, FILE-A, FILE-B, and FILE-C." t nil) - -(defalias 'ediff3 'ediff-files3) - -(defalias 'ediff 'ediff-files) - -(autoload 'ediff-buffers "ediff" "\ -Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B." t nil) - -(defalias 'ebuffers 'ediff-buffers) - -(autoload 'ediff-buffers3 "ediff" "\ -Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C." t nil) - -(defalias 'ebuffers3 'ediff-buffers3) - -(autoload 'ediff-directories "ediff" "\ -Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." t nil) - -(defalias 'edirs 'ediff-directories) - -(autoload 'ediff-directory-revisions "ediff" "\ -Run Ediff on a directory, DIR1, comparing its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." t nil) - -(defalias 'edir-revisions 'ediff-directory-revisions) - -(autoload 'ediff-directories3 "ediff" "\ -Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that -have the same name in all three. The last argument, REGEXP, is a regular -expression that can be used to filter out certain file names." t nil) - -(defalias 'edirs3 'ediff-directories3) - -(autoload 'ediff-merge-directories "ediff" "\ -Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." t nil) - -(defalias 'edirs-merge 'ediff-merge-directories) - -(autoload 'ediff-merge-directories-with-ancestor "ediff" "\ -Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors. -Ediff merges files that have identical names in DIR1, DIR2. If a pair of files -in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge -without ancestor. The fourth argument, REGEXP, is a regular expression that -can be used to filter out certain file names." t nil) - -(autoload 'ediff-merge-directory-revisions "ediff" "\ -Run Ediff on a directory, DIR1, merging its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." t nil) - -(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions) - -(autoload 'ediff-merge-directory-revisions-with-ancestor "ediff" "\ -Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." t nil) - -(defalias 'edir-merge-revisions-with-ancestor 'ediff-merge-directory-revisions-with-ancestor) - -(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor) - -(autoload 'ediff-windows-wordwise "ediff" "\ -Compare WIND-A and WIND-B, which are selected by clicking, wordwise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." t nil) - -(autoload 'ediff-windows-linewise "ediff" "\ -Compare WIND-A and WIND-B, which are selected by clicking, linewise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." t nil) - -(autoload 'ediff-regions-wordwise "ediff" "\ -Run Ediff on a pair of regions in two different buffers. -Regions (i.e., point and mark) are assumed to be set in advance. -This function is effective only for relatively small regions, up to 200 -lines. For large regions, use `ediff-regions-linewise'." t nil) - -(autoload 'ediff-regions-linewise "ediff" "\ -Run Ediff on a pair of regions in two different buffers. -Regions (i.e., point and mark) are assumed to be set in advance. -Each region is enlarged to contain full lines. -This function is effective for large regions, over 100-200 -lines. For small regions, use `ediff-regions-wordwise'." t nil) - -(defalias 'ediff-merge 'ediff-merge-files) - -(autoload 'ediff-merge-files "ediff" "\ -Merge two files without ancestor." t nil) - -(autoload 'ediff-merge-files-with-ancestor "ediff" "\ -Merge two files with ancestor." t nil) - -(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor) - -(autoload 'ediff-merge-buffers "ediff" "\ -Merge buffers without ancestor." t nil) - -(autoload 'ediff-merge-buffers-with-ancestor "ediff" "\ -Merge buffers with ancestor." t nil) - -(autoload 'ediff-merge-revisions "ediff" "\ -Run Ediff by merging two revisions of a file. -The file is the optional FILE argument or the file visited by the current -buffer." t nil) - -(autoload 'ediff-merge-revisions-with-ancestor "ediff" "\ -Run Ediff by merging two revisions of a file with a common ancestor. -The file is the the optional FILE argument or the file visited by the current -buffer." t nil) - -(autoload 'run-ediff-from-cvs-buffer "ediff" "\ -Run Ediff-merge on appropriate revisions of the selected file. -First run after `M-x cvs-update'. Then place the cursor on a line describing a -file and then run `run-ediff-from-cvs-buffer'." t nil) - -(autoload 'ediff-patch-file "ediff" "\ -Run Ediff by patching SOURCE-FILENAME." t nil) - -(autoload 'ediff-patch-buffer "ediff" "\ -Run Ediff by patching BUFFER-NAME." t nil) - -(defalias 'epatch 'ediff-patch-file) - -(defalias 'epatch-buffer 'ediff-patch-buffer) - -(autoload 'ediff-revision "ediff" "\ -Run Ediff by comparing versions of a file. -The file is an optional FILE argument or the file visited by the current -buffer. Use `vc.el' or `rcs.el' depending on `ediff-version-control-package'." t nil) - -(defalias 'erevision 'ediff-revision) - -(autoload 'ediff-version "ediff" "\ -Return string describing the version of Ediff. -When called interactively, displays the version." t nil) - -(autoload 'ediff-documentation "ediff" "\ -Display Ediff's manual. -With optional NODE, goes to that node." t nil) - -;;;*** - -(provide 'ediff-autoloads)
--- a/lisp/ediff/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Oct 4 18:11:25 1997 - -;;; Code: - -(custom-put 'tools 'custom-loads '("ediff")) -(custom-put 'ediff-diff 'custom-loads '("ediff-diff")) -(custom-put 'frames 'custom-loads '("ediff-wind")) -(custom-put 'ediff-ptch 'custom-loads '("ediff-ptch")) -(custom-put 'ediff-merge 'custom-loads '("ediff-merg")) -(custom-put 'ediff-mult 'custom-loads '("ediff-mult")) -(custom-put 'ediff 'custom-loads '("ediff-diff" "ediff-init" "ediff-merg" "ediff-mult" "ediff-ptch" "ediff-wind" "ediff")) - -;;; custom-load.el ends here
--- a/lisp/ediff/ediff-diff.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1246 +0,0 @@ -;;; ediff-diff.el --- diff-related utilities - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-diff) - -;; compiler pacifier -(defvar ediff-default-variant) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defgroup ediff-diff nil - "Diff related utilities" - :prefix "ediff-" - :group 'ediff) - - -(defcustom ediff-shell - (cond ((eq system-type 'emx) "cmd") ; OS/2 - ((memq system-type '(ms-dos windows-nt windows-95)) - shell-file-name) ; no standard name on MS-DOS - ((memq system-type '(vax-vms axp-vms)) "*dcl*") ; VMS - (t "sh")) ; UNIX - "*The shell used to run diff and patch. If user's .profile or -.cshrc files are set up correctly, any shell will do. However, some people -set $prompt or other things incorrectly, which leads to undesirable output -messages. These may cause Ediff to fail. In such a case, set ediff-shell -to a shell that you are not using or, better, fix your shell's startup file." - :type 'string - :group 'ediff-diff) - - -(defcustom ediff-diff-program "diff" - "*Program to use for generating the differential of the two files." - :type 'string - :group 'ediff-diff) -(defcustom ediff-diff-options "" - "*Options to pass to `ediff-diff-program'. -If diff\(1\) is used as `ediff-diff-program', then the most useful options are -`-w', to ignore space, and `-i', to ignore case of letters. -At present, the option `-c' is not allowed." - :type 'string - :group 'ediff-diff) - -(defcustom ediff-custom-diff-program ediff-diff-program - "*Program to use for generating custom diff output for saving it in a file. -This output is not used by Ediff internally." - :type 'string - :group 'ediff-diff) -(defcustom ediff-custom-diff-options "-c" - "*Options to pass to `ediff-custom-diff-program'." - :type 'string - :group 'ediff-diff) - -;;; Support for diff3 - -(defvar ediff-match-diff3-line "^====\\(.?\\)$" - "Pattern to match lines produced by diff3 that describe differences.") -(defcustom ediff-diff3-program "diff3" - "*Program to be used for three-way comparison. -Must produce output compatible with Unix's diff3 program." - :type 'string - :group 'ediff-diff) -(defcustom ediff-diff3-options "" - "*Options to pass to `ediff-diff3-program'." - :type 'string - :group 'ediff-diff) -(defcustom ediff-diff3-ok-lines-regexp - "^\\([1-3]:\\|====\\| \\|.*Warning *:\\|.*No newline\\|.*missing newline\\|^\C-m$\\)" - "*Regexp that matches normal output lines from `ediff-diff3-program'. -Lines that do not match are assumed to be error messages." - :type 'regexp - :group 'ediff-diff) - -;; keeps the status of the current diff in 3-way jobs. -;; the status can be =diff(A), =diff(B), or =diff(A+B) -(ediff-defvar-local ediff-diff-status "" "") - - -;;; Fine differences - -(ediff-defvar-local ediff-auto-refine (if (ediff-has-face-support-p) 'on 'nix) - "If `on', Ediff auto-highlights fine diffs for the current diff region. -If `off', auto-highlighting is not used. If `nix', no fine diffs are shown -at all, unless the user force-refines the region by hitting `*'. - -This variable can be set either in .emacs or toggled interactively. -Use `setq-default' if setting it in .emacs") - -(ediff-defvar-local ediff-ignore-similar-regions nil - "*If t, skip over difference regions that differ only in the white space and line breaks. -This variable can be set either in .emacs or toggled interactively. -Use `setq-default' if setting it in .emacs") - -(ediff-defvar-local ediff-auto-refine-limit 1400 - "*Auto-refine only the regions of this size \(in bytes\) or less.") - -;;; General - -(defvar ediff-diff-ok-lines-regexp - "^\\([0-9,]+[acd][0-9,]+$\\|[<>] \\|---\\|.*Warning *:\\|.*No +newline\\|.*missing +newline\\|^\C-m$\\)" - "Regexp that matches normal output lines from `ediff-diff-program'. -This is mostly lifted from Emerge, except that Ediff also considers -warnings and `Missing newline'-type messages to be normal output. -Lines that do not match are assumed to be error messages.") - -(defvar ediff-match-diff-line (let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)")) - (concat "^" x "\\([acd]\\)" x "$")) - "Pattern to match lines produced by diff that describe differences.") - -(ediff-defvar-local ediff-setup-diff-regions-function nil - "value is a function symbol depending on the kind of job is to be done. -For 2-way jobs and for ediff-merge, it should be `ediff-setup-diff-regions'. -For jobs requiring diff3, it should be `ediff-setup-diff-regions3'. - -The function should take three mandatory arguments, file-A, file-B, and -file-C. It may ignore file C for diff2 jobs. It should also take -one optional arguments, diff-number to refine.") - - -;;; Functions - -;; Generate the difference vector and overlays for the two files -;; With optional arg REG-TO-REFINE, refine this region. -;; File-C argument is not used here. It is there just because -;; ediff-setup-diff-regions is called via a funcall to -;; ediff-setup-diff-regions-function, which can also have the value -;; ediff-setup-diff-regions3, which takes 4 arguments. -(defun ediff-setup-diff-regions (file-A file-B file-C) - (if (string-match "c" ediff-diff-options) - (error "Option `-c' is not allowed in `ediff-diff-options'")) - - ;; create, if it doesn't exist - (or (ediff-buffer-live-p ediff-diff-buffer) - (setq ediff-diff-buffer - (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*")))) - (ediff-make-diff2-buffer ediff-diff-buffer file-A file-B) - (ediff-prepare-error-list ediff-diff-ok-lines-regexp ediff-diff-buffer) - (ediff-convert-diffs-to-overlays - (ediff-extract-diffs - ediff-diff-buffer ediff-word-mode ediff-narrow-bounds))) - -;; Run the diff program on FILE1 and FILE2 and put the output in DIFF-BUFFER -;; Return the size of DIFF-BUFFER -(defun ediff-make-diff2-buffer (diff-buffer file1 file2) - (let ((file1-size (ediff-file-size file1)) - (file2-size (ediff-file-size file2))) - (cond ((not (numberp file1-size)) - (message "Can't find file: %s" - (ediff-abbreviate-file-name file1)) - (sit-for 2) - ;; 1 is an error exit code - 1) - ((not (numberp file2-size)) - (message "Can't find file: %s" - (ediff-abbreviate-file-name file2)) - (sit-for 2) - ;; 1 is an error exit code - 1) - ((< file1-size 0) - (message "Can't diff remote files: %s" - (ediff-abbreviate-file-name file1)) - (sit-for 2) - ;; 1 is an error exit code - 1) - ((< file2-size 0) - (message "Can't diff remote file: %s" - (ediff-abbreviate-file-name file2)) - (sit-for 2) - (message "") - ;; 1 is an error exit code - 1) - (t (message "Computing differences between %s and %s ..." - (file-name-nondirectory file1) - (file-name-nondirectory file2)) - ;; this erases the diff buffer automatically - (ediff-exec-process ediff-diff-program - diff-buffer - 'synchronize - ediff-diff-options file1 file2) - (message "") - (ediff-with-current-buffer diff-buffer - (buffer-size)))))) - - - -;; If file-A/B/C is nil, do 2-way comparison with the non-nil buffers -;; This function works for diff3 and diff2 jobs -(defun ediff-setup-fine-diff-regions (file-A file-B file-C reg-num) - (or (ediff-buffer-live-p ediff-fine-diff-buffer) - (setq ediff-fine-diff-buffer - (get-buffer-create - (ediff-unique-buffer-name "*ediff-fine-diff" "*")))) - - (let (diff3-job diff-program diff-options ok-regexp diff-list) - (setq diff3-job ediff-3way-job - diff-program (if diff3-job ediff-diff3-program ediff-diff-program) - diff-options (if diff3-job ediff-diff3-options ediff-diff-options) - ok-regexp (if diff3-job - ediff-diff3-ok-lines-regexp - ediff-diff-ok-lines-regexp)) - - (ediff-message-if-verbose "Refining difference region %d ..." (1+ reg-num)) - (ediff-exec-process diff-program ediff-fine-diff-buffer 'synchronize - diff-options - ;; The shuffle below is because we can compare 3-way - ;; or in several 2-way fashions, like fA fC, fA fB, - ;; or fB fC. - (if file-A file-A file-B) - (if file-B file-B file-A) - (if diff3-job - (if file-C file-C file-B)) - ) ; exec process - - (ediff-prepare-error-list ok-regexp ediff-fine-diff-buffer) - (ediff-message-if-verbose - "") - ;; "Refining difference region %d ... done" (1+ reg-num)) - - (setq diff-list - (if diff3-job - (ediff-extract-diffs3 - ediff-fine-diff-buffer '3way-comparison 'word-mode) - (ediff-extract-diffs ediff-fine-diff-buffer 'word-mode))) - ;; fixup diff-list - (if diff3-job - (cond ((not file-A) - (mapcar (function (lambda (elt) - (aset elt 0 nil) - (aset elt 1 nil))) - (cdr diff-list))) - ((not file-B) - (mapcar (function (lambda (elt) - (aset elt 2 nil) - (aset elt 3 nil))) - (cdr diff-list))) - ((not file-C) - (mapcar (function (lambda (elt) - (aset elt 4 nil) - (aset elt 5 nil))) - (cdr diff-list))) - )) - - (ediff-convert-fine-diffs-to-overlays diff-list reg-num) - )) - - -(defun ediff-prepare-error-list (ok-regexp diff-buff) - (or (ediff-buffer-live-p ediff-error-buffer) - (setq ediff-error-buffer - (get-buffer-create (ediff-unique-buffer-name - "*ediff-errors" "*")))) - (ediff-with-current-buffer ediff-error-buffer - (erase-buffer) - (insert (ediff-with-current-buffer diff-buff (buffer-string))) - (goto-char (point-min)) - (delete-matching-lines ok-regexp) - (if (memq system-type '(vax-vms axp-vms)) - (delete-matching-lines "^$"))) - ;; If diff reports errors, show them then quit. - (if (/= 0 (ediff-with-current-buffer ediff-error-buffer (buffer-size))) - (let ((ctl-buf ediff-control-buffer) - (error-buf ediff-error-buffer)) - (ediff-skip-unsuitable-frames) - (switch-to-buffer error-buf) - (ediff-kill-buffer-carefully ctl-buf) - (error "Errors in diff output. Diff output is in %S" diff-buff)))) - -;; BOUNDS specifies visibility bounds to use. -;; WORD-MODE tells whether we are in the word-mode or not. -;; If WORD-MODE, also construct vector of diffs using word numbers. -;; Else, use point values. -;; This function handles diff-2 jobs including the case of -;; merging buffers and files without ancestor. -(defun ediff-extract-diffs (diff-buffer word-mode &optional bounds) - (let ((A-buffer ediff-buffer-A) - (B-buffer ediff-buffer-B) - (C-buffer ediff-buffer-C) - (a-prev 1) ; this is needed to set the first diff line correctly - (b-prev 1) - (c-prev 1) - diff-list shift-A shift-B - ) - - ;; diff list contains word numbers, unless changed later - (setq diff-list (cons (if word-mode 'words 'points) - diff-list)) - ;; we don't use visibility bounds for buffer C when merging - (if bounds - (setq shift-A - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'A bounds)) - shift-B - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'B bounds)))) - - ;; reset point in buffers A/B/C - (ediff-with-current-buffer A-buffer - (goto-char (if shift-A shift-A (point-min)))) - (ediff-with-current-buffer B-buffer - (goto-char (if shift-B shift-B (point-min)))) - (if (ediff-buffer-live-p C-buffer) - (ediff-with-current-buffer C-buffer - (goto-char (point-min)))) - - (ediff-with-current-buffer diff-buffer - (goto-char (point-min)) - (while (re-search-forward ediff-match-diff-line nil t) - (let* ((a-begin (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (a-end (let ((b (match-beginning 3)) - (e (match-end 3))) - (if b - (string-to-int (buffer-substring b e)) - a-begin))) - (diff-type (buffer-substring (match-beginning 4) (match-end 4))) - (b-begin (string-to-int (buffer-substring (match-beginning 5) - (match-end 5)))) - (b-end (let ((b (match-beginning 7)) - (e (match-end 7))) - (if b - (string-to-int (buffer-substring b e)) - b-begin))) - a-begin-pt a-end-pt b-begin-pt b-end-pt - c-begin c-end c-begin-pt c-end-pt) - ;; fix the beginning and end numbers, because diff is somewhat - ;; strange about how it numbers lines - (if (string-equal diff-type "a") - (setq b-end (1+ b-end) - a-begin (1+ a-begin) - a-end a-begin) - (if (string-equal diff-type "d") - (setq a-end (1+ a-end) - b-begin (1+ b-begin) - b-end b-begin) - ;; (string-equal diff-type "c") - (setq a-end (1+ a-end) - b-end (1+ b-end)))) - - (if (eq ediff-default-variant 'default-B) - (setq c-begin b-begin - c-end b-end) - (setq c-begin a-begin - c-end a-end)) - - ;; compute main diff vector - (if word-mode - ;; make diff-list contain word numbers - (setq diff-list - (nconc diff-list - (list - (if (ediff-buffer-live-p C-buffer) - (vector (- a-begin a-prev) (- a-end a-begin) - (- b-begin b-prev) (- b-end b-begin) - (- c-begin c-prev) (- c-end c-begin) - nil nil ; dummy ancestor - nil ; state of diff - nil ; state of merge - nil ; state of ancestor - ) - (vector (- a-begin a-prev) (- a-end a-begin) - (- b-begin b-prev) (- b-end b-begin) - nil nil ; dummy buf C - nil nil ; dummy ancestor - nil ; state of diff - nil ; state of merge - nil ; state of ancestor - )) - )) - a-prev a-end - b-prev b-end - c-prev c-end) - ;; else convert lines to points - (ediff-with-current-buffer A-buffer - (forward-line (- a-begin a-prev)) - (setq a-begin-pt (point)) - (forward-line (- a-end a-begin)) - (setq a-end-pt (point) - a-prev a-end)) - (ediff-with-current-buffer B-buffer - (forward-line (- b-begin b-prev)) - (setq b-begin-pt (point)) - (forward-line (- b-end b-begin)) - (setq b-end-pt (point) - b-prev b-end)) - (if (ediff-buffer-live-p C-buffer) - (ediff-with-current-buffer C-buffer - (forward-line (- c-begin c-prev)) - (setq c-begin-pt (point)) - (forward-line (- c-end c-begin)) - (setq c-end-pt (point) - c-prev c-end))) - (setq diff-list - (nconc - diff-list - (list - (if (ediff-buffer-live-p C-buffer) - (vector - a-begin-pt a-end-pt b-begin-pt b-end-pt - c-begin-pt c-end-pt - nil nil ; dummy ancestor - ;; state of diff - ;; shows which buff is different from the other two - (if (eq ediff-default-variant 'default-B) 'A 'B) - ediff-default-variant ; state of merge - nil ; state of ancestor - ) - (vector a-begin-pt a-end-pt - b-begin-pt b-end-pt - nil nil ; dummy buf C - nil nil ; dummy ancestor - nil nil ; dummy state of diff & merge - nil ; dummy state of ancestor - ))) - ))) - - ))) ; end ediff-with-current-buffer - diff-list - )) - - -(defun ediff-convert-diffs-to-overlays (diff-list) - (ediff-set-diff-overlays-in-one-buffer 'A diff-list) - (ediff-set-diff-overlays-in-one-buffer 'B diff-list) - (if ediff-3way-job - (ediff-set-diff-overlays-in-one-buffer 'C diff-list)) - (if ediff-merge-with-ancestor-job - (ediff-set-diff-overlays-in-one-buffer 'Ancestor diff-list)) - ;; set up vector showing the status of merge regions - (if ediff-merge-job - (setq ediff-state-of-merge - (vconcat - (mapcar (function - (lambda (elt) - (let ((state-of-merge (aref elt 9)) - (state-of-ancestor (aref elt 10))) - (vector - (if state-of-merge (format "%S" state-of-merge)) - state-of-ancestor)))) - ;; the first elt designates type of list - (cdr diff-list)) - ))) - (message "Processing difference regions ... done")) - - -(defun ediff-set-diff-overlays-in-one-buffer (buf-type diff-list) - (let* ((current-diff -1) - (buff (ediff-get-buffer buf-type)) - ;; ediff-extract-diffs puts the type of diff-list as the first elt - ;; of this list. The type is either 'points or 'words - (diff-list-type (car diff-list)) - (shift (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - buf-type ediff-narrow-bounds))) - (limit (ediff-overlay-end - (ediff-get-value-according-to-buffer-type - buf-type ediff-narrow-bounds))) - diff-overlay-list list-element total-diffs - begin end pt-saved overlay state-of-diff) - - (setq diff-list (cdr diff-list)) ; discard diff list type - (setq total-diffs (length diff-list)) - - ;; shift, if necessary - (ediff-with-current-buffer buff (setq pt-saved shift)) - - (while diff-list - (setq current-diff (1+ current-diff) - list-element (car diff-list) - begin (aref list-element (cond ((eq buf-type 'A) 0) - ((eq buf-type 'B) 2) - ((eq buf-type 'C) 4) - (t 6))) ; Ancestor - end (aref list-element (cond ((eq buf-type 'A) 1) - ((eq buf-type 'B) 3) - ((eq buf-type 'C) 5) - (t 7))) ; Ancestor - state-of-diff (aref list-element 8) - ) - - (cond ((and (not (eq buf-type state-of-diff)) - (not (eq buf-type 'Ancestor)) - (memq state-of-diff '(A B C))) - (setq state-of-diff - (car (delq buf-type (delq state-of-diff (list 'A 'B 'C))))) - (setq state-of-diff (format "=diff(%S)" state-of-diff)) - ) - (t (setq state-of-diff nil))) - - ;; Put overlays at appropriate places in buffer - ;; convert word numbers to points, if necessary - (if (eq diff-list-type 'words) - (progn - (ediff-with-current-buffer buff (goto-char pt-saved)) - (setq begin (ediff-goto-word (1+ begin) buff) - end (ediff-goto-word end buff 'end)) - (if (> end limit) (setq end limit)) - (if (> begin end) (setq begin end)) - (setq pt-saved (ediff-with-current-buffer buff (point))))) - (setq overlay (ediff-make-bullet-proof-overlay begin end buff)) - - (ediff-overlay-put overlay 'priority ediff-shadow-overlay-priority) - (ediff-overlay-put overlay 'ediff-diff-num current-diff) - (if (and (ediff-has-face-support-p) - ediff-use-faces ediff-highlight-all-diffs) - (ediff-set-overlay-face - overlay (ediff-background-face buf-type current-diff))) - - (if (= 0 (mod current-diff 10)) - (message "Buffer %S: Processing difference region %d of %d" - buf-type current-diff total-diffs)) - ;; record all overlays for this difference - ;; the second elt, nil, is a place holder for the fine diff vector. - ;; the third elt, nil, is a place holder for no-fine-diffs flag. - (setq diff-overlay-list - (nconc - diff-overlay-list - (list (vector overlay nil nil state-of-diff))) - diff-list - (cdr diff-list)) - ) ; while - - (set (ediff-get-symbol-from-alist buf-type ediff-difference-vector-alist) - (vconcat diff-overlay-list)) - )) - -;; `n' is the diff region to work on. Default is ediff-current-difference. -;; if `flag' is 'noforce then make fine-diffs only if this region's fine -;; diffs have not been computed before. -;; if `flag' is 'skip then don't compute fine diffs for this region. -(defun ediff-make-fine-diffs (&optional n flag) - (or n (setq n ediff-current-difference)) - - (if (< ediff-number-of-differences 1) - (error ediff-NO-DIFFERENCES)) - - (if ediff-word-mode - (setq flag 'skip - ediff-auto-refine 'nix)) - - (or (< n 0) - (>= n ediff-number-of-differences) - ;; n is within the range - (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer)) - (file-A ediff-temp-file-A) - (file-B ediff-temp-file-B) - (file-C ediff-temp-file-C) - (empty-A (ediff-empty-diff-region-p n 'A)) - (empty-B (ediff-empty-diff-region-p n 'B)) - (empty-C (ediff-empty-diff-region-p n 'C)) - (whitespace-A (ediff-whitespace-diff-region-p n 'A)) - (whitespace-B (ediff-whitespace-diff-region-p n 'B)) - (whitespace-C (ediff-whitespace-diff-region-p n 'C)) - cumulative-fine-diff-length) - - (cond ;; If one of the regions is empty (or 2 in 3way comparison) - ;; then don't refine. - ;; If the region happens to be entirely whitespace or empty then - ;; mark as such. - ((> (length (delq nil (list empty-A empty-B empty-C))) 1) - (if (and (ediff-looks-like-combined-merge n) - ediff-merge-job) - (ediff-set-fine-overlays-in-one-buffer 'C nil n)) - (if ediff-3way-comparison-job - (ediff-message-if-verbose - "Region %d is empty in all buffers but %S" - (1+ n) - (cond ((not empty-A) 'A) - ((not empty-B) 'B) - ((not empty-C) 'C))) - (ediff-message-if-verbose - "Region %d in buffer %S is empty" - (1+ n) - (cond (empty-A 'A) - (empty-B 'B) - (empty-C 'C))) - ) - ;; if all regions happen to be whitespace - (if (and whitespace-A whitespace-B whitespace-C) - ;; mark as space only - (ediff-mark-diff-as-space-only n t) - ;; if some regions are white and others don't, then mark as - ;; non-white-space-only - (ediff-mark-diff-as-space-only n nil))) - - ;; don't compute fine diffs if diff vector exists - ((and (eq flag 'noforce) (ediff-get-fine-diff-vector n 'A)) - (if (ediff-no-fine-diffs-p n) - (message - "Only white-space differences in region %d %s" - (1+ n) - (cond ((eq (ediff-no-fine-diffs-p n) 'A) - "in buffers B & C") - ((eq (ediff-no-fine-diffs-p n) 'B) - "in buffers A & C") - ((eq (ediff-no-fine-diffs-p n) 'C) - "in buffers A & B") - (t ""))))) - ;; don't compute fine diffs for this region - ((eq flag 'skip) - (or (ediff-get-fine-diff-vector n 'A) - (memq ediff-auto-refine '(off nix)) - (ediff-message-if-verbose - "Region %d exceeds auto-refine limit. Type `%s' to refine" - (1+ n) - (substitute-command-keys - "\\[ediff-make-or-kill-fine-diffs]") - ))) - (t - ;; recompute fine diffs - (ediff-wordify - (ediff-get-diff-posn 'A 'beg n) - (ediff-get-diff-posn 'A 'end n) - ediff-buffer-A - tmp-buffer - ediff-control-buffer) - (setq file-A - (ediff-make-temp-file tmp-buffer "fineDiffA" file-A)) - - (ediff-wordify - (ediff-get-diff-posn 'B 'beg n) - (ediff-get-diff-posn 'B 'end n) - ediff-buffer-B - tmp-buffer - ediff-control-buffer) - (setq file-B - (ediff-make-temp-file tmp-buffer "fineDiffB" file-B)) - - (if ediff-3way-job - (progn - (ediff-wordify - (ediff-get-diff-posn 'C 'beg n) - (ediff-get-diff-posn 'C 'end n) - ediff-buffer-C - tmp-buffer - ediff-control-buffer) - (setq file-C - (ediff-make-temp-file - tmp-buffer "fineDiffC" file-C)))) - - ;; save temp file names. - (setq ediff-temp-file-A file-A - ediff-temp-file-B file-B - ediff-temp-file-C file-C) - - ;; set the new vector of fine diffs, if none exists - (cond ((and ediff-3way-job whitespace-A) - (ediff-setup-fine-diff-regions nil file-B file-C n)) - ((and ediff-3way-job whitespace-B) - (ediff-setup-fine-diff-regions file-A nil file-C n)) - ((and ediff-3way-job - ;; In merge-jobs, whitespace-C is t, since - ;; ediff-empty-diff-region-p returns t in this case - whitespace-C) - (ediff-setup-fine-diff-regions file-A file-B nil n)) - (t - (ediff-setup-fine-diff-regions file-A file-B file-C n))) - - (setq cumulative-fine-diff-length - (+ (length (ediff-get-fine-diff-vector n 'A)) - (length (ediff-get-fine-diff-vector n 'B)) - ;; in merge jobs, the merge buffer is never refined - (if (and file-C (not ediff-merge-job)) - (length (ediff-get-fine-diff-vector n 'C)) - 0))) - - (cond ((or - ;; all regions are white space - (and whitespace-A whitespace-B whitespace-C) - ;; none is white space and no fine diffs detected - (and (not whitespace-A) - (not whitespace-B) - (not (and ediff-3way-job whitespace-C)) - (eq cumulative-fine-diff-length 0))) - (ediff-mark-diff-as-space-only n t) - (ediff-message-if-verbose - "Only white-space differences in region %d" (1+ n))) - ((eq cumulative-fine-diff-length 0) - (ediff-message-if-verbose - "Only white-space differences in region %d %s" - (1+ n) - (cond (whitespace-A (ediff-mark-diff-as-space-only n 'A) - "in buffers B & C") - (whitespace-B (ediff-mark-diff-as-space-only n 'B) - "in buffers A & C") - (whitespace-C (ediff-mark-diff-as-space-only n 'C) - "in buffers A & B")))) - (t - (ediff-mark-diff-as-space-only n nil))) - ) - ) ; end cond - (ediff-set-fine-diff-properties n) - ))) - -;; Interface to ediff-make-fine-diffs. Checks for auto-refine limit, etc. -(defun ediff-install-fine-diff-if-necessary (n) - (cond ((eq ediff-auto-refine 'on) - (if (and - (> ediff-auto-refine-limit - (- (ediff-get-diff-posn 'A 'end n) - (ediff-get-diff-posn 'A 'beg n))) - (> ediff-auto-refine-limit - (- (ediff-get-diff-posn 'B 'end n) - (ediff-get-diff-posn 'B 'beg n)))) - (ediff-make-fine-diffs n 'noforce) - (ediff-make-fine-diffs n 'skip))) - - ;; highlight iff fine diffs already exist - ((eq ediff-auto-refine 'off) - (ediff-make-fine-diffs n 'skip)))) - - -;; if fine diff vector is not set for diff N, then do nothing -(defun ediff-set-fine-diff-properties (n &optional default) - (or (not (ediff-has-face-support-p)) - (< n 0) - (>= n ediff-number-of-differences) - ;; when faces are supported, set faces and priorities of fine overlays - (progn - (ediff-set-fine-diff-properties-in-one-buffer 'A n default) - (ediff-set-fine-diff-properties-in-one-buffer 'B n default) - (if ediff-3way-job - (ediff-set-fine-diff-properties-in-one-buffer 'C n default))))) - -(defun ediff-set-fine-diff-properties-in-one-buffer (buf-type - n &optional default) - (let ((fine-diff-vector (ediff-get-fine-diff-vector n buf-type)) - (face (if default - 'default - (face-name - (ediff-get-symbol-from-alist - buf-type ediff-fine-diff-face-alist)))) - (priority (if default - 0 - (1+ (or (ediff-overlay-get - (symbol-value - (ediff-get-symbol-from-alist - buf-type - ediff-current-diff-overlay-alist)) - 'priority) - 0))))) - (mapcar - (function (lambda (overl) - (ediff-set-overlay-face overl face) - (ediff-overlay-put overl 'priority priority))) - fine-diff-vector))) - -;; This assumes buffer C and that the region looks like a combination of -;; regions in buffer A and C. -(defun ediff-set-fine-overlays-for-combined-merge (diff-list reg-num) - (let (overlay1 overlay2 overlay3) - (setq overlay1 (ediff-make-bullet-proof-overlay (nth 0 diff-list) - (nth 1 diff-list) - ediff-buffer-C) - overlay2 (ediff-make-bullet-proof-overlay (nth 2 diff-list) - (nth 3 diff-list) - ediff-buffer-C) - overlay3 (ediff-make-bullet-proof-overlay (nth 4 diff-list) - (nth 5 diff-list) - ediff-buffer-C)) - (ediff-set-fine-diff-vector reg-num 'C (vector overlay1 overlay2 overlay3)) - )) - - -;; Convert diff list to overlays for a given DIFF-REGION -;; in buffer of type BUF-TYPE -(defun ediff-set-fine-overlays-in-one-buffer (buf-type diff-list region-num) - (let* ((current-diff -1) - (reg-start (ediff-get-diff-posn buf-type 'beg region-num)) - (buff (ediff-get-buffer buf-type)) - combined-merge-diff-list - diff-overlay-list list-element - begin end overlay) - - (ediff-clear-fine-differences-in-one-buffer region-num buf-type) - (setq diff-list (cdr diff-list)) ; discard list type (words or points) - (ediff-with-current-buffer buff (goto-char reg-start)) - - ;; if it is a combined merge then set overlays in buff C specially - (if (and ediff-merge-job (eq buf-type 'C) - (setq combined-merge-diff-list - (ediff-looks-like-combined-merge region-num))) - (ediff-set-fine-overlays-for-combined-merge - combined-merge-diff-list region-num) - ;; regular fine diff - (while diff-list - (setq current-diff (1+ current-diff) - list-element (car diff-list) - begin (aref list-element (cond ((eq buf-type 'A) 0) - ((eq buf-type 'B) 2) - (t 4))) ; buf C - end (aref list-element (cond ((eq buf-type 'A) 1) - ((eq buf-type 'B) 3) - (t 5)))) ; buf C - (if (not (or begin end)) - () ; skip this diff - ;; Put overlays at appropriate places in buffers - ;; convert lines to points, if necessary - (setq begin (ediff-goto-word (1+ begin) buff) - end (ediff-goto-word end buff 'end)) - (setq overlay (ediff-make-bullet-proof-overlay begin end buff)) - ;; record all overlays for this difference region - (setq diff-overlay-list (nconc diff-overlay-list (list overlay)))) - - (setq diff-list (cdr diff-list)) - ) ; while - ;; convert the list of difference information into a vector - ;; for fast access - (ediff-set-fine-diff-vector - region-num buf-type (vconcat diff-overlay-list)) - ))) - - -;; Stolen from emerge.el -(defun ediff-get-diff3-group (file) - ;; This save-excursion allows ediff-get-diff3-group to be called for the - ;; various groups of lines (1, 2, 3) in any order, and for the lines to - ;; appear in any order. The reason this is necessary is that Gnu diff3 - ;; can produce the groups in the order 1, 2, 3 or 1, 3, 2. - (save-excursion - (re-search-forward - (concat "^" file ":\\([0-9]+\\)\\(,\\([0-9]+\\)\\)?\\([ac]\\)$")) - (beginning-of-line 2) - ;; treatment depends on whether it is an "a" group or a "c" group - (if (string-equal (buffer-substring (match-beginning 4) (match-end 4)) "c") - ;; it is a "c" group - (if (match-beginning 2) - ;; it has two numbers - (list (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))) - (1+ (string-to-int - (buffer-substring (match-beginning 3) (match-end 3))))) - ;; it has one number - (let ((x (string-to-int - (buffer-substring (match-beginning 1) (match-end 1))))) - (list x (1+ x)))) - ;; it is an "a" group - (let ((x (1+ (string-to-int - (buffer-substring (match-beginning 1) (match-end 1)))))) - (list x x))))) - - -;; If WORD-MODE, construct vector of diffs using word numbers. -;; Else, use point values. -;; WORD-MODE also tells if we are in the word-mode or not. -;; If THREE-WAY-COMP, then it is a 3-way comparison. Else, it is merging -;; with ancestor, in which case buffer-C contents is identical to buffer-A/B, -;; contents (unless buffer-A is narrowed) depending on ediff-default-variant's -;; value. -;; BOUNDS specifies visibility bounds to use. -(defun ediff-extract-diffs3 (diff-buffer word-mode three-way-comp - &optional bounds) - (let ((A-buffer ediff-buffer-A) - (B-buffer ediff-buffer-B) - (C-buffer ediff-buffer-C) - (anc-buffer ediff-ancestor-buffer) - (a-prev 1) ; needed to set the first diff line correctly - (b-prev 1) - (c-prev 1) - (anc-prev 1) - diff-list shift-A shift-B shift-C - ) - - ;; diff list contains word numbers or points, depending on word-mode - (setq diff-list (cons (if word-mode 'words 'points) - diff-list)) - (if bounds - (setq shift-A - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'A bounds)) - shift-B - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'B bounds)) - shift-C - (if three-way-comp - (ediff-overlay-start - (ediff-get-value-according-to-buffer-type 'C bounds))))) - - ;; reset point in buffers A, B, C - (ediff-with-current-buffer A-buffer - (goto-char (if shift-A shift-A (point-min)))) - (ediff-with-current-buffer B-buffer - (goto-char (if shift-B shift-B (point-min)))) - (if three-way-comp - (ediff-with-current-buffer C-buffer - (goto-char (if shift-C shift-C (point-min))))) - (if (ediff-buffer-live-p anc-buffer) - (ediff-with-current-buffer anc-buffer - (goto-char (point-min)))) - - (ediff-with-current-buffer diff-buffer - (goto-char (point-min)) - (while (re-search-forward ediff-match-diff3-line nil t) - ;; leave point after matched line - (beginning-of-line 2) - (let ((agreement (buffer-substring (match-beginning 1) (match-end 1)))) - ;; if the files A and B are the same and not 3way-comparison, - ;; ignore the difference - (if (or three-way-comp (not (string-equal agreement "3"))) - (let* ((a-begin (car (ediff-get-diff3-group "1"))) - (a-end (nth 1 (ediff-get-diff3-group "1"))) - (b-begin (car (ediff-get-diff3-group "2"))) - (b-end (nth 1 (ediff-get-diff3-group "2"))) - (c-or-anc-begin (car (ediff-get-diff3-group "3"))) - (c-or-anc-end (nth 1 (ediff-get-diff3-group "3"))) - (state-of-merge - (cond ((string-equal agreement "1") 'prefer-A) - ((string-equal agreement "2") 'prefer-B) - (t ediff-default-variant))) - (state-of-diff-merge - (if (memq state-of-merge '(default-A prefer-A)) 'B 'A)) - (state-of-diff-comparison - (cond ((string-equal agreement "1") 'A) - ((string-equal agreement "2") 'B) - ((string-equal agreement "3") 'C))) - state-of-ancestor - c-begin c-end - a-begin-pt a-end-pt - b-begin-pt b-end-pt - c-begin-pt c-end-pt - anc-begin-pt anc-end-pt) - - (setq state-of-ancestor - (= c-or-anc-begin c-or-anc-end)) - - (cond (three-way-comp - (setq c-begin c-or-anc-begin - c-end c-or-anc-end)) - ((eq ediff-default-variant 'default-B) - (setq c-begin b-begin - c-end b-end)) - (t - (setq c-begin a-begin - c-end a-end))) - - ;; compute main diff vector - (if word-mode - ;; make diff-list contain word numbers - (setq diff-list - (nconc diff-list - (list (vector - (- a-begin a-prev) (- a-end a-begin) - (- b-begin b-prev) (- b-end b-begin) - (- c-begin c-prev) (- c-end c-begin) - nil nil ; dummy ancestor - nil ; state of diff - nil ; state of merge - nil ; state of ancestor - ))) - a-prev a-end - b-prev b-end - c-prev c-end) - ;; else convert lines to points - (ediff-with-current-buffer A-buffer - (forward-line (- a-begin a-prev)) - (setq a-begin-pt (point)) - (forward-line (- a-end a-begin)) - (setq a-end-pt (point) - a-prev a-end)) - (ediff-with-current-buffer B-buffer - (forward-line (- b-begin b-prev)) - (setq b-begin-pt (point)) - (forward-line (- b-end b-begin)) - (setq b-end-pt (point) - b-prev b-end)) - (ediff-with-current-buffer C-buffer - (forward-line (- c-begin c-prev)) - (setq c-begin-pt (point)) - (forward-line (- c-end c-begin)) - (setq c-end-pt (point) - c-prev c-end)) - (if (ediff-buffer-live-p anc-buffer) - (ediff-with-current-buffer anc-buffer - (forward-line (- c-or-anc-begin anc-prev)) - (setq anc-begin-pt (point)) - (forward-line (- c-or-anc-end c-or-anc-begin)) - (setq anc-end-pt (point) - anc-prev c-or-anc-end))) - (setq diff-list - (nconc - diff-list - ;; if comparing with ancestor, then there also is a - ;; state-of-difference marker - (if three-way-comp - (list (vector - a-begin-pt a-end-pt - b-begin-pt b-end-pt - c-begin-pt c-end-pt - nil nil ; ancestor begin/end - state-of-diff-comparison - nil ; state of merge - nil ; state of ancestor - )) - (list (vector a-begin-pt a-end-pt - b-begin-pt b-end-pt - c-begin-pt c-end-pt - anc-begin-pt anc-end-pt - state-of-diff-merge - state-of-merge - state-of-ancestor - ))) - ))) - )) - - ))) ; end ediff-with-current-buffer - diff-list - )) - -;; Generate the difference vector and overlays for three files -;; File-C is either the third file to compare (in case of 3-way comparison) -;; or it is the ancestor file. -(defun ediff-setup-diff-regions3 (file-A file-B file-C) - (or (ediff-buffer-live-p ediff-diff-buffer) - (setq ediff-diff-buffer - (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*")))) - - (message "Computing differences ...") - (ediff-exec-process ediff-diff3-program ediff-diff-buffer 'synchronize - ediff-diff3-options file-A file-B file-C) - - (ediff-prepare-error-list ediff-diff3-ok-lines-regexp ediff-diff-buffer) - ;;(message "Computing differences ... done") - (ediff-convert-diffs-to-overlays - (ediff-extract-diffs3 - ediff-diff-buffer - ediff-word-mode ediff-3way-comparison-job ediff-narrow-bounds) - )) - - -;; Execute PROGRAM asynchronously, unless OS/2, Windows-*, or DOS, or unless -;; SYNCH is non-nil. BUFFER must be a buffer object, and must be alive. The -;; OPTIONS arg is a list of options to pass to PROGRAM. It may be a blank -;; string. All elements in FILES must be strings. We also delete nil from -;; args. -(defun ediff-exec-process (program buffer synch options &rest files) - (let ((data (match-data)) - args) - (setq args (append (split-string options) files)) - (setq args (delete "" (delq nil args))) ; delete nil and "" from arguments - (unwind-protect - (let ((directory default-directory) - proc) - (save-excursion - (set-buffer buffer) - (erase-buffer) - (setq default-directory directory) - (if (or (memq system-type '(emx ms-dos windows-nt windows-95)) - synch) - ;; In OS/2 (emx) do it synchronously, since OS/2 doesn't let us - ;; delete files used by other processes. Thus, in ediff-buffers - ;; and similar functions, we can't delete temp files because - ;; they might be used by the asynch process that computes - ;; custom diffs. So, we have to wait till custom diff - ;; subprocess is done. - ;; Similarly for Windows-* - ;; In DOS, must synchronize because DOS doesn't have - ;; asynchronous processes. - (apply 'call-process program nil buffer nil args) - ;; On other systems, do it asynchronously. - (setq proc (get-buffer-process buffer)) - (if proc (kill-process proc)) - (setq proc - (apply 'start-process "Custom Diff" buffer program args)) - (setq mode-line-process '(":%s")) - (set-process-sentinel proc 'ediff-process-sentinel) - (set-process-filter proc 'ediff-process-filter) - ))) - (store-match-data data)))) - -;; This is shell-command-filter from simple.el in FSF Emacs. -;; Copied here because XEmacs doesn't have it. -(defun ediff-process-filter (proc string) - ;; Do save-excursion by hand so that we can leave point numerically unchanged - ;; despite an insertion immediately after it. - (let* ((obuf (current-buffer)) - (buffer (process-buffer proc)) - opoint - (window (get-buffer-window buffer)) - (pos (window-start window))) - (unwind-protect - (progn - (set-buffer buffer) - (or (= (point) (point-max)) - (setq opoint (point))) - (goto-char (point-max)) - (insert-before-markers string)) - ;; insert-before-markers moved this marker: set it back. - (set-window-start window pos) - ;; Finish our save-excursion. - (if opoint - (goto-char opoint)) - (set-buffer obuf)))) - -;; like shell-command-sentinel but doesn't print an exit status message -;; we do this because diff always exits with status 1, if diffs are found -;; so shell-command-sentinel displays a confusing message to the user -(defun ediff-process-sentinel (process signal) - (if (and (memq (process-status process) '(exit signal)) - (buffer-name (process-buffer process))) - (progn - (save-excursion - (set-buffer (process-buffer process)) - (setq mode-line-process nil)) - (delete-process process)))) - - -;;; Word functions used to refine the current diff - -(defvar ediff-forward-word-function 'ediff-forward-word - "*Function to call to move to the next word. -Used for splitting difference regions into individual words.") - -(defvar ediff-whitespace " \n\t\f" - "*Characters constituting white space. -These characters are ignored when differing regions are split into words.") - -;;(defvar ediff-word-1 "a-zA-Z---_`'.?!:" -(defvar ediff-word-1 "a-zA-Z---_" - "*Characters that constitute words of type 1. -More precisely, [ediff-word-1] is a regexp that matches type 1 words. -See `ediff-forward-word' for more details.") - -(defvar ediff-word-2 "0-9.," - "*Characters that constitute words of type 2. -More precisely, [ediff-word-2] is a regexp that matches type 2 words. -See `ediff-forward-word' for more details.") - -(defvar ediff-word-3 "`'?!:;\"{}[]()" - "*Characters that constitute words of type 3. -More precisely, [ediff-word-3] is a regexp that matches type 3 words. -See `ediff-forward-word' for more details.") - -(defvar ediff-word-4 - (concat "^" ediff-word-1 ediff-word-2 ediff-word-3 ediff-whitespace) - "*Characters that constitute words of type 4. -More precisely, [ediff-word-4] is a regexp that matches type 4 words. -See `ediff-forward-word' for more details.") - -;; Split region along word boundaries. Each word will be on its own line. -;; Output to buffer out-buffer. -(defun ediff-forward-word () - "Move point one word forward. -There are four types of words, each of which consists entirely of -characters in `ediff-word-1', `ediff-word-2', `ediff-word-3', or -`ediff-word-4'. Words are recognized by passing these in turn as the -argument to `skip-chars-forward'." - (or (> (skip-chars-forward ediff-word-1) 0) - (> (skip-chars-forward ediff-word-2) 0) - (> (skip-chars-forward ediff-word-3) 0) - (> (skip-chars-forward ediff-word-4) 0) - )) - -(defun ediff-wordify (beg end in-buffer out-buffer &optional control-buf) - (let (sv-point string) - (save-excursion - (set-buffer in-buffer) - (setq string (buffer-substring-no-properties beg end)) - - (set-buffer out-buffer) - (erase-buffer) - (insert string) - (goto-char (point-min)) - (skip-chars-forward ediff-whitespace) - (delete-region (point-min) (point)) - - (while (not (eobp)) - ;; eval incontrol buf to let user create local versions for - ;; different invocations - (if control-buf - (funcall - (ediff-with-current-buffer control-buf ediff-forward-word-function)) - (funcall ediff-forward-word-function)) - (setq sv-point (point)) - (skip-chars-forward ediff-whitespace) - (delete-region sv-point (point)) - (insert "\n"))))) - -;; copy string from BEG END from IN-BUF to OUT-BUF -(defun ediff-copy-to-buffer (beg end in-buffer out-buffer) - (let (string) - (save-excursion - (set-buffer in-buffer) - (setq string (buffer-substring beg end)) - - (set-buffer out-buffer) - (erase-buffer) - (insert string) - (goto-char (point-min))))) - - -;; goto word #n starting at current position in buffer `buf' -;; For ediff, a word is either a string of a-z,A-Z, incl `-' and `_'; -;; or a string of other non-blanks. A blank is a \n\t\f -;; If `flag' is non-nil, goto the end of the n-th word. -(defun ediff-goto-word (n buf &optional flag) - ;; remember val ediff-forward-word-function has in ctl buf - (let ((fwd-word-fun ediff-forward-word-function)) - (ediff-with-current-buffer buf - (skip-chars-forward ediff-whitespace) - (while (> n 1) - (funcall fwd-word-fun) - (skip-chars-forward ediff-whitespace) - (setq n (1- n))) - (if (and flag (> n 0)) - (funcall fwd-word-fun)) - (point)))) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - - -;; ediff-diff.el ends here
--- a/lisp/ediff/ediff-help.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,313 +0,0 @@ -;;; ediff-help.el --- Code related to the contents of Ediff help buffers - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-help) - -;; Compiler pacifier start -(defvar ediff-multiframe) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -;; Help messages - -(defconst ediff-long-help-message-head - " Move around | Toggle features | Manipulate -=====================|===========================|=============================" - "The head of the full help message.") -(defconst ediff-long-help-message-tail - "=====================|===========================|============================= - R -show registry | = -compare regions | M -show session group - D -diff output | E -browse Ediff manual| G -send bug report - i -status info | ? -help off | z/q -suspend/quit -------------------------------------------------------------------------------- -For help on a specific command: Click Button 2 over it; or - Put the cursor over it and type RET." - "The tail of the full-help message.") - -(defconst ediff-long-help-message-compare3 - " -p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| | ! -update diff regions - C-l -recenter | ## -ignore whitespace | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - </> -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -rotate buffers| m -wide display | -" - "Help message usually used for 3-way comparison. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-compare2 - " -p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| | ! -update diff regions - C-l -recenter | ## -ignore whitespace | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - </> -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -swap variants | m -wide display | -" - "Help message usually used for 2-way comparison. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-narrow2 - " -p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| % -narrow/widen buffs | ! -update diff regions - C-l -recenter | ## -ignore whitespace | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - </> -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -swap variants | m -wide display | -" - "Help message when comparing windows or regions line-by-line. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-word-mode - " -p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y -n,SPC -next diff | h -hilighting | rx -restore buf X's old diff - j -jump to diff | | - gx -goto X's point| % -narrow/widen buffs | ! -recompute diffs - C-l -recenter | | - v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X - </> -scroll lt/rt | X -read-only in buf X | wd -save diff output - ~ -swap variants | m -wide display | -" - "Help message when comparing windows or regions word-by-word. -Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-long-help-message-merge - " -p,DEL -previous diff | | -vert/horiz split | x -copy buf X's region to C -n,SPC -next diff | h -hilighting | r -restore buf C's old diff - j -jump to diff | @ -auto-refinement | * -refine current region - gx -goto X's point| ## -ignore whitespace | ! -update diff regions - C-l -recenter | #f/#h -focus/hide regions | + -combine diff regions - v/V -scroll up/dn | X -read-only in buf X | wx -save buf X - </> -scroll lt/rt | m -wide display | wd -save diff output - ~ -swap variants | s -shrink window C | / -show ancestor buff - | $ -show clashes only | & -merge w/new default -" - "Help message during merging. -Normally, not a user option. See `ediff-help-message' for details.") - -;; The actual long help message. -(ediff-defvar-local ediff-long-help-message "" - "Normally, not a user option. See `ediff-help-message' for details.") - -(defconst ediff-brief-message-string - "? -quick help " - "Contents of the brief help message.") -;; The actual brief help message -(ediff-defvar-local ediff-brief-help-message "" - "Normally, not a user option. See `ediff-help-message' for details.") - -(ediff-defvar-local ediff-brief-help-message-function nil - "The brief help message that the user can customize. -If the user sets this to a parameter-less function, Ediff will use it to -produce the brief help message. This function must return a string.") -(ediff-defvar-local ediff-long-help-message-function nil - "The long help message that the user can customize. -See `ediff-brief-help-message-function' for more.") - -(defvar ediff-use-long-help-message nil - "*If t, Ediff displays a long help message. Short help message otherwise.") - -;; The actual help message. -(ediff-defvar-local ediff-help-message "" - "The actual help message. -Normally, the user shouldn't touch this. However, if you want Ediff to -start up with different help messages for different jobs, you can change -the value of this variable and the variables `ediff-help-message-*' in -`ediff-startup-hook'.") - - -;; the keymap that defines clicks over the quick help regions -(defvar ediff-help-region-map (make-sparse-keymap)) - -(define-key - ediff-help-region-map - (if ediff-emacs-p [mouse-2] [button2]) - 'ediff-help-for-quick-help) - -;; runs in the control buffer -(defun ediff-set-help-overlays () - (goto-char (point-min)) - (let (overl beg end cmd) - (while (re-search-forward " *\\([^ \t\n|]+\\||\\) +-[^|\n]+" nil 'noerror) - (setq beg (match-beginning 0) - end (match-end 0) - cmd (buffer-substring (match-beginning 1) (match-end 1))) - (setq overl (ediff-make-overlay beg end)) - (if ediff-emacs-p - (ediff-overlay-put overl 'mouse-face 'highlight) - (ediff-overlay-put overl 'highlight t)) - (ediff-overlay-put overl 'ediff-help-info cmd)))) - - -(defun ediff-help-for-quick-help () - "Explain Ediff commands in more detail." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((pos (ediff-event-point last-command-event)) - overl cmd) - - (if ediff-xemacs-p - (setq overl (extent-at pos (current-buffer) 'ediff-help-info) - cmd (ediff-overlay-get overl 'ediff-help-info)) - (setq cmd (car (mapcar (function (lambda (elt) - (overlay-get elt 'ediff-help-info))) - (overlays-at pos))))) - - (if (not (stringp cmd)) - (error "Hmm... I don't see an Ediff command around here...")) - - (ediff-documentation "Quick Help Commands") - - (let (case-fold-search) - (cond ((string= cmd "?") (re-search-forward "^`\\?'")) - ((string= cmd "G") (re-search-forward "^`G'")) - ((string= cmd "E") (re-search-forward "^`E'")) - ((string= cmd "wd") (re-search-forward "^`wd'")) - ((string= cmd "wx") (re-search-forward "^`wa'")) - ((string= cmd "a/b") (re-search-forward "^`a'")) - ((string= cmd "x") (re-search-forward "^`a'")) - ((string= cmd "xy") (re-search-forward "^`ab'")) - ((string= cmd "p,DEL") (re-search-forward "^`p'")) - ((string= cmd "n,SPC") (re-search-forward "^`n'")) - ((string= cmd "j") (re-search-forward "^`j'")) - ((string= cmd "gx") (re-search-forward "^`ga'")) - ((string= cmd "!") (re-search-forward "^`!'")) - ((string= cmd "*") (re-search-forward "^`\\*'")) - ((string= cmd "m") (re-search-forward "^`m'")) - ((string= cmd "|") (re-search-forward "^`|'")) - ((string= cmd "@") (re-search-forward "^`@'")) - ((string= cmd "h") (re-search-forward "^`h'")) - ((string= cmd "r") (re-search-forward "^`r'")) - ((string= cmd "rx") (re-search-forward "^`ra'")) - ((string= cmd "##") (re-search-forward "^`##'")) - ((string= cmd "#f/#h") (re-search-forward "^`#f'")) - ((string= cmd "X") (re-search-forward "^`A'")) - ((string= cmd "v/V") (re-search-forward "^`v'")) - ((string= cmd "</>") (re-search-forward "^`<'")) - ((string= cmd "~") (re-search-forward "^`~'")) - ((string= cmd "i") (re-search-forward "^`i'")) - ((string= cmd "D") (re-search-forward "^`D'")) - ((string= cmd "R") (re-search-forward "^`R'")) - ((string= cmd "M") (re-search-forward "^`M'")) - ((string= cmd "z/q") (re-search-forward "^`z'")) - ((string= cmd "%") (re-search-forward "^`%'")) - ((string= cmd "C-l") (re-search-forward "^`C-l'")) - ((string= cmd "$") (re-search-forward "^`\\$'")) - ((string= cmd "/") (re-search-forward "^`/'")) - ((string= cmd "&") (re-search-forward "^`&'")) - ((string= cmd "s") (re-search-forward "^`s'")) - ((string= cmd "+") (re-search-forward "^`\\+'")) - ((string= cmd "=") (re-search-forward "^`='")) - (t (error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer"))) - ) ; let case-fold-search - )) - - -;; assuming we are in control window, calculate length of the first line in -;; help message -(defun ediff-help-message-line-length () - (save-excursion - (goto-char (point-min)) - (if ediff-use-long-help-message - (next-line 1)) - (end-of-line) - (current-column))) - - -(defun ediff-indent-help-message () - (let* ((shift (/ (max 0 (- (window-width (selected-window)) - (ediff-help-message-line-length))) - 2)) - (str (make-string shift ?\ ))) - (save-excursion - (goto-char (point-min)) - (while (< (point) (point-max)) - (insert str) - (beginning-of-line) - (forward-line 1))))) - - -;; compose the help message as a string -(defun ediff-set-help-message () - (setq ediff-long-help-message - (cond ((and ediff-long-help-message-function - (or (symbolp ediff-long-help-message-function) - (consp ediff-long-help-message-function))) - (funcall ediff-long-help-message-function)) - (ediff-word-mode - (concat ediff-long-help-message-head - ediff-long-help-message-word-mode - ediff-long-help-message-tail)) - (ediff-narrow-job - (concat ediff-long-help-message-head - ediff-long-help-message-narrow2 - ediff-long-help-message-tail)) - (ediff-merge-job - (concat ediff-long-help-message-head - ediff-long-help-message-merge - ediff-long-help-message-tail)) - (ediff-diff3-job - (concat ediff-long-help-message-head - ediff-long-help-message-compare3 - ediff-long-help-message-tail)) - (t - (concat ediff-long-help-message-head - ediff-long-help-message-compare2 - ediff-long-help-message-tail)))) - (setq ediff-brief-help-message - (cond ((and ediff-brief-help-message-function - (or (symbolp ediff-brief-help-message-function) - (consp ediff-brief-help-message-function))) - (funcall ediff-brief-help-message-function)) - ((stringp ediff-brief-help-message-function) - ediff-brief-help-message-function) - ((ediff-multiframe-setup-p) ediff-brief-message-string) - (t ; long brief msg, not multiframe --- put in the middle - ediff-brief-message-string) - )) - (setq ediff-help-message (if ediff-use-long-help-message - ediff-long-help-message - ediff-brief-help-message)) - (run-hooks 'ediff-display-help-hook)) - - -;;; ediff-help.el ends here
--- a/lisp/ediff/ediff-hook.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,349 +0,0 @@ -;;; ediff-hook.el --- setup for Ediff's menus and autoloads - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; These must be placed in menu-bar.el in Emacs -;; -;; (define-key menu-bar-tools-menu [ediff-misc] -;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu)) -;; (define-key menu-bar-tools-menu [epatch] -;; '("Apply Patch" . menu-bar-epatch-menu)) -;; (define-key menu-bar-tools-menu [ediff-merge] -;; '("Merge" . menu-bar-ediff-merge-menu)) -;; (define-key menu-bar-tools-menu [ediff] -;; '("Compare" . menu-bar-ediff-menu)) - -;; Compiler pacifier -(defvar ediff-menu) -(defvar ediff-merge-menu) -(defvar epatch-menu) -(defvar ediff-misc-menu) -;; end pacifier - -;; allow menus to be set up without ediff-wind.el being loaded -(defvar ediff-window-setup-function) - - -(defun ediff-xemacs-init-menus () - (if (featurep 'menubar) - (progn - (add-submenu - '("Tools") ediff-menu "OO-Browser...") - (add-submenu - '("Tools") ediff-merge-menu "OO-Browser...") - (add-submenu - '("Tools") epatch-menu "OO-Browser...") - (add-submenu - '("Tools") ediff-misc-menu "OO-Browser...") - (add-menu-button - '("Tools") - ["-------" nil nil] "OO-Browser...") - ))) - - -;; explicit string-match is needed: ediff-xemacs-p is not defined at build time -(cond ((string-match "XEmacs" emacs-version) - (defvar ediff-menu - '("Compare" - ["Two Files..." ediff-files t] - ["Two Buffers..." ediff-buffers t] - ["Three Files..." ediff-files3 t] - ["Three Buffers..." ediff-buffers3 t] - "---" - ["Two Directories..." ediff-directories t] - ["Three Directories..." ediff-directories3 t] - "---" - ["File with Revision..." ediff-revision t] - ["Directory Revisions..." ediff-directory-revisions t] - "---" - ["Windows Word-by-word..." ediff-windows-wordwise t] - ["Windows Line-by-line..." ediff-windows-linewise t] - "---" - ["Regions Word-by-word..." ediff-regions-wordwise t] - ["Regions Line-by-line..." ediff-regions-linewise t] - )) - (defvar ediff-merge-menu - '("Merge" - ["Files..." ediff-merge-files t] - ["Files with Ancestor..." ediff-merge-files-with-ancestor t] - ["Buffers..." ediff-merge-buffers t] - ["Buffers with Ancestor..." - ediff-merge-buffers-with-ancestor t] - "---" - ["Directories..." ediff-merge-directories t] - ["Directories with Ancestor..." - ediff-merge-directories-with-ancestor t] - "---" - ["Revisions..." ediff-merge-revisions t] - ["Revisions with Ancestor..." - ediff-merge-revisions-with-ancestor t] - ["Directory Revisions..." ediff-merge-directory-revisions t] - ["Directory Revisions with Ancestor..." - ediff-merge-directory-revisions-with-ancestor t] - )) - (defvar epatch-menu - '("Apply Patch" - ["To a file..." ediff-patch-file t] - ["To a buffer..." ediff-patch-buffer t] - )) - (defvar ediff-misc-menu - '("Ediff Miscellanea" - ["Ediff Manual..." ediff-documentation t] - ["List Ediff Sessions..." ediff-show-registry t] - ["Use separate frame for Ediff control buffer..." - ediff-toggle-multiframe - :style toggle - :selected (if (and (featurep 'ediff-util) - (boundp 'ediff-window-setup-function)) - (eq ediff-window-setup-function - 'ediff-setup-windows-multiframe))] - ["Use a toolbar with Ediff control buffer" - ediff-toggle-use-toolbar - :style toggle - :selected (if (featurep 'ediff-tbar) - (ediff-use-toolbar-p))] - )) - - ;; put these menus before Object-Oriented-Browser in Tools menu -;; (add-hook 'before-init-hook 'ediff-xemacs-init-menus) -;; (if (not purify-flag) -;; (ediff-xemacs-init-menus)) -;; ) - (ediff-xemacs-init-menus)) - - ;; Emacs--only if menu-bar is loaded - ((featurep 'menu-bar) - ;; initialize menu bar keymaps - (defvar menu-bar-ediff-misc-menu - (make-sparse-keymap "Ediff Miscellanea")) - (fset 'menu-bar-ediff-misc-menu - (symbol-value 'menu-bar-ediff-misc-menu)) - (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch")) - (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu)) - (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge")) - (fset 'menu-bar-ediff-merge-menu - (symbol-value 'menu-bar-ediff-merge-menu)) - (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare")) - (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu)) - - ;; define ediff-menu - (define-key menu-bar-ediff-menu [window] - '("This Window and Next Window" . compare-windows)) - (define-key menu-bar-ediff-menu [ediff-windows-linewise] - '("Windows Line-by-line..." . ediff-windows-linewise)) - (define-key menu-bar-ediff-menu [ediff-windows-wordwise] - '("Windows Word-by-word..." . ediff-windows-wordwise)) - (define-key menu-bar-ediff-menu [separator-ediff-windows] '("--")) - (define-key menu-bar-ediff-menu [ediff-regions-linewise] - '("Regions Line-by-line..." . ediff-regions-linewise)) - (define-key menu-bar-ediff-menu [ediff-regions-wordwise] - '("Regions Word-by-word..." . ediff-regions-wordwise)) - (define-key menu-bar-ediff-menu [separator-ediff-regions] '("--")) - (define-key menu-bar-ediff-menu [ediff-dir-revision] - '("Directory Revisions..." . ediff-directory-revisions)) - (define-key menu-bar-ediff-menu [ediff-revision] - '("File with Revision..." . ediff-revision)) - (define-key menu-bar-ediff-menu [separator-ediff-directories] '("--")) - (define-key menu-bar-ediff-menu [ediff-directories3] - '("Three Directories..." . ediff-directories3)) - (define-key menu-bar-ediff-menu [ediff-directories] - '("Two Directories..." . ediff-directories)) - (define-key menu-bar-ediff-menu [separator-ediff-files] '("--")) - (define-key menu-bar-ediff-menu [ediff-buffers3] - '("Three Buffers..." . ediff-buffers3)) - (define-key menu-bar-ediff-menu [ediff-files3] - '("Three Files..." . ediff-files3)) - (define-key menu-bar-ediff-menu [ediff-buffers] - '("Two Buffers..." . ediff-buffers)) - (define-key menu-bar-ediff-menu [ediff-files] - '("Two Files..." . ediff-files)) - - ;; define merge menu - (define-key - menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor] - '("Directory Revisions with Ancestor..." - . ediff-merge-directory-revisions-with-ancestor)) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-dir-revisions] - '("Directory Revisions..." . ediff-merge-directory-revisions)) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-revisions-with-ancestor] - '("Revisions with Ancestor..." - . ediff-merge-revisions-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-revisions] - '("Revisions..." . ediff-merge-revisions)) - (define-key menu-bar-ediff-merge-menu [separator-ediff-merge] '("--")) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-directories-with-ancestor] - '("Directories with Ancestor..." - . ediff-merge-directories-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-directories] - '("Directories..." . ediff-merge-directories)) - (define-key - menu-bar-ediff-merge-menu [separator-ediff-merge-dirs] '("--")) - (define-key - menu-bar-ediff-merge-menu [ediff-merge-buffers-with-ancestor] - '("Buffers with Ancestor..." . ediff-merge-buffers-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-buffers] - '("Buffers..." . ediff-merge-buffers)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-files-with-ancestor] - '("Files with Ancestor..." . ediff-merge-files-with-ancestor)) - (define-key menu-bar-ediff-merge-menu [ediff-merge-files] - '("Files..." . ediff-merge-files)) - - ;; define epatch menu - (define-key menu-bar-epatch-menu [ediff-patch-buffer] - '("To a Buffer..." . ediff-patch-buffer)) - (define-key menu-bar-epatch-menu [ediff-patch-file] - '("To a File..." . ediff-patch-file)) - - ;; define ediff miscellanea - (define-key menu-bar-ediff-misc-menu [emultiframe] - '("Toggle use of separate control buffer frame..." - . ediff-toggle-multiframe)) - (define-key menu-bar-ediff-misc-menu [eregistry] - '("List Ediff Sessions..." . ediff-show-registry)) - (define-key menu-bar-ediff-misc-menu [ediff-doc] - '("Ediff Manual..." . ediff-documentation)) - ) - - ) ; cond - -;; arrange for autoloads -(if purify-flag - () ; if dumping, autoloads are set up in loaddefs.el - ;; if the user decides to load this file, set up autoloads - ;; compare files and buffers - (autoload 'ediff "ediff" "Compare two files" t) - (autoload 'ediff-files "ediff" "Compare two files" t) - (autoload 'ediff-buffers "ediff" "Compare two bufers" t) - (autoload 'ebuffers "ediff" "Compare two bufers" t) - (autoload 'ediff3 "ediff" "Compare three files" t) - (autoload 'ediff-files3 "ediff" "Compare three files" t) - (autoload 'ediff-buffers3 "ediff" "Compare three bufers" t) - (autoload 'ebuffers3 "ediff" "Compare three bufers" t) - - (autoload 'erevision "ediff" "Compare versions of a file" t) - (autoload 'ediff-revision "ediff" "Compare versions of a file" t) - - ;; compare regions and windows - (autoload 'ediff-windows-wordwise - "ediff" "Compare two windows word-by-word." t) - (autoload 'ediff-regions-wordwise - "ediff" "Compare two regions word-by-word." t) - (autoload 'ediff-windows-linewise - "ediff" "Compare two windows line-by-line." t) - (autoload 'ediff-regions-linewise - "ediff" "Compare two regions line-by-line." t) - - ;; patch - (autoload 'ediff-patch-file "ediff" "Patch a file." t) - (autoload 'epatch "ediff" "Patch a file." t) - (autoload 'ediff-patch-buffer "ediff" "Patch a buffer.") - (autoload 'epatch-buffer "ediff" "Patch a buffer." t) - - ;; merge - (autoload 'ediff-merge "ediff" "Merge two files." t) - (autoload 'ediff-merge-files "ediff" "Merge two files." t) - (autoload 'ediff-merge-files-with-ancestor - "ediff" "Merge two files using a third file as an ancestor." t) - (autoload 'ediff-merge-buffers "ediff" "Merge two buffers." t) - (autoload 'ediff-merge-buffers-with-ancestor - "ediff" "Merge two buffers using a third buffer as an ancestor." t) - - (autoload 'ediff-merge-revisions "ediff" "Merge two versions of a file." t) - (autoload 'ediff-merge-revisions-with-ancestor - "ediff" "Merge two versions of a file." t) - - ;; compare directories - (autoload 'edirs "ediff" "Compare files in two directories." t) - (autoload 'ediff-directories "ediff" "Compare files in two directories." t) - (autoload 'edirs3 "ediff" "Compare files in three directories." t) - (autoload - 'ediff-directories3 "ediff" "Compare files in three directories." t) - - (autoload 'edir-revisions - "ediff" "Compare two versions of a file." t) - (autoload 'ediff-directory-revisions - "ediff" "Compare two versions of a file." t) - - ;; merge directories - (autoload 'edirs-merge "ediff" "Merge files in two directories." t) - (autoload 'ediff-merge-directories - "ediff" "Merge files in two directories." t) - (autoload 'edirs-merge-with-ancestor - "ediff" - "Merge files in two directories using files in a third dir as ancestors." - t) - (autoload 'ediff-merge-directories-with-ancestor - "ediff" - "Merge files in two directories using files in a third dir as ancestors." - t) - - (autoload 'edir-merge-revisions - "ediff" "Merge versions of files in a directory." t) - (autoload 'ediff-merge-directory-revisions - "ediff" "Merge versions of files in a directory." t) - (autoload 'ediff-merge-directory-revisions-with-ancestor - "ediff" - "Merge versions of files in a directory using other versions as ancestors." - t) - (autoload 'edir-merge-revisions-with-ancestor - "ediff" - "Merge versions of files in a directory using other versions as ancestors." - t) - - ;; misc - (autoload 'ediff-show-registry - "ediff-mult" - "Display the registry of active Ediff sessions." - t) - (autoload 'eregistry - "ediff-mult" - "Display the registry of active Ediff sessions." - t) - (autoload 'ediff-documentation - "ediff" - "Display Ediff's manual." - t) - (autoload 'ediff-version - "ediff" - "Show Ediff's version and last modification date." - t) - (autoload 'ediff-toggle-multiframe - "ediff-util" - "Toggle the use of separate frame for Ediff control buffer." - t) - (autoload 'ediff-toggle-use-toolbar - "ediff-util" - "Toggle the use of Ediff toolbar." - t) - - ) ; if purify-flag - - -(provide 'ediff-hook) - - -;;; ediff-hook.el ends here
--- a/lisp/ediff/ediff-init.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2058 +0,0 @@ -;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;; Start compiler pacifier -(defvar ediff-metajob-name) -(defvar ediff-meta-buffer) -(defvar pm-color-alist) -(defvar ediff-grab-mouse) -(defvar ediff-mouse-pixel-position) -(defvar ediff-mouse-pixel-threshold) -(defvar ediff-whitespace) -(defvar ediff-multiframe) - -(and noninteractive - (eval-when-compile - (load "ange-ftp" 'noerror))) -;; end pacifier - -;; Is it XEmacs? -(defconst ediff-xemacs-p (string-match "XEmacs" emacs-version)) -;; Is it Emacs? -(defconst ediff-emacs-p (not ediff-xemacs-p)) - -(defvar ediff-force-faces nil - "If t, Ediff will think that it is running on a display that supports faces. -This is provided as a temporary relief for users of face-capable displays -that Ediff doesn't know about.") - -;; Are we running as a window application or on a TTY? -(defsubst ediff-device-type () - (if ediff-emacs-p - window-system - (device-type (selected-device)))) - -;; in XEmacs: device-type is tty on tty and stream in batch. -(defun ediff-window-display-p () - (and (ediff-device-type) (not (memq (ediff-device-type) '(tty pc stream))))) - -;; test if supports faces -;; ediff-force-faces is for those devices that support faces, but we don't know -;; this yet -(defun ediff-has-face-support-p () - (cond ((ediff-window-display-p)) - (ediff-force-faces) - (ediff-emacs-p (memq (ediff-device-type) '(pc))) - (ediff-xemacs-p (memq (ediff-device-type) '(tty pc))))) - - -;; Defines SYMBOL as an advertised local variable. -;; Performs a defvar, then executes `make-variable-buffer-local' on -;; the variable. Also sets the `permanent-local' property, -;; so that `kill-all-local-variables' (called by major-mode setting -;; commands) won't destroy Ediff control variables. -;; -;; Plagiarised from `emerge-defvar-local' for XEmacs. -(defmacro ediff-defvar-local (var value doc) - (` (progn - (defvar (, var) (, value) (, doc)) - (make-variable-buffer-local '(, var)) - (put '(, var) 'permanent-local t)))) - - - -;; Variables that control each Ediff session---local to the control buffer. - -;; Mode variables -;; The buffer in which the A variant is stored. -(ediff-defvar-local ediff-buffer-A nil "") -;; The buffer in which the B variant is stored. -(ediff-defvar-local ediff-buffer-B nil "") -;; The buffer in which the C variant is stored. -(ediff-defvar-local ediff-buffer-C nil "") -;; Ancestor buffer -(ediff-defvar-local ediff-ancestor-buffer nil "") -;; The Ediff control buffer -(ediff-defvar-local ediff-control-buffer nil "") - - -;; Association between buff-type and ediff-buffer-* -(defconst ediff-buffer-alist - '((?A . ediff-buffer-A) - (?B . ediff-buffer-B) - (?C . ediff-buffer-C))) - -;;; Macros -(defmacro ediff-odd-p (arg) - (` (eq (logand (, arg) 1) 1))) - -(defmacro ediff-buffer-live-p (buf) - (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf)))))) - -(defmacro ediff-get-buffer (arg) - (` (cond ((eq (, arg) 'A) ediff-buffer-A) - ((eq (, arg) 'B) ediff-buffer-B) - ((eq (, arg) 'C) ediff-buffer-C) - ((eq (, arg) 'Ancestor) ediff-ancestor-buffer) - ) - )) - -(defmacro ediff-get-value-according-to-buffer-type (buf-type list) - (` (cond ((eq (, buf-type) 'A) (nth 0 (, list))) - ((eq (, buf-type) 'B) (nth 1 (, list))) - ((eq (, buf-type) 'C) (nth 2 (, list)))))) - -(defmacro ediff-char-to-buftype (arg) - (` (cond ((memq (, arg) '(?a ?A)) 'A) - ((memq (, arg) '(?b ?B)) 'B) - ((memq (, arg) '(?c ?C)) 'C) - ) - )) - - -;; A-list is supposed to be of the form (A . symb) (B . symb)...) -;; where the first part of any association is a buffer type and the second is -;; an appropriate symbol. Given buffer-type, this function returns the -;; symbol. This is used to avoid using `intern' -(defsubst ediff-get-symbol-from-alist (buf-type alist) - (cdr (assoc buf-type alist))) - -(defconst ediff-difference-vector-alist - '((A . ediff-difference-vector-A) - (B . ediff-difference-vector-B) - (C . ediff-difference-vector-C) - (Ancestor . ediff-difference-vector-Ancestor))) - -(defmacro ediff-get-difference (n buf-type) - (` (aref - (symbol-value - (ediff-get-symbol-from-alist - (, buf-type) ediff-difference-vector-alist)) - (, n)))) - -;; Tell if it has been previously determined that the region has -;; no diffs other than the white space and newlines -;; The argument, N, is the diff region number used by Ediff to index the -;; diff vector. It is 1 less than the number seen by the user. -;; Returns: -;; t if the diffs are whitespace in all buffers -;; 'A (in 3-buf comparison only) if there are only whitespace -;; diffs in bufs B and C -;; 'B (in 3-buf comparison only) if there are only whitespace -;; diffs in bufs A and C -;; 'C (in 3-buf comparison only) if there are only whitespace -;; diffs in bufs A and B -;; -;; A difference vector has the form: -;; [diff diff diff ...] -;; where each diff has the form: -;; [overlay fine-diff-vector no-fine-diffs-flag] -;; fine-diff-vector is a vector [fine-diff fine-diff fine-diff ...] -(defmacro ediff-no-fine-diffs-p (n) - (` (aref (ediff-get-difference (, n) 'A) 2))) - -(defmacro ediff-get-diff-overlay-from-diff-record (diff-rec) - (` (aref (, diff-rec) 0))) - -(defmacro ediff-get-diff-overlay (n buf-type) - (` (ediff-get-diff-overlay-from-diff-record - (ediff-get-difference (, n) (, buf-type))))) - -(defmacro ediff-get-fine-diff-vector-from-diff-record (diff-rec) - (` (aref (, diff-rec) 1))) - -(defmacro ediff-set-fine-diff-vector (n buf-type fine-vec) - (` (aset (ediff-get-difference (, n) (, buf-type)) 1 (, fine-vec)))) - -(defmacro ediff-get-state-of-diff (n buf-type) - (` (if (ediff-buffer-live-p ediff-buffer-C) - (aref (ediff-get-difference (, n) (, buf-type)) 3)))) -(defmacro ediff-set-state-of-diff (n buf-type val) - (` (aset (ediff-get-difference (, n) (, buf-type)) 3 (, val)))) -(defmacro ediff-get-state-of-merge (n) - (` (if ediff-state-of-merge - (aref (aref ediff-state-of-merge (, n)) 0)))) -(defmacro ediff-get-state-of-ancestor (n) - (` (if ediff-state-of-merge - (aref (aref ediff-state-of-merge (, n)) 1)))) -(defmacro ediff-set-state-of-merge (n val) - (` (if ediff-state-of-merge - (aset (aref ediff-state-of-merge (, n)) 0 (, val))))) - -;; if flag is t, puts a mark on diff region saying that -;; the differences are in white space only. If flag is nil, -;; the region is marked as essential (i.e., differences are -;; not just in the white space and newlines.) -(defmacro ediff-mark-diff-as-space-only (n flag) - (` (aset (ediff-get-difference (, n) 'A) 2 (, flag)))) - -(defmacro ediff-get-fine-diff-vector (n buf-type) - (` (ediff-get-fine-diff-vector-from-diff-record - (ediff-get-difference (, n) (, buf-type))))) - -;; Macro to switch to BUFFER, evaluate BODY, returns to original buffer. -;; Doesn't save the point and mark. -;; This is `with-current-buffer' with the added test for live buffers." -(defmacro ediff-with-current-buffer (buffer &rest body) - (` (if (ediff-buffer-live-p (, buffer)) - (save-current-buffer - (set-buffer (, buffer)) - (,@ body)) - (or (eq this-command 'ediff-quit) - (error ediff-KILLED-VITAL-BUFFER)) - ))) - - -(defsubst ediff-multiframe-setup-p () - (and (ediff-window-display-p) ediff-multiframe)) - -(defmacro ediff-narrow-control-frame-p () - (` (and (ediff-multiframe-setup-p) - (equal ediff-help-message ediff-brief-message-string)))) - -(defmacro ediff-3way-comparison-job () - (` (memq - ediff-job-name - '(ediff-files3 ediff-buffers3)))) -(ediff-defvar-local ediff-3way-comparison-job nil "") - -(defmacro ediff-merge-job () - (` (memq - ediff-job-name - '(ediff-merge-files - ediff-merge-buffers - ediff-merge-files-with-ancestor - ediff-merge-buffers-with-ancestor - ediff-merge-revisions - ediff-merge-revisions-with-ancestor)))) -(ediff-defvar-local ediff-merge-job nil "") - -(defmacro ediff-merge-with-ancestor-job () - (` (memq - ediff-job-name - '(ediff-merge-files-with-ancestor - ediff-merge-buffers-with-ancestor - ediff-merge-revisions-with-ancestor)))) -(ediff-defvar-local ediff-merge-with-ancestor-job nil "") - -(defmacro ediff-3way-job () - (` (or ediff-3way-comparison-job ediff-merge-job))) -(ediff-defvar-local ediff-3way-job nil "") - -;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use -;; of diff3. -(defmacro ediff-diff3-job () - (` (or ediff-3way-comparison-job - ediff-merge-with-ancestor-job))) -(ediff-defvar-local ediff-diff3-job nil "") - -(defmacro ediff-windows-job () - (` (memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))) -(ediff-defvar-local ediff-windows-job nil "") - -(defmacro ediff-word-mode-job () - (` (memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))) -(ediff-defvar-local ediff-word-mode-job nil "") - -(defmacro ediff-narrow-job () - (` (memq ediff-job-name '(ediff-windows-wordwise - ediff-regions-wordwise - ediff-windows-linewise - ediff-regions-linewise)))) -(ediff-defvar-local ediff-narrow-job nil "") - -;; Note: ediff-merge-directory-revisions-with-ancestor is not treated as an -;; ancestor metajob, since it behaves differently. -(defsubst ediff-ancestor-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-merge-directories-with-ancestor - ediff-merge-filegroups-with-ancestor))) -(defsubst ediff-revision-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-directory-revisions - ediff-merge-directory-revisions - ediff-merge-directory-revisions-with-ancestor))) -(defsubst ediff-patch-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-multifile-patch))) -;; metajob involving only one group of files, such as multipatch or directory -;; revision -(defsubst ediff-one-filegroup-metajob (&optional metajob) - (or (ediff-revision-metajob metajob) - (ediff-patch-metajob metajob) - ;; add more here - )) -(defsubst ediff-collect-diffs-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-directories - ediff-directory-revisions - ediff-merge-directories - ediff-merge-directories-with-ancestor - ediff-merge-directory-revisions - ediff-merge-directory-revisions-with-ancestor - ;; add more here - ))) -(defsubst ediff-merge-metajob (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-merge-directories - ediff-merge-directories-with-ancestor - ediff-merge-directory-revisions - ediff-merge-directory-revisions-with-ancestor - ediff-merge-filegroups-with-ancestor - ;; add more here - ))) - -(defsubst ediff-metajob3 (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-merge-directories-with-ancestor - ediff-merge-filegroups-with-ancestor - ediff-directories3 - ediff-filegroups3))) -(defsubst ediff-comparison-metajob3 (&optional metajob) - (memq (or metajob ediff-metajob-name) - '(ediff-directories3 ediff-filegroups3))) - -;; with no argument, checks if we are in ediff-control-buffer -;; with argument, checks if we are in ediff-meta-buffer -(defun ediff-in-control-buffer-p (&optional meta-buf-p) - (and (boundp 'ediff-control-buffer) - (eq (if meta-buf-p ediff-meta-buffer ediff-control-buffer) - (current-buffer)))) - -(defsubst ediff-barf-if-not-control-buffer (&optional meta-buf-p) - (or (ediff-in-control-buffer-p meta-buf-p) - (error "%S: This command runs in Ediff Control Buffer only!" - this-command))) - -;; Hook variables - -(defcustom ediff-before-setup-windows-hook nil - "*Hooks to run before Ediff sets its window configuration. -This can be used to save the previous window config, which can be restored -on ediff-quit or ediff-suspend." - :type 'hook - :group 'ediff) -(defcustom ediff-after-setup-windows-hook nil - "*Hooks to run after Ediff sets its window configuration. -This can be used to set up control window or icon in a desired place." - :type 'hook - :group 'ediff) -(defcustom ediff-before-setup-control-frame-hook nil - "*Hooks run before setting up the frame to display Ediff Control Panel. -Can be used to change control frame parameters to position it where it -is desirable." - :type 'hook - :group 'ediff) -(defcustom ediff-after-setup-control-frame-hook nil - "*Hooks run after setting up the frame to display Ediff Control Panel. -Can be used to move the frame where it is desired." - :type 'hook - :group 'ediff) -(defcustom ediff-startup-hook nil - "*Hooks to run in the control buffer after Ediff has been set up." - :type 'hook - :group 'ediff) -(defcustom ediff-select-hook nil - "*Hooks to run after a difference has been selected." - :type 'hook - :group 'ediff) -(defcustom ediff-unselect-hook nil - "*Hooks to run after a difference has been unselected." - :type 'hook - :group 'ediff) -(defcustom ediff-prepare-buffer-hook nil - "*Hooks called after buffers A, B, and C are set up." - :type 'hook - :group 'ediff) -(defcustom ediff-load-hook nil - "*Hook run after Ediff is loaded. Can be used to change defaults." - :type 'hook - :group 'ediff) - -(defcustom ediff-mode-hook nil - "*Hook run just after ediff-mode is set up in the control buffer. -This is done before any windows or frames are created. One can use it to -set local variables that determine how the display looks like." - :type 'hook - :group 'ediff) -(defcustom ediff-keymap-setup-hook nil - "*Hook run just after the default bindings in Ediff keymap are set up." - :type 'hook - :group 'ediff) - -(defcustom ediff-display-help-hook nil - "*Hooks run after preparing the help message." - :type 'hook - :group 'ediff) - -(defcustom ediff-suspend-hook (list 'ediff-default-suspend-function) - "*Hooks to run in the Ediff control buffer when Ediff is suspended." - :type 'hook - :group 'ediff) -(defcustom ediff-quit-hook (list 'ediff-cleanup-mess) - "*Hooks to run in the Ediff control buffer after finishing Ediff." - :type 'hook - :group 'ediff) -(defcustom ediff-cleanup-hook nil - "*Hooks to run on exiting Ediff but before killing the control buffer. -This is a place to do various cleanups, such as deleting the variant buffers. -Ediff provides a function, `ediff-janitor', as one such possible hook." - :type 'hook - :group 'ediff) - -;; Error messages -(defconst ediff-KILLED-VITAL-BUFFER - "You have killed a vital Ediff buffer---you must leave Ediff now!") -(defconst ediff-NO-DIFFERENCES - "Sorry, comparison of identical variants is not what I am made for...") -(defconst ediff-BAD-DIFF-NUMBER - ;; %S stands for this-command, %d - diff number, %d - max diff - "%S: Bad diff region number, %d. Valid numbers are 1 to %d") -(defconst ediff-BAD-INFO (format " -*** The Info file for Ediff, a part of the standard distribution -*** of %sEmacs, does not seem to be properly installed. -*** -*** Please contact your system administrator. " - (if ediff-xemacs-p "X" ""))) - -;; Selective browsing - -(ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs - "Function that determines the next/previous diff region to show. -Should return t for regions to be ignored and nil otherwise. -This function gets a region number as an argument. The region number -is the one used internally by Ediff. It is 1 less than the number seen -by the user.") - -(ediff-defvar-local ediff-hide-regexp-matches-function - 'ediff-hide-regexp-matches - "Function to use in determining which regions to hide. -See the documentation string of `ediff-hide-regexp-matches' for details.") -(ediff-defvar-local ediff-focus-on-regexp-matches-function - 'ediff-focus-on-regexp-matches - "Function to use in determining which regions to focus on. -See the documentation string of `ediff-focus-on-regexp-matches' for details.") - -;; Regexp that determines buf A regions to focus on when skipping to diff -(ediff-defvar-local ediff-regexp-focus-A "" "") -;; Regexp that determines buf B regions to focus on when skipping to diff -(ediff-defvar-local ediff-regexp-focus-B "" "") -;; Regexp that determines buf C regions to focus on when skipping to diff -(ediff-defvar-local ediff-regexp-focus-C "" "") -;; connective that determines whether to focus regions that match both or -;; one of the regexps -(ediff-defvar-local ediff-focus-regexp-connective 'and "") - -;; Regexp that determines buf A regions to ignore when skipping to diff -(ediff-defvar-local ediff-regexp-hide-A "" "") -;; Regexp that determines buf B regions to ignore when skipping to diff -(ediff-defvar-local ediff-regexp-hide-B "" "") -;; Regexp that determines buf C regions to ignore when skipping to diff -(ediff-defvar-local ediff-regexp-hide-C "" "") -;; connective that determines whether to hide regions that match both or -;; one of the regexps -(ediff-defvar-local ediff-hide-regexp-connective 'and "") - - -;;; Copying difference regions between buffers. - -;; A list of killed diffs. -;; A diff is saved here if it is replaced by a diff -;; from another buffer. This alist has the form: -;; \((num (buff-object . diff) (buff-object . diff) (buff-object . diff)) ...), -;; where some buffer-objects may be missing. -(ediff-defvar-local ediff-killed-diffs-alist nil "") - - -;; Highlighting -(defcustom ediff-before-flag-bol (if ediff-xemacs-p (make-glyph "->>") "->>") - "*Flag placed before a highlighted block of differences, if block starts at beginning of a line." - :type 'string - :tag "Region before-flag at beginning of line" - :group 'ediff) - -(defcustom ediff-after-flag-eol (if ediff-xemacs-p (make-glyph "<<-") "<<-") - "*Flag placed after a highlighted block of differences, if block ends at end of a line." - :type 'string - :tag "Region after-flag at end of line" - :group 'ediff) - -(defcustom ediff-before-flag-mol (if ediff-xemacs-p (make-glyph "->>") "->>") - "*Flag placed before a highlighted block of differences, if block starts in mid-line." - :type 'string - :tag "Region before-flag in the middle of line" - :group 'ediff) -(defcustom ediff-after-flag-mol (if ediff-xemacs-p (make-glyph "<<-") "<<-") - "*Flag placed after a highlighted block of differences, if block ends in mid-line." - :type 'string - :tag "Region after-flag in the middle of line" - :group 'ediff) - - -(ediff-defvar-local ediff-use-faces t - "If t, differences are highlighted using faces, if device supports faces. -If nil, differences are highlighted using ASCII flags, ediff-before-flag -and ediff-after-flag. On a non-window system, differences are always -highlighted using ASCII flags. -This variable can be set either in .emacs or toggled interactively. -Use `setq-default' if setting it in .emacs") - -;; this indicates that diff regions are word-size, so fine diffs are -;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise -(ediff-defvar-local ediff-word-mode nil "") -;; Name of the job (ediff-files, ediff-windows, etc.) -(ediff-defvar-local ediff-job-name nil "") - -;; Narrowing and ediff-region/windows support -;; This is a list (overlay-A overlay-B overlay-C) -;; If set, Ediff compares only those parts of buffers A/B/C that lie within -;; the bounds of these overlays. -(ediff-defvar-local ediff-narrow-bounds nil "") - -;; List (overlay-A overlay-B overlay-C), where each overlay spans the -;; entire corresponding buffer. -(ediff-defvar-local ediff-wide-bounds nil "") - -;; Current visibility boundaries in buffers A, B, and C. -;; This is also a list of overlays. When the user toggles narrow/widen, -;; this list changes from ediff-wide-bounds to ediff-narrow-bounds. -;; and back. -(ediff-defvar-local ediff-visible-bounds nil "") - -(ediff-defvar-local ediff-start-narrowed t - "Non-nil means start narrowed, if doing ediff-windows-* or ediff-regions-*") -(ediff-defvar-local ediff-quit-widened t - "*Non-nil means: when finished, Ediff widens buffers A/B. -Actually, Ediff restores the scope of visibility that existed at startup.") - -(defcustom ediff-keep-variants t - "*Nil means that non-modified variant buffers should be removed at the end of the session after some interrogation. -Supplying a prefix argument to the quit command `q' temporarily reverses the -meaning of this variable." - :type 'boolean - :group 'ediff) - -(ediff-defvar-local ediff-highlight-all-diffs t - "If nil, only the selected differences are highlighted. -This variable can be set either in .emacs or toggled interactively, using -ediff-toggle-hilit. Use `setq-default' to set it.") - -;; A var local to each control panel buffer. Indicates highlighting style -;; in effect for this buffer: `face', `ascii', nil -- temporarily -;; unhighlighted, `off' -- turned off \(on a dumb terminal only\). -(ediff-defvar-local ediff-highlighting-style nil "") - - -;; The suffix of the control buffer name. -(ediff-defvar-local ediff-control-buffer-suffix nil "") -;; Same as ediff-control-buffer-suffix, but without <,>. -;; It's a number rather than string. -(ediff-defvar-local ediff-control-buffer-number nil "") - - -;; The original values of ediff-protected-variables for buffer A -(ediff-defvar-local ediff-buffer-values-orig-A nil "") -;; The original values of ediff-protected-variables for buffer B -(ediff-defvar-local ediff-buffer-values-orig-B nil "") -;; The original values of ediff-protected-variables for buffer C -(ediff-defvar-local ediff-buffer-values-orig-C nil "") -;; The original values of ediff-protected-variables for buffer Ancestor -(ediff-defvar-local ediff-buffer-values-orig-Ancestor nil "") - -;; association between buff-type and ediff-buffer-values-orig-* -(defconst ediff-buffer-values-orig-alist - '((A . ediff-buffer-values-orig-A) - (B . ediff-buffer-values-orig-B) - (C . ediff-buffer-values-orig-C) - (Ancestor . ediff-buffer-values-orig-Ancestor))) - -;; Buffer-local variables to be saved then restored during Ediff sessions -(defconst ediff-protected-variables '( - ;;buffer-read-only - mode-line-format)) - -;; Vector of differences between the variants. Each difference is -;; represented by a vector of two overlays plus a vector of fine diffs, -;; plus a no-fine-diffs flag. The first overlay spans the -;; difference region in the A buffer and the second overlays the diff in -;; the B buffer. If a difference section is empty, the corresponding -;; overlay's endpoints coincide. -;; -;; The precise form of a difference vector for one buffer is: -;; [diff diff diff ...] -;; where each diff has the form: -;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-difference] -;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...] -;; no-fine-diffs-flag says if there are fine differences. -;; state-of-difference is A, B, C, or nil, indicating which buffer is -;; different from the other two (used only in 3-way jobs. -(ediff-defvar-local ediff-difference-vector-A nil "") -(ediff-defvar-local ediff-difference-vector-B nil "") -(ediff-defvar-local ediff-difference-vector-C nil "") -(ediff-defvar-local ediff-difference-vector-Ancestor nil "") -;; A-list of diff vector types associated with buffer types -(defconst ediff-difference-vector-alist - '((A . ediff-difference-vector-A) - (B . ediff-difference-vector-B) - (C . ediff-difference-vector-C) - (Ancestor . ediff-difference-vector-Ancestor))) - -;; [ status status status ...] -;; Each status: [state-of-merge state-of-ancestor] -;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It -;; indicates the way a diff region was created in buffer C. -;; state-of-ancestor says if the corresponding region in ancestor buffer is -;; empty. -(ediff-defvar-local ediff-state-of-merge nil "") - -;; The difference that is currently selected. -(ediff-defvar-local ediff-current-difference -1 "") -;; Number of differences found. -(ediff-defvar-local ediff-number-of-differences nil "") - -;; Buffer containing the output of diff, which is used by Ediff to step -;; through files. -(ediff-defvar-local ediff-diff-buffer nil "") -;; Like ediff-diff-buffer, but contains context diff. It is not used by -;; Ediff, but it is saved in a file, if user requests so. -(ediff-defvar-local ediff-custom-diff-buffer nil "") -;; Buffer used for diff-style fine differences between regions. -(ediff-defvar-local ediff-fine-diff-buffer nil "") -;; Temporary buffer used for computing fine differences. -(defconst ediff-tmp-buffer " *ediff-tmp*" "") -;; Buffer used for messages -(defconst ediff-msg-buffer " *ediff-message*" "") -;; Buffer containing the output of diff when diff returns errors. -(ediff-defvar-local ediff-error-buffer nil "") -;; Buffer to display debug info -(ediff-defvar-local ediff-debug-buffer "*ediff-debug*" "") - -;; List of ediff control panels associated with each buffer A/B/C/Ancestor. -;; Not used any more, but may be needed in the future. -(ediff-defvar-local ediff-this-buffer-ediff-sessions nil "") - -;; to be deleted in due time -;; List of difference overlays disturbed by working with the current diff. -(defvar ediff-disturbed-overlays nil "") - -;; Priority of non-selected overlays. -(defvar ediff-shadow-overlay-priority 100 "") - -(defcustom ediff-version-control-package 'vc - "Version control package used. -Currently, Ediff supports vc.el, rcs.el, pcl-cvs.el, and generic-sc.el. The -standard Emacs interface to RCS, CVS, SCCS, etc., is vc.el. However, some -people find the other two packages more convenient. Set this variable to the -appropriate symbol: `rcs', `pcl-cvs', or `generic-sc' if you so desire." - :type 'symbol - :group 'ediff) - - -(if ediff-xemacs-p - (progn - (fset 'ediff-read-event (symbol-function 'next-command-event)) - (fset 'ediff-overlayp (symbol-function 'extentp)) - (fset 'ediff-make-overlay (symbol-function 'make-extent)) - (fset 'ediff-delete-overlay (symbol-function 'delete-extent))) - (fset 'ediff-read-event (symbol-function 'read-event)) - (fset 'ediff-overlayp (symbol-function 'overlayp)) - (fset 'ediff-make-overlay (symbol-function 'make-overlay)) - (fset 'ediff-delete-overlay (symbol-function 'delete-overlay))) - -;; Check the current version against the major and minor version numbers -;; using op: cur-vers op major.minor If emacs-major-version or -;; emacs-minor-version are not defined, we assume that the current version -;; is hopelessly outdated. We assume that emacs-major-version and -;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the -;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value -;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be -;; incorrect. However, this gives correct result in our cases, since we are -;; testing for sufficiently high Emacs versions. -(defun ediff-check-version (op major minor &optional type-of-emacs) - (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) - (and (cond ((eq type-of-emacs 'xemacs) ediff-xemacs-p) - ((eq type-of-emacs 'emacs) ediff-emacs-p) - (t t)) - (cond ((eq op '=) (and (= emacs-minor-version minor) - (= emacs-major-version major))) - ((memq op '(> >= < <=)) - (and (or (funcall op emacs-major-version major) - (= emacs-major-version major)) - (if (= emacs-major-version major) - (funcall op emacs-minor-version minor) - t))) - (t - (error "%S: Invalid op in ediff-check-version" op)))) - (cond ((memq op '(= > >=)) nil) - ((memq op '(< <=)) t)))) - - - -;; A fix for NeXT Step -;; Should probably be eliminated in later versions. -(if (and (ediff-window-display-p) (eq (ediff-device-type) 'ns)) - (progn - (fset 'x-display-color-p (symbol-function 'ns-display-color-p)) - (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p)) - (fset 'x-display-pixel-height (symbol-function 'ns-display-pixel-height)) - (fset 'x-display-pixel-width (symbol-function 'ns-display-pixel-width)) - )) - - -(defsubst ediff-color-display-p () - (if ediff-emacs-p - (x-display-color-p) - (eq (device-class (selected-device)) 'color))) - - -(if (ediff-has-face-support-p) - (if ediff-xemacs-p - (progn - (fset 'ediff-valid-color-p (symbol-function 'valid-color-name-p)) - (fset 'ediff-get-face (symbol-function 'get-face))) - ;; Temporary fix for OS/2 port of Emacs - ;; pm-win.el in PM-Emacs should be fixed. - (if (eq (ediff-device-type) 'pm) - (fset 'ediff-valid-color-p - (function (lambda (color) (assoc color pm-color-alist)))) - (fset 'ediff-valid-color-p (symbol-function 'x-color-defined-p))) - (fset 'ediff-get-face (symbol-function 'internal-get-face)))) - -(if (ediff-window-display-p) - (if ediff-xemacs-p - (progn - (fset 'ediff-display-pixel-width - (symbol-function 'device-pixel-width)) - (fset 'ediff-display-pixel-height - (symbol-function 'device-pixel-height))) - (fset 'ediff-display-pixel-width - (symbol-function 'x-display-pixel-width)) - (fset 'ediff-display-pixel-height - (symbol-function 'x-display-pixel-height)))) - -;; A-list of current-diff-overlay symbols asssociated with buf types -(defconst ediff-current-diff-overlay-alist - '((A . ediff-current-diff-overlay-A) - (B . ediff-current-diff-overlay-B) - (C . ediff-current-diff-overlay-C) - (Ancestor . ediff-current-diff-overlay-Ancestor))) - -;; A-list of current-diff-face-* symbols asssociated with buf types -(defconst ediff-current-diff-face-alist - '((A . ediff-current-diff-face-A) - (B . ediff-current-diff-face-B) - (C . ediff-current-diff-face-C) - (Ancestor . ediff-current-diff-face-Ancestor))) - - -(defun ediff-make-current-diff-overlay (type) - (if (ediff-has-face-support-p) - (let ((overlay (ediff-get-symbol-from-alist - type ediff-current-diff-overlay-alist)) - (buffer (ediff-get-buffer type)) - (face (face-name - (symbol-value - (ediff-get-symbol-from-alist - type ediff-current-diff-face-alist))))) - (set overlay - (ediff-make-bullet-proof-overlay (point-max) (point-max) buffer)) - (ediff-set-overlay-face (symbol-value overlay) face) - (ediff-overlay-put (symbol-value overlay) 'ediff ediff-control-buffer)) - )) - -(defun ediff-set-overlay-face (extent face) - (ediff-overlay-put extent 'face face) - (ediff-overlay-put extent 'help-echo 'ediff-region-help-echo)) - -;; This does nothing in Emacs, since overlays there have no help-echo property -(defun ediff-region-help-echo (extent) - (let ((is-current (ediff-overlay-get extent 'ediff)) - (face (ediff-overlay-get extent 'face)) - (diff-num (ediff-overlay-get extent 'ediff-diff-num)) - face-help) - - ;; This happens only for refinement overlays - (setq face-help (and face (get face 'ediff-help-echo))) - - (cond ((and is-current diff-num) ; current diff region - (format "Difference region %S -- current" (1+ diff-num))) - (face-help) ; refinement of current diff region - (diff-num ; non-current - (format "Difference region %S -- non-current" (1+ diff-num))) - (t "")) ; none - )) - -;;(defun ediff-set-face (ground face color) -;; "Set face foreground/background." -;; (if (ediff-has-face-support-p) -;; (if (ediff-valid-color-p color) -;; (if (eq ground 'foreground) -;; (set-face-foreground face color) -;; (set-face-background face color)) -;; (cond ((memq face -;; '(ediff-current-diff-face-A -;; ediff-current-diff-face-B -;; ediff-current-diff-face-C -;; ediff-current-diff-face-Ancestor)) -;; (copy-face 'highlight face)) -;; ((memq face -;; '(ediff-fine-diff-face-A -;; ediff-fine-diff-face-B -;; ediff-fine-diff-face-C -;; ediff-fine-diff-face-Ancestor)) -;; (copy-face 'secondary-selection face) -;; (set-face-underline-p face t)) -;; ((memq face -;; '(ediff-even-diff-face-A -;; ediff-odd-diff-face-A -;; ediff-even-diff-face-B ediff-odd-diff-face-B -;; ediff-even-diff-face-C ediff-odd-diff-face-C -;; ediff-even-diff-face-Ancestor -;; ediff-odd-diff-face-Ancestor)) -;; (copy-face 'secondary-selection face)))) -;; )) - -(defun ediff-set-face-pixmap (face pixmap) - "Set face pixmap on a monochrome display." - (if (and (ediff-window-display-p) (not (ediff-color-display-p))) - (condition-case nil - (set-face-background-pixmap face pixmap) - (error - (message "Pixmap not found for %S: %s" (face-name face) pixmap) - (sit-for 1))))) - -(defun ediff-hide-face (face) - (if (and (ediff-has-face-support-p) ediff-emacs-p) - (add-to-list 'facemenu-unlisted-faces face))) - -(defgroup ediff-highlighting nil - "Hilighting of difference regions in Ediff" - :prefix "ediff-" - :group 'ediff) - -;;(defvar ediff-current-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-current-diff-face-A "firebrick") -;; (ediff-set-face -;; 'background 'ediff-current-diff-face-A "pale green")) -;; (t -;; (if ediff-xemacs-p -;; (copy-face 'modeline 'ediff-current-diff-face-A) -;; (copy-face 'highlight 'ediff-current-diff-face-A)) -;; ))) -;; 'ediff-current-diff-face-A)) -;; "Face for highlighting the selected difference in buffer A.") - -(defface ediff-current-diff-face-A - '((((class color)) (:foreground "firebrick" :background "pale green")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-A 'ediff-current-diff-face-A - "Face for highlighting the selected difference in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-current-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-A) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-A)) - - - -;;(defvar ediff-current-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-current-diff-face-B "DarkOrchid") -;; (ediff-set-face -;; 'background 'ediff-current-diff-face-B "Yellow")) -;; (t -;; (if ediff-xemacs-p -;; (copy-face 'modeline 'ediff-current-diff-face-B) -;; (copy-face 'highlight 'ediff-current-diff-face-B)) -;; ))) -;; 'ediff-current-diff-face-B)) -;; "Face for highlighting the selected difference in buffer B.") - -(defface ediff-current-diff-face-B - '((((class color)) (:foreground "DarkOrchid" :background "Yellow")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-B 'ediff-current-diff-face-B - "Face for highlighting the selected difference in buffer B. - this variable. Instead, use the customization -widget to customize the actual face `ediff-current-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-B) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-B)) - -;;(defvar ediff-current-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-C) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-current-diff-face-C "Navy") -;; (ediff-set-face -;; 'background 'ediff-current-diff-face-C "Pink")) -;; (t -;; (if ediff-xemacs-p -;; (copy-face 'modeline 'ediff-current-diff-face-C) -;; (copy-face 'highlight 'ediff-current-diff-face-C)) -;; ))) -;; 'ediff-current-diff-face-C)) -;; "Face for highlighting the selected difference in buffer C.") - -(defface ediff-current-diff-face-C - '((((class color)) (:foreground "Navy" :background "Pink")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-C 'ediff-current-diff-face-C - "Face for highlighting the selected difference in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-current-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-C) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-C)) - -;;(defvar ediff-current-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-current-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-current-diff-face-Ancestor) -;; (copy-face -;; 'ediff-current-diff-face-C 'ediff-current-diff-face-Ancestor)) -;; 'ediff-current-diff-face-Ancestor)) -;; "Face for highlighting the selected difference in the ancestor buffer.") - -(defface ediff-current-diff-face-Ancestor - '((((class color)) (:foreground "Black" :background "VioletRed")) - (t (:inverse-video t))) - "Face for highlighting the selected difference in buffer Ancestor." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-current-diff-face-Ancestor 'ediff-current-diff-face-Ancestor - "Face for highlighting the selected difference in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-current-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-current-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :inverse-video we do this. -;; This means that some user customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (copy-face 'modeline 'ediff-current-diff-face-Ancestor)) - -;;(defvar ediff-fine-diff-pixmap "gray3" -;; "Pixmap to use for highlighting fine differences.") -;;(defvar ediff-odd-diff-pixmap "gray1" -;; "Pixmap to use for highlighting odd differences.") -;;(defvar ediff-even-diff-pixmap "Stipple" -;; "Pixmap to use for highlighting even differences.") - -;;(defvar ediff-fine-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face 'foreground 'ediff-fine-diff-face-A -;; "Navy") -;; (ediff-set-face 'background 'ediff-fine-diff-face-A -;; "sky blue")) -;; (t -;; (set-face-underline-p 'ediff-fine-diff-face-A t) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-A -;; ediff-fine-diff-pixmap) -;; ))) -;; 'ediff-fine-diff-face-A)) -;; "Face for highlighting the refinement of the selected diff in buffer A.") - - -(defface ediff-fine-diff-face-A - '((((class color)) (:foreground "Navy" :background "sky blue")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-A 'ediff-fine-diff-face-A - "Face for highlighting the fine differences in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-A) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-fine-diff-face-A "gray3")) - -;;(defvar ediff-fine-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face 'foreground 'ediff-fine-diff-face-B "Black") -;; (ediff-set-face 'background 'ediff-fine-diff-face-B "cyan")) -;; (t -;; (set-face-underline-p 'ediff-fine-diff-face-B t) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-B -;; ediff-fine-diff-pixmap) -;; ))) -;; 'ediff-fine-diff-face-B)) -;; "Face for highlighting the refinement of the selected diff in buffer B.") - -(defface ediff-fine-diff-face-B - '((((class color)) (:foreground "Black" :background "cyan")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-B 'ediff-fine-diff-face-B - "Face for highlighting the fine differences in buffer B. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-B) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-fine-diff-face-B "gray3")) - -;;(defvar ediff-fine-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-C) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face 'foreground 'ediff-fine-diff-face-C "black") -;; (ediff-set-face -;; 'background 'ediff-fine-diff-face-C "Turquoise")) -;; (t -;; (set-face-underline-p 'ediff-fine-diff-face-C t) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-C -;; ediff-fine-diff-pixmap) -;; ))) -;; 'ediff-fine-diff-face-C)) -;; "Face for highlighting the refinement of the selected diff in buffer C.") - -(defface ediff-fine-diff-face-C - '((((class color)) (:foreground "Black" :background "Turquoise")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-C 'ediff-fine-diff-face-C - "Face for highlighting the fine differences in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-C) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-fine-diff-face-C "gray3")) - -;;(defvar ediff-fine-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-fine-diff-face-Ancestor) -;; (ediff-hide-face 'ediff-fine-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-fine-diff-face-Ancestor) -;; (progn -;; (copy-face -;; 'ediff-fine-diff-face-C 'ediff-fine-diff-face-Ancestor) -;; (ediff-set-face-pixmap 'ediff-fine-diff-face-Ancestor -;; ediff-fine-diff-pixmap)) -;; ))) -;; "Face highlighting refinements of the selected diff in ancestor buffer. -;;Presently, this is not used, as difference regions are not refined in the -;;ancestor buffer.") - -(defface ediff-fine-diff-face-Ancestor - '((((class color)) (:foreground "Black" :background "Green")) - (t (:underline t :stipple "gray3"))) - "Face for highlighting the refinement of the selected diff in the ancestor buffer. -At present, this face is not used and no fine differences are computed for the -ancestor buffer." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-fine-diff-face-Ancestor 'ediff-fine-diff-face-Ancestor - "Face for highlighting the fine differences in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-fine-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-fine-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap - 'ediff-fine-diff-face-Ancestor "gray3")) - -;;(defvar ediff-even-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-even-diff-face-A "black") -;; (ediff-set-face -;; 'background 'ediff-even-diff-face-A "light grey")) -;; (t -;; (copy-face 'italic 'ediff-even-diff-face-A) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-A -;; ediff-even-diff-pixmap) -;; ))) -;; 'ediff-even-diff-face-A)) -;; "Face used for highlighting even-numbered differences in buffer A.") - -(defface ediff-even-diff-face-A - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-A 'ediff-even-diff-face-A - "Face for highlighting even-numbered non-current differences in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-A) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-even-diff-face-A "Stipple")) - -;;(defvar ediff-even-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-even-diff-face-B "White") -;; (ediff-set-face -;; 'background 'ediff-even-diff-face-B "Gray")) -;; (t -;; (copy-face 'italic 'ediff-even-diff-face-B) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-B -;; ediff-even-diff-pixmap) -;; ))) -;; 'ediff-even-diff-face-B)) -;; "Face used for highlighting even-numbered differences in buffer B.") - -(defface ediff-even-diff-face-B - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-B 'ediff-even-diff-face-B - "Face for highlighting even-numbered non-current differences in buffer B. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-B) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-even-diff-face-B "Stipple")) - -;;(defvar ediff-even-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-C) -;; (ediff-hide-face 'ediff-even-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-C) -;; (progn -;; (copy-face 'ediff-even-diff-face-A 'ediff-even-diff-face-C) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-C -;; ediff-even-diff-pixmap))) -;; 'ediff-even-diff-face-C)) -;; "Face used for highlighting even-numbered differences in buffer C.") - -(defface ediff-even-diff-face-C - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-C 'ediff-even-diff-face-C - "Face for highlighting even-numbered non-current differences in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-C) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-even-diff-face-C "Stipple")) - -;;(defvar ediff-even-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-even-diff-face-Ancestor) -;; (ediff-hide-face 'ediff-even-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-even-diff-face-Ancestor) -;; (progn -;; (copy-face -;; 'ediff-even-diff-face-C 'ediff-even-diff-face-Ancestor) -;; (ediff-set-face-pixmap 'ediff-even-diff-face-Ancestor -;; ediff-even-diff-pixmap))) -;; 'ediff-even-diff-face-Ancestor)) -;; "Face highlighting even-numbered differences in the ancestor buffer.") - -(defface ediff-even-diff-face-Ancestor - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "Stipple"))) - "Face for highlighting even-numbered non-current differences in the ancestor buffer." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-even-diff-face-Ancestor 'ediff-even-diff-face-Ancestor - "Face for highlighting even-numbered non-current differences in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-even-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-even-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap - 'ediff-even-diff-face-Ancestor "Stipple")) - -;; Association between buffer types and even-diff-face symbols -(defconst ediff-even-diff-face-alist - '((A . ediff-even-diff-face-A) - (B . ediff-even-diff-face-B) - (C . ediff-even-diff-face-C) - (Ancestor . ediff-even-diff-face-Ancestor))) - -;;(defvar ediff-odd-diff-face-A -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-A) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-A) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-odd-diff-face-A "White") -;; (ediff-set-face -;; 'background 'ediff-odd-diff-face-A "Gray")) -;; (t -;; (copy-face 'italic 'ediff-odd-diff-face-A) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-A -;; ediff-odd-diff-pixmap) -;; ))) -;; 'ediff-odd-diff-face-A)) -;; "Face used for highlighting odd-numbered differences in buffer A.") - -(defface ediff-odd-diff-face-A - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in buffer A." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-A 'ediff-odd-diff-face-A - "Face for highlighting odd-numbered non-current differences in buffer A. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-A' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-A) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-A "gray1")) - -;;(defvar ediff-odd-diff-face-B -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-B) -;; (ediff-hide-face 'ediff-odd-diff-face-B) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-B) -;; (cond ((ediff-color-display-p) -;; (ediff-set-face -;; 'foreground 'ediff-odd-diff-face-B "Black") -;; (ediff-set-face -;; 'background 'ediff-odd-diff-face-B "light grey")) -;; (t -;; (copy-face 'italic 'ediff-odd-diff-face-B) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-B -;; ediff-odd-diff-pixmap) -;; ))) -;; 'ediff-odd-diff-face-B)) -;; "Face used for highlighting odd-numbered differences in buffer B.") - -(defface ediff-odd-diff-face-B - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in buffer B." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-B 'ediff-odd-diff-face-B - "Face for highlighting odd-numbered non-current differences in buffer B. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-B' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-B) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-B "gray1")) - -;;(defvar ediff-odd-diff-face-C -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-C) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-C) -;; (progn -;; (copy-face 'ediff-odd-diff-face-A 'ediff-odd-diff-face-C) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-C -;; ediff-odd-diff-pixmap))) -;; 'ediff-odd-diff-face-C)) -;; "Face used for highlighting odd-numbered differences in buffer C.") - -(defface ediff-odd-diff-face-C - '((((class color)) (:foreground "White" :background "Grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in buffer C." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-C 'ediff-odd-diff-face-C - "Face for highlighting odd-numbered non-current differences in buffer C. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-C' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-C) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-C "gray1")) - -;;(defvar ediff-odd-diff-face-Ancestor -;; (if (ediff-has-face-support-p) -;; (progn -;; (make-face 'ediff-odd-diff-face-Ancestor) -;; (or (face-differs-from-default-p 'ediff-odd-diff-face-Ancestor) -;; (progn -;; (copy-face 'ediff-odd-diff-face-C 'ediff-odd-diff-face-Ancestor) -;; (ediff-set-face-pixmap 'ediff-odd-diff-face-Ancestor -;; ediff-odd-diff-pixmap))) -;; 'ediff-odd-diff-face-Ancestor)) -;; "Face used for highlighting even-numbered differences in the ancestor buffer.") - -(defface ediff-odd-diff-face-Ancestor - '((((class color)) (:foreground "Black" :background "light grey")) - (t (:italic t :stipple "gray1"))) - "Face for highlighting odd-numbered non-current differences in the ancestor buffer." - :group 'ediff-highlighting) -;; An internal variable. Ediff takes the face from here. When unhighlighting, -;; this variable is set to nil, then again to the appropriate face. -(defvar ediff-odd-diff-face-Ancestor 'ediff-odd-diff-face-Ancestor - "Face for highlighting odd-numbered non-current differences in buffer Ancestor. -DO NOT CHANGE this variable. Instead, use the customization -widget to customize the actual face object `ediff-odd-diff-face-Ancestor' -this variable represents.") -(ediff-hide-face 'ediff-odd-diff-face-Ancestor) -;; Until custom.el for XEmacs starts supporting :stipple we do this. -;; This means that some use customization may be trashed. -(if (and ediff-xemacs-p - (ediff-has-face-support-p) - (not (ediff-color-display-p))) - (ediff-set-face-pixmap 'ediff-odd-diff-face-Ancestor "gray1")) - -;; Association between buffer types and odd-diff-face symbols -(defconst ediff-odd-diff-face-alist - '((A . ediff-odd-diff-face-A) - (B . ediff-odd-diff-face-B) - (C . ediff-odd-diff-face-C) - (Ancestor . ediff-odd-diff-face-Ancestor))) - -;; A-list of fine-diff face symbols associated with buffer types -(defconst ediff-fine-diff-face-alist - '((A . ediff-fine-diff-face-A) - (B . ediff-fine-diff-face-B) - (C . ediff-fine-diff-face-C) - (Ancestor . ediff-fine-diff-face-Ancestor))) - -;; Help echo -(put 'ediff-fine-diff-face-A 'ediff-help-echo - "A `refinement' of the current difference region") -(put 'ediff-fine-diff-face-B 'ediff-help-echo - "A `refinement' of the current difference region") -(put 'ediff-fine-diff-face-C 'ediff-help-echo - "A `refinement' of the current difference region") -(put 'ediff-fine-diff-face-Ancestor 'ediff-help-echo - "A `refinement' of the current difference region") - - -;;; Overlays - -(ediff-defvar-local ediff-current-diff-overlay-A nil - "Overlay for the current difference region in buffer A.") -(ediff-defvar-local ediff-current-diff-overlay-B nil - "Overlay for the current difference region in buffer B.") -(ediff-defvar-local ediff-current-diff-overlay-C nil - "Overlay for the current difference region in buffer C.") -(ediff-defvar-local ediff-current-diff-overlay-Ancestor nil - "Overlay for the current difference region in the ancestor buffer.") - -;; Compute priority of ediff overlay. -(defun ediff-highest-priority (start end buffer) - (let ((pos (max 1 (1- start))) - ovr-list) - (if ediff-xemacs-p - (1+ ediff-shadow-overlay-priority) - (ediff-with-current-buffer buffer - (while (< pos (min (point-max) (1+ end))) - (setq ovr-list (append (overlays-at pos) ovr-list)) - (setq pos (next-overlay-change pos))) - (1+ (apply '+ - (mapcar (function - (lambda (ovr) - (if ovr - (or (ediff-overlay-get ovr 'priority) 0) - 0))) - ovr-list) - )) - )))) - - -(defvar ediff-toggle-read-only-function nil - "*Specifies the function to be used to toggle read-only. -If nil, Ediff tries to deduce the function from the binding of C-x C-q. -Normally, this is the `toggle-read-only' function, but, if version -control is used, it could be `vc-toggle-read-only' or `rcs-toggle-read-only'.") - -(defcustom ediff-make-buffers-readonly-at-startup nil - "*Make all variant buffers read-only when Ediff starts up. -This property can be toggled interactively." - :type 'boolean - :group 'ediff) - - -;;; Misc - -;; if nil, this silences some messages -(defconst ediff-verbose-p t) - -(ediff-defvar-local ediff-autostore-merges 'group-jobs-only - "*Save the results of merge jobs automatically. -Nil means don't save automatically. t means always save. Anything but nil or t -means save automatically only if the merge job is part of a group of jobs, such -as `ediff-merge-directory' or `ediff-merge-directory-revisions'.") - -;; file where the result of the merge is to be saved. used internally -(ediff-defvar-local ediff-merge-store-file nil "") - -(defcustom ediff-no-emacs-help-in-control-buffer nil - "*Non-nil means C-h should not invoke Emacs help in control buffer. -Instead, C-h would jump to previous difference." - :type 'boolean - :group 'ediff) - -(defvar ediff-temp-file-prefix - (let ((env (or (getenv "TMPDIR") - (getenv "TMP") - (getenv "TEMP"))) - d) - (setq d (if (and env (> (length env) 0)) - env - (cond ((memq system-type '(vax-vms axp-vms)) "SYS$SCRATCH:") - ((eq system-type 'ms-dos) "c:/") - (t "/tmp")))) - ;; The following is to make sure we get something to which we can - ;; add directory levels on VMS. - (setq d (file-name-as-directory (directory-file-name d))) - ) - "*Prefix to put on Ediff temporary file names. -Do not start with `~/' or `~user-name/'.") - -(defvar ediff-temp-file-mode 384 ; u=rw only - "*Mode for Ediff temporary files.") - -;; Metacharacters that have to be protected from the shell when executing -;; a diff/diff3 command. -(defvar ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]" - "Characters that must be quoted with \\ when used in a shell command line. -More precisely, a regexp to match any one such character.") - -;; needed to simulate frame-char-width in XEmacs. -(defvar ediff-H-glyph (if ediff-xemacs-p (make-glyph "H"))) - - -;; Temporary file used for refining difference regions in buffer A. -(ediff-defvar-local ediff-temp-file-A nil "") -;; Temporary file used for refining difference regions in buffer B. -(ediff-defvar-local ediff-temp-file-B nil "") -;; Temporary file used for refining difference regions in buffer C. -(ediff-defvar-local ediff-temp-file-C nil "") - - -;;; In-line functions - -(or (fboundp 'ediff-file-remote-p) ; user supplied his own function: use it - (defun ediff-file-remote-p (file-name) - (car (cond ((featurep 'efs-auto) (efs-ftp-path file-name)) - ((fboundp 'file-remote-p) (file-remote-p file-name)) - (t (require 'ange-ftp) - ;; Can happen only in Emacs, since XEmacs has file-remote-p - (ange-ftp-ftp-name file-name)))))) - - -(defsubst ediff-frame-unsplittable-p (frame) - (cdr (assq 'unsplittable (frame-parameters frame)))) - -(defsubst ediff-get-next-window (wind prev-wind) - (or (window-live-p wind) - (setq wind (if prev-wind - (next-window wind) - (selected-window))))) - - -(defsubst ediff-kill-buffer-carefully (buf) - "Kill buffer BUF if it exists." - (if (ediff-buffer-live-p buf) - (kill-buffer (get-buffer buf)))) - -(defsubst ediff-background-face (buf-type dif-num) - ;; The value of dif-num is always 1- the one that user sees. - ;; This is why even face is used when dif-num is odd. - (ediff-get-symbol-from-alist - buf-type (if (ediff-odd-p dif-num) - ediff-even-diff-face-alist - ediff-odd-diff-face-alist) - )) - - -;; activate faces on diff regions in buffer -(defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight) - (let ((diff-vector - (eval (ediff-get-symbol-from-alist - buf-type ediff-difference-vector-alist))) - overl diff-num) - (mapcar (function - (lambda (rec) - (setq overl (ediff-get-diff-overlay-from-diff-record rec) - diff-num (ediff-overlay-get overl 'ediff-diff-num)) - (if (ediff-overlay-buffer overl) - ;; only if overlay is alive - (ediff-set-overlay-face - overl - (if (not unhighlight) - (ediff-background-face buf-type diff-num)))) - )) - diff-vector))) - - -;; activate faces on diff regions in all buffers -(defun ediff-paint-background-regions (&optional unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'A unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'B unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'C unhighlight) - (ediff-paint-background-regions-in-one-buffer - 'Ancestor unhighlight)) - -(defun ediff-highlight-diff-in-one-buffer (n buf-type) - (if (ediff-buffer-live-p (ediff-get-buffer buf-type)) - (let* ((buff (ediff-get-buffer buf-type)) - (last (ediff-with-current-buffer buff (point-max))) - (begin (ediff-get-diff-posn buf-type 'beg n)) - (end (ediff-get-diff-posn buf-type 'end n)) - (xtra (if (equal begin end) 1 0)) - (end-hilit (min last (+ end xtra))) - (current-diff-overlay - (symbol-value - (ediff-get-symbol-from-alist - buf-type ediff-current-diff-overlay-alist)))) - - (if ediff-xemacs-p - (ediff-move-overlay current-diff-overlay begin end-hilit) - (ediff-move-overlay current-diff-overlay begin end-hilit buff)) - (ediff-overlay-put current-diff-overlay 'priority - (ediff-highest-priority begin end-hilit buff)) - (ediff-overlay-put current-diff-overlay 'ediff-diff-num n) - - ;; unhighlight the background overlay for diff n so it won't - ;; interfere with the current diff overlay - (ediff-set-overlay-face (ediff-get-diff-overlay n buf-type) nil) - ))) - - -(defun ediff-unhighlight-diff-in-one-buffer (buf-type) - (if (ediff-buffer-live-p (ediff-get-buffer buf-type)) - (let ((current-diff-overlay - (symbol-value - (ediff-get-symbol-from-alist - buf-type ediff-current-diff-overlay-alist))) - (overlay - (ediff-get-diff-overlay ediff-current-difference buf-type)) - ) - - (ediff-move-overlay current-diff-overlay 1 1) - - ;; rehighlight the overlay in the background of the - ;; current difference region - (ediff-set-overlay-face - overlay - (if (and (ediff-has-face-support-p) - ediff-use-faces ediff-highlight-all-diffs) - (ediff-background-face buf-type ediff-current-difference))) - ))) - -(defun ediff-unhighlight-diffs-totally-in-one-buffer (buf-type) - (ediff-unselect-and-select-difference -1) - (if (and (ediff-has-face-support-p) ediff-use-faces) - (let* ((inhibit-quit t) - (current-diff-overlay-var - (ediff-get-symbol-from-alist - buf-type ediff-current-diff-overlay-alist)) - (current-diff-overlay (symbol-value current-diff-overlay-var))) - (ediff-paint-background-regions 'unhighlight) - (if (ediff-overlayp current-diff-overlay) - (ediff-delete-overlay current-diff-overlay)) - (set current-diff-overlay-var nil) - ))) - - -(defsubst ediff-highlight-diff (n) - "Put face on diff N. Invoked for X displays only." - (ediff-highlight-diff-in-one-buffer n 'A) - (ediff-highlight-diff-in-one-buffer n 'B) - (ediff-highlight-diff-in-one-buffer n 'C) - (ediff-highlight-diff-in-one-buffer n 'Ancestor) - ) - - -(defsubst ediff-unhighlight-diff () - "Remove overlays from buffers A, B, and C." - (ediff-unhighlight-diff-in-one-buffer 'A) - (ediff-unhighlight-diff-in-one-buffer 'B) - (ediff-unhighlight-diff-in-one-buffer 'C) - (ediff-unhighlight-diff-in-one-buffer 'Ancestor) - ) - -;; delete highlighting overlays, restore faces to their original form -(defsubst ediff-unhighlight-diffs-totally () - (ediff-unhighlight-diffs-totally-in-one-buffer 'A) - (ediff-unhighlight-diffs-totally-in-one-buffer 'B) - (ediff-unhighlight-diffs-totally-in-one-buffer 'C) - (ediff-unhighlight-diffs-totally-in-one-buffer 'Ancestor) - ) - - -;; arg is a record for a given diff in a difference vector -;; this record is itself a vector -(defsubst ediff-clear-fine-diff-vector (diff-record) - (if diff-record - (mapcar 'ediff-delete-overlay - (ediff-get-fine-diff-vector-from-diff-record diff-record)))) - -(defsubst ediff-clear-fine-differences-in-one-buffer (n buf-type) - (ediff-clear-fine-diff-vector (ediff-get-difference n buf-type)) - (ediff-set-fine-diff-vector n buf-type nil)) - -(defsubst ediff-clear-fine-differences (n) - (ediff-clear-fine-differences-in-one-buffer n 'A) - (ediff-clear-fine-differences-in-one-buffer n 'B) - (if ediff-3way-job - (ediff-clear-fine-differences-in-one-buffer n 'C))) - - -(defsubst ediff-convert-fine-diffs-to-overlays (diff-list region-num) - (ediff-set-fine-overlays-in-one-buffer 'A diff-list region-num) - (ediff-set-fine-overlays-in-one-buffer 'B diff-list region-num) - (if ediff-3way-job - (ediff-set-fine-overlays-in-one-buffer 'C diff-list region-num) - )) - -(defsubst ediff-mouse-event-p (event) - (if ediff-xemacs-p - (button-event-p event) - (string-match "mouse" (format "%S" (event-basic-type event))) - )) - - -(defsubst ediff-key-press-event-p (event) - (if ediff-xemacs-p - (key-press-event-p event) - (or (char-or-string-p event) (symbolp event)))) - -(defun ediff-event-point (event) - (cond ((ediff-mouse-event-p event) - (if ediff-xemacs-p - (event-point event) - (posn-point (event-start event)))) - ((ediff-key-press-event-p event) - (point)) - (t (error)))) - -(defun ediff-event-buffer (event) - (cond ((ediff-mouse-event-p event) - (if ediff-xemacs-p - (event-buffer event) - (window-buffer (posn-window (event-start event))))) - ((ediff-key-press-event-p event) - (current-buffer)) - (t (error)))) - - -(defsubst ediff-frame-iconified-p (frame) - (if (and (ediff-window-display-p) (frame-live-p frame)) - (if ediff-xemacs-p - (frame-iconified-p frame) - (eq (frame-visible-p frame) 'icon)))) - -(defsubst ediff-window-visible-p (wind) - ;; under TTY, window-live-p also means window is visible - (and (window-live-p wind) - (or (not (ediff-window-display-p)) - (frame-visible-p (window-frame wind))))) - - -(defsubst ediff-frame-char-width (frame) - (if ediff-xemacs-p - (/ (frame-pixel-width frame) (frame-width frame)) - (frame-char-width frame))) - -(defun ediff-reset-mouse (&optional frame do-not-grab-mouse) - (or frame (setq frame (selected-frame))) - (if (ediff-window-display-p) - (let ((frame-or-wind frame)) - (if ediff-xemacs-p - (setq frame-or-wind (frame-selected-window frame))) - (or do-not-grab-mouse - ;; don't set mouse if the user said to never do this - (not ediff-grab-mouse) - ;; Don't grab on quit, if the user doesn't want to. - ;; If ediff-grab-mouse = t, then mouse won't be grabbed for - ;; sessions that are not part of a group (this is done in - ;; ediff-recenter). The condition below affects only terminating - ;; sessions in session groups (in which case mouse is warped into - ;; a meta buffer). - (and (eq ediff-grab-mouse 'maybe) - (memq this-command '(ediff-quit ediff-update-diffs))) - (set-mouse-position frame-or-wind 1 0)) - ))) - -(defsubst ediff-spy-after-mouse () - (setq ediff-mouse-pixel-position (mouse-pixel-position))) - -;; It is not easy to find out when the user grabs the mouse, since emacs and -;; xemacs behave differently when mouse is not in any frame. Also, this is -;; sensitive to when the user grabbed mouse. Not used for now. -(defun ediff-user-grabbed-mouse () - (if ediff-mouse-pixel-position - (cond ((not (eq (car ediff-mouse-pixel-position) - (car (mouse-pixel-position))))) - ((and (car (cdr ediff-mouse-pixel-position)) - (car (cdr (mouse-pixel-position))) - (cdr (cdr ediff-mouse-pixel-position)) - (cdr (cdr (mouse-pixel-position)))) - (not (and (< (abs (- (car (cdr ediff-mouse-pixel-position)) - (car (cdr (mouse-pixel-position))))) - ediff-mouse-pixel-threshold) - (< (abs (- (cdr (cdr ediff-mouse-pixel-position)) - (cdr (cdr (mouse-pixel-position))))) - ediff-mouse-pixel-threshold)))) - (t nil)))) - -(defsubst ediff-frame-char-height (frame) - (if ediff-xemacs-p - (glyph-height ediff-H-glyph (selected-window frame)) - (frame-char-height frame))) - -;; Some overlay functions - -(defsubst ediff-overlay-start (overl) - (if (ediff-overlayp overl) - (if ediff-emacs-p - (overlay-start overl) - (extent-start-position overl)))) - -(defsubst ediff-overlay-end (overl) - (if (ediff-overlayp overl) - (if ediff-emacs-p - (overlay-end overl) - (extent-end-position overl)))) - -(defsubst ediff-empty-overlay-p (overl) - (= (ediff-overlay-start overl) (ediff-overlay-end overl))) - -;; like overlay-buffer in Emacs. In XEmacs, returns nil if the extent is -;; dead. Otherwise, works like extent-buffer -(defun ediff-overlay-buffer (overl) - (if ediff-emacs-p - (overlay-buffer overl) - (and (extent-live-p overl) (extent-object overl)))) - -;; like overlay-get in Emacs. In XEmacs, returns nil if the extent is -;; dead. Otherwise, like extent-property -(defun ediff-overlay-get (overl property) - (if ediff-emacs-p - (overlay-get overl property) - (and (extent-live-p overl) (extent-property overl property)))) - - -;; These two functions are here because XEmacs refuses to -;; handle overlays whose buffers were deleted. -(defun ediff-move-overlay (overlay beg end &optional buffer) - "Calls `move-overlay' in Emacs and `set-extent-endpoints' in Lemacs. -Checks if overlay's buffer exists before actually doing the move." - (let ((buf (and overlay (ediff-overlay-buffer overlay)))) - (if (ediff-buffer-live-p buf) - (if ediff-xemacs-p - (set-extent-endpoints overlay beg end) - (move-overlay overlay beg end buffer)) - ;; buffer's dead - (if overlay - (ediff-delete-overlay overlay))))) - -(defun ediff-overlay-put (overlay prop value) - "Calls `overlay-put' or `set-extent-property' depending on Emacs version. -Checks if overlay's buffer exists." - (if (ediff-buffer-live-p (ediff-overlay-buffer overlay)) - (if ediff-xemacs-p - (set-extent-property overlay prop value) - (overlay-put overlay prop value)) - (ediff-delete-overlay overlay))) - -;; Some diff region tests - -;; t if diff region is empty. -;; In case of buffer C, t also if it is not a 3way -;; comparison job (merging jobs return t as well). -(defun ediff-empty-diff-region-p (n buf-type) - (if (eq buf-type 'C) - (or (not ediff-3way-comparison-job) - (= (ediff-get-diff-posn 'C 'beg n) - (ediff-get-diff-posn 'C 'end n))) - (= (ediff-get-diff-posn buf-type 'beg n) - (ediff-get-diff-posn buf-type 'end n)))) - -;; Test if diff region is white space only. -;; If 2-way job and buf-type = C, then returns t. -(defun ediff-whitespace-diff-region-p (n buf-type) - (or (and (eq buf-type 'C) (not ediff-3way-job)) - (ediff-empty-diff-region-p n buf-type) - (let ((beg (ediff-get-diff-posn buf-type 'beg n)) - (end (ediff-get-diff-posn buf-type 'end n))) - (ediff-with-current-buffer (ediff-get-buffer buf-type) - (save-excursion - (goto-char beg) - (skip-chars-forward ediff-whitespace) - (>= (point) end)))))) - -;; temporarily uses DIR to abbreviate file name -;; if DIR is nil, use default-directory -(defun ediff-abbreviate-file-name (file &optional dir) - (cond ((stringp dir) - (let ((directory-abbrev-alist (list (cons dir "")))) - (abbreviate-file-name file))) - (ediff-emacs-p (abbreviate-file-name file)) - (t ; XEmacs requires addl argument - (abbreviate-file-name file t)))) - -;; Takes a directory and returns the parent directory. -;; does nothing to `/'. If the ARG is a regular file, -;; strip the file AND the last dir. -(defun ediff-strip-last-dir (dir) - (if (not (stringp dir)) (setq dir default-directory)) - (setq dir (expand-file-name dir)) - (or (file-directory-p dir) (setq dir (file-name-directory dir))) - (let* ((pos (1- (length dir))) - (last-char (aref dir pos))) - (if (and (> pos 0) (= last-char ?/)) - (setq dir (substring dir 0 pos))) - (ediff-abbreviate-file-name (file-name-directory dir)))) - -(defun ediff-truncate-string-left (str newlen) - ;; leave space for ... on the left - (let ((len (length str)) - substr) - (if (<= len newlen) - str - (setq newlen (max 0 (- newlen 3))) - (setq substr (substring str (max 0 (- len 1 newlen)))) - (concat "..." substr)))) - -(defun ediff-abbrev-jobname (jobname) - (cond ((eq jobname 'ediff-directories) - "Compare two directories") - ((eq jobname 'ediff-files) - "Compare two files") - ((eq jobname 'ediff-buffers) - "Compare two buffers") - ((eq jobname 'ediff-directories3) - "Compare three directories") - ((eq jobname 'ediff-files3) - "Compare three files") - ((eq jobname 'ediff-buffers3) - "Compare three buffers") - ((eq jobname 'ediff-revision) - "Compare file with a version") - ((eq jobname 'ediff-directory-revisions) - "Compare dir files with versions") - ((eq jobname 'ediff-merge-directory-revisions) - "Merge dir files with versions") - ((eq jobname 'ediff-merge-directory-revisions-with-ancestor) - "Merge dir versions via ancestors") - (t - (let* ((str (substring (symbol-name jobname) 6)) - (len (length str)) - (pos 0)) - (while (< pos len) - (if (= pos 0) - (aset str pos (upcase (aref str pos)))) - (if (= (aref str pos) ?-) - (aset str pos ?\ )) - (setq pos (1+ pos))) - str)))) - - - -(defsubst ediff-get-region-contents (n buf-type ctrl-buf &optional start end) - (ediff-with-current-buffer - (ediff-with-current-buffer ctrl-buf (ediff-get-buffer buf-type)) - (buffer-substring - (or start (ediff-get-diff-posn buf-type 'beg n ctrl-buf)) - (or end (ediff-get-diff-posn buf-type 'end n ctrl-buf))))) - -;; If ediff modified mode line, strip the modification -(defsubst ediff-strip-mode-line-format () - (if (member (car mode-line-format) '(" A: " " B: " " C: " " Ancestor: ")) - (setq mode-line-format (nth 2 mode-line-format)))) - -;; Verify that we have a difference selected. -(defsubst ediff-valid-difference-p (&optional n) - (or n (setq n ediff-current-difference)) - (and (>= n 0) (< n ediff-number-of-differences))) - -(defsubst ediff-show-all-diffs (n) - "Don't skip difference regions." - nil) - -(defsubst Xor (a b) - (or (and a (not b)) (and (not a) b))) - -(defsubst ediff-message-if-verbose (string &rest args) - (if ediff-verbose-p - (apply 'message string args))) - -(defun ediff-file-attributes (filename attr-number) - (if (ediff-file-remote-p filename) - -1 - (nth attr-number (file-attributes filename)))) - -(defsubst ediff-file-size (filename) - (ediff-file-attributes filename 7)) -(defsubst ediff-file-modtime (filename) - (ediff-file-attributes filename 5)) - - -(defun ediff-convert-standard-filename (fname) - (if (fboundp 'convert-standard-filename) - (convert-standard-filename fname) - fname)) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -(provide 'ediff-init) - - -;;; ediff-init.el ends here
--- a/lisp/ediff/ediff-merg.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,313 +0,0 @@ -;;; ediff-merg.el --- merging utilities - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-merg) - -(defgroup ediff-merge nil - "Merging utilities" - :prefix "ediff-" - :group 'ediff) - - -;; compiler pacifier -(defvar ediff-window-A) -(defvar ediff-window-B) -(defvar ediff-window-C) -(defvar ediff-merge-window-share) -(defvar ediff-window-config-saved) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defcustom ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge - "*Hooks to run before quitting a merge job. -The most common use is to save and delete the merge buffer." - :type 'hook - :group 'ediff-merge) - - -(defcustom ediff-default-variant 'combined - "*The variant to be used as a default for buffer C in merging. -Valid values are the symbols `default-A', `default-B', and `combined'." - :type '(radio (const default-A) (const default-B) (const combined)) - :group 'ediff-merge) - -(defcustom ediff-combination-pattern - '("<<<<<<<<<<<<<< variant A" ">>>>>>>>>>>>>> variant B" "======= end of combination") - "*Pattern to be used for combining difference regions in buffers A and B. -The value is (STRING1 STRING2 STRING3). The combined text will look like this: - -STRING1 -diff region from variant A -STRING2 -diff region from variant B -STRING3 -" - :type '(list string string string) - :group 'ediff-merge) - -(ediff-defvar-local ediff-show-clashes-only nil - "*If t, show only those diff regions where both buffers disagree with the ancestor. -This means that regions that have status prefer-A or prefer-B will be -skiped over. Nil means show all regions.") - -;; If ediff-show-clashes-only, check if there is no clash between the ancestor -;; and one of the variants. -(defsubst ediff-merge-region-is-non-clash (n) - (and ediff-show-clashes-only - (string-match "prefer" (or (ediff-get-state-of-merge n) "")))) - - -(defsubst ediff-get-combined-region (n) - (concat (nth 0 ediff-combination-pattern) "\n" - (ediff-get-region-contents n 'A ediff-control-buffer) - (nth 1 ediff-combination-pattern) "\n" - (ediff-get-region-contents n 'B ediff-control-buffer) - (nth 2 ediff-combination-pattern) "\n")) - -(defsubst ediff-make-combined-diff (regA regB) - (concat (nth 0 ediff-combination-pattern) "\n" - regA - (nth 1 ediff-combination-pattern) "\n" - regB - (nth 2 ediff-combination-pattern) "\n")) - -(defsubst ediff-set-state-of-all-diffs-in-all-buffers (ctl-buf) - (let ((n 0)) - (while (< n ediff-number-of-differences) - (ediff-set-state-of-diff-in-all-buffers n ctl-buf) - (setq n (1+ n))))) - -(defun ediff-set-state-of-diff-in-all-buffers (n ctl-buf) - (let ((regA (ediff-get-region-contents n 'A ctl-buf)) - (regB (ediff-get-region-contents n 'B ctl-buf)) - (regC (ediff-get-region-contents n 'C ctl-buf))) - (cond ((and (string= regA regB) (string= regA regC)) - (ediff-set-state-of-diff n 'A "=diff(B)") - (ediff-set-state-of-diff n 'B "=diff(C)") - (ediff-set-state-of-diff n 'C "=diff(A)")) - ((string= regA regB) - (ediff-set-state-of-diff n 'A "=diff(B)") - (ediff-set-state-of-diff n 'B "=diff(A)") - (ediff-set-state-of-diff n 'C nil)) - ((string= regA regC) - (ediff-set-state-of-diff n 'A "=diff(C)") - (ediff-set-state-of-diff n 'C "=diff(A)") - (ediff-set-state-of-diff n 'B nil)) - ((string= regB regC) - (ediff-set-state-of-diff n 'C "=diff(B)") - (ediff-set-state-of-diff n 'B "=diff(C)") - (ediff-set-state-of-diff n 'A nil)) - ((string= regC (ediff-get-combined-region n)) - (ediff-set-state-of-diff n 'A nil) - (ediff-set-state-of-diff n 'B nil) - (ediff-set-state-of-diff n 'C "=diff(A+B)")) - (t (ediff-set-state-of-diff n 'A nil) - (ediff-set-state-of-diff n 'B nil) - (ediff-set-state-of-diff n 'C nil))) - )) - -(defun ediff-set-merge-mode () - ;; by Stig@hackvan.com - (normal-mode t) - (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode)) - - -;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C -;; according to the state of the difference. -;; Since ediff-copy-diff refuses to copy identical diff regions, there is -;; no need to optimize ediff-do-merge any further. -;; -;; If re-merging, change state of merge in all diffs starting with -;; DIFF-NUM, except those where the state is prefer-* or where it is -;; `default-*' or `combined' but the buf C region appears to be modified -;; since last set by default. -(defun ediff-do-merge (diff-num &optional remerging) - (if (< diff-num 0) (setq diff-num 0)) - (let ((n diff-num) - ;;(default-state-of-merge (format "%S" ediff-default-variant)) - do-not-copy state-of-merge) - (while (< n ediff-number-of-differences) - (setq do-not-copy nil) ; reset after each cycle - (if (= (mod n 10) 0) - (message "%s buffers A & B into C ... region %d of %d" - (if remerging "Re-merging" "Merging") - n - ediff-number-of-differences)) - - (setq state-of-merge (ediff-get-state-of-merge n)) - - (if remerging - (let ((reg-A (ediff-get-region-contents n 'A ediff-control-buffer)) - (reg-B (ediff-get-region-contents n 'B ediff-control-buffer)) - (reg-C (ediff-get-region-contents n 'C ediff-control-buffer))) - - ;; if region was edited since it was first set by default - (if (or (and (string= state-of-merge "default-A") - (not (string= reg-A reg-C))) - ;; was edited since first set by default - (and (string= state-of-merge "default-B") - (not (string= reg-B reg-C))) - ;; was edited since first set by default - (and (string= state-of-merge "combined") - (not (string= - (ediff-make-combined-diff reg-A reg-B) reg-C))) - ;; was preferred--ignore - (string-match "prefer" state-of-merge)) - (setq do-not-copy t)) - - ;; change state of merge for this diff, if necessary - (if (and (string-match "\\(default\\|combined\\)" state-of-merge) - (not do-not-copy)) - (ediff-set-state-of-merge - n (format "%S" ediff-default-variant))) - )) - - ;; state-of-merge may have changed via ediff-set-state-of-merge, so - ;; check it once again - (setq state-of-merge (ediff-get-state-of-merge n)) - - (or do-not-copy - (if (string= state-of-merge "combined") - ;; use n+1 because ediff-combine-diffs works via user numbering - ;; of diffs, which is 1+ to what ediff uses internally - (ediff-combine-diffs (1+ n) 'batch) - (ediff-copy-diff - n (if (string-match "-A" state-of-merge) 'A 'B) 'C 'batch))) - (setq n (1+ n))) - (message "Merging buffers A & B into C ... Done") - )) - - -(defun ediff-re-merge () - "Remerge unmodified diff regions using a new default. Start with the current region." - (interactive) - (let* ((default-variant-alist - (list '("default-A") '("default-B") '("combined"))) - (actual-alist - (delete (list (symbol-name ediff-default-variant)) - default-variant-alist))) - (setq ediff-default-variant - (intern - (completing-read - (format "Current merge default is `%S'. New default: " - ediff-default-variant) - actual-alist nil 'must-match))) - (ediff-do-merge ediff-current-difference 'remerge) - (ediff-recenter) - )) - -(defun ediff-shrink-window-C (arg) - "Shrink window C to just one line. -With a prefix argument, returns window C to its normal size. -Used only for merging jobs." - (interactive "P") - (if (not ediff-merge-job) - (error "ediff-shrink-window-C can be used only for merging jobs")) - (cond ((eq arg '-) (setq arg -1)) - ((not (numberp arg)) (setq arg nil))) - (cond ((null arg) - (let ((ediff-merge-window-share - (if (< (window-height ediff-window-C) 3) - ediff-merge-window-share 0))) - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight))) - ((and (< arg 0) (> (window-height ediff-window-C) 2)) - (setq ediff-merge-window-share (* ediff-merge-window-share 0.9)) - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight)) - ((and (> arg 0) (> (window-height ediff-window-A) 2)) - (setq ediff-merge-window-share (* ediff-merge-window-share 1.1)) - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight)))) - - -;; N here is the user's region number. It is 1+ what Ediff uses internally. -(defun ediff-combine-diffs (n &optional batch-invocation) - "Combine Nth diff regions of buffers A and B and place the combination in C. -N is a prefix argument. If nil, combine the current difference regions. -Combining is done according to the specifications in variable -`ediff-combination-pattern'." - (interactive "P") - (setq n (if (numberp n) (1- n) ediff-current-difference)) - - (let (regA regB reg-combined) - (setq regA (ediff-get-region-contents n 'A ediff-control-buffer) - regB (ediff-get-region-contents n 'B ediff-control-buffer)) - - (setq reg-combined (ediff-make-combined-diff regA regB)) - - (ediff-copy-diff n nil 'C batch-invocation reg-combined)) - (or batch-invocation (ediff-jump-to-difference (1+ n)))) - - -;; Checks if the region in buff C looks like a combination of the regions -;; in buffers A and B. Returns a list (reg-a-beg reg-a-end reg-b-beg reg-b-end) -;; These refer to where the copies of region A and B start and end in buffer C -(defun ediff-looks-like-combined-merge (region-num) - (if ediff-merge-job - (let ((combined (string-match (regexp-quote "(A+B)") - (or (ediff-get-state-of-diff region-num 'C) - ""))) - (reg-beg (ediff-get-diff-posn 'C 'beg region-num)) - (reg-end (ediff-get-diff-posn 'C 'end region-num)) - (pat1 (nth 0 ediff-combination-pattern)) - (pat2 (nth 1 ediff-combination-pattern)) - (pat3 (nth 2 ediff-combination-pattern)) - reg-a-beg reg-a-end reg-b-beg reg-b-end reg-c-beg reg-c-end) - - (if combined - (ediff-with-current-buffer ediff-buffer-C - (goto-char reg-beg) - (search-forward pat1 reg-end 'noerror) - (setq reg-a-beg (match-beginning 0)) - (setq reg-a-end (match-end 0)) - (search-forward pat2 reg-end 'noerror) - (setq reg-b-beg (match-beginning 0)) - (setq reg-b-end (match-end 0)) - (search-forward pat3 reg-end 'noerror) - (setq reg-c-beg (match-beginning 0)) - (setq reg-c-end (match-end 0)))) - - (if (and reg-a-beg reg-a-end reg-b-beg reg-b-end) - (list reg-a-beg reg-a-end reg-b-beg reg-b-end reg-c-beg reg-c-end)) - ))) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;; ediff-merg.el ends here
--- a/lisp/ediff/ediff-mult.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1777 +0,0 @@ -;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Users are encouraged to add functionality to this file. -;; The present file contains all the infrastructure needed for that. -;; -;; Generally, to to implement a new multisession capability within Ediff, -;; you need to tell it -;; -;; 1. How to display the session group buffer. -;; This function must indicate which Ediff sessions are active (+) and -;; which are finished (-). -;; See ediff-redraw-directory-group-buffer for an example. -;; In all likelihood, ediff-redraw-directory-group-buffer can be used -;; directly or after a small modification. -;; 2. What action to take when the user clicks button 2 or types v,e, or -;; RET. See ediff-filegroup-action. -;; 3. Provide a list of pairs or triples of file names (or buffers, -;; depending on the particular Ediff operation you want to invoke) -;; in the following format: -;; (descriptor (obj1 obj2 obj3) (...) ...) -;; Actually, the format of this list is pretty much up to the -;; developer. The only thing is that it must be a list of lists, -;; and the first list must describe the meta session, and subsequent -;; elements must describe individual sessions. -;; This descriptor must be a list of two, three, or four elements (nil -;; or string). The function ediff-redraw-registry-buffer displays the -;; second through last of these in the registry buffer. -;; Also, keep in mind that the function ediff-prepare-meta-buffer -;; (which see) prepends the session group buffer to the descriptor and -;; nil in front of each subsequent list (i.e., the above list -;; will become -;; ((meta-buf descriptor) (nil obj1 obj2 obj3) (nil ...) ...) -;; Ediff expects that your function (in 2 above) will arrange to -;; replace this prepended nil (via setcar) with the actual ediff -;; control buffer associated with an appropriate Ediff session. -;; This is arranged through internal startup hooks that can be passed -;; to any of Ediff major entries (such as ediff-files, epatch, etc.). -;; See how this is done in ediff-filegroup-action. -;; -;; Session descriptions are of the form (obj1 obj2 obj3), which -;; describe objects relevant to the session. Usually they are names of -;; files, but sometimes they may be other things. For instance, obj3 is -;; nil for jobs that involve only two files. For patch jobs, obj2 and -;; obj3 are markers that specify the patch corresponding to the file -;; (whose name is obj1). -;; 4. Write a function that makes a call to ediff-prepare-meta-buffer -;; passing all this info. -;; You may be able to use ediff-directories-internal as a template. -;; 5. If you intend to add several related pieces of functionality, -;; you may want to keep the function in 4 as an internal version -;; and then write several top-level interactive functions that call it -;; with different parameters. -;; See how ediff-directories, ediff-merge-directories, and -;; ediff-merge-directories-with-ancestor all use -;; ediff-directories-internal. -;; -;; A useful addition here could be session groups selected by patterns -;; (which are different in each directory). For instance, one may want to -;; compare files of the form abc{something}.c to files old{something}.d -;; which may be in the same or different directories. Or, one may want to -;; compare all files of the form {something} to files of the form {something}~. -;; -;; Implementing this requires writing an collating function, which should pair -;; up appropriate files. It will also require a generalization of the functions -;; that do the layout of the meta- and differences buffers and of -;; ediff-filegroup-action. - -;;; Code: - -(provide 'ediff-mult) - -(defgroup ediff-mult nil - "Multi-file and multi-buffer processing in Ediff" - :prefix "ediff-" - :group 'ediff) - - -;; compiler pacifier -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) -(require 'ediff-util) - -;; meta-buffer -(ediff-defvar-local ediff-meta-buffer nil "") -(ediff-defvar-local ediff-parent-meta-buffer nil "") -;; the registry buffer -(defvar ediff-registry-buffer nil) - -(defconst ediff-meta-buffer-message "This is an Ediff Session Group Panel: %s - -Useful commands: - button2, `v', RET over a session line: start that Ediff session - `M':\tin any session invoked from here, brings back this group panel - `R':\tdisplay the registry of active Ediff sessions - `h':\tmark session for hiding (toggle) - `x':\thide marked sessions; with prefix arg--unhide hidden sessions - `m':\tmark session for a non-hiding operation (toggle) - SPC:\tnext session - DEL:\tprevious session - `E':\tbrowse Ediff on-line manual - `q':\tquit this session group -") - -(ediff-defvar-local ediff-meta-buffer-map nil - "The keymap for the meta buffer.") -(defvar ediff-dir-diffs-buffer-map (make-sparse-keymap) - "The keymap to be installed in the buffer showing differences between -directories.") - -;; Variable specifying the action to take when the use invokes ediff in the -;; meta buffer. This is usually ediff-registry-action or ediff-filegroup-action -(ediff-defvar-local ediff-meta-action-function nil "") -;; Tells ediff-update-meta-buffer how to redraw it -(ediff-defvar-local ediff-meta-redraw-function nil "") -;; Tells ediff-filegroup-action and similar procedures how to invoke Ediff for -;; the sessions in a given session group -(ediff-defvar-local ediff-session-action-function nil "") - -(ediff-defvar-local ediff-metajob-name nil "") - -;; buffer used to collect custom diffs from individual sessions in the group -(ediff-defvar-local ediff-meta-diff-buffer nil "") - -;; history var to use for filtering groups -(defvar ediff-filtering-regexp-history nil "") - -;; This has the form ((meta-buf regexp dir1 dir2 dir3 merge-auto-store-dir) -;; (ctl-buf session-status (file1 . eq-status) (file2 . eq-status) (file3 -;; . eq-status)) (ctl-buf session-status (file1 . eq-status) (file2 -;; . eq-status)) ...) -;; If ctl-buf is nil, the file-pair hasn't processed yet. If it is -;; killed-buffer object, the file pair has been processed. If it is a live -;; buffer, this means ediff is still working on the pair. -;; Eq-status of a file is t if the file equals some other file in the same -;; group. -(ediff-defvar-local ediff-meta-list nil "") - - -;; the difference list between directories in a directory session group -(ediff-defvar-local ediff-dir-difference-list nil "") -(ediff-defvar-local ediff-dir-diffs-buffer nil "") - -;; The registry of Ediff sessions. A list of control buffers. -(defvar ediff-session-registry nil) - -(defcustom ediff-registry-setup-hook nil - "*Hooks run just after the registry control panel is set up." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-session-group-setup-hook nil - "*Hooks run just after a meta-buffer controlling a session group, such as -ediff-directories, is run." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-quit-session-group-hook nil - "*Hooks run just before exiting a session group." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-show-registry-hook nil - "*Hooks run just after the registry buffer is shown." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-show-session-group-hook nil - "*Hooks run just after a session group buffer is shown." - :type 'hook - :group 'ediff-mult) -(defcustom ediff-meta-buffer-keymap-setup-hook nil - "*Hooks run just after setting up the ediff-meta-buffer-map. -This keymap controls key bindings in the meta buffer and is a local variable. -This means that you can set different bindings for different kinds of meta -buffers." - :type 'hook - :group 'ediff-mult) - -;; buffer holding the multi-file patch. local to the meta buffer -(ediff-defvar-local ediff-meta-patchbufer nil "") - -;;; API for ediff-meta-list - -;; group buffer/regexp -(defsubst ediff-get-group-buffer (meta-list) - (nth 0 (car meta-list))) - -(defsubst ediff-get-group-regexp (meta-list) - (nth 1 (car meta-list))) -;; group objects -(defsubst ediff-get-group-objA (meta-list) - (nth 2 (car meta-list))) -(defsubst ediff-get-group-objB (meta-list) - (nth 3 (car meta-list))) -(defsubst ediff-get-group-objC (meta-list) - (nth 4 (car meta-list))) -(defsubst ediff-get-group-merge-autostore-dir (meta-list) - (nth 5 (car meta-list))) - -;; session buffer -(defsubst ediff-get-session-buffer (elt) - (nth 0 elt)) -(defsubst ediff-get-session-status (elt) - (nth 1 elt)) -(defsubst ediff-set-session-status (session-info new-status) - (setcar (cdr session-info) new-status)) -;; session objects -(defsubst ediff-get-session-objA (elt) - (nth 2 elt)) -(defsubst ediff-get-session-objB (elt) - (nth 3 elt)) -(defsubst ediff-get-session-objC (elt) - (nth 4 elt)) -(defsubst ediff-get-session-objA-name (elt) - (car (nth 2 elt))) -(defsubst ediff-get-session-objB-name (elt) - (car (nth 3 elt))) -(defsubst ediff-get-session-objC-name (elt) - (car (nth 4 elt))) -;; equality indicators -(defsubst ediff-get-file-eqstatus (elt) - (nth 1 elt)) -(defsubst ediff-set-file-eqstatus (elt value) - (setcar (cdr elt) value)) - -;; checks if the session is a meta session -(defun ediff-meta-session-p (session-info) - (and (stringp (ediff-get-session-objA-name session-info)) - (file-directory-p (ediff-get-session-objA-name session-info)) - (stringp (ediff-get-session-objB-name session-info)) - (file-directory-p (ediff-get-session-objB-name session-info)) - (if (stringp (ediff-get-session-objC-name session-info)) - (file-directory-p (ediff-get-session-objC-name session-info)) t))) - -;; set up the keymap in the meta buffer -(defun ediff-setup-meta-map() - (setq ediff-meta-buffer-map (make-sparse-keymap)) - (suppress-keymap ediff-meta-buffer-map) - (define-key ediff-meta-buffer-map "q" 'ediff-quit-meta-buffer) - (define-key ediff-meta-buffer-map "R" 'ediff-show-registry) - (define-key ediff-meta-buffer-map "E" 'ediff-documentation) - (define-key ediff-meta-buffer-map "v" ediff-meta-action-function) - (define-key ediff-meta-buffer-map "\C-m" ediff-meta-action-function) - (define-key ediff-meta-buffer-map " " 'ediff-next-meta-item) - (define-key ediff-meta-buffer-map "\C-?" 'ediff-previous-meta-item) - (define-key ediff-meta-buffer-map [delete] 'ediff-previous-meta-item) - (define-key ediff-meta-buffer-map [backspace] 'ediff-previous-meta-item) - (or (ediff-one-filegroup-metajob) - (define-key ediff-meta-buffer-map "=" 'ediff-meta-mark-equal-files)) - (if ediff-no-emacs-help-in-control-buffer - (define-key ediff-meta-buffer-map "\C-h" 'ediff-previous-meta-item)) - (if ediff-emacs-p - (define-key ediff-meta-buffer-map [mouse-2] ediff-meta-action-function) - (define-key ediff-meta-buffer-map [button2] ediff-meta-action-function)) - - (use-local-map ediff-meta-buffer-map) - ;; modify ediff-meta-buffer-map here - (run-hooks 'ediff-meta-buffer-keymap-setup-hook)) - -(defun ediff-meta-mode () - "This mode controls all operations on Ediff session groups. -It is entered through one of the following commands: - `ediff-directories' - `edirs' - `ediff-directories3' - `edirs3' - `ediff-merge-directories' - `edirs-merge' - `ediff-merge-directories-with-ancestor' - `edirs-merge-with-ancestor' - `ediff-directory-revisions' - `edir-revisions' - `ediff-merge-directory-revisions' - `edir-merge-revisions' - `ediff-merge-directory-revisions-with-ancestor' - `edir-merge-revisions-with-ancestor' - -Commands: -\\{ediff-meta-buffer-map}" - (kill-all-local-variables) - (setq major-mode 'ediff-meta-mode) - (setq mode-name "MetaEdiff")) - - -;; the keymap for the buffer showing directory differences -(suppress-keymap ediff-dir-diffs-buffer-map) -(define-key ediff-dir-diffs-buffer-map "q" 'ediff-bury-dir-diffs-buffer) -(define-key ediff-dir-diffs-buffer-map " " 'next-line) -(define-key ediff-dir-diffs-buffer-map "\C-?" 'previous-line) -(define-key ediff-dir-diffs-buffer-map [delete] 'previous-line) -(define-key ediff-dir-diffs-buffer-map [backspace] 'previous-line) - -(defun ediff-next-meta-item (count) - "Move to the next item in Ediff registry or session group buffer. -Moves in circular fashion. With numeric prefix arg, skip this many items." - (interactive "p") - (or count (setq count 1)) - (while (< 0 count) - (setq count (1- count)) - (ediff-next-meta-item1))) - -;; Move to the next meta item -(defun ediff-next-meta-item1 () - (let (pos) - (setq pos (ediff-next-meta-overlay-start (point))) -;;; ;; skip deleted -;;; (while (memq (ediff-get-session-status -;;; (ediff-get-meta-info (current-buffer) pos 'noerror)) -;;; '(?H ?I)) -;;; (setq pos (ediff-next-meta-overlay-start pos))) - - (if pos (goto-char pos)) - (if (eq ediff-metajob-name 'ediff-registry) - (if (and (ediff-get-meta-info (current-buffer) pos 'noerror) - (search-forward "*Ediff" nil t)) - (skip-chars-backward "a-zA-Z*")) - (if (> (skip-chars-forward "-+?H* \t0-9") 0) - (backward-char 1))))) - - -(defun ediff-previous-meta-item (count) - "Move to the previous item in Ediff registry or session group buffer. -Moves in circular fashion. With numeric prefix arg, skip this many items." - (interactive "p") - (or count (setq count 1)) - (while (< 0 count) - (setq count (1- count)) - (ediff-previous-meta-item1))) - -(defun ediff-previous-meta-item1 () - (let (pos) - (setq pos (ediff-previous-meta-overlay-start (point))) -;;; ;; skip deleted -;;; (while (ediff-get-session-status -;;; (ediff-get-meta-info (current-buffer) pos 'noerror)) -;;; (setq pos (ediff-previous-meta-overlay-start pos))) - - (if pos (goto-char pos)) - (if (eq ediff-metajob-name 'ediff-registry) - (if (and (ediff-get-meta-info (current-buffer) pos 'noerror) - (search-forward "*Ediff" nil t)) - (skip-chars-backward "a-zA-Z*")) - (if (> (skip-chars-forward "-+?H* \t0-9") 0) - (backward-char 1))) - )) - -(defsubst ediff-add-slash-if-directory (dir file) - (if (file-directory-p (concat dir file)) - (file-name-as-directory file) - file)) - - -;; DIR1, DIR2, DIR3 are directories. DIR3 can be nil. -;; OUTPUT-DIR is a directory for auto-storing the results of merge jobs. -;; Can be nil. -;; REGEXP is a regexp used to filter out files in the directories. -;; If a file is a directory in dir1 but not dir2 (or vice versa), it is not -;; included in the intersection. However, a regular file that is a dir in dir3 -;; is included, since dir3 files are supposed to be ancestors for merging. -;; Returns a list of the form: -;; ((dir1 dir2 dir3) (f1 f2 f3) (f1 f2 f3) ...) -;; dir3, f3 can be nil if intersecting only 2 directories. -;; If COMPARISON-FUNC is given, use it. Otherwise, use string= -;; DIFF-VAR contains the name of the variable in which to return the -;; difference list (which represents the differences among the contents of -;; directories). The diff list is of the form: -;; ((dir1 dir2 dir3) (file . num) (file . num)...) -;; where num encodes the set of dirs where the file is found: -;; 2 - only dir1; 3 - only dir2; 5 - only dir3; 6 - dir1&2; 10 - dir1&3; etc. -(defun ediff-intersect-directories (jobname - diff-var regexp dir1 dir2 - &optional - dir3 merge-autostore-dir comparison-func) - (setq comparison-func (or comparison-func 'string=)) - (let (lis1 lis2 lis3 common auxdir1 auxdir2 auxdir3 difflist) - - (setq auxdir1 (file-name-as-directory dir1) - lis1 (directory-files auxdir1 nil regexp) - lis1 (delete "." lis1) - lis1 (delete ".." lis1) - lis1 (mapcar - (function - (lambda (elt) - (ediff-add-slash-if-directory auxdir1 elt))) - lis1) - auxdir2 (file-name-as-directory dir2) - lis2 (mapcar - (function - (lambda (elt) - (ediff-add-slash-if-directory auxdir2 elt))) - (directory-files auxdir2 nil regexp))) - - (if (stringp dir3) - (setq auxdir3 (file-name-as-directory dir3) - lis3 (mapcar - (function - (lambda (elt) - (ediff-add-slash-if-directory auxdir3 elt))) - (directory-files auxdir3 nil regexp)))) - - (if (stringp merge-autostore-dir) - (setq merge-autostore-dir - (file-name-as-directory merge-autostore-dir))) - (setq common (ediff-intersection lis1 lis2 comparison-func)) - - ;; In merge with ancestor jobs, we don't intersect with lis3. - ;; If there is no ancestor, we'll offer to merge without the ancestor. - ;; So, we intersect with lis3 only when we are doing 3-way file comparison - (if (and lis3 (ediff-comparison-metajob3 jobname)) - (setq common (ediff-intersection common lis3 comparison-func))) - - ;; copying is needed because sort sorts via side effects - (setq common (sort (ediff-copy-list common) 'string-lessp)) - - ;; compute difference list - (setq difflist (ediff-set-difference - (ediff-union (ediff-union lis1 lis2 comparison-func) - lis3 - comparison-func) - common - comparison-func) - difflist (delete "." difflist) - ;; copying is needed because sort sorts via side effects - difflist (sort (ediff-copy-list (delete ".." difflist)) - 'string-lessp)) - - (setq difflist (mapcar (function (lambda (elt) (cons elt 1))) difflist)) - - ;; check for files belonging to lis1/2/3 - (mapcar (function (lambda (elt) - (if (member (car elt) lis1) - (setcdr elt (* (cdr elt) 2))) - (if (member (car elt) lis2) - (setcdr elt (* (cdr elt) 3))) - (if (member (car elt) lis3) - (setcdr elt (* (cdr elt) 5))) - )) - difflist) - (setq difflist (cons (list regexp auxdir1 auxdir2 auxdir3) difflist)) - - ;; return the difference list back to the calling function - (set diff-var difflist) - - ;; return result - (cons (list regexp auxdir1 auxdir2 auxdir3 merge-autostore-dir) - (mapcar - (function - (lambda (elt) - (list (concat auxdir1 elt) - (concat auxdir2 elt) - (if lis3 - (progn - ;; The following is done because: - ;; In merging with ancestor, we don't intersect - ;; with lis3. So, it is possible that elt is a - ;; file in auxdir1/2 but a directory in auxdir3 - ;; Or elt may not exist in auxdir3 at all. - ;; In the first case, we add a slash at the end. - ;; In the second case, we insert nil. - (setq elt (ediff-add-slash-if-directory auxdir3 elt)) - (if (file-exists-p (concat auxdir3 elt)) - (concat auxdir3 elt))))))) - common)) - )) - -;; find directory files that are under revision. -;; Include subdirectories, since we may visit them recursively. -;; DIR1 is the directory to inspect. -;; OUTPUT-DIR is the directory where to auto-store the results of merges. Can -;; be nil. -(defun ediff-get-directory-files-under-revision (jobname - regexp dir1 - &optional merge-autostore-dir) - (let (lis1 elt common auxdir1) - (setq auxdir1 (file-name-as-directory dir1) - lis1 (directory-files auxdir1 nil regexp)) - - (if (stringp merge-autostore-dir) - (setq merge-autostore-dir - (file-name-as-directory merge-autostore-dir))) - - (while lis1 - (setq elt (car lis1) - lis1 (cdr lis1)) - ;; take files under revision control - (cond ((file-directory-p (concat auxdir1 elt)) - (setq common (cons elt common))) - ((file-exists-p (concat auxdir1 elt ",v")) - (setq common (cons elt common))) - ((file-exists-p (concat auxdir1 "RCS/" elt ",v")) - (setq common (cons elt common))) - ) ; cond - ) ; while - - (setq common (delete "." common) - common (delete ".." common) - common (delete "RCS" common)) - - ;; copying is needed because sort sorts via side effects - (setq common (sort (ediff-copy-list common) 'string-lessp)) - - ;; return result - (cons (list regexp auxdir1 nil nil merge-autostore-dir) - (mapcar (function (lambda (elt) - (list (concat auxdir1 elt) - nil nil))) - common)) - )) - - -;; If file groups selected by patterns will ever be implemented, this -;; comparison function might become useful. -;;;; uses external variables PAT1 PAT2 to compare str1/2 -;;;; patterns must be of the form ???*???? where ??? are strings of chars -;;;; containing no *. -;;(defun ediff-pattern= (str1 str2) -;; (let (pos11 pos12 pos21 pos22 len1 len2) -;; (setq pos11 0 -;; len (length epat1) -;; pos12 len) -;; (while (and (< pos11 len) (not (= (aref epat1 pos11) ?*))) -;; (setq pos11 (1+ pos11))) -;; (while (and (> pos12 0) (not (= (aref epat1 (1- pos12)) ?*))) -;; (setq pos12 (1- pos12))) -;; -;; (setq pos21 0 -;; len (length epat2) -;; pos22 len) -;; (while (and (< pos21 len) (not (= (aref epat2 pos21) ?*))) -;; (setq pos21 (1+ pos21))) -;; (while (and (> pos22 0) (not (= (aref epat2 (1- pos22)) ?*))) -;; (setq pos22 (1- pos22))) -;; -;; (if (and (> (length str1) pos12) (>= pos12 pos11) (> pos11 -1) -;; (> (length str2) pos22) (>= pos22 pos21) (> pos21 -1)) -;; (string= (substring str1 pos11 pos12) -;; (substring str2 pos21 pos22))) -;; )) - - -;; Prepare meta-buffer in accordance with the argument-function and -;; redraw-function. Must return the created meta-buffer. -(defun ediff-prepare-meta-buffer (action-func meta-list - meta-buffer-name redraw-function - jobname &optional startup-hooks) - (let* ((meta-buffer-name - (ediff-unique-buffer-name meta-buffer-name "*")) - (meta-buffer (get-buffer-create meta-buffer-name))) - (ediff-with-current-buffer meta-buffer - - ;; comes first - (ediff-meta-mode) - - (setq ediff-meta-action-function action-func - ediff-meta-redraw-function redraw-function - ediff-metajob-name jobname - ediff-meta-buffer meta-buffer) - - ;; comes after ediff-meta-action-function is set - (ediff-setup-meta-map) - - (if (eq ediff-metajob-name 'ediff-registry) - (progn - (setq ediff-registry-buffer meta-buffer - ediff-meta-list meta-list) - ;; this func is used only from registry buffer, not from other - ;; meta-buffs. - (define-key - ediff-meta-buffer-map "M" 'ediff-show-meta-buff-from-registry)) - ;; Initialize the meta list -- don't do this for registry. - ;; - ;; We prepend '(nil nil) to all elts of meta-list, except the first. - ;; The first nil will later be replaced by the session buffer. The - ;; second is reserved for session status. - ;; - ;; (car ediff-meta-list) gets cons'ed with the session group buffer. - ;; Also, session objects A/B/C are turned into lists of the form - ;; (obj eq-indicator). Eq-indicator is either nil or =. Initialized to - ;; nil. If later it is discovered that this file is = to some other - ;; file in the same session, eq-indicator is changed to `='. - ;; For now, the eq-indicator is used only for 2 and 3-file jobs. - (setq ediff-meta-list - (cons (cons meta-buffer (car meta-list)) - (mapcar - (function - (lambda (elt) - (cons nil - (cons nil - ;; convert each obj to (obj nil), - ;; where nil is the initial value - ;; for eq-indicator -- see above - (mapcar - (function (lambda (obj) (list obj nil))) - elt))))) - (cdr meta-list))))) - - (or (eq meta-buffer ediff-registry-buffer) - (setq ediff-session-registry - (cons meta-buffer ediff-session-registry))) - - ;; redraw-function uses ediff-meta-list - (funcall redraw-function ediff-meta-list) - - ;; set read-only/non-modified - (setq buffer-read-only t) - (set-buffer-modified-p nil) - - (run-hooks 'startup-hooks) - - ;; Arrange to show directory contents differences - ;; Must be after run startup-hooks, since ediff-dir-difference-list is - ;; set inside these hooks - (if (eq action-func 'ediff-filegroup-action) - (progn - ;; put meta buffer in (car ediff-dir-difference-list) - (setq ediff-dir-difference-list - (cons (cons meta-buffer (car ediff-dir-difference-list)) - (cdr ediff-dir-difference-list))) - - (or (ediff-one-filegroup-metajob jobname) - (ediff-draw-dir-diffs ediff-dir-difference-list)) - (define-key ediff-meta-buffer-map "h" 'ediff-mark-for-hiding) - (define-key - ediff-meta-buffer-map "x" 'ediff-hide-marked-sessions) - (define-key ediff-meta-buffer-map "m" 'ediff-mark-for-operation) - (cond ((ediff-collect-diffs-metajob jobname) - (define-key - ediff-meta-buffer-map "P" 'ediff-collect-custom-diffs)) - ((ediff-patch-metajob jobname) - (define-key - ediff-meta-buffer-map "P" 'ediff-meta-show-patch))) - (define-key ediff-meta-buffer-map "u" 'ediff-up-meta-hierarchy) - (define-key ediff-meta-buffer-map "D" 'ediff-show-dir-diffs))) - - (if (eq ediff-metajob-name 'ediff-registry) - (run-hooks 'ediff-registry-setup-hook) - (run-hooks 'ediff-session-group-setup-hook)) - ) ; eval in meta-buffer - meta-buffer)) - - -;; this is a setup function for ediff-directories -;; must return meta-buffer -(defun ediff-redraw-directory-group-buffer (meta-list) - ;; extract directories - (let ((meta-buf (ediff-get-group-buffer meta-list)) - (empty t) - (sessionNum 0) - regexp elt session-buf f1 f2 f3 pt - merge-autostore-dir - point tmp-list buffer-read-only) - (ediff-with-current-buffer meta-buf - (setq point (point)) - (erase-buffer) - (insert (format ediff-meta-buffer-message - (ediff-abbrev-jobname ediff-metajob-name))) - - (setq regexp (ediff-get-group-regexp meta-list) - merge-autostore-dir (ediff-get-group-merge-autostore-dir meta-list)) - - (cond ((ediff-collect-diffs-metajob) - (insert - " `P':\tcollect custom diffs of all marked sessions\n")) - ((ediff-patch-metajob) - (insert - " `P':\tshow patch appropriately for the context (session or group)\n"))) - (insert - " `u':\tshow parent session group\n") - (or (ediff-one-filegroup-metajob) - (insert - " `D':\tshow differences among directories\n" - " `=':\tmark identical files in each session\n\n")) - - (if (and (stringp regexp) (> (length regexp) 0)) - (insert - (format "\n*** Filter-through regular expression: %s\n" regexp))) - (if (and ediff-autostore-merges (ediff-merge-metajob) - (stringp merge-autostore-dir)) - (insert (format - "\nMerges are automatically stored in directory: %s\n" - merge-autostore-dir))) - (insert "\n - Size Last modified Name - ----------------------------------------------------------------------- - -") - - ;; discard info on directories and regexp - (setq meta-list (cdr meta-list) - tmp-list meta-list) - (while (and tmp-list empty) - (if (and (car tmp-list) - (not (eq (ediff-get-session-status (car tmp-list)) ?I))) - (setq empty nil)) - (setq tmp-list (cdr tmp-list))) - - (if empty - (insert - " ****** ****** This session group has no members\n")) - - ;; now organize file names like this: - ;; use-mark sizeA dateA sizeB dateB filename - ;; make sure directories are displayed with a trailing slash. - (while meta-list - (setq elt (car meta-list) - meta-list (cdr meta-list) - sessionNum (1+ sessionNum)) - (if (eq (ediff-get-session-status elt) ?I) - () - (setq session-buf (ediff-get-session-buffer elt) - f1 (ediff-get-session-objA elt) - f2 (ediff-get-session-objB elt) - f3 (ediff-get-session-objC elt)) - (setq pt (point)) - ;; insert markers - (insert (cond ((null session-buf) " ") ; virgin session - ((ediff-buffer-live-p session-buf) "+") ;active session - (t "-"))) ; finished session - (insert (cond ((ediff-get-session-status elt)) ; session has status, - ;;; e.g., ?H, ?I - (t " "))) ; normal session - (insert " Session " (int-to-string sessionNum) ":\n") - (ediff-meta-insert-file-info f1) - (ediff-meta-insert-file-info f2) - (ediff-meta-insert-file-info f3) - (ediff-set-meta-overlay pt (point) elt))) - (set-buffer-modified-p nil) - (goto-char point) - meta-buf))) - -;; Check if this is a problematic session. -;; Return nil if not. Otherwise, return symbol representing the problem -;; At present, problematic sessions occur only in -with-ancestor comparisons -;; when the ancestor is a directory rather than a file, or when there is no -;; suitable ancestor file in the ancestor directory -(defun ediff-problematic-session-p (session) - (let ((f1 (ediff-get-session-objA-name session)) - (f2 (ediff-get-session-objB-name session)) - (f3 (ediff-get-session-objC-name session))) - (cond ((and (stringp f1) (not (file-directory-p f1)) - (stringp f2) (not (file-directory-p f2)) - ;; either invalid file name or a directory - (or (not (stringp f3)) (file-directory-p f3)) - (ediff-ancestor-metajob)) - ;; more may be added later - 'ancestor-is-dir) - (t nil)))) - -(defun ediff-meta-insert-file-info (fileinfo) - (let ((fname (car fileinfo)) - (feq (ediff-get-file-eqstatus fileinfo)) - file-modtime file-size) - - (cond ((not (stringp fname)) (setq file-size -2)) ; file doesn't exits - ((not (ediff-file-remote-p fname)) - (if (file-exists-p fname) - ;; set real size and modtime - (setq file-size (ediff-file-size fname) - file-modtime (ediff-file-modtime fname)) - (setq file-size -2))) ; file doesn't exist - ( t (setq file-size -1))) ; remote file - (if (stringp fname) - (insert - (format - "%s %s %-20s %s\n" - (if feq "=" " ") ; equality indicator - (format "%10s" (cond ((= file-size -1) "--") - ((< file-size -1) "--") - (t file-size))) - (cond ((= file-size -1) "*remote file*") - ((< file-size -1) "*file doesn't exist*") - (t (ediff-format-date (decode-time file-modtime)))) - - ;; dir names in meta lists have training slashes, so we just - ;; abbreviate the file name, if file exists - (if (and (not (stringp fname)) (< file-size -1)) - "-------" ; file doesn't exist - (ediff-abbreviate-file-name fname))))))) - -(defconst ediff-months '((1 . "Jan") (2 . "Feb") (3 . "Mar") (4 . "Apr") - (5 . "May") (6 . "Jun") (7 . "Jul") (8 . "Aug") - (9 . "Sep") (10 . "Oct") (11 . "Nov") (12 . "Dec")) - "Months' associative array.") - -;; returns 2char string -(defsubst ediff-fill-leading-zero (num) - (if (< num 10) - (format "0%d" num) - (number-to-string num))) - -;; TIME is like the output of decode-time -(defun ediff-format-date (time) - (format "%s %2d %4d %s:%s:%s" - (cdr (assoc (nth 4 time) ediff-months)) ; month - (nth 3 time) ; day - (nth 5 time) ; year - (ediff-fill-leading-zero (nth 2 time)) ; hour - (ediff-fill-leading-zero (nth 1 time)) ; min - (ediff-fill-leading-zero (nth 0 time)) ; sec - )) - -(defun ediff-draw-dir-diffs (diff-list) - (if (null diff-list) (error "Lost difference info on these directories")) - (let* ((buf-name (ediff-unique-buffer-name - "*Ediff File Group Differences" "*")) - (regexp (ediff-get-group-regexp diff-list)) - (dir1 (ediff-abbreviate-file-name (ediff-get-group-objA diff-list))) - (dir2 (ediff-abbreviate-file-name (ediff-get-group-objB diff-list))) - (dir3 (ediff-get-group-objC diff-list)) - (dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3))) - (meta-buf (ediff-get-group-buffer diff-list)) - (underline (make-string 26 ?-)) - file code - buffer-read-only) - ;; skip the directory part - (setq diff-list (cdr diff-list)) - (setq ediff-dir-diffs-buffer (get-buffer-create buf-name)) - (ediff-with-current-buffer ediff-dir-diffs-buffer - (use-local-map ediff-dir-diffs-buffer-map) - (erase-buffer) - (setq ediff-meta-buffer meta-buf) - (insert "\t\t*** Directory Differences ***\n") - (insert " -Useful commands: - `q': hide this buffer - SPC: next line - DEL: previous line\n\n") - - (if (and (stringp regexp) (> (length regexp) 0)) - (insert - (format "\n*** Filter-through regular expression: %s\n" regexp))) - (insert "\n") - (insert (format "\n%-27s%-26s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (file-name-as-directory dir1)) - 25) - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (file-name-as-directory dir2)) - 25))) - (if dir3 - (insert (format " %-25s\n" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (file-name-as-directory dir3)) - 25))) - (insert "\n")) - (insert (format "%s%s" underline underline)) - (if (stringp dir3) - (insert (format "%s\n\n" underline)) - (insert "\n\n")) - - (if (null diff-list) - (insert "\n\t*** No differences ***\n")) - - (while diff-list - (setq file (car (car diff-list)) - code (cdr (car diff-list)) - diff-list (cdr diff-list)) - (if (= (mod code 2) 0) ; dir1 - (insert (format "%-27s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (if (file-directory-p (concat dir1 file)) - (file-name-as-directory file) - file)) - 24))) - (insert (format "%-27s" "---"))) - (if (= (mod code 3) 0) ; dir2 - (insert (format "%-26s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (if (file-directory-p (concat dir2 file)) - (file-name-as-directory file) - file)) - 24))) - (insert (format "%-26s" "---"))) - (if (stringp dir3) - (if (= (mod code 5) 0) ; dir3 - (insert (format " %-25s" - (ediff-truncate-string-left - (ediff-abbreviate-file-name - (if (file-directory-p (concat dir3 file)) - (file-name-as-directory file) - file)) - 24))) - (insert (format " %-25s" "---")))) - (insert "\n")) - (setq buffer-read-only t) - (set-buffer-modified-p nil)) ; eval in diff buffer - )) - -(defun ediff-bury-dir-diffs-buffer () - "Bury the directory difference buffer. Display the meta buffer instead." - (interactive) - (let ((buf ediff-meta-buffer) - wind) - (bury-buffer) - (if (setq wind (ediff-get-visible-buffer-window buf)) - (select-window wind) - (set-window-buffer (selected-window) buf)))) - -;; executes in dir session group buffer -;; show buffer differences -(defun ediff-show-dir-diffs () - "Display differences among the directories involved in session group." - (interactive) - (if (ediff-one-filegroup-metajob) - (error "This command is inapplicable in the present context")) - (or (ediff-buffer-live-p ediff-dir-diffs-buffer) - (ediff-draw-dir-diffs ediff-dir-difference-list)) - (let ((buf ediff-dir-diffs-buffer)) - (other-window 1) - (set-window-buffer (selected-window) buf) - (goto-char (point-min)))) - -(defun ediff-up-meta-hierarchy () - "Go to the parent session group buffer." - (interactive) - (if (ediff-buffer-live-p ediff-parent-meta-buffer) - (ediff-show-meta-buffer ediff-parent-meta-buffer) - (error "This session group has no parent"))) - - -;; argument is ignored -(defun ediff-redraw-registry-buffer (&optional ignore) - (ediff-with-current-buffer ediff-registry-buffer - (let ((point (point)) - elt bufAname bufBname bufCname cur-diff total-diffs pt - job-name meta-list registry-list buffer-read-only) - (erase-buffer) - (insert "This is a registry of all active Ediff sessions. - -Useful commands: - button2, `v', RET over a session record: switch to that session - `M' over a session record: display the associated session group - `R' in any Ediff session: display session registry - SPC:\tnext session - DEL:\tprevious session - `E':\tbrowse Ediff on-line manual - `q':\tbury registry - - -\t\tActive Ediff Sessions: -\t\t---------------------- - -") - ;; purge registry list from dead buffers - (mapcar (function (lambda (elt) - (if (not (ediff-buffer-live-p elt)) - (setq ediff-session-registry - (delq elt ediff-session-registry))))) - ediff-session-registry) - - (if (null ediff-session-registry) - (insert " ******* No active Ediff sessions *******\n")) - - (setq registry-list ediff-session-registry) - (while registry-list - (setq elt (car registry-list) - registry-list (cdr registry-list)) - - (if (ediff-buffer-live-p elt) - (if (ediff-with-current-buffer elt - (setq job-name ediff-metajob-name - meta-list ediff-meta-list) - (and ediff-metajob-name - (not (eq ediff-metajob-name 'ediff-registry)))) - (progn - (setq pt (point)) - (insert (format " *group*\t%s: %s\n" - (buffer-name elt) - (ediff-abbrev-jobname job-name))) - (insert (format "\t\t %s %s %s\n" - (ediff-abbreviate-file-name - (ediff-get-group-objA meta-list)) - (ediff-abbreviate-file-name - (if (stringp - (ediff-get-group-objB meta-list)) - (ediff-get-group-objB meta-list) - "")) - (ediff-abbreviate-file-name - (if (stringp - (ediff-get-group-objC meta-list)) - (ediff-get-group-objC meta-list) - "")))) - (ediff-set-meta-overlay pt (point) elt)) - (progn - (ediff-with-current-buffer elt - (setq bufAname (if (ediff-buffer-live-p ediff-buffer-A) - (buffer-name ediff-buffer-A) - "!!!killed buffer!!!") - bufBname (if (ediff-buffer-live-p ediff-buffer-B) - (buffer-name ediff-buffer-B) - "!!!killed buffer!!!") - bufCname (cond ((not (ediff-3way-job)) - "") - ((ediff-buffer-live-p ediff-buffer-C) - (buffer-name ediff-buffer-C)) - (t "!!!killed buffer!!!"))) - (setq total-diffs (format "%-4d" ediff-number-of-differences) - cur-diff - (cond ((= ediff-current-difference -1) " _") - ((= ediff-current-difference - ediff-number-of-differences) - " $") - (t (format - "%4d" (1+ ediff-current-difference)))) - job-name ediff-job-name)) - ;; back in the meta buf - (setq pt (point)) - (insert cur-diff "/" total-diffs "\t" - (buffer-name elt) - (format ": %s" (ediff-abbrev-jobname job-name))) - (insert - "\n\t\t " bufAname " " bufBname " " bufCname "\n") - (ediff-set-meta-overlay pt (point) elt)))) - ) ; while - (set-buffer-modified-p nil) - (goto-char point) - ))) - -;; sets overlay around a meta record with 'ediff-meta-info property PROP -(defun ediff-set-meta-overlay (b e prop) - (let (overl) - (setq overl (ediff-make-overlay b e)) - (if ediff-emacs-p - (ediff-overlay-put overl 'mouse-face 'highlight) - (ediff-overlay-put overl 'highlight t)) - (ediff-overlay-put overl 'ediff-meta-info prop))) - -(defun ediff-mark-for-hiding (unmark) - "Mark session for hiding. With prefix arg, unmark." - (interactive "P") - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos)) - (session-buf (ediff-get-session-buffer info))) - - (if (eq (ediff-get-session-status info) ?H) - (setq unmark t)) - (if unmark - (ediff-set-session-status info nil) - (if (ediff-buffer-live-p session-buf) - (error "Can't hide active session, %s" (buffer-name session-buf))) - (ediff-set-session-status info ?H)) - (or unmark - (ediff-next-meta-item 1)) - (ediff-update-meta-buffer meta-buf) - )) - -(defun ediff-mark-for-operation (unmark) - "Mark session for a group operation. With prefix arg, unmark." - (interactive "P") - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos))) - - (if (eq (ediff-get-session-status info) ?*) - (setq unmark t)) - (if unmark - (ediff-set-session-status info nil) - (ediff-set-session-status info ?*)) - (or unmark - (ediff-next-meta-item 1)) - (ediff-update-meta-buffer meta-buf) - )) - -(defun ediff-hide-marked-sessions (unhide) - "Hide marked sessions. With prefix arg, unhide." - (interactive "P") - (let ((grp-buf (ediff-get-group-buffer ediff-meta-list)) - (meta-list (cdr ediff-meta-list)) - (from (if unhide ?I ?H)) - (to (if unhide ?H ?I)) - (numMarked 0) - active-sessions-exist session-buf elt) - (while meta-list - (setq elt (car meta-list) - meta-list (cdr meta-list) - session-buf (ediff-get-session-buffer elt)) - - (if (eq (ediff-get-session-status elt) from) - (progn - (setq numMarked (1+ numMarked)) - (if (and (eq to ?I) (buffer-live-p session-buf)) - ;; shouldn't hide active sessions - (setq active-sessions-exist t) - (ediff-set-session-status elt to))))) - (if (> numMarked 0) - (ediff-update-meta-buffer grp-buf) - (beep) - (if unhide - (message "Nothing to reveal...") - (message "Nothing to hide..."))) - (if active-sessions-exist - (message "Note: didn't hide active sessions!")) - )) - -;; Apply OPERATION to marked sessions. Operation expects one argument of type -;; meta-list member (not the first one), i.e., a regular session description. -;; Returns number of marked sessions on which operation was performed -(defun ediff-operate-on-marked-sessions (operation) - (let ((grp-buf (ediff-get-group-buffer ediff-meta-list)) - (meta-list (cdr ediff-meta-list)) - (marksym ?*) - (numMarked 0) - (sessionNum 0) - (diff-buffer ediff-meta-diff-buffer) - session-buf elt) - (while meta-list - (setq elt (car meta-list) - meta-list (cdr meta-list) - sessionNum (1+ sessionNum)) - (cond ((eq (ediff-get-session-status elt) marksym) - (save-excursion - (setq numMarked (1+ numMarked)) - (funcall operation elt sessionNum))) - ((and (ediff-meta-session-p elt) - (ediff-buffer-live-p - (setq session-buf (ediff-get-session-buffer elt)))) - (setq numMarked - (+ numMarked - (ediff-with-current-buffer session-buf - ;; pass meta-diff along - (setq ediff-meta-diff-buffer diff-buffer) - ;; collect diffs in child group - (ediff-operate-on-marked-sessions operation))))))) - (ediff-update-meta-buffer grp-buf) ; just in case - numMarked - )) - -(defun ediff-append-custom-diff (session sessionNum) - (or (ediff-collect-diffs-metajob) - (error "Hmm, I'd hate to do it to you ...")) - (let ((session-buf (ediff-get-session-buffer session)) - (meta-diff-buff ediff-meta-diff-buffer) - (metajob ediff-metajob-name) - tmp-buf custom-diff-buf) - (if (ediff-buffer-live-p session-buf) - (ediff-with-current-buffer session-buf - (if (eq ediff-control-buffer session-buf) ; individual session - (progn - (ediff-compute-custom-diffs-maybe) - (setq custom-diff-buf ediff-custom-diff-buffer))))) - - (or (ediff-buffer-live-p meta-diff-buff) - (error "Ediff: something wrong--no multiple diffs buffer")) - - (cond ((ediff-buffer-live-p custom-diff-buf) - (save-excursion - (set-buffer meta-diff-buff) - (goto-char (point-max)) - (insert-buffer custom-diff-buf) - (insert "\n"))) - ((memq metajob '(ediff-directories - ediff-merge-directories - ediff-merge-directories-with-ancestor)) - ;; get diffs by calling shell command on ediff-custom-diff-program - (save-excursion - (set-buffer (setq tmp-buf (get-buffer-create ediff-tmp-buffer))) - (erase-buffer) - (shell-command - (format "%s %s %s %s" - ediff-custom-diff-program ediff-custom-diff-options - (ediff-get-session-objA-name session) - (ediff-get-session-objB-name session)) - t)) - (save-excursion - (set-buffer meta-diff-buff) - (goto-char (point-max)) - (insert-buffer tmp-buf) - (insert "\n"))) - (t - (error "Can't make context diff for Session %d" sessionNum ))) - )) - -(defun ediff-collect-custom-diffs () - "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'. -This operation is defined only for `ediff-directories' and -`ediff-directory-revisions', since its intent is to produce -multifile patches. For `ediff-directory-revisions', we insist that -all marked sessions must be active." - (interactive) - (or (ediff-buffer-live-p ediff-meta-diff-buffer) - (setq ediff-meta-diff-buffer - (get-buffer-create - (ediff-unique-buffer-name "*Ediff Multifile Diffs" "*")))) - (ediff-with-current-buffer ediff-meta-diff-buffer - (erase-buffer)) - (if (> (ediff-operate-on-marked-sessions 'ediff-append-custom-diff) 0) - ;; did something - (display-buffer ediff-meta-diff-buffer 'not-this-window) - (beep) - (message "No marked sessions found"))) - -(defun ediff-meta-show-patch () - "Show the multi-file patch associated with this group session." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - (info (ediff-get-meta-info meta-buf pos 'noerror)) - (patchbuffer ediff-meta-patchbufer)) - (if (ediff-buffer-live-p patchbuffer) - (ediff-with-current-buffer patchbuffer - (save-restriction - (if (not info) - (widen) - (narrow-to-region - (ediff-get-session-objB-name info) - (ediff-get-session-objC-name info))) - (set-buffer (get-buffer-create ediff-tmp-buffer)) - (erase-buffer) - (insert-buffer patchbuffer) - (display-buffer ediff-tmp-buffer 'not-this-window) - )) - (error "The patch buffer wasn't found")))) - - -;; This function executes in meta buffer. It knows where event happened. -(defun ediff-filegroup-action () - "Execute appropriate action for the selected session." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos)) - merge-autostore-dir - session-buf file1 file2 file3 regexp) - - (setq session-buf (ediff-get-session-buffer info) - file1 (ediff-get-session-objA-name info) - file2 (ediff-get-session-objB-name info) - file3 (ediff-get-session-objC-name info)) - - ;; make sure we don't start on hidden sessions - ;; ?H means marked for hiding. ?I means invalid (hidden). - (if (memq (ediff-get-session-status info) '(?I)) - (progn - (beep) - (if (y-or-n-p "This session is marked as hidden, unmark? ") - (progn - (ediff-set-session-status info nil) - (ediff-update-meta-buffer meta-buf)) - (error "Aborted")))) - - (ediff-with-current-buffer meta-buf - (setq merge-autostore-dir - (ediff-get-group-merge-autostore-dir ediff-meta-list)) - (goto-char pos) ; if the user clicked on session--move point there - ;; First handle sessions involving directories (which are themselves - ;; session groups) - ;; After that handle individual sessions - (cond ((ediff-meta-session-p info) - ;; do ediff/ediff-merge on subdirectories - (if (ediff-buffer-live-p session-buf) - (ediff-show-meta-buffer session-buf) - (setq regexp (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history)) - (ediff-directories-internal - file1 file2 file3 regexp - ediff-session-action-function - ediff-metajob-name - ;; make it update car info after startup - (` (list (lambda () - ;; child session group should know its parent - (setq ediff-parent-meta-buffer - (quote (, ediff-meta-buffer))) - ;; and parent will know its child - (setcar (quote (, info)) ediff-meta-buffer))))))) - - ;; Do ediff-revision on a subdirectory - ((and (ediff-one-filegroup-metajob) - (ediff-revision-metajob) - (file-directory-p file1)) - (if (ediff-buffer-live-p session-buf) - (ediff-show-meta-buffer session-buf) - (setq regexp (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history)) - (ediff-directory-revisions-internal - file1 regexp - ediff-session-action-function ediff-metajob-name - ;; make it update car info after startup - (` (list (lambda () - ;; child session group should know its parent - (setq ediff-parent-meta-buffer - (quote (, ediff-meta-buffer))) - ;; and parent will know its child - (setcar (quote (, info)) ediff-meta-buffer))))))) - - ;; From here on---only individual session handlers - - ;; handle an individual session with a live control buffer - ((ediff-buffer-live-p session-buf) - (ediff-with-current-buffer session-buf - (setq ediff-mouse-pixel-position (mouse-pixel-position)) - (ediff-recenter 'no-rehighlight))) - - ((ediff-problematic-session-p info) - (beep) - (if (y-or-n-p - "This session has no ancestor. Merge without the ancestor? ") - (ediff-merge-files - file1 file2 - ;; provide startup hooks - (` (list (lambda () - (setq ediff-meta-buffer (, (current-buffer))) - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - ;; make ediff-startup pass - ;; ediff-control-buffer back to the meta - ;; level; see below - (setcar - (quote (, info)) ediff-control-buffer))))) - (error "Aborted"))) - ((ediff-one-filegroup-metajob) ; needs 1 file arg - (funcall ediff-session-action-function - file1 - ;; provide startup hooks - (` (list (lambda () - (setq ediff-meta-buffer (, (current-buffer))) - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - ;; make ediff-startup pass - ;; ediff-control-buffer back to the meta - ;; level; see below - (setcar - (quote (, info)) ediff-control-buffer)))))) - ((not (ediff-metajob3)) ; need 2 file args - (funcall ediff-session-action-function - file1 file2 - ;; provide startup hooks - (` (list (lambda () - (setq ediff-meta-buffer (, (current-buffer))) - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - ;; make ediff-startup pass - ;; ediff-control-buffer back to the meta - ;; level; see below - (setcar - (quote (, info)) ediff-control-buffer)))))) - ((ediff-metajob3) ; need 3 file args - (funcall ediff-session-action-function - file1 file2 file3 - ;; arrange startup hooks - (` (list (lambda () - (setq ediff-merge-store-file - (, (concat - merge-autostore-dir - "mrg_" - (file-name-nondirectory file1)))) - (setq ediff-meta-buffer (, (current-buffer))) - ;; this arranges that ediff-startup will pass - ;; the value of ediff-control-buffer back to - ;; the meta level, to the record in the meta - ;; list containing the information about the - ;; session associated with that - ;; ediff-control-buffer - (setcar - (quote (, info)) ediff-control-buffer)))))) - ) ; cond - ) ; eval in meta-buf - )) - -(defun ediff-registry-action () - "Switch to a selected session." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (buf (ediff-event-buffer last-command-event)) - (ctl-buf (ediff-get-meta-info buf pos))) - - (if (ediff-buffer-live-p ctl-buf) - ;; check if this is ediff-control-buffer or ediff-meta-buffer - (if (ediff-with-current-buffer ctl-buf - (eq (key-binding "q") 'ediff-quit-meta-buffer)) - ;; it's a meta-buffer -- last action should just display it - (ediff-show-meta-buffer ctl-buf) - ;; it's a session buffer -- invoke go back to session - (ediff-with-current-buffer ctl-buf - (setq ediff-mouse-pixel-position (mouse-pixel-position)) - (ediff-recenter 'no-rehighlight))) - (beep) - (message "You've selected a stale session --- try again") - (ediff-update-registry)) - (ediff-with-current-buffer buf - (goto-char pos)) - )) - - -(defun ediff-show-meta-buffer (&optional meta-buf) - "Show the session group buffer." - (interactive) - (let (wind frame silent) - (if meta-buf (setq silent t)) - - (setq meta-buf (or meta-buf ediff-meta-buffer)) - (cond ((not (bufferp meta-buf)) - (error "This Ediff session is not part of a session group")) - ((not (ediff-buffer-live-p meta-buf)) - (error - "Can't find this session's group panel -- session itself is ok"))) - - (ediff-cleanup-meta-buffer meta-buf) - (ediff-with-current-buffer meta-buf - (save-excursion - (cond ((setq wind (ediff-get-visible-buffer-window meta-buf)) - (or silent - (message - "Already showing the group panel for this session")) - (set-window-buffer wind meta-buf) - (select-window wind)) - ((window-live-p (setq wind ediff-window-C)) ;in merge--merge buf - (set-window-buffer ediff-window-C meta-buf) - (select-window wind)) - ((window-live-p (setq wind ediff-window-A)) - (set-window-buffer ediff-window-A meta-buf) - (select-window wind)) - ((window-live-p (setq wind ediff-window-B)) - (set-window-buffer ediff-window-B meta-buf) - (select-window wind)) - ((and - (setq wind - (ediff-get-visible-buffer-window ediff-registry-buffer)) - (ediff-window-display-p)) - (select-window wind) - (other-window 1) - (set-window-buffer (selected-window) meta-buf)) - (t (ediff-skip-unsuitable-frames 'ok-unsplittable) - (set-window-buffer (selected-window) meta-buf))) - )) - (if (and (ediff-window-display-p) - (window-live-p - (setq wind (ediff-get-visible-buffer-window meta-buf)))) - (progn - (setq frame (window-frame wind)) - (raise-frame frame) - (ediff-reset-mouse frame))) - (run-hooks 'ediff-show-session-group-hook) - )) - -(defun ediff-show-meta-buff-from-registry () - "Display the session group buffer for a selected session group." - (interactive) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - (info (ediff-get-meta-info meta-buf pos)) - (meta-or-session-buf info)) - (ediff-with-current-buffer meta-or-session-buf - (ediff-show-meta-buffer)))) - -;;;###autoload -(defun ediff-show-registry () - "Display Ediff's registry." - (interactive) - (ediff-update-registry) - (if (not (ediff-buffer-live-p ediff-registry-buffer)) - (error "No active Ediff sessions or corrupted session registry")) - (let (wind frame) - ;; for some reason, point moves in ediff-registry-buffer, so we preserve it - ;; explicitly - (ediff-with-current-buffer ediff-registry-buffer - (save-excursion - (cond ((setq wind - (ediff-get-visible-buffer-window ediff-registry-buffer)) - (message "Already showing the registry") - (set-window-buffer wind ediff-registry-buffer) - (select-window wind)) - ((window-live-p ediff-window-C) - (set-window-buffer ediff-window-C ediff-registry-buffer) - (select-window ediff-window-C)) - ((window-live-p ediff-window-A) - (set-window-buffer ediff-window-A ediff-registry-buffer) - (select-window ediff-window-A)) - ((window-live-p ediff-window-B) - (set-window-buffer ediff-window-B ediff-registry-buffer) - (select-window ediff-window-B)) - ((and (setq wind - (ediff-get-visible-buffer-window ediff-meta-buffer)) - (ediff-window-display-p)) - (select-window wind) - (other-window 1) - (set-window-buffer (selected-window) ediff-registry-buffer)) - (t (ediff-skip-unsuitable-frames 'ok-unsplittable) - (set-window-buffer (selected-window) ediff-registry-buffer))) - )) - (if (ediff-window-display-p) - (progn - (setq frame - (window-frame - (ediff-get-visible-buffer-window ediff-registry-buffer))) - (raise-frame frame) - (ediff-reset-mouse frame))) - (run-hooks 'ediff-show-registry-hook) - )) - -;;;###autoload -(defalias 'eregistry 'ediff-show-registry) - -;; If meta-buf doesn't exist, it is created. In that case, id doesn't have a -;; parent meta-buf -;; Check if META-BUF exists before calling this function -(defun ediff-update-meta-buffer (meta-buf) - (ediff-with-current-buffer (current-buffer) - (if (ediff-buffer-live-p meta-buf) - (ediff-with-current-buffer meta-buf - (funcall ediff-meta-redraw-function ediff-meta-list)) - ))) - -(defun ediff-update-registry () - (ediff-with-current-buffer (current-buffer) - (if (ediff-buffer-live-p ediff-registry-buffer) - (ediff-redraw-registry-buffer) - (ediff-prepare-meta-buffer - 'ediff-registry-action - ediff-session-registry - "*Ediff Registry" - 'ediff-redraw-registry-buffer - 'ediff-registry)) - )) - -;; If meta-buf exists, it is redrawn along with parent. -;; Otherwise, nothing happens. -(defun ediff-cleanup-meta-buffer (meta-buffer) - (if (ediff-buffer-live-p meta-buffer) - (ediff-with-current-buffer meta-buffer - (ediff-update-meta-buffer meta-buffer) - (if (ediff-buffer-live-p ediff-parent-meta-buffer) - (ediff-update-meta-buffer ediff-parent-meta-buffer))))) - -;; t if no session in progress -(defun ediff-safe-to-quit (meta-buffer) - (if (ediff-buffer-live-p meta-buffer) - (let ((lis ediff-meta-list) - (cont t) - buffer-read-only) - (ediff-update-meta-buffer meta-buffer) - (ediff-with-current-buffer meta-buffer - (setq lis (cdr lis)) ; discard the description part of meta-list - (while (and cont lis) - (if (ediff-buffer-live-p - (ediff-get-group-buffer lis)) ; in progress - (setq cont nil)) - (setq lis (cdr lis))) - cont)))) - -(defun ediff-quit-meta-buffer () - "If the group has no active session, delete the meta buffer. -If no session is in progress, ask to confirm before deleting meta buffer. -Otherwise, bury the meta buffer. -If this is a session registry buffer then just bury it." - (interactive) - (let* ((buf (current-buffer)) - (dir-diffs-buffer ediff-dir-diffs-buffer) - (meta-diff-buffer ediff-meta-diff-buffer) - (parent-buf ediff-parent-meta-buffer) - (dont-show-registry (eq buf ediff-registry-buffer))) - (if dont-show-registry - (bury-buffer) - (ediff-cleanup-meta-buffer buf) - (cond ((and (ediff-safe-to-quit buf) - (y-or-n-p "Quit this session group? ")) - (run-hooks 'ediff-quit-session-group-hook) - (message "") - (ediff-dispose-of-meta-buffer buf)) - ((ediff-safe-to-quit buf) - (bury-buffer)) - (t - (error - "This session group has active sessions---cannot exit"))) - (ediff-cleanup-meta-buffer parent-buf) - (ediff-kill-buffer-carefully dir-diffs-buffer) - (ediff-kill-buffer-carefully meta-diff-buffer) - (if (ediff-buffer-live-p parent-buf) - (progn - (setq dont-show-registry t) - (ediff-show-meta-buffer parent-buf))) - ) - (or dont-show-registry - (ediff-show-registry)))) - -(defun ediff-dispose-of-meta-buffer (buf) - (setq ediff-session-registry (delq buf ediff-session-registry)) - (ediff-with-current-buffer buf - (if (ediff-buffer-live-p ediff-dir-diffs-buffer) - (kill-buffer ediff-dir-diffs-buffer))) - (kill-buffer buf)) - - -;; Obtain information on a meta record where the user clicked or typed -;; BUF is the buffer where this happened and POINT is the position -;; If optional NOERROR arg is given, don't report error and return nil if no -;; meta info is found on line. -(defun ediff-get-meta-info (buf point &optional noerror) - (let (result olist tmp) - (if (and point (ediff-buffer-live-p buf)) - (ediff-with-current-buffer buf - (if ediff-xemacs-p - (setq result - (if (setq tmp (extent-at point buf 'ediff-meta-info)) - (ediff-overlay-get tmp 'ediff-meta-info))) - (setq olist (overlays-at point)) - (setq olist - (mapcar (function (lambda (elt) - (overlay-get elt 'ediff-meta-info))) - olist)) - (while (and olist (null (car olist)) - (overlay-get (car olist) 'invisible)) - (setq olist (cdr olist))) - (setq result (car olist))))) - (if result - result - (if noerror - nil - (ediff-update-registry) - (error "No session info in this line"))))) - -;; return location of the next meta overlay after point -(defun ediff-next-meta-overlay-start (point) - (if (eobp) - (goto-char (point-min)) - (let (overl) - (if ediff-xemacs-p - (progn - (setq overl (extent-at point (current-buffer) 'ediff-meta-info)) - (if overl - (setq overl (next-extent overl)) - (setq overl (next-extent (current-buffer)))) - (if overl - (extent-start-position overl) - (point-max))) - (setq overl (car (overlays-at point))) - (if (and overl (overlay-get overl 'ediff-meta-info)) - ;; note: end of current overlay is the beginning of the next one - (overlay-end overl) - (next-overlay-change point)))) - )) - -(defun ediff-previous-meta-overlay-start (point) - (if (bobp) - (goto-char (point-max)) - (let (overl) - (if ediff-xemacs-p - (progn - (setq overl (extent-at point (current-buffer) 'ediff-meta-info)) - (if overl - (setq overl (previous-extent overl)) - (setq overl (previous-extent (current-buffer)))) - (if overl - (extent-start-position overl) - (point-min))) - (setq overl (car (overlays-at point))) - (if (and overl (overlay-get overl 'ediff-meta-info)) - (setq point (overlay-start overl))) - ;; to get to the beginning of prev overlay - (if (not (bobp)) - ;; trickery to overcome an emacs bug--doesn't always find previous - ;; overlay change correctly - (setq point (1- point))) - (setq point (previous-overlay-change point)) - ;; If we are not over an overlay after subtracting 1, it means we are - ;; in the description area preceding session records. In this case, - ;; goto the top of the registry buffer. - (or (car (overlays-at point)) - (setq point (point-min))) - point - )))) - -;; this is the action invoked when the user selects a patch from the meta -;; buffer. -(defun ediff-patch-file-form-meta (file &optional startup-hooks) - (let* ((pos (ediff-event-point last-command-event)) - (meta-buf (ediff-event-buffer last-command-event)) - ;; ediff-get-meta-info gives error if meta-buf or pos are invalid - (info (ediff-get-meta-info meta-buf pos)) - (meta-patchbuf ediff-meta-patchbufer) - session-buf beg-marker end-marker) - - (if (or (file-directory-p file) (string-match "/dev/null" file)) - (error "`%s' is not an ordinary file" (file-name-as-directory file))) - (setq session-buf (ediff-get-session-buffer info) - beg-marker (ediff-get-session-objB-name info) - end-marker (ediff-get-session-objC-name info)) - - (or (ediff-buffer-live-p session-buf) ; either an active patch session - (null session-buf) ; or it is a virgin session - (error - "Patch has been already applied to this file--cannot be repeated!")) - - (ediff-with-current-buffer meta-patchbuf - (save-restriction - (widen) - (narrow-to-region beg-marker end-marker) - (ediff-patch-file-internal meta-patchbuf file startup-hooks))))) - - -(defun ediff-meta-mark-equal-files () - "Run though the session list and mark identical files. -This is used only for sessions that involve 2 or 3 files at the same time." - (interactive) - (let ((list (cdr ediff-meta-list)) - fileinfo1 fileinfo2 fileinfo3 elt) - (while (setq elt (car list)) - (setq fileinfo1 (ediff-get-session-objA elt) - fileinfo2 (ediff-get-session-objB elt) - fileinfo3 (ediff-get-session-objC elt)) - (ediff-set-file-eqstatus fileinfo1 nil) - (ediff-set-file-eqstatus fileinfo2 nil) - (ediff-set-file-eqstatus fileinfo3 nil) - - (ediff-mark-if-equal fileinfo1 fileinfo2) - (if (ediff-metajob3) - (progn - (ediff-mark-if-equal fileinfo1 fileinfo3) - (ediff-mark-if-equal fileinfo2 fileinfo3))) - (setq list (cdr list)))) - (ediff-update-meta-buffer (current-buffer))) - -;; mark files 1 and 2 as equal, if they are. -(defun ediff-mark-if-equal (fileinfo1 fileinfo2) - (get-buffer-create ediff-tmp-buffer) - (or (file-directory-p (car fileinfo1)) - (file-directory-p (car fileinfo2)) - (if (= (ediff-make-diff2-buffer - ediff-tmp-buffer (car fileinfo1) (car fileinfo2)) - 0) - (progn - (ediff-set-file-eqstatus fileinfo1 t) - (ediff-set-file-eqstatus fileinfo2 t))))) - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-mult.el ends here
--- a/lisp/ediff/ediff-ptch.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,710 +0,0 @@ -;;; ediff-ptch.el --- Ediff's patch support - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;;; Code: - -(provide 'ediff-ptch) - -(defgroup ediff-ptch nil - "Ediff patch support" - :tag "Patch" - :prefix "ediff-" - :group 'ediff) - -;; compiler pacifier -(defvar ediff-window-A) -(defvar ediff-window-B) -(defvar ediff-window-C) -(defvar ediff-use-last-dir) -(defvar ediff-shell) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff) - (load "ediff.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defcustom ediff-patch-program "patch" - "*Name of the program that applies patches. -It is recommended to use GNU-compatible versions." - :type 'string - :group 'ediff-ptch) -(defcustom ediff-patch-options "-f" - "*Options to pass to ediff-patch-program. - -Note: the `-b' option should be specified in `ediff-backup-specs'. - -It is recommended to pass the `-f' option to the patch program, so it won't ask -questions. However, some implementations don't accept this option, in which -case the default value for this variable should be changed." - :type 'string - :group 'ediff-ptch) - -(defvar ediff-last-dir-patch nil - "Last directory used by an Ediff command for file to patch.") - -;; the default backup extension -(defconst ediff-default-backup-extension - (if (memq system-type '(vax-vms axp-vms emx ms-dos)) - "_orig" ".orig")) - - -(defcustom ediff-backup-extension ediff-default-backup-extension - "Backup extension used by the patch program. -See also `ediff-backup-specs'." - :type 'string - :group 'ediff-ptch) - -(defun ediff-test-patch-utility () - (cond ((zerop (call-process ediff-patch-program nil nil nil "-z." "-b")) - ;; GNU `patch' v. >= 2.2 - 'gnu) - ((zerop (call-process ediff-patch-program nil nil nil "-b")) - 'posix) - (t 'traditional))) - -(defcustom ediff-backup-specs - (let ((type (ediff-test-patch-utility))) - (cond ((eq type 'gnu) - ;; GNU `patch' v. >= 2.2 - (format "-z%s -b" ediff-backup-extension)) - ((eq type 'posix) - ;; POSIX `patch' -- ediff-backup-extension must be ".orig" - (setq ediff-backup-extension ediff-default-backup-extension) - "-b") - (t - ;; traditional `patch' - (format "-b %s" ediff-backup-extension)))) - "*Backup directives to pass to the patch program. -Ediff requires that the old version of the file \(before applying the patch\) -be saved in a file named `the-patch-file.extension'. Usually `extension' is -`.orig', but this can be changed by the user and may depend on the system. -Therefore, Ediff needs to know the backup extension used by the patch program. - -Some versions of the patch program let you specify `-b backup-extension'. -Other versions only permit `-b', which assumes the extension `.orig' -\(in which case ediff-backup-extension MUST be also `.orig'\). The latest -versions of GNU patch require `-b -z backup-extension'. - -Note that both `ediff-backup-extension' and `ediff-backup-specs' -must be set properly. If your patch program takes the option `-b', -but not `-b extension', the variable `ediff-backup-extension' must -still be set so Ediff will know which extension to use. - -Ediff tries to guess the appropriate value for this variables. It is believed -to be working for `traditional' patch, all versions of GNU patch, and for POSIX -patch. So, don't change these variables, unless the default doesn't work." - :type 'string - :group 'ediff-ptch) - - -(defcustom ediff-patch-default-directory nil - "*Default directory to look for patches." - :type '(choice (const nil) string) - :group 'ediff-ptch) - -(defcustom ediff-context-diff-label-regexp - (concat "\\(" ; context diff 2-liner - "^\\*\\*\\* \\([^ \t]+\\)[^*]+[\t ]*\n--- \\([^ \t]+\\)" - "\\|" ; GNU unified format diff 2-liner - "^--- \\([^ \t]+\\)[\t ]+.*\n\\+\\+\\+ \\([^ \t]+\\)" - "\\)") - "*Regexp matching filename 2-liners at the start of each context diff. -You probably don't want to change that, unless you are using an obscure patch -program." - :type 'regexp - :group 'ediff-ptch) - -;; The buffer of the patch file. Local to control buffer. -(ediff-defvar-local ediff-patchbufer nil "") - -;; The buffer where patch displays its diagnostics. -(ediff-defvar-local ediff-patch-diagnostics nil "") - -;; Map of patch buffer. Has the form: -;; ((filename1 marker1 marker2) (filename2 marker1 marker2) ...) -;; where filenames are files to which patch would have applied the patch; -;; marker1 delimits the beginning of the corresponding patch and marker2 does -;; it for the end. -(ediff-defvar-local ediff-patch-map nil "") - -;; strip prefix from filename -;; returns /dev/null, if can't strip prefix -(defsubst ediff-file-name-sans-prefix (filename prefix) - (save-match-data - (if (string-match (concat "^" prefix) filename) - (substring filename (match-end 0)) - (concat "/null/" filename)))) - - - -;; no longer used -;; return the number of matches of regexp in buf starting from the beginning -(defun ediff-count-matches (regexp buf) - (ediff-with-current-buffer buf - (let ((count 0) opoint) - (save-excursion - (goto-char (point-min)) - (while (and (not (eobp)) - (progn (setq opoint (point)) - (re-search-forward regexp nil t))) - (if (= opoint (point)) - (forward-char 1) - (setq count (1+ count))))) - count))) - -;; Scan BUF (which is supposed to contain a patch) and make a list of the form -;; ((filename1 marker1 marker2) (filename2 marker1 marker2) ...) -;; where filenames are files to which patch would have applied the patch; -;; marker1 delimits the beginning of the corresponding patch and marker2 does -;; it for the end. This list is then assigned to ediff-patch-map. -;; Returns the number of elements in the list ediff-patch-map -(defun ediff-map-patch-buffer (buf) - (ediff-with-current-buffer buf - (let ((count 0) - (mark1 (move-marker (make-marker) (point-min))) - (mark1-end (point-min)) - (possible-file-names '("/dev/null" . "/dev/null")) - mark2-end mark2 filenames - beg1 beg2 end1 end2 - patch-map opoint) - (save-excursion - (goto-char (point-min)) - (setq opoint (point)) - (while (and (not (eobp)) - (re-search-forward ediff-context-diff-label-regexp nil t)) - (if (= opoint (point)) - (forward-char 1) ; ensure progress towards the end - (setq mark2 (move-marker (make-marker) (match-beginning 0)) - mark2-end (match-end 0) - beg1 (or (match-beginning 2) (match-beginning 4)) - end1 (or (match-end 2) (match-end 4)) - beg2 (or (match-beginning 3) (match-beginning 5)) - end2 (or (match-end 3) (match-end 5))) - ;; possible-file-names is holding the new file names until we - ;; insert the old file name in the patch map - ;; It is a pair (filename from 1st header line . fn from 2nd line) - (setq possible-file-names - (cons (if (and beg1 end1) - (buffer-substring beg1 end1) - "/dev/null") - (if (and beg2 end2) - (buffer-substring beg2 end2) - "/dev/null"))) - ;; check for any `Index:' or `Prereq:' lines, but don't use them - (if (re-search-backward "^Index:" mark1-end 'noerror) - (move-marker mark2 (match-beginning 0))) - (if (re-search-backward "^Prereq:" mark1-end 'noerror) - (move-marker mark2 (match-beginning 0))) - - (goto-char mark2-end) - - (if filenames - (setq patch-map (cons (list filenames mark1 mark2) patch-map))) - (setq mark1 mark2 - mark1-end mark2-end - filenames possible-file-names)) - (setq opoint (point) - count (1+ count)))) - (setq mark2 (point-max-marker) - patch-map (cons (list possible-file-names mark1 mark2) patch-map)) - (setq ediff-patch-map (nreverse patch-map)) - count))) - -;; Fix up the file names in the list using the argument FILENAME -;; Algorithm: find the first file's directory and cut it out from each file -;; name in the patch. Prepend the directory of FILENAME to each file in the -;; patch. In addition, the first file in the patch is replaced by FILENAME. -;; Each file is actually a file-pair of files found in the context diff header -;; In the end, for each pair, we select the shortest existing file. -;; Note: Ediff doesn't recognize multi-file patches that are separated -;; with the `Index:' line. It treats them as a single-file patch. -;; -;; Executes inside the patch buffer -(defun ediff-fixup-patch-map (filename) - (setq filename (expand-file-name filename)) - (let ((actual-dir (if (file-directory-p filename) - ;; directory part of filename - (file-name-as-directory filename) - (file-name-directory filename))) - ;; directory part of the first file in the patch - (base-dir1 (file-name-directory (car (car (car ediff-patch-map))))) - (base-dir2 (file-name-directory (cdr (car (car ediff-patch-map))))) - ) - - ;; chop off base-dirs - (mapcar (function (lambda (triple) - (or (string= (car (car triple)) "/dev/null") - (setcar (car triple) - (ediff-file-name-sans-prefix - (car (car triple)) base-dir1))) - (or (string= (cdr (car triple)) "/dev/null") - (setcdr (car triple) - (ediff-file-name-sans-prefix - (cdr (car triple)) base-dir2))) - )) - ediff-patch-map) - - ;; take the given file name into account - (or (file-directory-p filename) - (string= "/dev/null" filename) - (progn - (setcar (car ediff-patch-map) - (cons (file-name-nondirectory filename) - (file-name-nondirectory filename))))) - - ;; prepend actual-dir - (mapcar (function (lambda (triple) - (if (and (string-match "^/null/" (car (car triple))) - (string-match "^/null/" (cdr (car triple)))) - ;; couldn't strip base-dir1 and base-dir2 - ;; hence, something wrong - (progn - (with-output-to-temp-buffer ediff-msg-buffer - (princ - (format " -The patch file contains a context diff for - %s - %s -However, Ediff cannot infer the name of the actual file -to be patched on your system. If you know the correct file name, -please enter it now. - -If you don't know and still would like to apply patches to -other files, enter /dev/null -" - (substring (car (car triple)) 6) - (substring (cdr (car triple)) 6)))) - (let ((directory t) - user-file) - (while directory - (setq user-file - (read-file-name - "Please enter file name: " - actual-dir actual-dir t)) - (if (not (file-directory-p user-file)) - (setq directory nil) - (setq directory t) - (beep) - (message "%s is a directory" user-file) - (sit-for 2))) - (setcar triple (cons user-file user-file)))) - (setcar (car triple) - (expand-file-name - (concat actual-dir (car (car triple))))) - (setcdr (car triple) - (expand-file-name - (concat actual-dir (cdr (car triple)))))) - )) - ediff-patch-map) - ;; check for the shorter existing file in each pair and discard the other - ;; one - (mapcar (function (lambda (triple) - (let* ((file1 (car (car triple))) - (file2 (cdr (car triple))) - (f1-exists (file-exists-p file1)) - (f2-exists (file-exists-p file2))) - (cond - ((and (< (length file2) (length file1)) - f2-exists) - (setcar triple file2)) - ((and (< (length file1) (length file2)) - f1-exists) - (setcar triple file1)) - ((and f1-exists f2-exists - (string= file1 file2)) - (setcar triple file1)) - ((and f1-exists f2-exists) - (with-output-to-temp-buffer ediff-msg-buffer - (princ (format " -Ediff has inferred that - %s - %s -are two possible targets for applying the patch. -Both files seem to be plausible alternatives. - -Please advice: - Type `y' to use %s as the target; - Type `n' to use %s as the target. -" - file1 file2 file2 file1))) - (setcar triple - (if (y-or-n-p (format "Use %s ? " file2)) - file2 file1))) - (f2-exists (setcar triple file2)) - (f1-exists (setcar triple file1)) - (t - (with-output-to-temp-buffer ediff-msg-buffer - (princ "\nEdiff has inferred that") - (if (string= file1 file2) - (princ (format " - %s -is the target for this patch. However, this file does not exist." - file1)) - (princ (format " - %s - %s -are two possible targets for this patch. However, these files do not exist." - file1 file2))) - (princ " -\nPlease enter an alternative patch target ...\n")) - (let ((directory t) - target) - (while directory - (setq target (read-file-name - "Please enter a patch target: " - actual-dir actual-dir t)) - (if (not (file-directory-p target)) - (setq directory nil) - (beep) - (message "%s is a directory" target) - (sit-for 2))) - (setcar triple target))))))) - ediff-patch-map) - )) - -(defun ediff-show-patch-diagnostics () - (interactive) - (cond ((window-live-p ediff-window-A) - (set-window-buffer ediff-window-A ediff-patch-diagnostics)) - ((window-live-p ediff-window-B) - (set-window-buffer ediff-window-B ediff-patch-diagnostics)) - (t (display-buffer ediff-patch-diagnostics 'not-this-window)))) - -(defun ediff-get-patch-buffer () - "Obtain patch buffer. If patch is already in a buffer---use it. -Else, read patch file into a new buffer." - (let ((dir (cond (ediff-patch-default-directory) ; try patch default dir - (ediff-use-last-dir ediff-last-dir-patch) - (t default-directory))) - patch-buf) - (if (let ((last-nonmenu-event t) ; Emacs: don't use dialog box - last-command-event) ; XEmacs: don't use dialog box - (y-or-n-p "Is the patch already in a buffer? ")) - (setq patch-buf - (get-buffer - (read-buffer - "Which buffer contains the patch? " - (ediff-other-buffer - (if (eq (next-window (selected-window)) (selected-window)) - ;; only one window in frame --- don't skip current buff - "" - ;; >1 window --- skip current buff, assuming this is the one - ;; to patch, not the one that has the patch - (current-buffer))) - 'must-match))) - (setq patch-buf - (find-file-noselect - (read-file-name "Which file contains the patch? " - dir nil 'must-match)))) - - (ediff-with-current-buffer patch-buf - (goto-char (point-min)) - (or (ediff-get-visible-buffer-window patch-buf) - (progn - (pop-to-buffer patch-buf 'other-window) - (select-window (previous-window))))) - (ediff-map-patch-buffer patch-buf) - patch-buf)) - -;; Dispatch the right patch file function: regular or meta-level, -;; depending on how many patches are in the patch file. -;; At present, there is no support for meta-level patches. -;; Should return either the ctl buffer or the meta-buffer -(defun ediff-dispatch-file-patching-job (patch-buf filename - &optional startup-hooks) - (ediff-with-current-buffer patch-buf - ;; relativize names in the patch with respect to source-file - (ediff-fixup-patch-map filename) - (if (< (length ediff-patch-map) 2) - (ediff-patch-file-internal - patch-buf - (if (and (not (string-match "^/dev/null" (car (car ediff-patch-map)))) - (> (length (car (car ediff-patch-map))) 1)) - (car (car ediff-patch-map)) - filename) - startup-hooks) - (ediff-multi-patch-internal patch-buf startup-hooks)) - )) - - -;; When patching a buffer, never change the orig file. Instead, create a new -;; buffer, ***_patched, even if the buff visits a file. -;; Users who want to actually patch the buffer should use -;; ediff-patch-file, not ediff-patch-buffer. -(defun ediff-patch-buffer-internal (patch-buf - buf-to-patch-name - &optional startup-hooks) - (let* ((buf-to-patch (get-buffer buf-to-patch-name)) - (visited-file (if buf-to-patch (buffer-file-name buf-to-patch))) - (buf-mod-status (buffer-modified-p buf-to-patch)) - (multifile-patch-p (> (length (ediff-with-current-buffer patch-buf - ediff-patch-map)) 1)) - default-dir file-name ctl-buf) - (if multifile-patch-p - (error - "Can't apply multi-file patches to buffers that visit no files")) - - ;; create a temp file to patch - (ediff-with-current-buffer buf-to-patch - (setq default-dir default-directory) - (setq file-name (ediff-make-temp-file buf-to-patch)) - ;; temporarily switch visited file name, if any - (set-visited-file-name file-name) - ;; don't create auto-save file, if buff was visiting a file - (or visited-file - (setq buffer-auto-save-file-name nil)) - ;; don't confuse the user with a new bufname - (rename-buffer buf-to-patch-name) - (set-buffer-modified-p nil) - (set-visited-file-modtime) ; sync buffer and temp file - (setq default-directory default-dir) - ) - - ;; dispatch a patch function - (setq ctl-buf (ediff-dispatch-file-patching-job - patch-buf file-name startup-hooks)) - - (ediff-with-current-buffer ctl-buf - (delete-file (buffer-file-name ediff-buffer-A)) - (delete-file (buffer-file-name ediff-buffer-B)) - (ediff-with-current-buffer ediff-buffer-A - (if default-dir (setq default-directory default-dir)) - (set-visited-file-name visited-file) ; visited-file might be nil - (rename-buffer buf-to-patch-name) - (set-buffer-modified-p buf-mod-status)) - (ediff-with-current-buffer ediff-buffer-B - (setq buffer-auto-save-file-name nil) ; don't create auto-save file - (if default-dir (setq default-directory default-dir)) - (set-visited-file-name nil) - (rename-buffer (ediff-unique-buffer-name - (concat buf-to-patch-name "_patched") "")) - (set-buffer-modified-p t))) - )) - - -;; Traditional patch has weird return codes. -;; GNU and Posix return 1 if some hanks failed and 2 in case of trouble. -;; 0 is a good code in all cases. -;; We'll do the concervative thing. -(defun ediff-patch-return-code-ok (code) - (eq code 0)) -;;; (if (eq (ediff-test-patch-utility) 'traditional) -;;; (eq code 0) -;;; (not (eq code 2)))) - -(defun ediff-patch-file-internal (patch-buf source-filename - &optional startup-hooks) - (setq source-filename (expand-file-name source-filename)) - - (let* ((shell-file-name ediff-shell) - (patch-diagnostics (get-buffer-create "*ediff patch diagnostics*")) - ;; ediff-find-file may use a temp file to do the patch - ;; so, we save source-filename and true-source-filename as a var - ;; that initially is source-filename but may be changed to a temp - ;; file for the purpose of patching. - (true-source-filename source-filename) - (target-filename source-filename) - target-buf buf-to-patch file-name-magic-p - patch-return-code ctl-buf backup-style aux-wind) - - (if (string-match "V" ediff-patch-options) - (error - "Ediff doesn't take the -V option in `ediff-patch-options'--sorry")) - - ;; Make a temp file, if source-filename has a magic file handler (or if - ;; it is handled via auto-mode-alist and similar magic). - ;; Check if there is a buffer visiting source-filename and if they are in - ;; sync; arrange for the deletion of temp file. - (ediff-find-file 'true-source-filename 'buf-to-patch - 'ediff-last-dir-patch 'startup-hooks) - - ;; Check if source file name has triggered black magic, such as file name - ;; handlers or auto mode alist, and make a note of it. - ;; true-source-filename should be either the original name or a - ;; temporary file where we put the after-product of the file handler. - (setq file-name-magic-p (not (equal (file-truename true-source-filename) - (file-truename source-filename)))) - - ;; Checkout orig file, if necessary, so that the patched file - ;; could be checked back in. - (ediff-maybe-checkout buf-to-patch) - - (ediff-with-current-buffer patch-diagnostics - (insert-buffer patch-buf) - (message "Applying patch ... ") - ;; fix environment for gnu patch, so it won't make numbered extensions - (setq backup-style (getenv "VERSION_CONTROL")) - (setenv "VERSION_CONTROL" nil) - (setq patch-return-code - (call-process-region - (point-min) (point-max) - shell-file-name - t ; delete region (which contains the patch - t ; insert output (patch diagnostics) in current buffer - nil ; don't redisplay - shell-command-switch ; usually -c - (format "%s %s %s %s" - ediff-patch-program - ediff-patch-options - ediff-backup-specs - (expand-file-name true-source-filename)) - )) - - ;; restore environment for gnu patch - (setenv "VERSION_CONTROL" backup-style)) - - (message "Applying patch ... done") - (message "") - - (switch-to-buffer patch-diagnostics) - (sit-for 0) ; synchronize - let the user see diagnostics - - (or (and (ediff-patch-return-code-ok patch-return-code) - (file-exists-p - (concat true-source-filename ediff-backup-extension))) - (progn - (with-output-to-temp-buffer ediff-msg-buffer - (princ (format - "Patch program has failed due to a bad patch file, -it couldn't apply all hunks, OR -it couldn't create the backup for the file being patched. - -The former could be caused by a corrupt patch file or because the %S -program doesn't understand the format of the patch file in use. - -The second problem might be due to an incompatibility among these settings: - ediff-patch-program = %S ediff-patch-options = %S - ediff-backup-extension = %S ediff-backup-specs = %S - -See Ediff on-line manual for more details on these variables. -In particular, check the documentation for `ediff-backup-specs'. - -In any of the above cases, Ediff doesn't compare files automatically. -However, if the patch was applied partially and the backup file was created, -you can still examine the changes via M-x ediff-files" - ediff-patch-program - ediff-patch-program - ediff-patch-options - ediff-backup-extension - ediff-backup-specs - ))) - (beep 1) - (if (setq aux-wind (get-buffer-window ediff-msg-buffer)) - (progn - (select-window aux-wind) - (goto-char (point-max)))) - (switch-to-buffer-other-window patch-diagnostics) - (error "Patch appears to have failed"))) - - ;; If black magic is involved, apply patch to a temp copy of the - ;; file. Otherwise, apply patch to the orig copy. If patch is applied - ;; to temp copy, we name the result old-name_patched for local files - ;; and temp-copy_patched for remote files. The orig file name isn't - ;; changed, and the temp copy of the original is later deleted. - ;; Without magic, the original file is renamed (usually into - ;; old-name_orig) and the result of patching will have the same name as - ;; the original. - (if (not file-name-magic-p) - (ediff-with-current-buffer buf-to-patch - (set-visited-file-name - (concat source-filename ediff-backup-extension)) - (set-buffer-modified-p nil)) - - ;; Black magic in effect. - ;; If orig file was remote, put the patched file in the temp directory. - ;; If orig file is local, put the patched file in the directory of - ;; the orig file. - (setq target-filename - (concat - (if (ediff-file-remote-p (file-truename source-filename)) - true-source-filename - source-filename) - "_patched")) - - (rename-file true-source-filename target-filename t) - - ;; arrange that the temp copy of orig will be deleted - (rename-file (concat true-source-filename ediff-backup-extension) - true-source-filename t)) - - ;; make orig buffer read-only - (setq startup-hooks - (cons 'ediff-set-read-only-in-buf-A startup-hooks)) - - ;; set up a buf for the patched file - (setq target-buf (find-file-noselect target-filename)) - - (setq ctl-buf - (ediff-buffers-internal - buf-to-patch target-buf nil - startup-hooks 'epatch)) - (ediff-with-current-buffer ctl-buf - (setq ediff-patchbufer patch-buf - ediff-patch-diagnostics patch-diagnostics)) - - (bury-buffer patch-diagnostics) - (message "Type `P', if you need to see patch diagnostics") - ctl-buf)) - -(defun ediff-multi-patch-internal (patch-buf &optional startup-hooks) - (let (meta-buf) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons (` (lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function - 'ediff-patch-file-form-meta - ediff-meta-patchbufer patch-buf) - )) - startup-hooks)) - (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action - (ediff-with-current-buffer patch-buf - ;; nil replaces a regular expression - (cons (list nil (format "%S" patch-buf)) - ediff-patch-map)) - "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer - 'ediff-multifile-patch - startup-hooks)) - (ediff-show-meta-buffer meta-buf) - )) - - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-ptch.el ends here
--- a/lisp/ediff/ediff-tbar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -;;; ediff-tbar.el --- A toolbar for Ediff control buffer - -;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. - -;; Author: Marc Paquette <marcpa@cam.org> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-tbar) - -;; compiler pacifier -(defvar toolbar-icon-directory) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -(defvar ediff-use-toolbar-p nil - "If t, Ediff will use a toolbar for the control frame. -This has an effect only if your emacs supports Toolbars. -Currently, XEmacs does, but not Emacs. -Do not change the value of this variable interactively. -This should be done only via the menu bar or by executing -`ediff-toggle-use-toolbar'.") - -(defvar ediff-toolbar-height 21 - "The height of the Ediff toolbar. -The value must match the actual size of the toolbar icons.") - -(defvar ediff-toolbar-width 200.0 - "The width of the Ediff toolbar. -The value must match the actual width of the toolbar. -Here's an example: - There are 10 buttons, each 15 pixels large, and the shadows occupy 2 - pixels each side, and the last button is right-justified (so we reserve - about 30 pixels for fill space) = 200 pixels.") - -(defun ediff-has-toolbar-support-p () - (and ediff-xemacs-p - (featurep 'toolbar) - (console-on-window-system-p))) - -(defun ediff-use-toolbar-p () - (and (ediff-has-toolbar-support-p) ;Can it do it ? - ediff-use-toolbar-p)) ;Does the user want it ? - -;; Here the toolbar width is not the same width talked about in XEmacs -;; lispref info documentation : it is the minimal width needed by -;; ediff's toolbar to display all buttons, for an horizontal toolbar. -;; Ideally, we would query the toolbar for the width of each button -;; and add them, but I didn't find query functions in the doc on -;; toolbars. Therefore, I use a static number of pixels that should -;; be adjusted if the toolbar gets more or loses some buttons. --marcpa -(defun ediff-compute-toolbar-width () - (if (not (ediff-use-toolbar-p)) - 0 - (ceiling (/ ediff-toolbar-width (font-instance-width (face-font-instance 'default)))))) - -(defvar ediff-toolbar-next-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-next.xpm" "ediff-next.xbm") - toolbar-icon-directory))) - "Next difference icon in toolbar.") - -(defvar ediff-toolbar-previous-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-prev.xpm" "ediff-prev.xbm") - toolbar-icon-directory))) - "Previous difference icon in toolbar.") - -(defvar ediff-toolbar-A-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-A-up.xpm" "ediff-A-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DOWN - (if (featurep 'xpm) "ediff-A-up.xpm" "ediff-A-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DISABLED - (if (featurep 'xpm) "ediff-A-xx.xpm" "ediff-A-up.xbm") - toolbar-icon-directory) - )) - "Select diff A icon in toolbar.") - -(defvar ediff-toolbar-B-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-B-up.xpm" "ediff-B-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DOWN - (if (featurep 'xpm) "ediff-B-up.xpm" "ediff-B-up.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DISABLED - (if (featurep 'xpm) "ediff-B-xx.xpm" "ediff-B-up.xbm") - toolbar-icon-directory) - )) - "Select diff B icon in toolbar.") - -(defvar ediff-toolbar-toggle-split-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) - "ediff-toggle-split-up.xpm" "ediff-toggle-split-up.xbm") - toolbar-icon-directory) - )) - "Toggle split mode between side-to-side and one-on-top-of-another.") - -(defvar ediff-toolbar-save-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-save.xpm" "ediff-save.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DOWN - (if (featurep 'xpm) "ediff-save.xpm" "ediff-save.xbm") - toolbar-icon-directory) - (expand-file-name - ;; DISABLED - (if (featurep 'xpm) "ediff-save-xx.xpm" "ediff-save-xx.xbm") - toolbar-icon-directory) - )) - "Save merge buffer.") - -(defvar ediff-toolbar-quit-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-quit.xpm" "ediff-quit.xbm") - toolbar-icon-directory))) - "Exit Ediff session.") - -(defvar ediff-toolbar-help-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-help.xpm" "ediff-help.xbm") - toolbar-icon-directory))) - "Show Ediff help.") - -(defvar ediff-toolbar-refresh-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - (if (featurep 'xpm) "ediff-update.xpm" "ediff-update.xbm") - toolbar-icon-directory))) - "Refresh Ediff display (aka recenter).") - -(defvar ediff-toolbar-refine-icon - (if (featurep 'toolbar) - (toolbar-make-button-list - (expand-file-name - ;; UP - (if (featurep 'xpm) "ediff-refine.xpm" "ediff-refine.xbm") - toolbar-icon-directory) - )) - "Refine current difference region by computing fine diffs.") - -(defun ediff-toolbar-previous-difference () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-previous-difference 1))) - -(defun ediff-toolbar-next-difference () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-next-difference 1))) - -(defun ediff-toolbar-select/copy-A () - (interactive) - (let ((ediff-grab-mouse nil)) - (cond ((or (ediff-merge-job) - (ediff-merge-with-ancestor-job)) - (ediff-copy-A-to-C nil)) - (t - (ediff-copy-A-to-B nil))))) - -(defun ediff-toolbar-select/copy-B () - (interactive) - (let ((ediff-grab-mouse nil)) - (cond ((or (ediff-merge-job) - (ediff-merge-with-ancestor-job)) - (ediff-copy-B-to-C nil)) - (t - (ediff-copy-B-to-A nil))))) - -(defun ediff-toolbar-toggle-split () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-toggle-split))) - - -(defun ediff-toolbar-save () - (interactive) - (ediff-barf-if-not-control-buffer) - (if (ediff-merge-job) - (ediff-maybe-save-and-delete-merge 'save-and-continue) - ;; 2-way or 3-way compare: save modified buffers - (mapcar (function - (lambda (type) - (let ((ebuf (ediff-get-buffer type))) - (and (ediff-buffer-live-p ebuf) - (ediff-with-current-buffer ebuf - (and (buffer-modified-p) - (save-buffer))))))) - '(A B C)))) - - -(defun ediff-toolbar-quit () - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-quit nil))) - -(defun ediff-toolbar-help () - (interactive) - (ediff-toggle-help)) - -(defun ediff-toolbar-refresh () - "Recenter" - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-recenter))) - -(defun ediff-toolbar-refine () - "Refine current difference region by computing fine diffs." - (interactive) - (let ((ediff-grab-mouse nil)) - (ediff-make-or-kill-fine-diffs 'make-them))) - -(defun ediff-toolbar-refine-needed-p () - (and (> ediff-current-difference 0) - (> ediff-auto-refine-limit - (- (ediff-get-diff-posn 'A 'end ediff-current-difference) - (ediff-get-diff-posn 'A 'beg ediff-current-difference))))) - -(defvar ediff-toolbar - (if (featurep 'toolbar) - '([ediff-toolbar-refine-icon - ediff-toolbar-refine - t - ;;; The toolbar is not automatically refreshed (in 19.14) - ;;; when :activep changes state. - ;;(ediff-toolbar-refine-needed-p) - "Refine current difference region by computing fine diffs."] - [ediff-toolbar-previous-icon - ediff-toolbar-previous-difference - t - "Go to the previous difference."] - [ediff-toolbar-next-icon - ediff-toolbar-next-difference - t - "Advance to the next difference."] - [ediff-toolbar-A-icon - ediff-toolbar-select/copy-A - (not (ediff-3way-comparison-job)) - "Select/Copy difference A."] - [ediff-toolbar-B-icon - ediff-toolbar-select/copy-B - (not (ediff-3way-comparison-job)) - "Select/Copy difference B."] - [ediff-toolbar-save-icon - ediff-toolbar-save - t - "Save buffers modified in this session."] - [ediff-toolbar-refresh-icon - ediff-toolbar-refresh - t - "Refresh Ediff display (aka recenter)."] - [ediff-toolbar-toggle-split-icon - ediff-toolbar-toggle-split - t - "Toggle split mode between side-to-side and one-on-top-of-another."] - [ediff-toolbar-help-icon - ediff-toolbar-help - t - "Toggle short/long help."] - nil - [ediff-toolbar-quit-icon - ediff-toolbar-quit - t - "Quit this ediff session."] - ))) - -(defvar ediff-toolbar-3way - (if (featurep 'toolbar) - '([ediff-toolbar-refine-icon - ediff-toolbar-refine - t - ;;; The toolbar is not automatically refreshed (in 19.14) - ;;; when :activep changes state. - ;;(ediff-toolbar-refine-needed-p) - "Refine current difference region by computing fine diffs."] - [ediff-toolbar-previous-icon - ediff-toolbar-previous-difference - t - "Go to the previous difference."] - [ediff-toolbar-next-icon - ediff-toolbar-next-difference - t - "Advance to the next difference."] - [ediff-toolbar-save-icon - ediff-toolbar-save - t - "Save buffers modified in this session."] - [ediff-toolbar-refresh-icon - ediff-toolbar-refresh - t - "Refresh Ediff display (aka recenter)."] - [ediff-toolbar-toggle-split-icon - ediff-toolbar-toggle-split - t - "Toggle split mode between side-to-side and one-on-top-of-another."] - [ediff-toolbar-help-icon - ediff-toolbar-help - t - "Toggle short/long help."] - nil - [ediff-toolbar-quit-icon - ediff-toolbar-quit - t - "Quit this ediff session."] - ))) - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-tbar.el ends here
--- a/lisp/ediff/ediff-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3729 +0,0 @@ -;;; ediff-util.el --- the core commands and utilities of ediff - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-util) - -;; Compiler pacifier -(defvar ediff-patch-diagnostics) -(defvar ediff-patchbufer) -(defvar ediff-toolbar) -(defvar ediff-toolbar-3way) -(defvar bottom-toolbar) -(defvar bottom-toolbar-visible-p) -(defvar bottom-toolbar-height) -(defvar mark-active) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-help) - (load "ediff-help.el" nil nil 'nosuffix)) - (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) - (or (featurep 'ediff-wind) - (load "ediff-wind.el" nil nil 'nosuffix)) - (or (featurep 'ediff-diff) - (load "ediff-diff.el" nil nil 'nosuffix)) - (or (featurep 'ediff-merg) - (load "ediff-merg.el" nil nil 'nosuffix)) - (or (featurep 'ediff) - (load "ediff.el" nil nil 'nosuffix)) - (or (featurep 'ediff-tbar) - (load "ediff-tbar.el" 'noerror nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) -(require 'ediff-help) -(require 'ediff-mult) -(require 'ediff-wind) -(require 'ediff-diff) -(require 'ediff-merg) - - -;; be careful with ediff-tbar -(if ediff-xemacs-p - (condition-case nil - (require 'ediff-tbar) - (error - (defun ediff-use-toolbar-p () nil))) - (defun ediff-use-toolbar-p () nil)) - - -;;; Functions - -(defun ediff-mode () - "Ediff mode controls all operations in a single Ediff session. -This mode is entered through one of the following commands: - `ediff' - `ediff-files' - `ediff-buffers' - `ebuffers' - `ediff3' - `ediff-files3' - `ediff-buffers3' - `ebuffers3' - `ediff-merge' - `ediff-merge-files' - `ediff-merge-files-with-ancestor' - `ediff-merge-buffers' - `ediff-merge-buffers-with-ancestor' - `ediff-merge-revisions' - `ediff-merge-revisions-with-ancestor' - `ediff-windows-wordwise' - `ediff-windows-linewise' - `ediff-regions-wordwise' - `ediff-regions-linewise' - `epatch' - `ediff-patch-file' - `ediff-patch-buffer' - `epatch-buffer' - `erevision' - `ediff-revision' - -Commands: -\\{ediff-mode-map}" - (kill-all-local-variables) - (setq major-mode 'ediff-mode) - (setq mode-name "Ediff") - (run-hooks 'ediff-mode-hook)) - - - -;;; Build keymaps - -(ediff-defvar-local ediff-mode-map nil - "Local keymap used in Ediff mode. -This is local to each Ediff Control Panel, so they may vary from invocation -to invocation.") - -;; Set up the keymap in the control buffer -(defun ediff-set-keys () - "Set up Ediff keymap, if necessary." - (if (null ediff-mode-map) - (ediff-setup-keymap)) - (use-local-map ediff-mode-map)) - -;; Reload Ediff keymap. For debugging only. -(defun ediff-reload-keymap () - (interactive) - (setq ediff-mode-map nil) - (ediff-set-keys)) - - -(defun ediff-setup-keymap () - "Set up the keymap used in the control buffer of Ediff." - (setq ediff-mode-map (make-sparse-keymap)) - (suppress-keymap ediff-mode-map) - - (define-key ediff-mode-map - (if ediff-emacs-p [mouse-2] [button2]) 'ediff-help-for-quick-help) - (define-key ediff-mode-map "\C-m" 'ediff-help-for-quick-help) - - (define-key ediff-mode-map "p" 'ediff-previous-difference) - (define-key ediff-mode-map "\C-?" 'ediff-previous-difference) - (define-key ediff-mode-map [delete] 'ediff-previous-difference) - (define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer - 'ediff-previous-difference nil)) - ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs - (define-key ediff-mode-map [backspace] 'ediff-previous-difference) - (define-key ediff-mode-map "n" 'ediff-next-difference) - (define-key ediff-mode-map " " 'ediff-next-difference) - (define-key ediff-mode-map "j" 'ediff-jump-to-difference) - (define-key ediff-mode-map "g" nil) - (define-key ediff-mode-map "ga" 'ediff-jump-to-difference-at-point) - (define-key ediff-mode-map "gb" 'ediff-jump-to-difference-at-point) - (define-key ediff-mode-map "q" 'ediff-quit) - (define-key ediff-mode-map "D" 'ediff-show-diff-output) - (define-key ediff-mode-map "z" 'ediff-suspend) - (define-key ediff-mode-map "\C-l" 'ediff-recenter) - (define-key ediff-mode-map "|" 'ediff-toggle-split) - (define-key ediff-mode-map "h" 'ediff-toggle-hilit) - (or ediff-word-mode - (define-key ediff-mode-map "@" 'ediff-toggle-autorefine)) - (if ediff-narrow-job - (define-key ediff-mode-map "%" 'ediff-toggle-narrow-region)) - (define-key ediff-mode-map "~" 'ediff-swap-buffers) - (define-key ediff-mode-map "v" 'ediff-scroll-vertically) - (define-key ediff-mode-map "\C-v" 'ediff-scroll-vertically) - (define-key ediff-mode-map "^" 'ediff-scroll-vertically) - (define-key ediff-mode-map "\M-v" 'ediff-scroll-vertically) - (define-key ediff-mode-map "V" 'ediff-scroll-vertically) - (define-key ediff-mode-map "<" 'ediff-scroll-horizontally) - (define-key ediff-mode-map ">" 'ediff-scroll-horizontally) - (define-key ediff-mode-map "i" 'ediff-status-info) - (define-key ediff-mode-map "E" 'ediff-documentation) - (define-key ediff-mode-map "?" 'ediff-toggle-help) - (define-key ediff-mode-map "!" 'ediff-update-diffs) - (define-key ediff-mode-map "M" 'ediff-show-meta-buffer) - (define-key ediff-mode-map "R" 'ediff-show-registry) - (or ediff-word-mode - (define-key ediff-mode-map "*" 'ediff-make-or-kill-fine-diffs)) - (define-key ediff-mode-map "a" nil) - (define-key ediff-mode-map "b" nil) - (define-key ediff-mode-map "r" nil) - (cond (ediff-merge-job - ;; Will barf if no ancestor - (define-key ediff-mode-map "/" 'ediff-show-ancestor) - ;; In merging, we allow only A->C and B->C copying. - (define-key ediff-mode-map "a" 'ediff-copy-A-to-C) - (define-key ediff-mode-map "b" 'ediff-copy-B-to-C) - (define-key ediff-mode-map "r" 'ediff-restore-diff-in-merge-buffer) - (define-key ediff-mode-map "s" 'ediff-shrink-window-C) - (define-key ediff-mode-map "+" 'ediff-combine-diffs) - (define-key ediff-mode-map "$" 'ediff-toggle-show-clashes-only) - (define-key ediff-mode-map "&" 'ediff-re-merge)) - (ediff-3way-comparison-job - (define-key ediff-mode-map "ab" 'ediff-copy-A-to-B) - (define-key ediff-mode-map "ba" 'ediff-copy-B-to-A) - (define-key ediff-mode-map "ac" 'ediff-copy-A-to-C) - (define-key ediff-mode-map "bc" 'ediff-copy-B-to-C) - (define-key ediff-mode-map "c" nil) - (define-key ediff-mode-map "ca" 'ediff-copy-C-to-A) - (define-key ediff-mode-map "cb" 'ediff-copy-C-to-B) - (define-key ediff-mode-map "ra" 'ediff-restore-diff) - (define-key ediff-mode-map "rb" 'ediff-restore-diff) - (define-key ediff-mode-map "rc" 'ediff-restore-diff) - (define-key ediff-mode-map "C" 'ediff-toggle-read-only)) - (t ; 2-way comparison - (define-key ediff-mode-map "a" 'ediff-copy-A-to-B) - (define-key ediff-mode-map "b" 'ediff-copy-B-to-A) - (define-key ediff-mode-map "ra" 'ediff-restore-diff) - (define-key ediff-mode-map "rb" 'ediff-restore-diff)) - ) ; cond - (define-key ediff-mode-map "G" 'ediff-submit-report) - (define-key ediff-mode-map "#" nil) - (define-key ediff-mode-map "#h" 'ediff-toggle-regexp-match) - (define-key ediff-mode-map "#f" 'ediff-toggle-regexp-match) - (or ediff-word-mode - (define-key ediff-mode-map "##" 'ediff-toggle-skip-similar)) - (define-key ediff-mode-map "o" nil) - (define-key ediff-mode-map "A" 'ediff-toggle-read-only) - (define-key ediff-mode-map "B" 'ediff-toggle-read-only) - (define-key ediff-mode-map "w" nil) - (define-key ediff-mode-map "wa" 'ediff-save-buffer) - (define-key ediff-mode-map "wb" 'ediff-save-buffer) - (define-key ediff-mode-map "wd" 'ediff-save-buffer) - (define-key ediff-mode-map "=" 'ediff-inferior-compare-regions) - (if (fboundp 'ediff-show-patch-diagnostics) - (define-key ediff-mode-map "P" 'ediff-show-patch-diagnostics)) - (if ediff-3way-job - (progn - (define-key ediff-mode-map "wc" 'ediff-save-buffer) - (define-key ediff-mode-map "gc" 'ediff-jump-to-difference-at-point) - )) - - (define-key ediff-mode-map "m" 'ediff-toggle-wide-display) - - ;; Allow ediff-mode-map to be referenced indirectly - (fset 'ediff-mode-map ediff-mode-map) - (run-hooks 'ediff-keymap-setup-hook)) - - -;;; Setup functions - -;; Common startup entry for all Ediff functions It now returns control buffer -;; so other functions can do post-processing SETUP-PARAMETERS is a list of the -;; form ((param .val) (param . val)...) This serves a similar purpose to -;; STARTUP-HOOKS, but these parameters are set in the new control buffer right -;; after this buf is created and before any windows are set and such. -(defun ediff-setup (buffer-A file-A buffer-B file-B buffer-C file-C - startup-hooks setup-parameters) - ;; ediff-convert-standard-filename puts file names in the form appropriate - ;; for the OS at hand. - (setq file-A (ediff-convert-standard-filename (expand-file-name file-A))) - (setq file-B (ediff-convert-standard-filename (expand-file-name file-B))) - (if (stringp file-C) - (setq file-C - (ediff-convert-standard-filename (expand-file-name file-C)))) - (let* ((control-buffer-name - (ediff-unique-buffer-name "*Ediff Control Panel" "*")) - (control-buffer (ediff-with-current-buffer buffer-A - (get-buffer-create control-buffer-name)))) - (ediff-with-current-buffer control-buffer - (ediff-mode) - - (make-local-variable 'ediff-use-long-help-message) - (make-local-variable 'ediff-prefer-iconified-control-frame) - (make-local-variable 'ediff-split-window-function) - (make-local-variable 'ediff-default-variant) - (make-local-variable 'ediff-merge-window-share) - (make-local-variable 'ediff-window-setup-function) - (make-local-variable 'ediff-keep-variants) - - ;; unwrap set up parameters passed as argument - (while setup-parameters - (set (car (car setup-parameters)) (cdr (car setup-parameters))) - (setq setup-parameters (cdr setup-parameters))) - - ;; set variables classifying the current ediff job - ;; must come AFTER setup-parameters - (setq ediff-3way-comparison-job (ediff-3way-comparison-job) - ediff-merge-job (ediff-merge-job) - ediff-merge-with-ancestor-job (ediff-merge-with-ancestor-job) - ediff-3way-job (ediff-3way-job) - ediff-diff3-job (ediff-diff3-job) - ediff-narrow-job (ediff-narrow-job) - ediff-windows-job (ediff-windows-job) - ediff-word-mode-job (ediff-word-mode-job)) - - ;; Don't delete variants in case of ediff-buffer-* jobs without asking. - ;; This is because u may loose work---dangerous. - (if (string-match "buffer" (symbol-name ediff-job-name)) - (setq ediff-keep-variants t)) - - (make-local-hook 'pre-command-hook) - (if (ediff-window-display-p) - (add-hook 'pre-command-hook 'ediff-spy-after-mouse nil t)) - (setq ediff-mouse-pixel-position (mouse-pixel-position)) - - ;; adjust for merge jobs - (if ediff-merge-job - (let ((buf - ;; If default variant is `combined', the right stuff is - ;; inserted by ediff-do-merge - ;; Note: at some point, we tried to put ancestor buffer here - ;; (which is currently buffer C. This didn't work right - ;; because the merge buffer will contain lossage: diff regions - ;; in the ancestor, which correspond to revisions that agree - ;; in both buf A and B. - (cond ((eq ediff-default-variant 'default-B) - buffer-B) - (t buffer-A)))) - - (setq ediff-split-window-function - ediff-merge-split-window-function) - - ;; remember the ancestor buffer, if any - (setq ediff-ancestor-buffer buffer-C) - - (setq buffer-C - (get-buffer-create - (ediff-unique-buffer-name "*ediff-merge" "*"))) - (save-excursion - (set-buffer buffer-C) - (insert-buffer buf) - (funcall (ediff-with-current-buffer buf major-mode)) - ;; after Stig@hackvan.com - (add-hook 'local-write-file-hooks 'ediff-set-merge-mode nil t) - ))) - (setq buffer-read-only nil - ediff-buffer-A buffer-A - ediff-buffer-B buffer-B - ediff-buffer-C buffer-C - ediff-control-buffer control-buffer) - - (setq ediff-control-buffer-suffix - (if (string-match "<[0-9]*>" control-buffer-name) - (substring control-buffer-name - (match-beginning 0) (match-end 0)) - "") - ediff-control-buffer-number - (max - 0 - (1- - (string-to-number - (substring - ediff-control-buffer-suffix - (or - (string-match "[0-9]+" ediff-control-buffer-suffix) - 0)))))) - - (setq ediff-error-buffer - (get-buffer-create (ediff-unique-buffer-name "*ediff-errors" "*"))) - - (ediff-with-current-buffer buffer-A (ediff-strip-mode-line-format)) - (ediff-with-current-buffer buffer-B (ediff-strip-mode-line-format)) - (if ediff-3way-job - (ediff-with-current-buffer buffer-C (ediff-strip-mode-line-format))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-strip-mode-line-format))) - - (ediff-save-protected-variables) ; save variables to be restored on exit - - ;; ediff-setup-diff-regions-function must be set after setup - ;; parameters are processed. - (setq ediff-setup-diff-regions-function - (if ediff-diff3-job - 'ediff-setup-diff-regions3 - 'ediff-setup-diff-regions)) - - (setq ediff-wide-bounds - (list (ediff-make-bullet-proof-overlay - '(point-min) '(point-max) ediff-buffer-A) - (ediff-make-bullet-proof-overlay - '(point-min) '(point-max) ediff-buffer-B) - (ediff-make-bullet-proof-overlay - '(point-min) '(point-max) ediff-buffer-C))) - - ;; This has effect only on ediff-windows/regions - ;; In all other cases, ediff-visible-region sets visibility bounds to - ;; ediff-wide-bounds, and ediff-narrow-bounds are ignored. - (if ediff-start-narrowed - (setq ediff-visible-bounds ediff-narrow-bounds) - (setq ediff-visible-bounds ediff-wide-bounds)) - - (ediff-set-keys) ; comes after parameter setup - - ;; set up ediff-narrow-bounds, if not set - (or ediff-narrow-bounds - (setq ediff-narrow-bounds ediff-wide-bounds)) - - ;; All these must be inside ediff-with-current-buffer control-buffer, - ;; since these vars are local to control-buffer - ;; These won't run if there are errors in diff - (ediff-with-current-buffer ediff-buffer-A - (ediff-nuke-selective-display) - (run-hooks 'ediff-prepare-buffer-hook) - (if (ediff-with-current-buffer control-buffer ediff-merge-job) - (setq buffer-read-only t)) - ;; add control-buffer to the list of sessions--no longer used, but may - ;; be used again in the future - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer ediff-this-buffer-ediff-sessions))) - (if ediff-make-buffers-readonly-at-startup - (setq buffer-read-only t)) - ) - - (ediff-with-current-buffer ediff-buffer-B - (ediff-nuke-selective-display) - (run-hooks 'ediff-prepare-buffer-hook) - (if (ediff-with-current-buffer control-buffer ediff-merge-job) - (setq buffer-read-only t)) - ;; add control-buffer to the list of sessions - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer ediff-this-buffer-ediff-sessions))) - (if ediff-make-buffers-readonly-at-startup - (setq buffer-read-only t)) - ) - - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (ediff-nuke-selective-display) - (run-hooks 'ediff-prepare-buffer-hook) - ;; add control-buffer to the list of sessions - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer - ediff-this-buffer-ediff-sessions))) - (if ediff-make-buffers-readonly-at-startup - (setq buffer-read-only t)) - )) - - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-nuke-selective-display) - (setq buffer-read-only t) - (run-hooks 'ediff-prepare-buffer-hook) - (or (memq control-buffer ediff-this-buffer-ediff-sessions) - (setq ediff-this-buffer-ediff-sessions - (cons control-buffer - ediff-this-buffer-ediff-sessions))) - )) - - ;; must come after setting up ediff-narrow-bounds AND after - ;; nuking selective display - (funcall ediff-setup-diff-regions-function file-A file-B file-C) - (setq ediff-number-of-differences (length ediff-difference-vector-A)) - (setq ediff-current-difference -1) - - (ediff-make-current-diff-overlay 'A) - (ediff-make-current-diff-overlay 'B) - (if ediff-3way-job - (ediff-make-current-diff-overlay 'C)) - (if ediff-merge-with-ancestor-job - (ediff-make-current-diff-overlay 'Ancestor)) - - (ediff-setup-windows buffer-A buffer-B buffer-C control-buffer) - - (let ((shift-A (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds))) - (shift-B (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds))) - (shift-C (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'C ediff-narrow-bounds)))) - ;; position point in buf A - (save-excursion - (select-window ediff-window-A) - (goto-char shift-A)) - ;; position point in buf B - (save-excursion - (select-window ediff-window-B) - (goto-char shift-B)) - (if ediff-3way-job - (save-excursion - (select-window ediff-window-C) - (goto-char shift-C))) - ) - - (select-window ediff-control-window) - (ediff-visible-region) - - (run-hooks 'startup-hooks) - (ediff-refresh-mode-lines) - (setq buffer-read-only t) - (setq ediff-session-registry - (cons control-buffer ediff-session-registry)) - (ediff-update-registry) - (if (ediff-buffer-live-p ediff-meta-buffer) - (ediff-update-meta-buffer ediff-meta-buffer)) - (run-hooks 'ediff-startup-hook) - ) ; eval in control-buffer - control-buffer)) - - -;; This function assumes that we are in the window where control buffer is -;; to reside. -(defun ediff-setup-control-buffer (ctl-buf) - "Set up window for control buffer." - (if (window-dedicated-p (selected-window)) - (set-buffer ctl-buf) ; we are in control frame but just in case - (switch-to-buffer ctl-buf)) - (let ((window-min-height 2)) - (erase-buffer) - (ediff-set-help-message) - (insert ediff-help-message) - (shrink-window-if-larger-than-buffer) - (or (ediff-multiframe-setup-p) - (ediff-indent-help-message)) - (ediff-set-help-overlays) - - (set-buffer-modified-p nil) - (ediff-refresh-mode-lines) - (setq ediff-control-window (selected-window)) - (setq ediff-window-config-saved - (format "%S%S%S%S%S%S%S" - ediff-control-window - ediff-window-A - ediff-window-B - ediff-window-C - ediff-split-window-function - (ediff-multiframe-setup-p) - ediff-wide-display-p)) - - ;; In multiframe, toolbar is set in ediff-setup-control-frame - (if (not (ediff-multiframe-setup-p)) - (ediff-make-bottom-toolbar)) ; this checks if toolbar is requested - (goto-char (point-min)) - (skip-chars-forward ediff-whitespace))) - - - - -;;; Commands for working with Ediff - -(defun ediff-update-diffs () - "Recompute difference regions in buffers A, B, and C. -Buffers are not synchronized with their respective files, so changes done -to these buffers are not saved at this point---the user can do this later, -if necessary." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (and (ediff-buffer-live-p ediff-ancestor-buffer) - (not - (y-or-n-p - "Ancestor buffer will not be used. Recompute diffs anyway? "))) - (error "Recomputation of differences canceled")) - - (let ((point-A (ediff-with-current-buffer ediff-buffer-A (point))) - ;;(point-B (ediff-with-current-buffer ediff-buffer-B (point))) - (tmp-buffer (get-buffer-create ediff-tmp-buffer)) - (buf-A-file-name (buffer-file-name ediff-buffer-A)) - (buf-B-file-name (buffer-file-name ediff-buffer-B)) - ;; (null ediff-buffer-C) is no problem, as we later check if - ;; ediff-buffer-C is alive - (buf-C-file-name (buffer-file-name ediff-buffer-C)) - (overl-A (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds)) - (overl-B (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds)) - (overl-C (ediff-get-value-according-to-buffer-type - 'C ediff-narrow-bounds)) - beg-A end-A beg-B end-B beg-C end-C - file-A file-B file-C) - - (if (stringp buf-A-file-name) - (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) - (if (stringp buf-B-file-name) - (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) - (if (stringp buf-C-file-name) - (setq buf-C-file-name (file-name-nondirectory buf-C-file-name))) - - (ediff-unselect-and-select-difference -1) - - (setq beg-A (ediff-overlay-start overl-A) - beg-B (ediff-overlay-start overl-B) - beg-C (ediff-overlay-start overl-C) - end-A (ediff-overlay-end overl-A) - end-B (ediff-overlay-end overl-B) - end-C (ediff-overlay-end overl-C)) - - (if ediff-word-mode - (progn - (ediff-wordify beg-A end-A ediff-buffer-A tmp-buffer) - (setq file-A (ediff-make-temp-file tmp-buffer "regA")) - (ediff-wordify beg-B end-B ediff-buffer-B tmp-buffer) - (setq file-B (ediff-make-temp-file tmp-buffer "regB")) - (if ediff-3way-job - (progn - (ediff-wordify beg-C end-C ediff-buffer-C tmp-buffer) - (setq file-C (ediff-make-temp-file tmp-buffer "regC")))) - ) - ;; not word-mode - (setq file-A (ediff-make-temp-file ediff-buffer-A buf-A-file-name)) - (setq file-B (ediff-make-temp-file ediff-buffer-B buf-B-file-name)) - (if ediff-3way-job - (setq file-C (ediff-make-temp-file ediff-buffer-C buf-C-file-name))) - ) - - (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also) - (ediff-clear-diff-vector - 'ediff-difference-vector-Ancestor 'fine-diffs-also) - ;; let them garbage collect. we can't use the ancestor after recomputing - ;; the diffs. - (setq ediff-difference-vector-Ancestor nil - ediff-ancestor-buffer nil - ediff-state-of-merge nil) - - (setq ediff-killed-diffs-alist nil) ; invalidate saved killed diff regions - - ;; In case of merge job, fool it into thinking that it is just doing - ;; comparison - (let ((ediff-setup-diff-regions-function ediff-setup-diff-regions-function) - (ediff-3way-comparison-job ediff-3way-comparison-job) - (ediff-merge-job ediff-merge-job) - (ediff-merge-with-ancestor-job ediff-merge-with-ancestor-job) - (ediff-job-name ediff-job-name)) - (if ediff-merge-job - (setq ediff-setup-diff-regions-function 'ediff-setup-diff-regions3 - ediff-3way-comparison-job t - ediff-merge-job nil - ediff-merge-with-ancestor-job nil - ediff-job-name 'ediff-files3)) - (funcall ediff-setup-diff-regions-function file-A file-B file-C)) - - (setq ediff-number-of-differences (length ediff-difference-vector-A)) - (delete-file file-A) - (delete-file file-B) - (if file-C - (delete-file file-C)) - - (if ediff-3way-job - (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer)) - - (ediff-jump-to-difference (ediff-diff-at-point 'A point-A)) - (message "") - )) - -;; Not bound to any key---to dangerous. A user can do it if necessary. -(defun ediff-revert-buffers-then-recompute-diffs (noconfirm) - "Revert buffers A, B and C. Then rerun Ediff on file A and file B." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (let ((bufA ediff-buffer-A) - (bufB ediff-buffer-B) - (bufC ediff-buffer-C) - (ctl-buf ediff-control-buffer) - (keep-variants ediff-keep-variants) - (ancestor-buf ediff-ancestor-buffer) - (ancestor-job ediff-merge-with-ancestor-job) - (merge ediff-merge-job) - (comparison ediff-3way-comparison-job)) - (ediff-with-current-buffer bufA - (revert-buffer t noconfirm)) - (ediff-with-current-buffer bufB - (revert-buffer t noconfirm)) - ;; this should only be executed in a 3way comparison, not in merge - (if comparison - (ediff-with-current-buffer bufC - (revert-buffer t noconfirm))) - (if merge - (progn - (set-buffer ctl-buf) - ;; the argument says whether to reverse the meaning of - ;; ediff-keep-variants, i.e., ediff-really-quit runs here with - ;; variants kept. - (ediff-really-quit (not keep-variants)) - (kill-buffer bufC) - (if ancestor-job - (ediff-merge-buffers-with-ancestor bufA bufB ancestor-buf) - (ediff-merge-buffers bufA bufB))) - (ediff-update-diffs)))) - - -;; optional NO-REHIGHLIGHT says to not rehighlight buffers -(defun ediff-recenter (&optional no-rehighlight) - "Bring the highlighted region of all buffers being compared into view. -Reestablish the default three-window display." - (interactive) - (ediff-barf-if-not-control-buffer) - (let (buffer-read-only) - (if (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C))) - (ediff-setup-windows - ediff-buffer-A ediff-buffer-B ediff-buffer-C ediff-control-buffer) - (or (eq this-command 'ediff-quit) - (message ediff-KILLED-VITAL-BUFFER - (beep 1))) - )) - - ;; set visibility range appropriate to this invocation of Ediff. - (ediff-visible-region) - ;; raise - (if (and (ediff-window-display-p) - (symbolp this-command) - (symbolp last-command) - ;; Either one of the display-changing commands - (or (memq this-command - '(ediff-recenter - ediff-dir-action ediff-registry-action - ediff-patch-action - ediff-toggle-wide-display ediff-toggle-multiframe)) - ;; Or one of the movement cmds and prev cmd was an Ediff cmd - ;; This avoids raising frames unnecessarily. - (and (memq this-command - '(ediff-next-difference - ediff-previous-difference - ediff-jump-to-difference - ediff-jump-to-difference-at-point)) - (not (string-match "^ediff-" (symbol-name last-command))) - ))) - (progn - (if (window-live-p ediff-window-A) - (raise-frame (window-frame ediff-window-A))) - (if (window-live-p ediff-window-B) - (raise-frame (window-frame ediff-window-B))) - (if (window-live-p ediff-window-C) - (raise-frame (window-frame ediff-window-C))))) - (if (and (ediff-window-display-p) - (frame-live-p ediff-control-frame) - (not ediff-use-long-help-message) - (not (ediff-frame-iconified-p ediff-control-frame))) - (raise-frame ediff-control-frame)) - - ;; Redisplay whatever buffers are showing, if there is a selected difference - (let ((control-frame ediff-control-frame) - (control-buf ediff-control-buffer)) - (if (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C))) - (progn - (or no-rehighlight - (ediff-select-difference ediff-current-difference)) - - (ediff-recenter-one-window 'A) - (ediff-recenter-one-window 'B) - (if ediff-3way-job - (ediff-recenter-one-window 'C)) - - (ediff-with-current-buffer control-buf - (ediff-recenter-ancestor) ; check if ancestor is alive - - (if (and (ediff-multiframe-setup-p) - (not ediff-use-long-help-message) - (not (ediff-frame-iconified-p ediff-control-frame))) - ;; never grab mouse on quit in this place - (ediff-reset-mouse - control-frame - (eq this-command 'ediff-quit)))) - )) - - (ediff-restore-highlighting) - (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines)) - )) - -;; this function returns to the window it was called from -;; (which was the control window) -(defun ediff-recenter-one-window (buf-type) - (if (ediff-valid-difference-p) - ;; context must be saved before switching to windows A/B/C - (let* ((ctl-wind (selected-window)) - (shift (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - buf-type ediff-narrow-bounds))) - (job-name ediff-job-name) - (control-buf ediff-control-buffer) - (window-name (ediff-get-symbol-from-alist - buf-type ediff-window-alist)) - (window (if (window-live-p (symbol-value window-name)) - (symbol-value window-name)))) - - (if (and window ediff-windows-job) - (set-window-start window shift)) - (if window - (progn - (select-window window) - (ediff-deactivate-mark) - (ediff-position-region - (ediff-get-diff-posn buf-type 'beg nil control-buf) - (ediff-get-diff-posn buf-type 'end nil control-buf) - (ediff-get-diff-posn buf-type 'beg nil control-buf) - job-name - ))) - (select-window ctl-wind) - ))) - -(defun ediff-recenter-ancestor () - ;; do half-hearted job by recentering the ancestor buffer, if it is alive and - ;; visible. - (if (and (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-valid-difference-p)) - (let ((window (ediff-get-visible-buffer-window ediff-ancestor-buffer)) - (ctl-wind (selected-window)) - (job-name ediff-job-name) - (ctl-buf ediff-control-buffer)) - (ediff-with-current-buffer ediff-ancestor-buffer - (goto-char (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf)) - (if window - (progn - (select-window window) - (ediff-position-region - (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf) - (ediff-get-diff-posn 'Ancestor 'end nil ctl-buf) - (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf) - job-name)))) - (select-window ctl-wind) - ))) - - -;; This will have to be refined for 3way jobs -(defun ediff-toggle-split () - "Toggle vertical/horizontal window split. -Does nothing if file-A and file-B are in different frames." - (interactive) - (ediff-barf-if-not-control-buffer) - (let* ((wind-A (if (window-live-p ediff-window-A) ediff-window-A)) - (wind-B (if (window-live-p ediff-window-B) ediff-window-B)) - (wind-C (if (window-live-p ediff-window-C) ediff-window-C)) - (frame-A (if wind-A (window-frame wind-A))) - (frame-B (if wind-B (window-frame wind-B))) - (frame-C (if wind-C (window-frame wind-C)))) - (if (or (eq frame-A frame-B) - (not (frame-live-p frame-A)) - (not (frame-live-p frame-B)) - (if ediff-3way-comparison-job - (or (not (frame-live-p frame-C)) - (eq frame-A frame-C) (eq frame-B frame-C)))) - (setq ediff-split-window-function - (if (eq ediff-split-window-function 'split-window-vertically) - 'split-window-horizontally - 'split-window-vertically)) - (message "Buffers being compared are in different frames")) - (ediff-recenter 'no-rehighlight))) - -(defun ediff-toggle-hilit () - "Switch between highlighting using ASCII flags and highlighting using faces. -On a dumb terminal, switches between ASCII highlighting and no highlighting." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (not (ediff-has-face-support-p)) - (if (eq ediff-highlighting-style 'ascii) - (progn - (message "ASCII highlighting flags removed") - (ediff-unselect-and-select-difference ediff-current-difference - 'unselect-only) - (setq ediff-highlighting-style 'off)) - (ediff-unselect-and-select-difference ediff-current-difference - 'select-only)) - (ediff-unselect-and-select-difference ediff-current-difference - 'unselect-only) - ;; cycle through highlighting - (cond ((and ediff-use-faces ediff-highlight-all-diffs) - (message "Unhighlighting unselected difference regions") - (setq ediff-highlight-all-diffs nil)) - (ediff-use-faces - (message "Highlighting with ASCII flags") - (setq ediff-use-faces nil)) - (t - (message "Re-highlighting all difference regions") - (setq ediff-use-faces t - ediff-highlight-all-diffs t))) - - (if (and ediff-use-faces ediff-highlight-all-diffs) - (ediff-paint-background-regions) - (ediff-paint-background-regions 'unhighlight)) - - (ediff-unselect-and-select-difference - ediff-current-difference 'select-only)) - ) - - -(defun ediff-toggle-autorefine () - "Toggle auto-refine mode." - (interactive) - (ediff-barf-if-not-control-buffer) - (if ediff-word-mode - (error "No fine differences in this mode")) - (cond ((eq ediff-auto-refine 'nix) - (setq ediff-auto-refine 'on) - (ediff-make-fine-diffs ediff-current-difference 'noforce) - (message "Auto-refining is ON")) - ((eq ediff-auto-refine 'on) - (message "Auto-refining is OFF") - (setq ediff-auto-refine 'off)) - (t ;; nix 'em - (ediff-set-fine-diff-properties ediff-current-difference 'default) - (message "Refinements are HIDDEN") - (setq ediff-auto-refine 'nix)) - )) - -(defun ediff-show-ancestor () - "Show the ancestor buffer in a suitable window." - (interactive) - (ediff-recenter) - (or (ediff-buffer-live-p ediff-ancestor-buffer) - (if ediff-merge-with-ancestor-job - (error "Lost connection to ancestor buffer...sorry") - (error "Not merging with ancestor"))) - (let (wind) - (cond ((setq wind (ediff-get-visible-buffer-window ediff-ancestor-buffer)) - (raise-frame (window-frame wind))) - (t (set-window-buffer ediff-window-C ediff-ancestor-buffer))))) - -(defun ediff-make-or-kill-fine-diffs (arg) - "Compute fine diffs. With negative prefix arg, kill fine diffs. -In both cases, operates on the currrent difference region." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (cond ((eq arg '-) - (ediff-clear-fine-differences ediff-current-difference)) - ((and (numberp arg) (< arg 0)) - (ediff-clear-fine-differences ediff-current-difference)) - (t (ediff-make-fine-diffs)))) - - -(defun ediff-toggle-help () - "Toggle short/long help message." - (interactive) - (ediff-barf-if-not-control-buffer) - (let (buffer-read-only) - (erase-buffer) - (setq ediff-use-long-help-message (not ediff-use-long-help-message)) - (ediff-set-help-message)) - ;; remember the icon status of the control frame when the user requested - ;; full control message - (if (and ediff-use-long-help-message (ediff-multiframe-setup-p)) - (setq ediff-prefer-iconified-control-frame - (ediff-frame-iconified-p ediff-control-frame))) - - (setq ediff-window-config-saved "") ; force redisplay - (ediff-recenter 'no-rehighlight)) - - -;; If BUF, this is the buffer to toggle, not current buffer. -(defun ediff-toggle-read-only (&optional buf) - "Toggle read-only in current buffer. -If buffer is under version control and locked, check it out first. -If optional argument BUF is specified, toggle read-only in that buffer instead -of the current buffer." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((ctl-buf (if (null buf) (current-buffer))) - (buf-type (ediff-char-to-buftype last-command-char))) - (or buf (ediff-recenter)) - (or buf - (setq buf (ediff-get-buffer buf-type))) - - (ediff-with-current-buffer buf ; eval in buf A/B/C - (let* ((file (buffer-file-name buf)) - (file-writable (and file - (file-exists-p file) - (file-writable-p file))) - (toggle-ro-cmd (cond (ediff-toggle-read-only-function) - ((ediff-file-checked-out-p file) - 'toggle-read-only) - (file-writable 'toggle-read-only) - (t (key-binding "\C-x\C-q"))))) - ;; If the file is checked in, make sure we don't make buffer modifiable - ;; without warning the user. The user can fool our checks by making the - ;; buffer non-RO without checking the file out. We regard this as a - ;; user problem. - (if (and (ediff-file-checked-in-p file) - ;; If ctl-buf is null, this means we called this - ;; non-interactively, in which case don't ask questions - ctl-buf) - (cond ((not buffer-read-only) - (setq toggle-ro-cmd 'toggle-read-only)) - ((and (or (beep 1) t) ; always beep - (y-or-n-p - (format - "File %s is under version control. Check it out? " - (ediff-abbreviate-file-name file)))) - ;; if we checked the file out, we should also change the - ;; original state of buffer-read-only to nil. If we don't - ;; do this, the mode line will show %%, since the file was - ;; RO before ediff started, so the user will think the file - ;; is checked in. - (ediff-with-current-buffer ctl-buf - (ediff-change-saved-variable - 'buffer-read-only nil buf-type))) - (t - (setq toggle-ro-cmd 'toggle-read-only) - (beep 1) (beep 1) - (message - "Boy, this is risky! Don't modify this file...") - (sit-for 3)))) ; let the user see the warning - (if (and toggle-ro-cmd - (string-match "toggle-read-only" (symbol-name toggle-ro-cmd))) - (save-excursion - (save-window-excursion - (select-window (ediff-get-visible-buffer-window buf)) - (command-execute toggle-ro-cmd))) - (error "Don't know how to toggle read-only in buffer %S" buf)) - - ;; Check if we made the current buffer updatable, but its file is RO. - ;; Signal a warning in this case. - (if (and file (not buffer-read-only) - (eq this-command 'ediff-toggle-read-only) - (file-exists-p file) - (not (file-writable-p file))) - (message "Warning: file %s is read-only" - (ediff-abbreviate-file-name file) (beep 1))) - )))) - -;; checkout if visited file is checked in -(defun ediff-maybe-checkout (buf) - (let ((file (buffer-file-name buf)) - (checkout-function (key-binding "\C-x\C-q"))) - (if (and (ediff-file-checked-in-p file) - (or (beep 1) t) - (y-or-n-p - (format - "File %s is under version control. Check it out? " - (ediff-abbreviate-file-name file)))) - (ediff-with-current-buffer buf - (command-execute checkout-function))))) - - -;; This is a simple-minded check for whether a file is under version control. -;; If file,v exists but file doesn't, this file is considered to be not checked -;; in and not checked out for the purpose of patching (since patch won't be -;; able to read such a file anyway). -;; FILE is a string representing file name -(defun ediff-file-under-version-control (file) - (let* ((filedir (file-name-directory file)) - (file-nondir (file-name-nondirectory file)) - (trial (concat file-nondir ",v")) - (full-trial (concat filedir trial)) - (full-rcs-trial (concat filedir "RCS/" trial))) - (and (stringp file) - (file-exists-p file) - (or - (and - (file-exists-p full-trial) - ;; in FAT FS, `file,v' and `file' may turn out to be the same! - ;; don't be fooled by this! - (not (equal (file-attributes file) - (file-attributes full-trial)))) - ;; check if a version is in RCS/ directory - (file-exists-p full-rcs-trial))) - )) - -(defun ediff-file-checked-out-p (file) - (and (ediff-file-under-version-control file) - (file-writable-p file))) -(defun ediff-file-checked-in-p (file) - (and (ediff-file-under-version-control file) - (not (file-writable-p file)))) - -(defun ediff-swap-buffers () - "Rotate the display of buffers A, B, and C." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)) - (let ((buf ediff-buffer-A) - (values ediff-buffer-values-orig-A) - (diff-vec ediff-difference-vector-A) - (hide-regexp ediff-regexp-hide-A) - (focus-regexp ediff-regexp-focus-A) - (wide-visibility-p (eq ediff-visible-bounds ediff-wide-bounds)) - (overlay (if (ediff-has-face-support-p) - ediff-current-diff-overlay-A))) - (if ediff-3way-comparison-job - (progn - (set-window-buffer ediff-window-A ediff-buffer-C) - (set-window-buffer ediff-window-B ediff-buffer-A) - (set-window-buffer ediff-window-C ediff-buffer-B) - ) - (set-window-buffer ediff-window-A ediff-buffer-B) - (set-window-buffer ediff-window-B ediff-buffer-A)) - ;; swap diff buffers - (if ediff-3way-comparison-job - (setq ediff-buffer-A ediff-buffer-C - ediff-buffer-C ediff-buffer-B - ediff-buffer-B buf) - (setq ediff-buffer-A ediff-buffer-B - ediff-buffer-B buf)) - - ;; swap saved buffer characteristics - (if ediff-3way-comparison-job - (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-C - ediff-buffer-values-orig-C ediff-buffer-values-orig-B - ediff-buffer-values-orig-B values) - (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-B - ediff-buffer-values-orig-B values)) - - ;; swap diff vectors - (if ediff-3way-comparison-job - (setq ediff-difference-vector-A ediff-difference-vector-C - ediff-difference-vector-C ediff-difference-vector-B - ediff-difference-vector-B diff-vec) - (setq ediff-difference-vector-A ediff-difference-vector-B - ediff-difference-vector-B diff-vec)) - - ;; swap hide/focus regexp - (if ediff-3way-comparison-job - (setq ediff-regexp-hide-A ediff-regexp-hide-C - ediff-regexp-hide-C ediff-regexp-hide-B - ediff-regexp-hide-B hide-regexp - ediff-regexp-focus-A ediff-regexp-focus-C - ediff-regexp-focus-C ediff-regexp-focus-B - ediff-regexp-focus-B focus-regexp) - (setq ediff-regexp-hide-A ediff-regexp-hide-B - ediff-regexp-hide-B hide-regexp - ediff-regexp-focus-A ediff-regexp-focus-B - ediff-regexp-focus-B focus-regexp)) - - ;; The following is needed for XEmacs, since there one can't move - ;; overlay to another buffer. In Emacs, this swap is redundant. - (if (ediff-has-face-support-p) - (if ediff-3way-comparison-job - (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-C - ediff-current-diff-overlay-C ediff-current-diff-overlay-B - ediff-current-diff-overlay-B overlay) - (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-B - ediff-current-diff-overlay-B overlay))) - - ;; swap wide bounds - (setq ediff-wide-bounds - (cond (ediff-3way-comparison-job - (list (nth 2 ediff-wide-bounds) - (nth 0 ediff-wide-bounds) - (nth 1 ediff-wide-bounds))) - (ediff-3way-job - (list (nth 1 ediff-wide-bounds) - (nth 0 ediff-wide-bounds) - (nth 2 ediff-wide-bounds))) - (t - (list (nth 1 ediff-wide-bounds) - (nth 0 ediff-wide-bounds))))) - ;; swap narrow bounds - (setq ediff-narrow-bounds - (cond (ediff-3way-comparison-job - (list (nth 2 ediff-narrow-bounds) - (nth 0 ediff-narrow-bounds) - (nth 1 ediff-narrow-bounds))) - (ediff-3way-job - (list (nth 1 ediff-narrow-bounds) - (nth 0 ediff-narrow-bounds) - (nth 2 ediff-narrow-bounds))) - (t - (list (nth 1 ediff-narrow-bounds) - (nth 0 ediff-narrow-bounds))))) - (if wide-visibility-p - (setq ediff-visible-bounds ediff-wide-bounds) - (setq ediff-visible-bounds ediff-narrow-bounds)) - )) - (if ediff-3way-job - (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer)) - (ediff-recenter 'no-rehighlight) - ) - - -(defun ediff-toggle-wide-display () - "Toggle wide/regular display. -This is especially useful when comparing buffers side-by-side." - (interactive) - (ediff-barf-if-not-control-buffer) - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) - (ediff-recenter 'no-rehighlight) ; make sure buffs are displayed in windows - (let ((ctl-buf ediff-control-buffer)) - (setq ediff-wide-display-p (not ediff-wide-display-p)) - (if (not ediff-wide-display-p) - (ediff-with-current-buffer ctl-buf - (modify-frame-parameters - ediff-wide-display-frame ediff-wide-display-orig-parameters) - ;;(sit-for (if ediff-xemacs-p 0.4 0)) - ;; restore control buf, since ctl window may have been deleted - ;; during resizing - (set-buffer ctl-buf) - (setq ediff-wide-display-orig-parameters nil - ediff-window-B nil) ; force update of window config - (ediff-recenter 'no-rehighlight)) - (funcall ediff-make-wide-display-function) - ;;(sit-for (if ediff-xemacs-p 0.4 0)) - (ediff-with-current-buffer ctl-buf - (setq ediff-window-B nil) ; force update of window config - (ediff-recenter 'no-rehighlight))))) - -;;;###autoload -(defun ediff-toggle-multiframe () - "Switch from multiframe display to single-frame display and back. -To change the default, set the variable `ediff-window-setup-function', -which see." - (interactive) - (let (window-setup-func) - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) - - (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe) - (setq window-setup-func 'ediff-setup-windows-plain)) - ((eq ediff-window-setup-function 'ediff-setup-windows-plain) - (if (ediff-in-control-buffer-p) - (ediff-kill-bottom-toolbar)) - (setq window-setup-func 'ediff-setup-windows-multiframe))) - - ;; change default - (setq-default ediff-window-setup-function window-setup-func) - ;; change in all active ediff sessions - (mapcar (function (lambda(buf) - (ediff-with-current-buffer buf - (setq ediff-window-setup-function window-setup-func - ediff-window-B nil)))) - ediff-session-registry) - (if (ediff-in-control-buffer-p) - (ediff-recenter 'no-rehighlight)))) - - -;;;###autoload -(defun ediff-toggle-use-toolbar () - "Enable or disable Ediff toolbar. -Works only in versions of Emacs that support toolbars. -To change the default, set the variable `ediff-use-toolbar-p', which see." - (interactive) - (if (featurep 'ediff-tbar) - (progn - (or (ediff-window-display-p) - (error "%sEmacs is not running as a window application" - (if ediff-emacs-p "" "X"))) - (if (ediff-use-toolbar-p) - (ediff-kill-bottom-toolbar)) - ;; do this only after killing the toolbar - (setq ediff-use-toolbar-p (not ediff-use-toolbar-p)) - - (mapcar (function (lambda(buf) - (ediff-with-current-buffer buf - ;; force redisplay - (setq ediff-window-config-saved "") - ))) - ediff-session-registry) - (if (ediff-in-control-buffer-p) - (ediff-recenter 'no-rehighlight))))) - - -;; if was using toolbar, kill it -(defun ediff-kill-bottom-toolbar () - ;; Using ctl-buffer or ediff-control-window for LOCALE does not - ;; work properly in XEmacs 19.14: we have to use - ;;(selected-frame). - ;; The problem with this is that any previous bottom-toolbar - ;; will not re-appear after our cleanup here. Is there a way - ;; to do "push" and "pop" toolbars ? --marcpa - (if (ediff-use-toolbar-p) - (progn - (set-specifier bottom-toolbar (list (selected-frame) nil)) - (set-specifier bottom-toolbar-visible-p (list (selected-frame) nil))))) - -;; If wants to use toolbar, make it. -;; If not, zero the toolbar for XEmacs. -;; Do nothing for Emacs. -(defun ediff-make-bottom-toolbar (&optional frame) - (if (ediff-window-display-p) - (progn - (setq frame (or frame (selected-frame))) - (cond ((ediff-use-toolbar-p) ; this checks for XEmacs - (set-specifier - bottom-toolbar - (list frame (if (ediff-3way-comparison-job) - ediff-toolbar-3way ediff-toolbar))) - (set-specifier bottom-toolbar-visible-p (list frame t)) - (set-specifier bottom-toolbar-height - (list frame ediff-toolbar-height))) - (ediff-xemacs-p - (set-specifier bottom-toolbar-height (list frame 0))) - )) - )) - -;; Merging - -(defun ediff-toggle-show-clashes-only () - "Toggle the mode where only the regions where both buffers differ with the ancestor are shown." - (interactive) - (ediff-barf-if-not-control-buffer) - (if (not ediff-merge-with-ancestor-job) - (error "This command makes sense only when merging with an ancestor")) - (setq ediff-show-clashes-only (not ediff-show-clashes-only)) - (if ediff-show-clashes-only - (message "Focus on regions where both buffers differ from the ancestor") - (message "Canceling focus on regions where changes clash"))) - -;; Widening/narrowing - -(defun ediff-toggle-narrow-region () - "Toggle narrowing in buffers A, B, and C. -Used in ediff-windows/regions only." - (interactive) - (if (eq ediff-buffer-A ediff-buffer-B) - (error ediff-NO-DIFFERENCES)) - (if (eq ediff-visible-bounds ediff-wide-bounds) - (setq ediff-visible-bounds ediff-narrow-bounds) - (setq ediff-visible-bounds ediff-wide-bounds)) - (ediff-recenter 'no-rehighlight)) - -;; Narrow bufs A/B/C to ediff-visible-bounds. If this is currently set to -;; ediff-wide-bounds, then this actually widens. -;; This function does nothing if job-name is not -;; ediff-regions-wordwise/linewise or ediff-windows-wordwise/linewise. -;; Does nothing if buffer-A = buffer-B since we can't narrow -;; to two different regions in one buffer. -(defun ediff-visible-region () - (if (or (eq ediff-buffer-A ediff-buffer-B) - (eq ediff-buffer-A ediff-buffer-C) - (eq ediff-buffer-C ediff-buffer-B)) - () - ;; If ediff-*-regions/windows, ediff-visible-bounds is already set - ;; Otherwise, always use full range. - (if (not ediff-narrow-job) - (setq ediff-visible-bounds ediff-wide-bounds)) - (let ((overl-A (ediff-get-value-according-to-buffer-type - 'A ediff-visible-bounds)) - (overl-B (ediff-get-value-according-to-buffer-type - 'B ediff-visible-bounds)) - (overl-C (ediff-get-value-according-to-buffer-type - 'C ediff-visible-bounds)) - ) - (ediff-with-current-buffer ediff-buffer-A - (narrow-to-region - (ediff-overlay-start overl-A) (ediff-overlay-end overl-A))) - (ediff-with-current-buffer ediff-buffer-B - (narrow-to-region - (ediff-overlay-start overl-B) (ediff-overlay-end overl-B))) - - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (narrow-to-region - (ediff-overlay-start overl-C) (ediff-overlay-end overl-C)))) - ))) - - -;; Window scrolling operations - -;; Performs some operation on the two file windows (if they are showing). -;; Traps all errors on the operation in windows A/B/C. -;; Usually, errors come from scrolling off the -;; beginning or end of the buffer, and this gives error messages. -(defun ediff-operate-on-windows (operation arg) - - ;; make sure windows aren't dead - (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))) - (ediff-recenter 'no-rehighlight)) - (if (not (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) ediff-buffer-C) - )) - (error ediff-KILLED-VITAL-BUFFER)) - - (let* ((wind (selected-window)) - (wind-A ediff-window-A) - (wind-B ediff-window-B) - (wind-C ediff-window-C) - (coefA (ediff-get-region-size-coefficient 'A operation)) - (coefB (ediff-get-region-size-coefficient 'B operation)) - (three-way ediff-3way-job) - (coefC (if three-way - (ediff-get-region-size-coefficient 'C operation)))) - - (select-window wind-A) - (condition-case nil - (funcall operation (round (* coefA arg))) - (error)) - (select-window wind-B) - (condition-case nil - (funcall operation (round (* coefB arg))) - (error)) - (if three-way - (progn - (select-window wind-C) - (condition-case nil - (funcall operation (round (* coefC arg))) - (error)))) - (select-window wind))) - -(defun ediff-scroll-vertically (&optional arg) - "Vertically scroll buffers A, B \(and C if appropriate\). -With optional argument ARG, scroll ARG lines; otherwise scroll by nearly -the one half of the height of window-A." - (interactive "P") - (ediff-barf-if-not-control-buffer) - - ;; make sure windows aren't dead - (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))) - (ediff-recenter 'no-rehighlight)) - (if (not (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C)) - )) - (error ediff-KILLED-VITAL-BUFFER)) - - (ediff-operate-on-windows - (if (memq last-command-char '(?v ?\C-v)) - 'scroll-up - 'scroll-down) - ;; calculate argument to scroll-up/down - ;; if there is an explicit argument - (if (and arg (not (equal arg '-))) - ;; use it - (prefix-numeric-value arg) - ;; if not, see if we can determine a default amount (the window height) - (let (default-amount) - (setq default-amount - (- (/ (min (window-height ediff-window-A) - (window-height ediff-window-B) - (if ediff-3way-job - (window-height ediff-window-C) - 500)) ; some large number - 2) - 1 next-screen-context-lines)) - ;; window found - (if arg - ;; C-u as argument means half of default amount - (/ default-amount 2) - ;; no argument means default amount - default-amount))))) - - -(defun ediff-scroll-horizontally (&optional arg) - "Horizontally scroll buffers A, B \(and C if appropriate\). -If an argument is given, that is how many columns are scrolled, else nearly -the width of the A/B/C windows." - (interactive "P") - (ediff-barf-if-not-control-buffer) - - ;; make sure windows aren't dead - (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))) - (ediff-recenter 'no-rehighlight)) - (if (not (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (or (not ediff-3way-job) - (ediff-buffer-live-p ediff-buffer-C)) - )) - (error ediff-KILLED-VITAL-BUFFER)) - - (ediff-operate-on-windows - (if (= last-command-char ?<) - 'scroll-left - 'scroll-right) - ;; calculate argument to scroll-left/right - ;; if there is an explicit argument - (if (and arg (not (equal arg '-))) - ;; use it - (prefix-numeric-value arg) - ;; if not, see if we can determine a default amount - ;; (half the window width) - (if (null ediff-control-window) - ;; no control window, use nil - nil - (let ((default-amount - (- (/ (min (window-width ediff-window-A) - (window-width ediff-window-B) - (if ediff-3way-comparison-job - (window-width ediff-window-C) - 500) ; some large number - ) - 2) - 3))) - ;; window found - (if arg - ;; C-u as argument means half of default amount - (/ default-amount 2) - ;; no argument means default amount - default-amount)))))) - - -;;BEG, END show the region to be positioned. -;;JOB-NAME holds ediff-job-name. The ediff-windows job positions regions -;;differently. -(defun ediff-position-region (beg end pos job-name) - (if (> end (point-max)) - (setq end (point-max))) - (if ediff-windows-job - (if (pos-visible-in-window-p end) - () ; do nothing, wind is already positioned - ;; at this point, windows are positioned at the beginning of the - ;; file regions (not diff-regions) being compared. - (save-excursion - (move-to-window-line (- (window-height) 2)) - (let ((amount (+ 2 (count-lines (point) end)))) - (scroll-up amount)))) - (set-window-start (selected-window) beg) - (if (pos-visible-in-window-p end) - ;; Determine the number of lines that the region occupies - (let ((lines 0) - (prev-point 0)) - (while ( and (> end (progn - (move-to-window-line lines) - (point))) - ;; `end' may be beyond the window bottom, so check - ;; that we are making progress - (< prev-point (point))) - (setq prev-point (point)) - (setq lines (1+ lines))) - ;; And position the beginning on the right line - (goto-char beg) - (recenter (/ (1+ (max (- (1- (window-height (selected-window))) - lines) - 1) - ) - 2)))) - (goto-char pos) - )) - -;; get number of lines from window start to region end -(defun ediff-get-lines-to-region-end (buf-type &optional n ctl-buf) - (or n (setq n ediff-current-difference)) - (or ctl-buf (setq ctl-buf ediff-control-buffer)) - (ediff-with-current-buffer ctl-buf - (let* ((buf (ediff-get-buffer buf-type)) - (wind (eval (ediff-get-symbol-from-alist - buf-type ediff-window-alist))) - (beg (window-start wind)) - (end (ediff-get-diff-posn buf-type 'end)) - lines) - (ediff-with-current-buffer buf - (if (< beg end) - (setq lines (count-lines beg end)) - (setq lines 0)) - lines - )))) - -;; get number of lines from window end to region start -(defun ediff-get-lines-to-region-start (buf-type &optional n ctl-buf) - (or n (setq n ediff-current-difference)) - (or ctl-buf (setq ctl-buf ediff-control-buffer)) - (ediff-with-current-buffer ctl-buf - (let* ((buf (ediff-get-buffer buf-type)) - (wind (eval (ediff-get-symbol-from-alist - buf-type ediff-window-alist))) - (end (window-end wind)) - (beg (ediff-get-diff-posn buf-type 'beg))) - (ediff-with-current-buffer buf - (if (< beg end) (count-lines beg end) 0)) - ))) - - -;; region size coefficient is a coefficient by which to adjust scrolling -;; up/down of the window displaying buffer of type BUFTYPE. -;; The purpose of this coefficient is to make the windows scroll in sync, so -;; that it won't happen that one diff region is scrolled off while the other is -;; still seen. -;; -;; If the difference region is invalid, the coefficient is 1 -(defun ediff-get-region-size-coefficient (buf-type op &optional n ctl-buf) - (ediff-with-current-buffer (or ctl-buf ediff-control-buffer) - (if (ediff-valid-difference-p n) - (let* ((func (cond ((eq op 'scroll-down) - 'ediff-get-lines-to-region-start) - ((eq op 'scroll-up) - 'ediff-get-lines-to-region-end) - (t '(lambda (a b c) 0)))) - (max-lines (max (funcall func 'A n ctl-buf) - (funcall func 'B n ctl-buf) - (if (ediff-buffer-live-p ediff-buffer-C) - (funcall func 'C n ctl-buf) - 0)))) - ;; this covers the horizontal coefficient as well: - ;; if max-lines = 0 then coef = 1 - (if (> max-lines 0) - (/ (+ (funcall func buf-type n ctl-buf) 0.0) - (+ max-lines 0.0)) - 1)) - 1))) - - -(defun ediff-next-difference (&optional arg) - "Advance to the next difference. -With a prefix argument, go forward that many differences." - (interactive "p") - (ediff-barf-if-not-control-buffer) - (if (< ediff-current-difference ediff-number-of-differences) - (let ((n (min ediff-number-of-differences - (+ ediff-current-difference arg))) - non-clash-skip regexp-skip) - - (ediff-visible-region) - (or (>= n ediff-number-of-differences) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - (while (and (< n ediff-number-of-differences) - (or - ;; regexp skip - regexp-skip - ;; skip clashes, if necessary - non-clash-skip - ;; skip difference regions that differ in white space - (and ediff-ignore-similar-regions - (eq (ediff-no-fine-diffs-p n) t)))) - (setq n (1+ n)) - (if (= 0 (mod n 20)) - (message "Skipped over region %d and counting ..." n)) - (or (>= n ediff-number-of-differences) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - ) - (message "") - (ediff-unselect-and-select-difference n) - ) ; let - (ediff-visible-region) - (error "At end of the difference list"))) - -(defun ediff-previous-difference (&optional arg) - "Go to the previous difference. -With a prefix argument, go back that many differences." - (interactive "p") - (ediff-barf-if-not-control-buffer) - (if (> ediff-current-difference -1) - (let ((n (max -1 (- ediff-current-difference arg))) - non-clash-skip regexp-skip) - - (ediff-visible-region) - (or (< n 0) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - (while (and (> n -1) - (or - ;; regexp skip - regexp-skip - ;; skip clashes, if necessary - non-clash-skip - ;; skip difference regions that differ in white space - (and ediff-ignore-similar-regions - (eq (ediff-no-fine-diffs-p n) t)))) - (if (= 0 (mod (1+ n) 20)) - (message "Skipped over region %d and counting ..." (1+ n))) - (setq n (1- n)) - (or (< n 0) - (setq regexp-skip (funcall ediff-skip-diff-region-function n)) - ;; this won't exec if regexp-skip is t - (setq non-clash-skip (ediff-merge-region-is-non-clash n)) - (ediff-install-fine-diff-if-necessary n)) - ) - (message "") - (ediff-unselect-and-select-difference n) - ) ; let - (ediff-visible-region) - (error "At beginning of the difference list"))) - -;; The diff number is as perceived by the user (i.e., 1+ the internal -;; representation) -(defun ediff-jump-to-difference (difference-number) - "Go to the difference specified as a prefix argument. -If the prefix is negative, count differences from the end." - (interactive "p") - (ediff-barf-if-not-control-buffer) - (setq difference-number - (cond ((< difference-number 0) - (+ ediff-number-of-differences difference-number)) - ((> difference-number 0) (1- difference-number)) - (t -1))) - ;; -1 is allowed by ediff-unselect-and-select-difference --- it is the - ;; position before the first one. - (if (and (>= difference-number -1) - (<= difference-number ediff-number-of-differences)) - (ediff-unselect-and-select-difference difference-number) - (error ediff-BAD-DIFF-NUMBER - this-command (1+ difference-number) ediff-number-of-differences))) - -(defun ediff-jump-to-difference-at-point (arg) - "Go to difference closest to the point in buffer A, B, or C. -The buffer depends on last command character \(a, b, or c\) that invoked this -command. For instance, if the command was `ga' then the point value in buffer A -is used. -With a prefix argument, synchronize all files around the current point position -in the specified buffer." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (let* ((buf-type (ediff-char-to-buftype last-command-char)) - (buffer (ediff-get-buffer buf-type)) - (pt (ediff-with-current-buffer buffer (point))) - (diff-no (ediff-diff-at-point buf-type nil (if arg 'after))) - (past-last-diff (< ediff-number-of-differences diff-no)) - (beg (if past-last-diff - (ediff-with-current-buffer buffer (point-max)) - (ediff-get-diff-posn buf-type 'beg (1- diff-no)))) - ctl-wind wind-A wind-B wind-C - shift) - (if past-last-diff - (ediff-jump-to-difference -1) - (ediff-jump-to-difference diff-no)) - (setq ctl-wind (selected-window) - wind-A ediff-window-A - wind-B ediff-window-B - wind-C ediff-window-C) - (if arg - (progn - (ediff-with-current-buffer buffer - (setq shift (- beg pt))) - (select-window wind-A) - (if past-last-diff (goto-char (point-max))) - (condition-case nil - (backward-char shift) ; noerror, if beginning of buffer - (error)) - (recenter) - (select-window wind-B) - (if past-last-diff (goto-char (point-max))) - (condition-case nil - (backward-char shift) ; noerror, if beginning of buffer - (error)) - (recenter) - (if (window-live-p wind-C) - (progn - (select-window wind-C) - (if past-last-diff (goto-char (point-max))) - (condition-case nil - (backward-char shift) ; noerror, if beginning of buffer - (error)) - (recenter) - )) - (select-window ctl-wind) - )) - )) - - -;; find region most related to the current point position (or POS, if given) -;; returns diff number as seen by the user (i.e., 1+ the internal -;; representation) -;; The optional argument WHICH-DIFF can be `after' or `before'. If `after', -;; find the diff after the point. If `before', find the diff before the -;; point. If the point is inside a diff, return that diff. -(defun ediff-diff-at-point (buf-type &optional pos which-diff) - (let ((buffer (ediff-get-buffer buf-type)) - (ctl-buffer ediff-control-buffer) - (max-dif-num (1- ediff-number-of-differences)) - (diff-no -1) - (prev-beg 0) - (prev-end 0) - (beg 0) - (end 0)) - - (ediff-with-current-buffer buffer - (setq pos (or pos (point))) - (while (and (or (< pos prev-beg) (> pos beg)) - (< diff-no max-dif-num)) - (setq diff-no (1+ diff-no)) - (setq prev-beg beg - prev-end end) - (setq beg (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer) - end (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer)) - ) - - ;; boost diff-no by 1, if past the last diff region - (if (and (memq which-diff '(after before)) - (> pos beg) (= diff-no max-dif-num)) - (setq diff-no (1+ diff-no))) - - (cond ((eq which-diff 'after) (1+ diff-no)) - ((eq which-diff 'before) diff-no) - ((< (abs (count-lines pos (max 1 prev-end))) - (abs (count-lines pos (max 1 beg)))) - diff-no) ; choose prev difference - (t - (1+ diff-no))) ; choose next difference - ))) - - -;;; Copying diffs. - -(defun ediff-diff-to-diff (arg &optional keys) - "Copy buffer-X'th difference region to buffer Y \(X,Y are A, B, or C\). -If numerical prefix argument, copy the difference specified in the arg. -Otherwise, copy the difference given by `ediff-current-difference'. -This command assumes it is bound to a 2-character key sequence, `ab', `ba', -`ac', etc., which is used to determine the types of buffers to be used for -copying difference regions. The first character in the sequence specifies -the source buffer and the second specifies the target. - -If the second optional argument, a 2-character string, is given, use it to -determine the source and the target buffers instead of the command keys." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (or keys (setq keys (this-command-keys))) - (if (eq arg '-) (setq arg -1)) ; translate neg arg to -1 - (if (numberp arg) (ediff-jump-to-difference arg)) - - (let* ((key1 (aref keys 0)) - (key2 (aref keys 1)) - (char1 (if (and ediff-xemacs-p (eventp key1)) (event-key key1) key1)) - (char2 (if (and ediff-xemacs-p (eventp key1)) (event-key key2) key2)) - ediff-verbose-p) - (ediff-copy-diff ediff-current-difference - (ediff-char-to-buftype char1) - (ediff-char-to-buftype char2)) - ;; recenter with rehighlighting, but no messages - (ediff-recenter))) - -(defun ediff-copy-A-to-B (arg) - "Copy ARGth difference region from buffer A to B. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ab")) - -(defun ediff-copy-B-to-A (arg) - "Copy ARGth difference region from buffer B to A. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ba")) - -(defun ediff-copy-A-to-C (arg) - "Copy ARGth difference region from buffer A to buffer C. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ac")) - -(defun ediff-copy-B-to-C (arg) - "Copy ARGth difference region from buffer B to buffer C. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "bc")) - -(defun ediff-copy-C-to-B (arg) - "Copy ARGth difference region from buffer C to B. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "cb")) - -(defun ediff-copy-C-to-A (arg) - "Copy ARGth difference region from buffer C to A. -ARG is a prefix argument. If nil, copy the current difference region." - (interactive "P") - (ediff-diff-to-diff arg "ca")) - - - -;; Copy diff N from FROM-BUF-TYPE \(given as A, B or C\) to TO-BUF-TYPE. -;; If optional DO-NOT-SAVE is non-nil, do not save the old value of the -;; target diff. This is used in merging, when constructing the merged -;; version. -(defun ediff-copy-diff (n from-buf-type to-buf-type - &optional batch-invocation reg-to-copy) - (let* ((to-buf (ediff-get-buffer to-buf-type)) - ;;(from-buf (if (not reg-to-copy) (ediff-get-buffer from-buf-type))) - (ctrl-buf ediff-control-buffer) - (saved-p t) - (three-way ediff-3way-job) - messg - ediff-verbose-p - reg-to-delete reg-to-delete-beg reg-to-delete-end) - - (setq reg-to-delete-beg - (ediff-get-diff-posn to-buf-type 'beg n ctrl-buf)) - (setq reg-to-delete-end - (ediff-get-diff-posn to-buf-type 'end n ctrl-buf)) - - (if reg-to-copy - (setq from-buf-type nil) - (setq reg-to-copy (ediff-get-region-contents n from-buf-type ctrl-buf))) - - (setq reg-to-delete (ediff-get-region-contents - n to-buf-type ctrl-buf - reg-to-delete-beg reg-to-delete-end)) - - (if (string= reg-to-delete reg-to-copy) - (setq saved-p nil) ; don't copy identical buffers - ;; seems ok to copy - (if (or batch-invocation (ediff-test-save-region n to-buf-type)) - (condition-case conds - (progn - (ediff-with-current-buffer to-buf - ;; to prevent flags from interfering if buffer is writable - (let ((inhibit-read-only (null buffer-read-only))) - - (goto-char reg-to-delete-end) - (insert reg-to-copy) - - (if (> reg-to-delete-end reg-to-delete-beg) - (kill-region reg-to-delete-beg reg-to-delete-end)) - )) - (or batch-invocation - (setq - messg - (ediff-save-diff-region n to-buf-type reg-to-delete)))) - (error (message "ediff-copy-diff: %s %s" - (car conds) - (mapconcat 'prin1-to-string (cdr conds) " ")) - (beep 1) - (sit-for 2) ; let the user see the error msg - (setq saved-p nil) - ))) - ) - - ;; adjust state of difference in case 3-way and diff was copied ok - (if (and saved-p three-way) - (ediff-set-state-of-diff-in-all-buffers n ctrl-buf)) - - (if batch-invocation - (ediff-clear-fine-differences n) - ;; If diff3 job, we should recompute fine diffs so we clear them - ;; before reinserting flags (and thus before ediff-recenter). - (if (and saved-p three-way) - (ediff-clear-fine-differences n)) - - (ediff-refresh-mode-lines) - - ;; For diff2 jobs, don't recompute fine diffs, since we know there - ;; aren't any. So we clear diffs after ediff-recenter. - (if (and saved-p (not three-way)) - (ediff-clear-fine-differences n)) - ;; Make sure that the message about saving and how to restore is seen - ;; by the user - (message messg)) - )) - -;; Save Nth diff of buffer BUF-TYPE \(A, B, or C\). -;; That is to say, the Nth diff on the `ediff-killed-diffs-alist'. REG -;; is the region to save. It is redundant here, but is passed anyway, for -;; convenience. -(defun ediff-save-diff-region (n buf-type reg) - (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist)) - (buf (ediff-get-buffer buf-type)) - (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved)))) - - (if this-buf-n-th-diff-saved - ;; either nothing saved for n-th diff and buffer or we OK'ed - ;; overriding - (setcdr this-buf-n-th-diff-saved reg) - (if n-th-diff-saved ;; n-th diff saved, but for another buffer - (nconc n-th-diff-saved (list (cons buf reg))) - (setq ediff-killed-diffs-alist ;; create record for n-th diff - (cons (list n (cons buf reg)) - ediff-killed-diffs-alist)))) - (message "Saving old diff region #%d of buffer %S. To recover, type `r%s'" - (1+ n) buf-type - (if ediff-merge-job - "" (downcase (symbol-name buf-type)))) - )) - -;; Test if saving Nth difference region of buffer BUF-TYPE is possible. -(defun ediff-test-save-region (n buf-type) - (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist)) - (buf (ediff-get-buffer buf-type)) - (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved)))) - - (if this-buf-n-th-diff-saved - (if (yes-or-no-p - (format - "You've previously copied diff region %d to buffer %S. Confirm " - (1+ n) buf-type)) - t - (error "Quit")) - t))) - -(defun ediff-pop-diff (n buf-type) - "Pop last killed Nth diff region from buffer BUF-TYPE." - (let* ((n-th-record (assoc n ediff-killed-diffs-alist)) - (buf (ediff-get-buffer buf-type)) - (saved-rec (assoc buf (cdr n-th-record))) - (three-way ediff-3way-job) - (ctl-buf ediff-control-buffer) - ediff-verbose-p - saved-diff reg-beg reg-end recovered) - - (if (cdr saved-rec) - (setq saved-diff (cdr saved-rec)) - (if (> ediff-number-of-differences 0) - (error "Nothing saved for diff %d in buffer %S" (1+ n) buf-type) - (error ediff-NO-DIFFERENCES))) - - (setq reg-beg (ediff-get-diff-posn buf-type 'beg n ediff-control-buffer)) - (setq reg-end (ediff-get-diff-posn buf-type 'end n ediff-control-buffer)) - - (condition-case conds - (ediff-with-current-buffer buf - (let ((inhibit-read-only (null buffer-read-only))) - - (goto-char reg-end) - (insert saved-diff) - - (if (> reg-end reg-beg) - (kill-region reg-beg reg-end)) - - (setq recovered t) - )) - (error (message "ediff-pop-diff: %s %s" - (car conds) - (mapconcat 'prin1-to-string (cdr conds) " ")) - (beep 1))) - - ;; Clearing fine diffs is necessary for - ;; ediff-unselect-and-select-difference to properly recompute them. We - ;; can't rely on ediff-copy-diff to clear this vector, as the user might - ;; have modified diff regions after copying and, thus, may have recomputed - ;; fine diffs. - (if recovered - (ediff-clear-fine-differences n)) - - ;; adjust state of difference - (if (and three-way recovered) - (ediff-set-state-of-diff-in-all-buffers n ctl-buf)) - - (ediff-refresh-mode-lines) - - (if recovered - (progn - (setq n-th-record (delq saved-rec n-th-record)) - (message "Diff region %d in buffer %S restored" (1+ n) buf-type) - )) - )) - -(defun ediff-restore-diff (arg &optional key) - "Restore ARGth diff from `ediff-killed-diffs-alist'. -ARG is a prefix argument. If ARG is nil, restore the current-difference. -If the second optional argument, a character, is given, use it to -determine the target buffer instead of last-command-char" - (interactive "P") - (ediff-barf-if-not-control-buffer) - (if (numberp arg) - (ediff-jump-to-difference arg)) - (ediff-pop-diff ediff-current-difference - (ediff-char-to-buftype (or key last-command-char))) - ;; recenter with rehighlighting, but no messages - (let (ediff-verbose-p) - (ediff-recenter))) - -(defun ediff-restore-diff-in-merge-buffer (arg) - "Restore ARGth diff in the merge buffer. -ARG is a prefix argument. If nil, restore the current diff." - (interactive "P") - (ediff-restore-diff arg ?c)) - - -(defun ediff-toggle-regexp-match () - "Toggle between focusing and hiding of difference regions that match -a regular expression typed in by the user." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((regexp-A "") - (regexp-B "") - (regexp-C "") - msg-connective alt-msg-connective alt-connective) - (cond - ((or (and (eq ediff-skip-diff-region-function - ediff-focus-on-regexp-matches-function) - (eq last-command-char ?f)) - (and (eq ediff-skip-diff-region-function - ediff-hide-regexp-matches-function) - (eq last-command-char ?h))) - (message "Selective browsing by regexp turned off") - (setq ediff-skip-diff-region-function 'ediff-show-all-diffs)) - ((eq last-command-char ?h) - (setq ediff-skip-diff-region-function ediff-hide-regexp-matches-function - regexp-A - (read-string - (format - "Ignore A-regions matching this regexp (default \"%s\"): " - ediff-regexp-hide-A)) - regexp-B - (read-string - (format - "Ignore B-regions matching this regexp (default \"%s\"): " - ediff-regexp-hide-B))) - (if ediff-3way-comparison-job - (setq regexp-C - (read-string - (format - "Ignore C-regions matching this regexp (default \"%s\"): " - ediff-regexp-hide-C)))) - (if (eq ediff-hide-regexp-connective 'and) - (setq msg-connective "BOTH" - alt-msg-connective "ONE OF" - alt-connective 'or) - (setq msg-connective "ONE OF" - alt-msg-connective "BOTH" - alt-connective 'and)) - (if (y-or-n-p - (format - "Ignore regions that match %s regexps, OK? " - msg-connective alt-msg-connective)) - (message "Will ignore regions that match %s regexps" msg-connective) - (setq ediff-hide-regexp-connective alt-connective) - (message "Will ignore regions that match %s regexps" - alt-msg-connective)) - - (or (string= regexp-A "") (setq ediff-regexp-hide-A regexp-A)) - (or (string= regexp-B "") (setq ediff-regexp-hide-B regexp-B)) - (or (string= regexp-C "") (setq ediff-regexp-hide-C regexp-C))) - - ((eq last-command-char ?f) - (setq ediff-skip-diff-region-function - ediff-focus-on-regexp-matches-function - regexp-A - (read-string - (format - "Focus on A-regions matching this regexp (default \"%s\"): " - ediff-regexp-focus-A)) - regexp-B - (read-string - (format - "Focus on B-regions matching this regexp (default \"%s\"): " - ediff-regexp-focus-B))) - (if ediff-3way-comparison-job - (setq regexp-C - (read-string - (format - "Focus on C-regions matching this regexp (default \"%s\"): " - ediff-regexp-focus-C)))) - (if (eq ediff-focus-regexp-connective 'and) - (setq msg-connective "BOTH" - alt-msg-connective "ONE OF" - alt-connective 'or) - (setq msg-connective "ONE OF" - alt-msg-connective "BOTH" - alt-connective 'and)) - (if (y-or-n-p - (format - "Focus on regions that match %s regexps, OK? " - msg-connective alt-msg-connective)) - (message "Will focus on regions that match %s regexps" - msg-connective) - (setq ediff-focus-regexp-connective alt-connective) - (message "Will focus on regions that match %s regexps" - alt-msg-connective)) - - (or (string= regexp-A "") (setq ediff-regexp-focus-A regexp-A)) - (or (string= regexp-B "") (setq ediff-regexp-focus-B regexp-B)) - (or (string= regexp-C "") (setq ediff-regexp-focus-C regexp-C)))))) - -(defun ediff-toggle-skip-similar () - (interactive) - (ediff-barf-if-not-control-buffer) - (if (not (eq ediff-auto-refine 'on)) - (error - "Can't skip over whitespace regions: first turn auto-refining on")) - (setq ediff-ignore-similar-regions (not ediff-ignore-similar-regions)) - (if ediff-ignore-similar-regions - (message - "Skipping regions that differ only in white space & line breaks") - (message "Skipping over white-space differences turned off"))) - -(defun ediff-focus-on-regexp-matches (n) - "Focus on diffs that match regexp `ediff-regexp-focus-A/B'. -Regions to be ignored according to this function are those where -buf A region doesn't match `ediff-regexp-focus-A' and buf B region -doesn't match `ediff-regexp-focus-B'. -This function returns nil if the region number N (specified as -an argument) is not to be ignored and t if region N is to be ignored. - -N is a region number used by Ediff internally. It is 1 less -the number seen by the user." - (if (ediff-valid-difference-p n) - (let* ((ctl-buf ediff-control-buffer) - (regex-A ediff-regexp-focus-A) - (regex-B ediff-regexp-focus-B) - (regex-C ediff-regexp-focus-C) - (reg-A-match (ediff-with-current-buffer ediff-buffer-A - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'A 'beg n ctl-buf) - (ediff-get-diff-posn 'A 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-A nil t)))) - (reg-B-match (ediff-with-current-buffer ediff-buffer-B - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'B 'beg n ctl-buf) - (ediff-get-diff-posn 'B 'end n ctl-buf)) - (re-search-forward regex-B nil t)))) - (reg-C-match (if ediff-3way-comparison-job - (ediff-with-current-buffer ediff-buffer-C - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'C 'beg n ctl-buf) - (ediff-get-diff-posn 'C 'end n ctl-buf)) - (re-search-forward regex-C nil t)))))) - (not (eval (if ediff-3way-comparison-job - (list ediff-focus-regexp-connective - reg-A-match reg-B-match reg-C-match) - (list ediff-focus-regexp-connective - reg-A-match reg-B-match)))) - ))) - -(defun ediff-hide-regexp-matches (n) - "Hide diffs that match regexp `ediff-regexp-hide-A/B/C'. -Regions to be ignored are those where buf A region matches -`ediff-regexp-hide-A' and buf B region matches `ediff-regexp-hide-B'. -This function returns nil if the region number N (specified as -an argument) is not to be ignored and t if region N is to be ignored. - -N is a region number used by Ediff internally. It is 1 less -the number seen by the user." - (if (ediff-valid-difference-p n) - (let* ((ctl-buf ediff-control-buffer) - (regex-A ediff-regexp-hide-A) - (regex-B ediff-regexp-hide-B) - (regex-C ediff-regexp-hide-C) - (reg-A-match (ediff-with-current-buffer ediff-buffer-A - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'A 'beg n ctl-buf) - (ediff-get-diff-posn 'A 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-A nil t)))) - (reg-B-match (ediff-with-current-buffer ediff-buffer-B - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'B 'beg n ctl-buf) - (ediff-get-diff-posn 'B 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-B nil t)))) - (reg-C-match (if ediff-3way-comparison-job - (ediff-with-current-buffer ediff-buffer-C - (save-restriction - (narrow-to-region - (ediff-get-diff-posn 'C 'beg n ctl-buf) - (ediff-get-diff-posn 'C 'end n ctl-buf)) - (goto-char (point-min)) - (re-search-forward regex-C nil t)))))) - (eval (if ediff-3way-comparison-job - (list ediff-hide-regexp-connective - reg-A-match reg-B-match reg-C-match) - (list ediff-hide-regexp-connective reg-A-match reg-B-match))) - ))) - - - -;;; Quitting, suspending, etc. - -(defun ediff-quit (reverse-default-keep-variants) - "Finish an Ediff session and exit Ediff. -Unselects the selected difference, if any, restores the read-only and modified -flags of the compared file buffers, kills Ediff buffers for this session -\(but not buffers A, B, C\). - -If `ediff-keep-variants' is nil, the user will be asked whether the buffers -containing the variants should be removed \(if they haven't been modified\). -If it is t, they will be preserved unconditionally. A prefix argument, -temporarily reverses the meaning of this variable." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (let ((ctl-buf (current-buffer))) - (if (y-or-n-p (format "Quit this Ediff session%s? " - (if (ediff-buffer-live-p ediff-meta-buffer) - " & show containing session group" ""))) - (progn - (message "") - (set-buffer ctl-buf) - (ediff-really-quit reverse-default-keep-variants)) - (message "")))) - - -;; Perform the quit operations. -(defun ediff-really-quit (reverse-default-keep-variants) - (ediff-unhighlight-diffs-totally) - (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also) - (ediff-clear-diff-vector 'ediff-difference-vector-Ancestor 'fine-diffs-also) - - (ediff-delete-temp-files) - - ;; Restore visibility range. This affects only ediff-*-regions/windows. - ;; Since for other job names ediff-visible-region sets - ;; ediff-visible-bounds to ediff-wide-bounds, the settings below are - ;; ignored for such jobs. - (if ediff-quit-widened - (setq ediff-visible-bounds ediff-wide-bounds) - (setq ediff-visible-bounds ediff-narrow-bounds)) - - ;; Apply selective display to narrow or widen - (ediff-visible-region) - (mapcar (function (lambda (overl) - (if (ediff-overlayp overl) - (ediff-delete-overlay overl)))) - ediff-wide-bounds) - (mapcar (function (lambda (overl) - (if (ediff-overlayp overl) - (ediff-delete-overlay overl)))) - ediff-narrow-bounds) - - ;; restore buffer mode line id's in buffer-A/B/C - (let ((control-buffer ediff-control-buffer) - (meta-buffer ediff-meta-buffer) - ;; suitable working frame - (warp-frame (if (and (ediff-window-display-p) (eq ediff-grab-mouse t)) - (cond ((window-live-p ediff-window-A) - (window-frame ediff-window-A)) - ((window-live-p ediff-window-B) - (window-frame ediff-window-B)) - (t (next-frame)))))) - (condition-case nil - (ediff-with-current-buffer ediff-buffer-A - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (condition-case nil - (ediff-with-current-buffer ediff-buffer-B - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (condition-case nil - (ediff-with-current-buffer ediff-buffer-C - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (condition-case nil - (ediff-with-current-buffer ediff-ancestor-buffer - (setq ediff-this-buffer-ediff-sessions - (delq control-buffer ediff-this-buffer-ediff-sessions)) - (kill-local-variable 'mode-line-buffer-identification) - (kill-local-variable 'mode-line-format) - ) - (error)) - - (setq ediff-session-registry - (delq ediff-control-buffer ediff-session-registry)) - (ediff-update-registry) - ;; restore state of buffers to what it was before ediff - (ediff-restore-protected-variables) - - ;; If the user interrupts (canceling saving the merge buffer), continue - ;; normally. - (condition-case nil - (if (ediff-merge-job) - (run-hooks 'ediff-quit-merge-hook)) - (quit)) - - ;; good place to kill buffers A/B/C - (run-hooks 'ediff-cleanup-hook) - (let ((ediff-keep-variants ediff-keep-variants)) - (if reverse-default-keep-variants - (setq ediff-keep-variants (not ediff-keep-variants))) - (or ediff-keep-variants (ediff-janitor 'ask))) - - (run-hooks 'ediff-quit-hook) - (ediff-cleanup-meta-buffer meta-buffer) - - ;; warp mouse into a working window - (setq warp-frame ; if mouse is over a reasonable frame, use it - (cond ((ediff-good-frame-under-mouse)) - (t warp-frame))) - (if (frame-live-p warp-frame) - (set-mouse-position (if ediff-emacs-p - warp-frame - (frame-selected-window warp-frame)) - 2 1)) - - (if (ediff-buffer-live-p meta-buffer) - (ediff-show-meta-buffer meta-buffer)) - )) - -;; Returns frame under mouse, if this frame is not a minibuffer -;; frame. Otherwise: nil -(defun ediff-good-frame-under-mouse () - (let ((frame-or-win (car (mouse-position))) - (buf-name "") - frame obj-ok) - (setq obj-ok - (if ediff-emacs-p - (frame-live-p frame-or-win) - (window-live-p frame-or-win))) - (if obj-ok - (setq frame (if ediff-emacs-p frame-or-win (window-frame frame-or-win)) - buf-name - (buffer-name (window-buffer (frame-selected-window frame))))) - (if (string-match "Minibuf" buf-name) - nil - frame))) - - -(defun ediff-delete-temp-files () - (if (stringp ediff-temp-file-A) - (delete-file ediff-temp-file-A)) - (if (stringp ediff-temp-file-B) - (delete-file ediff-temp-file-B)) - (if (stringp ediff-temp-file-C) - (delete-file ediff-temp-file-C))) - - -;; Kill control buffer, other auxiliary Ediff buffers. -;; Leave one of the frames split between buffers A/B/C -(defun ediff-cleanup-mess () - (let ((buff-A ediff-buffer-A) - (buff-B ediff-buffer-B) - (buff-C ediff-buffer-C) - (ctl-buf ediff-control-buffer) - (ctl-frame ediff-control-frame) - (three-way-job ediff-3way-job)) - - (ediff-kill-buffer-carefully ediff-diff-buffer) - (ediff-kill-buffer-carefully ediff-custom-diff-buffer) - (ediff-kill-buffer-carefully ediff-fine-diff-buffer) - (ediff-kill-buffer-carefully ediff-tmp-buffer) - (ediff-kill-buffer-carefully ediff-error-buffer) - (ediff-kill-buffer-carefully ediff-msg-buffer) - (ediff-kill-buffer-carefully ediff-debug-buffer) - (if (boundp 'ediff-patch-diagnostics) - (ediff-kill-buffer-carefully ediff-patch-diagnostics)) - - (if (and (ediff-window-display-p) (frame-live-p ctl-frame)) - (delete-frame ctl-frame)) - ;; Hide bottom toolbar. --marcpa - (if (not (ediff-multiframe-setup-p)) - (ediff-kill-bottom-toolbar)) - - (ediff-kill-buffer-carefully ctl-buf) - - (delete-other-windows) - - ;; display only if not visible - (condition-case nil - (or (ediff-get-visible-buffer-window buff-B) - (switch-to-buffer buff-B)) - (error)) - (condition-case nil - (or (ediff-get-visible-buffer-window buff-A) - (progn - (if (ediff-get-visible-buffer-window buff-B) - (funcall ediff-split-window-function)) - (switch-to-buffer buff-A))) - (error)) - (if three-way-job - (condition-case nil - (or (ediff-get-visible-buffer-window buff-C) - (progn - (if (or (ediff-get-visible-buffer-window buff-A) - (ediff-get-visible-buffer-window buff-B)) - (funcall ediff-split-window-function)) - (switch-to-buffer buff-C) - (balance-windows))) - (error))) - (message "") - )) - -(defun ediff-janitor (&optional ask) - "Kill buffers A, B, and, possibly, C, if these buffers aren't modified. -In merge jobs, buffer C is never deleted. -However, the side effect of cleaning up may be that you cannot compare the same -buffer in two separate Ediff sessions: quitting one of them will delete this -buffer in another session as well." - (or (not (ediff-buffer-live-p ediff-buffer-A)) - (buffer-modified-p ediff-buffer-A) - (and ask - (not (y-or-n-p (format "Kill buffer A [%s]? " - (buffer-name ediff-buffer-A))))) - (ediff-kill-buffer-carefully ediff-buffer-A)) - (or (not (ediff-buffer-live-p ediff-buffer-B)) - (buffer-modified-p ediff-buffer-B) - (and ask - (not (y-or-n-p (format "Kill buffer B [%s]? " - (buffer-name ediff-buffer-B))))) - (ediff-kill-buffer-carefully ediff-buffer-B)) - (if ediff-merge-job ; don't del buf C if merging--del ancestor buf instead - (or (not (ediff-buffer-live-p ediff-ancestor-buffer)) - (buffer-modified-p ediff-ancestor-buffer) - (and ask - (not (y-or-n-p (format "Kill the ancestor buffer [%s]? " - (buffer-name ediff-ancestor-buffer))))) - (ediff-kill-buffer-carefully ediff-ancestor-buffer)) - (or (not (ediff-buffer-live-p ediff-buffer-C)) - (buffer-modified-p ediff-buffer-C) - (and ask (not (y-or-n-p (format "Kill buffer C [%s]? " - (buffer-name ediff-buffer-C))))) - (ediff-kill-buffer-carefully ediff-buffer-C)))) - -(defun ediff-maybe-save-and-delete-merge (&optional save-and-continue) - "Default hook to run on quitting a merge job. -This can also be used to save merge buffer in the middle of an Ediff session. - -If the optional SAVE-AND-CONTINUE argument is non-nil, save merge buffer and -continue. Otherwise: -If `ediff-autostore-merges' is nil, this does nothing. -If it is t, it saves the merge buffer in the file `ediff-merge-store-file' -or asks the user, if the latter is nil. It then asks the user whether to -delete the merge buffer. -If `ediff-autostore-merges' is neither nil nor t, the merge buffer is saved -only if this merge job is part of a group, i.e., was invoked from within -`ediff-merge-directories', `ediff-merge-directory-revisions', and such." - (let ((merge-store-file ediff-merge-store-file) - (ediff-autostore-merges ; fake ediff-autostore-merges, if necessary - (if save-and-continue t ediff-autostore-merges))) - (if ediff-autostore-merges - (cond ((stringp ediff-merge-store-file) - ;; store, ask to delete - (ediff-write-merge-buffer-and-maybe-kill - ediff-buffer-C merge-store-file 'show-file save-and-continue)) - ((eq ediff-autostore-merges t) - ;; ask for file name - (setq merge-store-file - (read-file-name "Save the merge buffer in file: ")) - (ediff-write-merge-buffer-and-maybe-kill - ediff-buffer-C merge-store-file nil save-and-continue)) - ((and (ediff-buffer-live-p ediff-meta-buffer) - (ediff-with-current-buffer ediff-meta-buffer - (ediff-merge-metajob))) - ;; This case shouldn't occur, as the parent metajob must pass on - ;; a file name, ediff-merge-store-file, where to save the result - ;; of the merge. - ;; Ask where to save anyway--will decide what to do here later. - (setq merge-store-file - (read-file-name "Save the merge buffer in file: ")) - (ediff-write-merge-buffer-and-maybe-kill - ediff-buffer-C merge-store-file nil save-and-continue)))) - )) - -;; write merge buffer. If the optional argument save-and-continue is non-nil, -;; then don't kill the merge buffer -(defun ediff-write-merge-buffer-and-maybe-kill (buf file - &optional - show-file save-and-continue) - (ediff-with-current-buffer buf - (if (or (not (file-exists-p file)) - (y-or-n-p (format "File %s exists, overwrite? " file))) - (progn - (write-region (point-min) (point-max) file) - (if show-file - (progn - (message "Merge buffer saved in: %s" file) - (sit-for 2))) - (if (and - (not save-and-continue) - (y-or-n-p "Merge buffer saved in file. Now kill the buffer? ")) - (ediff-kill-buffer-carefully buf)))))) - -;; The default way of suspending Ediff. -;; Buries Ediff buffers, kills all windows. -(defun ediff-default-suspend-function () - (let* ((buf-A ediff-buffer-A) - (buf-B ediff-buffer-B) - (buf-C ediff-buffer-C) - (buf-A-wind (ediff-get-visible-buffer-window buf-A)) - (buf-B-wind (ediff-get-visible-buffer-window buf-B)) - (buf-C-wind (ediff-get-visible-buffer-window buf-C)) - (buf-patch (if (boundp 'ediff-patchbufer) ediff-patchbufer nil)) - (buf-patch-diag (if (boundp 'ediff-patch-diagnostics) - ediff-patch-diagnostics nil)) - (buf-err ediff-error-buffer) - (buf-diff ediff-diff-buffer) - (buf-custom-diff ediff-custom-diff-buffer) - (buf-fine-diff ediff-fine-diff-buffer)) - - ;; hide the control panel - (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame)) - (iconify-frame ediff-control-frame) - (bury-buffer)) - (if buf-err (bury-buffer buf-err)) - (if buf-diff (bury-buffer buf-diff)) - (if buf-custom-diff (bury-buffer buf-custom-diff)) - (if buf-fine-diff (bury-buffer buf-fine-diff)) - (if buf-patch (bury-buffer buf-patch)) - (if buf-patch-diag (bury-buffer buf-patch-diag)) - (if (window-live-p buf-A-wind) - (progn - (select-window buf-A-wind) - (delete-other-windows) - (bury-buffer)) - (if (ediff-buffer-live-p buf-A) - (progn - (set-buffer buf-A) - (bury-buffer)))) - (if (window-live-p buf-B-wind) - (progn - (select-window buf-B-wind) - (delete-other-windows) - (bury-buffer)) - (if (ediff-buffer-live-p buf-B) - (progn - (set-buffer buf-B) - (bury-buffer)))) - (if (window-live-p buf-C-wind) - (progn - (select-window buf-C-wind) - (delete-other-windows) - (bury-buffer)) - (if (ediff-buffer-live-p buf-C) - (progn - (set-buffer buf-C) - (bury-buffer)))) - )) - - -(defun ediff-suspend () - "Suspend Ediff. -To resume, switch to the appropriate `Ediff Control Panel' -buffer and then type \\[ediff-recenter]. Ediff will automatically set -up an appropriate window config." - (interactive) - (ediff-barf-if-not-control-buffer) - (run-hooks 'ediff-suspend-hook) - (message - "To resume, type M-x eregistry and select the desired Ediff session")) - - -(defun ediff-status-info () - "Show the names of the buffers or files being operated on by Ediff. -Hit \\[ediff-recenter] to reset the windows afterward." - (interactive) - (ediff-barf-if-not-control-buffer) - (save-excursion - (ediff-skip-unsuitable-frames)) - (with-output-to-temp-buffer ediff-msg-buffer - (raise-frame (selected-frame)) - (princ (ediff-version)) - (princ "\n\n") - (ediff-with-current-buffer ediff-buffer-A - (if buffer-file-name - (princ - (format "File A = %S\n" buffer-file-name)) - (princ - (format "Buffer A = %S\n" (buffer-name))))) - (ediff-with-current-buffer ediff-buffer-B - (if buffer-file-name - (princ - (format "File B = %S\n" buffer-file-name)) - (princ - (format "Buffer B = %S\n" (buffer-name))))) - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (if buffer-file-name - (princ - (format "File C = %S\n" buffer-file-name)) - (princ - (format "Buffer C = %S\n" (buffer-name)))))) - (princ (format "Customized diff output %s\n" - (if (ediff-buffer-live-p ediff-custom-diff-buffer) - (concat "\tin buffer " - (buffer-name ediff-custom-diff-buffer)) - " is not available"))) - (princ (format "Plain diff output %s\n" - (if (ediff-buffer-live-p ediff-diff-buffer) - (concat "\tin buffer " - (buffer-name ediff-diff-buffer)) - " is not available"))) - - (let* ((A-line (ediff-with-current-buffer ediff-buffer-A - (1+ (count-lines (point-min) (point))))) - (B-line (ediff-with-current-buffer ediff-buffer-B - (1+ (count-lines (point-min) (point))))) - C-line) - (princ (format "\Buffer A's point is on line %d\n" A-line)) - (princ (format "Buffer B's point is on line %d\n" B-line)) - (if ediff-3way-job - (progn - (setq C-line (ediff-with-current-buffer ediff-buffer-C - (1+ (count-lines (point-min) (point))))) - (princ (format "Buffer C's point is on line %d\n" C-line))))) - - (princ (format "\nCurrent difference number = %S\n" - (cond ((< ediff-current-difference 0) 'start) - ((>= ediff-current-difference - ediff-number-of-differences) 'end) - (t (1+ ediff-current-difference))))) - - (princ - (format "\n%s regions that differ in white space & line breaks only" - (if ediff-ignore-similar-regions - "Ignoring" "Showing"))) - (if (and ediff-merge-job ediff-show-clashes-only) - (princ - "\nFocusing on regions where both buffers differ from the ancestor")) - - (cond ((eq ediff-skip-diff-region-function 'ediff-show-all-diffs) - (princ "\nSelective browsing by regexp is off\n")) - ((eq ediff-skip-diff-region-function - ediff-hide-regexp-matches-function) - (princ - "\nIgnoring regions that match") - (princ - (format - "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n" - ediff-regexp-hide-A ediff-hide-regexp-connective - ediff-regexp-hide-B))) - ((eq ediff-skip-diff-region-function - ediff-focus-on-regexp-matches-function) - (princ - "\nFocusing on regions that match") - (princ - (format - "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n" - ediff-regexp-focus-A ediff-focus-regexp-connective - ediff-regexp-focus-B))) - (t (princ "\nSelective browsing via a user-defined method.\n"))) - - (princ - (format "\nBugs/suggestions: type `%s' while in Ediff Control Panel." - (substitute-command-keys "\\[ediff-submit-report]"))) - ) ; with output - (if (frame-live-p ediff-control-frame) - (ediff-reset-mouse ediff-control-frame)) - (if (window-live-p ediff-control-window) - (select-window ediff-control-window))) - - - - -;;; Support routines - -;; Select a difference by placing the ASCII flags around the appropriate -;; group of lines in the A, B buffers -;; This may have to be modified for buffer C, when it will be supported. -(defun ediff-select-difference (n) - (if (and (ediff-buffer-live-p ediff-buffer-A) - (ediff-buffer-live-p ediff-buffer-B) - (ediff-valid-difference-p n)) - (progn - (if (and (ediff-has-face-support-p) ediff-use-faces) - (progn - (ediff-highlight-diff n) - (setq ediff-highlighting-style 'face)) - (setq ediff-highlighting-style 'ascii) - (ediff-place-flags-in-buffer - 'A ediff-buffer-A ediff-control-buffer n) - (ediff-place-flags-in-buffer - 'B ediff-buffer-B ediff-control-buffer n) - (if ediff-3way-job - (ediff-place-flags-in-buffer - 'C ediff-buffer-C ediff-control-buffer n)) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-place-flags-in-buffer - 'Ancestor ediff-ancestor-buffer - ediff-control-buffer n)) - ) - - (ediff-install-fine-diff-if-necessary n) - (run-hooks 'ediff-select-hook)))) - - -;; Unselect a difference by removing the ASCII flags in the buffers. -;; This may have to be modified for buffer C, when it will be supported. -(defun ediff-unselect-difference (n) - (if (ediff-valid-difference-p n) - (progn - (cond ((and (ediff-has-face-support-p) ediff-use-faces) - (ediff-unhighlight-diff)) - ((eq ediff-highlighting-style 'ascii) - (ediff-remove-flags-from-buffer - ediff-buffer-A - (ediff-get-diff-overlay n 'A)) - (ediff-remove-flags-from-buffer - ediff-buffer-B - (ediff-get-diff-overlay n 'B)) - (if ediff-3way-job - (ediff-remove-flags-from-buffer - ediff-buffer-C - (ediff-get-diff-overlay n 'C))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-remove-flags-from-buffer - ediff-ancestor-buffer - (ediff-get-diff-overlay n 'Ancestor))) - )) - (setq ediff-highlighting-style nil) - - ;; unhighlight fine diffs - (ediff-set-fine-diff-properties ediff-current-difference 'default) - (run-hooks 'ediff-unselect-hook)))) - - -;; Unselects prev diff and selects a new one, if FLAG has value other than -;; 'select-only or 'unselect-only. If FLAG is 'select-only, the -;; next difference is selected, but the current selection is not -;; unselected. If FLAG is 'unselect-only then the current selection is -;; unselected, but the next one is not selected. If NO-RECENTER is non-nil, -;; don't recenter buffers after selecting/unselecting. -(defun ediff-unselect-and-select-difference (n &optional flag no-recenter) - (let ((ediff-current-difference n)) - (or no-recenter - (ediff-recenter 'no-rehighlight))) - - (let ((control-buf ediff-control-buffer)) - (unwind-protect - (progn - (or (eq flag 'select-only) - (ediff-unselect-difference ediff-current-difference)) - - (or (eq flag 'unselect-only) - (ediff-select-difference n)) - (setq ediff-current-difference n) - ) ; end protected section - - (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines)) - ))) - - -(defun ediff-read-file-name (prompt default-dir default-file) -; This is a modified version of a similar function in `emerge.el'. -; PROMPT should not have trailing ': ', so that it can be modified -; according to context. -; If default-file is set, it should be used as the default value. -; If default-dir is non-nil, use it as the default directory. -; Otherwise, use the value of Emacs' variable `default-directory.' - - ;; hack default-dir if it is not set - (setq default-dir - (file-name-as-directory - (ediff-abbreviate-file-name - (expand-file-name (or default-dir - (and default-file - (file-name-directory default-file)) - default-directory))))) - - ;; strip the directory from default-file - (if default-file - (setq default-file (file-name-nondirectory default-file))) - (if (string= default-file "") - (setq default-file nil)) - - (let (f) - (setq f (expand-file-name - (read-file-name - (format "%s%s " - prompt - (cond (default-file - (concat " (default " default-file "):")) - (t (concat " (default " default-dir "):")))) - default-dir - (or default-file default-dir) - t ; must match, no-confirm - (if default-file (file-name-directory default-file)) - ) - default-dir - )) - ;; If user enters a directory name, expand the default file in that - ;; directory. This allows the user to enter a directory name for the - ;; B-file and diff against the default-file in that directory instead - ;; of a DIRED listing! - (if (and (file-directory-p f) default-file) - (setq f (expand-file-name - (file-name-nondirectory default-file) f))) - f)) - -;; If PREFIX is given, then it is used as a prefix for the temp file -;; name. Otherwise, `ediff_' is used. If FILE is given, use this -;; file and don't create a new one. -;; On MS-DOS, make sure the prefix isn't longer than 7 characters, or -;; else `make-temp-name' isn't guaranteed to return a unique filename. -;; Also, save buffer from START to END in the file. -;; START defaults to (point-min), END to (point-max) -(defun ediff-make-temp-file (buff &optional prefix given-file start end) - (let ((p (or prefix "ediff")) - f) - (if (and (eq system-type 'ms-dos) (> (length p) 7)) - (setq p (substring p 0 7))) - - (setq f (concat ediff-temp-file-prefix p) - f (cond (given-file) - ((find-file-name-handler f 'find-file-noselect) - ;; to thwart file handlers in write-region, e.g., if file - ;; name ends with .Z or .gz - ;; This is needed so that patches produced by ediff will - ;; have more meaningful names - (make-temp-name f)) - ;; Prefix is most often the same as the file name for the - ;; variant. Here we are trying to use the original file name - ;; but in the temp directory. - ((and prefix (not (file-exists-p f))) f) - ;; If a file with the orig name exists, add some random stuff - ;; to it. - (t (make-temp-name f)))) - - ;; create the file - (ediff-with-current-buffer buff - (write-region (if start start (point-min)) - (if end end (point-max)) - f - nil ; don't append---erase - 'no-message) - (set-file-modes f ediff-temp-file-mode) - (ediff-convert-standard-filename (expand-file-name f))))) - -;; Quote metacharacters (using \) when executing diff in Unix, but not in -;; EMX OS/2 -;;(defun ediff-protect-metachars (str) -;; (or (memq system-type '(emx vax-vms axp-vms)) -;; (let ((limit 0)) -;; (while (string-match ediff-metachars str limit) -;; (setq str (concat (substring str 0 (match-beginning 0)) -;; "\\" -;; (substring str (match-beginning 0)))) -;; (setq limit (1+ (match-end 0)))))) -;; str) - -;; Make sure the current buffer (for a file) has the same contents as the -;; file on disk, and attempt to remedy the situation if not. -;; Signal an error if we can't make them the same, or the user doesn't want -;; to do what is necessary to make them the same. -;; Also, Ediff always offers to revert obsolete buffers, whether they -;; are modified or not. -(defun ediff-verify-file-buffer (&optional file-magic) - ;; First check if the file has been modified since the buffer visited it. - (if (verify-visited-file-modtime (current-buffer)) - (if (buffer-modified-p) - ;; If buffer is not obsolete and is modified, offer to save - (if (yes-or-no-p - (format "Buffer out of sync with visited file. Save file %s? " - buffer-file-name)) - (condition-case nil - (save-buffer) - (error - (beep) - (message "Couldn't save %s" buffer-file-name))) - (error "Buffer is out of sync for file %s" buffer-file-name)) - ;; If buffer is not obsolete and is not modified, do nothing - nil) - ;; If buffer is obsolete, offer to revert - (if (yes-or-no-p - (format "Buffer is out of sync with visited file. REVERT file %s? " - buffer-file-name)) - (progn - (if file-magic - (erase-buffer)) - (revert-buffer t t)) - (error "Buffer out of sync for file %s" buffer-file-name)))) - - -(defun ediff-file-compressed-p (file) - (require 'jka-compr) - (string-match (jka-compr-build-file-regexp) file)) - -(defun ediff-filename-magic-p (file) - (or (ediff-file-compressed-p file) - (ediff-file-remote-p file))) - - -(defun ediff-save-buffer (arg) - "Safe way of saving buffers A, B, C, and the diff output. -`wa' saves buffer A, `wb' saves buffer B, `wc' saves buffer C, -and `wd' saves the diff output. - -With prefix argument, `wd' saves plain diff output. -Without an argument, it saves customized diff argument, if available -\(and plain output, if customized output was not generated\)." - (interactive "P") - (ediff-barf-if-not-control-buffer) - (ediff-compute-custom-diffs-maybe) - (ediff-with-current-buffer - (cond ((memq last-command-char '(?a ?b ?c)) - (ediff-get-buffer - (ediff-char-to-buftype last-command-char))) - ((eq last-command-char ?d) - (message "Saving diff output ...") - (sit-for 1) ; let the user see the message - (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer)) - ediff-diff-buffer) - ((ediff-buffer-live-p ediff-custom-diff-buffer) - ediff-custom-diff-buffer) - ((ediff-buffer-live-p ediff-diff-buffer) - ediff-diff-buffer) - (t (error "Output from `diff' not found")))) - ) - (save-buffer))) - -(defun ediff-compute-custom-diffs-maybe () - (let ((buf-A-file-name (buffer-file-name ediff-buffer-A)) - (buf-B-file-name (buffer-file-name ediff-buffer-B)) - file-A file-B) - (if (stringp buf-A-file-name) - (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) - (if (stringp buf-B-file-name) - (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) - (setq file-A (ediff-make-temp-file ediff-buffer-A buf-A-file-name) - file-B (ediff-make-temp-file ediff-buffer-B buf-B-file-name)) - - (or (ediff-buffer-live-p ediff-custom-diff-buffer) - (setq ediff-custom-diff-buffer - (get-buffer-create - (ediff-unique-buffer-name "*ediff-custom-diff" "*")))) - (ediff-exec-process - ediff-custom-diff-program ediff-custom-diff-buffer 'synchronize - ediff-custom-diff-options file-A file-B) - (delete-file file-A) - (delete-file file-B) - )) - -(defun ediff-show-diff-output (arg) - (interactive "P") - (ediff-barf-if-not-control-buffer) - (ediff-compute-custom-diffs-maybe) - (save-excursion - (ediff-skip-unsuitable-frames ' ok-unsplittable)) - (let ((buf (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer)) - ediff-diff-buffer) - ((ediff-buffer-live-p ediff-custom-diff-buffer) - ediff-custom-diff-buffer) - ((ediff-buffer-live-p ediff-diff-buffer) - ediff-diff-buffer) - (t - (beep) - (message "Output from `diff' not found") - nil)))) - (if buf - (progn - (ediff-with-current-buffer buf - (goto-char (point-min))) - (switch-to-buffer buf) - (raise-frame (selected-frame))))) - (if (frame-live-p ediff-control-frame) - (ediff-reset-mouse ediff-control-frame)) - (if (window-live-p ediff-control-window) - (select-window ediff-control-window))) - - -(defun ediff-inferior-compare-regions () - "Compare regions in an active Ediff session. -Like ediff-regions-linewise but is called from under an active Ediff session on -the files that belong to that session. - -After quitting the session invoked via this function, type C-l to the parent -Ediff Control Panel to restore highlighting." - (interactive) - (let ((answer "") - (possibilities (list ?A ?B ?C)) - (zmacs-regions t) - (ctl-buf (current-buffer)) - quit-now - begA begB endA endB bufA bufB) - - (cond ((ediff-merge-job) - (setq bufB ediff-buffer-C) - (while (cond ((eq answer ?A) - (setq bufA ediff-buffer-A - possibilities '(?B)) - nil) - ((eq answer ?B) - (setq bufA ediff-buffer-B - possibilities '(?A)) - nil) - ((equal answer "")) - (t (beep 1) - (message "Valid values are A or B") - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message "Which buffer to compare to the merge buffer (A/B)? ") - (setq answer (capitalize (read-char-exclusive)))))) - - ((ediff-3way-comparison-job) - (while (cond ((memq answer possibilities) - (setq possibilities (delq answer possibilities)) - (setq bufA - (eval - (ediff-get-symbol-from-alist - answer ediff-buffer-alist))) - nil) - ((equal answer "")) - (t (beep 1) - (message - "Valid values are %s" - (mapconcat 'char-to-string possibilities " or ")) - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message "Enter the 1st buffer you want to compare (%s): " - (mapconcat 'char-to-string possibilities "/")) - (setq answer (capitalize (read-char-exclusive))))) - (setq answer "") ; silence error msg - (while (cond ((memq answer possibilities) - (setq possibilities (delq answer possibilities)) - (setq bufB - (eval - (ediff-get-symbol-from-alist - answer ediff-buffer-alist))) - nil) - ((equal answer "")) - (t (beep 1) - (message - "Valid values are %s" - (mapconcat 'char-to-string possibilities " or ")) - (sit-for 2) - t)) - (let ((cursor-in-echo-area t)) - (message "Enter the 2nd buffer you want to compare (%s): " - (mapconcat 'char-to-string possibilities "/")) - (setq answer (capitalize (read-char-exclusive)))))) - (t ; 2way comparison - (setq bufA ediff-buffer-A - bufB ediff-buffer-B - possibilities nil))) - - (ediff-with-current-buffer bufA - (or (mark t) - (error "You forgot to specify a region in buffer %s" (buffer-name))) - (setq begA (region-beginning) - endA (region-end)) - (goto-char begA) - (beginning-of-line) - (setq begA (point)) - (goto-char endA) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq endA (point))) - (ediff-with-current-buffer bufB - (or (mark t) - (error "You forgot to specify a region in buffer %s" (buffer-name))) - (setq begB (region-beginning) - endB (region-end)) - (goto-char begB) - (beginning-of-line) - (setq begB (point)) - (goto-char endB) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq endB (point))) - - (ediff-unselect-and-select-difference - ediff-current-difference 'unselect-only) - (ediff-paint-background-regions 'unhighlight) - - (ediff-with-current-buffer bufA - (goto-char begA) - (set-mark endA) - (narrow-to-region begA endA) - ;; (ediff-activate-mark) - ) - ;; (sit-for 0) - (ediff-with-current-buffer bufB - (goto-char begB) - (set-mark endB) - (narrow-to-region begB endB) - ;; (ediff-activate-mark) - ) - ;; (sit-for 0) - - ;; At this point, possibilities contains either the window char A/B/C - ;; that was not selected, or it is nil. We delete the window that is not - ;; selected. - (if possibilities - (ediff-with-current-buffer ctl-buf - (let* ((wind-to-delete (eval - (ediff-get-symbol-from-alist - (car possibilities) - ediff-window-alist))) - (frame (window-frame wind-to-delete))) - (delete-window wind-to-delete) - (select-frame frame) - (balance-windows)))) - (or (y-or-n-p - "Please check regions selected for comparison. Continue? ") - (setq quit-now t)) - - (ediff-with-current-buffer bufA - (widen)) - (ediff-with-current-buffer bufB - (widen)) - (if quit-now - (ediff-with-current-buffer ctl-buf - (ediff-recenter) - (sit-for 0) - (error "All right. Make up your mind and come back..."))) - - (ediff-regions-internal - bufA begA endA bufB begB endB - nil ; setup-hook - 'ediff-regions-linewise ; job name - nil ; no word mode - ;; setup param to pass to ediff-setup - (list (cons 'ediff-split-window-function ediff-split-window-function))) - )) - - - -(defun ediff-remove-flags-from-buffer (buffer overlay) - (ediff-with-current-buffer buffer - (let ((inhibit-read-only t)) - (if ediff-xemacs-p - (ediff-overlay-put overlay 'begin-glyph nil) - (ediff-overlay-put overlay 'before-string nil)) - - (if ediff-xemacs-p - (ediff-overlay-put overlay 'end-glyph nil) - (ediff-overlay-put overlay 'after-string nil)) - ))) - - - -(defun ediff-place-flags-in-buffer (buf-type buffer ctl-buffer diff) - (ediff-with-current-buffer buffer - (ediff-place-flags-in-buffer1 buf-type ctl-buffer diff))) - - -(defun ediff-place-flags-in-buffer1 (buf-type ctl-buffer diff-no) - (let* ((curr-overl (ediff-with-current-buffer ctl-buffer - (ediff-get-diff-overlay diff-no buf-type))) - (before (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer)) - after beg-of-line flag) - - ;; insert flag before the difference - (goto-char before) - (setq beg-of-line (bolp)) - - (setq flag (ediff-with-current-buffer ctl-buffer - (if (eq ediff-highlighting-style 'ascii) - (if beg-of-line - ediff-before-flag-bol ediff-before-flag-mol)))) - - ;; insert the flag itself - (if ediff-xemacs-p - (ediff-overlay-put curr-overl 'begin-glyph flag) - (ediff-overlay-put curr-overl 'before-string flag)) - - ;; insert the flag after the difference - ;; `after' must be set here, after the before-flag was inserted - (setq after (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer)) - (goto-char after) - (setq beg-of-line (bolp)) - - (setq flag (ediff-with-current-buffer ctl-buffer - (if (eq ediff-highlighting-style 'ascii) - (if beg-of-line - ediff-after-flag-eol ediff-after-flag-mol)))) - - ;; insert the flag itself - (if ediff-xemacs-p - (ediff-overlay-put curr-overl 'end-glyph flag) - (ediff-overlay-put curr-overl 'after-string flag)) - )) - - -;; Returns positions of difference sectors in the BUF-TYPE buffer. -;; BUF-TYPE should be a symbol -- `A', `B', or `C'. -;; POS is either `beg' or `end'--it specifies whether you want the position at -;; the beginning of a difference or at the end. -;; -;; The optional argument N says which difference (default: -;; `ediff-current-difference'). N is the internal difference number (1- what -;; the user sees). The optional argument CONTROL-BUF says -;; which control buffer is in effect in case it is not the current -;; buffer. -(defun ediff-get-diff-posn (buf-type pos &optional n control-buf) - (let (diff-overlay) - (or control-buf - (setq control-buf (current-buffer))) - - (ediff-with-current-buffer control-buf - (or n (setq n ediff-current-difference)) - (if (or (< n 0) (>= n ediff-number-of-differences)) - (if (> ediff-number-of-differences 0) - (error ediff-BAD-DIFF-NUMBER - this-command (1+ n) ediff-number-of-differences) - (error ediff-NO-DIFFERENCES))) - (setq diff-overlay (ediff-get-diff-overlay n buf-type))) - (if (not (ediff-buffer-live-p (ediff-overlay-buffer diff-overlay))) - (error ediff-KILLED-VITAL-BUFFER)) - (if (eq pos 'beg) - (ediff-overlay-start diff-overlay) - (ediff-overlay-end diff-overlay)) - )) - - -;; Restore highlighting to what it should be according to ediff-use-faces, -;; ediff-highlighting-style, and ediff-highlight-all-diffs variables. -(defun ediff-restore-highlighting (&optional ctl-buf) - (ediff-with-current-buffer (or ctl-buf (current-buffer)) - (if (and (ediff-has-face-support-p) - ediff-use-faces - ediff-highlight-all-diffs) - (ediff-paint-background-regions)) - (ediff-select-difference ediff-current-difference))) - - - -;; null out difference overlays so they won't slow down future -;; editing operations -;; VEC is either a difference vector or a fine-diff vector -(defun ediff-clear-diff-vector (vec-var &optional fine-diffs-also) - (if (vectorp (symbol-value vec-var)) - (mapcar (function - (lambda (elt) - (ediff-delete-overlay - (ediff-get-diff-overlay-from-diff-record elt)) - (if fine-diffs-also - (ediff-clear-fine-diff-vector elt)) - )) - (symbol-value vec-var))) - ;; allow them to be garbage collected - (set vec-var nil)) - - - -;;; Misc - -;; In Emacs, this just makes overlay. In the future, when Emacs will start -;; supporting sticky overlays, this function will make a sticky overlay. -;; BEG and END are expressions telling where overlay starts. -;; If they are numbers or buffers, then all is well. Otherwise, they must -;; be expressions to be evaluated in buffer BUF in order to get the overlay -;; bounds. -;; If BUFF is not a live buffer, then return nil; otherwise, return the -;; newly created overlay. -(defun ediff-make-bullet-proof-overlay (beg end buff) - (if (ediff-buffer-live-p buff) - (let (overl) - (ediff-with-current-buffer buff - (or (number-or-marker-p beg) - (setq beg (eval beg))) - (or (number-or-marker-p end) - (setq end (eval end))) - (setq overl - (if ediff-xemacs-p - (make-extent beg end buff) - ;; advance front and rear of the overlay - (make-overlay beg end buff nil 'rear-advance))) - - ;; never detach - (ediff-overlay-put - overl (if ediff-emacs-p 'evaporate 'detachable) nil) - ;; make vip-minibuffer-overlay open-ended - ;; In emacs, it is made open ended at creation time - (if ediff-xemacs-p - (progn - (ediff-overlay-put overl 'start-open nil) - (ediff-overlay-put overl 'end-open nil))) - (ediff-overlay-put overl 'ediff-diff-num 0) - overl)))) - - -;; Like other-buffer, but prefers visible buffers and ignores temporary or -;; other insignificant buffers (those beginning with "^[ *]"). -;; Gets one arg--buffer name or a list of buffer names (it won't return -;; these buffers). -(defun ediff-other-buffer (buff-lst) - (or (listp buff-lst) (setq buff-lst (list buff-lst))) - (let* ((frame-buffers (buffer-list)) - (buff-name-list - (mapcar - (function (lambda (b) - (cond ((stringp b) b) - ((bufferp b) (buffer-name b))))) - buff-lst)) - (significant-buffers - (mapcar - (function (lambda (x) - (cond ((member (buffer-name x) buff-name-list) nil) - ((not (ediff-get-visible-buffer-window x)) nil) - ((string-match "^[ *]" (buffer-name x)) nil) - ((memq (ediff-with-current-buffer x major-mode) - '(dired-mode)) - nil) - (t x)))) - frame-buffers)) - (buffers (delq nil significant-buffers)) - less-significant-buffers) - - (cond (buffers (car buffers)) - ;; try also buffers that are not displayed in windows - ((setq less-significant-buffers - (delq nil - (mapcar - (function - (lambda (x) - (cond ((member (buffer-name x) buff-name-list) nil) - ((string-match "^[ *]" (buffer-name x)) nil) - ((memq - (ediff-with-current-buffer x major-mode) - '(dired-mode)) - nil) - (t x)))) - frame-buffers))) - (car less-significant-buffers)) - (t (other-buffer (current-buffer)))) - )) - - -;; Construct a unique buffer name. -;; The first one tried is prefixsuffix, then prefix<2>suffix, -;; prefix<3>suffix, etc. -(defun ediff-unique-buffer-name (prefix suffix) - (if (null (get-buffer (concat prefix suffix))) - (concat prefix suffix) - (let ((n 2)) - (while (get-buffer (format "%s<%d>%s" prefix n suffix)) - (setq n (1+ n))) - (format "%s<%d>%s" prefix n suffix)))) - - -(defun ediff-submit-report () - "Submit bug report on Ediff." - (interactive) - (ediff-barf-if-not-control-buffer) - (let ((reporter-prompt-for-summary-p t) - (ctl-buf ediff-control-buffer) - (ediff-device-type (ediff-device-type)) - varlist salutation buffer-name) - (setq varlist '(ediff-diff-program ediff-diff-options - ediff-patch-program ediff-patch-options - ediff-shell - ediff-use-faces - ediff-auto-refine ediff-highlighting-style - ediff-buffer-A ediff-buffer-B ediff-control-buffer - ediff-forward-word-function - ediff-control-frame - ediff-control-frame-parameters - ediff-control-frame-position-function - ediff-prefer-iconified-control-frame - ediff-window-setup-function - ediff-split-window-function - ediff-job-name - ediff-word-mode - buffer-name - ediff-device-type - )) - (setq salutation " -Congratulations! You may have unearthed a bug in Ediff! - -Please make a concise and accurate summary of what happened -and mail it to the address above. ------------------------------------------------------------ -") - - (ediff-skip-unsuitable-frames) - (ediff-reset-mouse) - - (switch-to-buffer ediff-msg-buffer) - (erase-buffer) - (delete-other-windows) - (insert " -Please read this first: ----------------------- - -Some ``bugs'' may actually be no bugs at all. For instance, if you are -reporting that certain difference regions are not matched as you think they -should, this is most likely due to the way Unix diff program decides what -constitutes a difference region. Ediff is an Emacs interface to diff, and -it has nothing to do with those decisions---it only takes the output from -diff and presents it in a way that is better suited for human browsing and -manipulation. - -If Emacs happens to dump core, this is NOT an Ediff problem---it is -an Emacs bug. Report this to Emacs maintainers. - -Another popular topic for reports is compilation messages. Because Ediff -interfaces to several other packages and runs under Emacs and XEmacs, -byte-compilation may produce output like this: - - While compiling toplevel forms in file ediff.el: - ** reference to free variable pm-color-alist - ........................ - While compiling the end of the data: - ** The following functions are not known to be defined: - ediff-valid-color-p, ediff-set-face, - ........................ - -These are NOT errors, but inevitable warnings, which ought to be ignored. - -Please do not report those and similar things. However, comments and -suggestions are always welcome. - -Mail anyway? (y or n) ") - - (if (y-or-n-p "Mail anyway? ") - (progn - (if (ediff-buffer-live-p ctl-buf) - (set-buffer ctl-buf)) - (setq buffer-name (buffer-name)) - (require 'reporter) - (reporter-submit-bug-report "kifer@cs.sunysb.edu" - (ediff-version) - varlist - nil - 'delete-other-windows - salutation)) - (bury-buffer) - (beep 1)(message "Bug report aborted") - (if (ediff-buffer-live-p ctl-buf) - (ediff-with-current-buffer ctl-buf - (ediff-recenter 'no-rehighlight)))) - )) - - -(defun ediff-deactivate-mark () - (if ediff-xemacs-p - (zmacs-deactivate-region) - (deactivate-mark))) -(defun ediff-activate-mark () - (if ediff-emacs-p - (setq mark-active t) - (zmacs-activate-region))) - -(cond ((fboundp 'nuke-selective-display) - ;; XEmacs 19.12 has nuke-selective-display - (fset 'ediff-nuke-selective-display 'nuke-selective-display)) - (t - (defun ediff-nuke-selective-display () - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((mod-p (buffer-modified-p)) - buffer-read-only end) - (and (eq t selective-display) - (while (search-forward "\^M" nil t) - (end-of-line) - (setq end (point)) - (beginning-of-line) - (while (search-forward "\^M" end t) - (delete-char -1) - (insert "\^J")))) - (set-buffer-modified-p mod-p) - (setq selective-display nil))))) - )) - - -;; The next two are modified versions from emerge.el. -;; VARS must be a list of symbols -;; ediff-save-variables returns an association list: ((var . val) ...) -(defsubst ediff-save-variables (vars) - (mapcar (function (lambda (v) (cons v (symbol-value v)))) - vars)) -;; VARS is a list of variable symbols. -(defun ediff-restore-variables (vars assoc-list) - (while vars - (set (car vars) (cdr (assoc (car vars) assoc-list))) - (setq vars (cdr vars)))) - -(defun ediff-change-saved-variable (var value buf-type) - (let* ((assoc-list - (symbol-value (ediff-get-symbol-from-alist - buf-type - ediff-buffer-values-orig-alist))) - (assoc-elt (assoc var assoc-list))) - (if assoc-elt - (setcdr assoc-elt value)))) - - -;; must execute in control buf -(defun ediff-save-protected-variables () - (setq ediff-buffer-values-orig-A - (ediff-with-current-buffer ediff-buffer-A - (ediff-save-variables ediff-protected-variables))) - (setq ediff-buffer-values-orig-B - (ediff-with-current-buffer ediff-buffer-B - (ediff-save-variables ediff-protected-variables))) - (if ediff-3way-comparison-job - (setq ediff-buffer-values-orig-C - (ediff-with-current-buffer ediff-buffer-C - (ediff-save-variables ediff-protected-variables)))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (setq ediff-buffer-values-orig-Ancestor - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-save-variables ediff-protected-variables))))) - -;; must execute in control buf -(defun ediff-restore-protected-variables () - (let ((values-A ediff-buffer-values-orig-A) - (values-B ediff-buffer-values-orig-B) - (values-C ediff-buffer-values-orig-C) - (values-Ancestor ediff-buffer-values-orig-Ancestor)) - (ediff-with-current-buffer ediff-buffer-A - (ediff-restore-variables ediff-protected-variables values-A)) - (ediff-with-current-buffer ediff-buffer-B - (ediff-restore-variables ediff-protected-variables values-B)) - (if ediff-3way-comparison-job - (ediff-with-current-buffer ediff-buffer-C - (ediff-restore-variables ediff-protected-variables values-C))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-restore-variables ediff-protected-variables values-Ancestor))) - )) - -;; save BUFFER in FILE. used in hooks. -(defun ediff-save-buffer-in-file (buffer file) - (ediff-with-current-buffer buffer - (write-file file))) - - -;;; Debug - -(ediff-defvar-local ediff-command-begin-time '(0 0 0) "") - -;; calculate time used by command -(defun ediff-calc-command-time () - (let ((end (current-time)) - micro sec) - (setq micro - (if (>= (nth 2 end) (nth 2 ediff-command-begin-time)) - (- (nth 2 end) (nth 2 ediff-command-begin-time)) - (+ (nth 2 end) (- 1000000 (nth 2 ediff-command-begin-time))))) - (setq sec (- (nth 1 end) (nth 1 ediff-command-begin-time))) - (or (equal ediff-command-begin-time '(0 0 0)) - (message "Elapsed time: %d second(s) + %d microsecond(s)" sec micro)))) - -(defsubst ediff-save-time () - (setq ediff-command-begin-time (current-time))) - -(defun ediff-profile () - "Toggle profiling Ediff commands." - (interactive) - (ediff-barf-if-not-control-buffer) - (make-local-hook 'post-command-hook) - (let ((pre-hook 'pre-command-hook) - (post-hook 'post-command-hook)) - (if (not (equal ediff-command-begin-time '(0 0 0))) - (progn (remove-hook pre-hook 'ediff-save-time) - (remove-hook post-hook 'ediff-calc-command-time) - (setq ediff-command-begin-time '(0 0 0)) - (message "Ediff profiling disabled")) - (add-hook pre-hook 'ediff-save-time t t) - (add-hook post-hook 'ediff-calc-command-time nil t) - (message "Ediff profiling enabled")))) - -(defun ediff-print-diff-vector (diff-vector-var) - (princ (format "\n*** %S ***\n" diff-vector-var)) - (mapcar (function - (lambda (overl-vec) - (princ - (format - "Diff %d: \tOverlay: %S -\t\tFine diffs: %s -\t\tNo-fine-diff-flag: %S -\t\tState-of-diff:\t %S -\t\tState-of-merge:\t %S -" - (1+ (ediff-overlay-get (aref overl-vec 0) 'ediff-diff-num)) - (aref overl-vec 0) - ;; fine-diff-vector - (if (= (length (aref overl-vec 1)) 0) - "none\n" - (mapconcat 'prin1-to-string - (aref overl-vec 1) "\n\t\t\t ")) - (aref overl-vec 2) ; no fine diff flag - (aref overl-vec 3) ; state-of-diff - (aref overl-vec 4) ; state-of-merge - )))) - (eval diff-vector-var))) - - - -(defun ediff-debug-info () - (interactive) - (ediff-barf-if-not-control-buffer) - (with-output-to-temp-buffer ediff-debug-buffer - (princ (format "\nCtl buffer: %S\n" ediff-control-buffer)) - (ediff-print-diff-vector (intern "ediff-difference-vector-A")) - (ediff-print-diff-vector (intern "ediff-difference-vector-B")) - (ediff-print-diff-vector (intern "ediff-difference-vector-C")) - (ediff-print-diff-vector (intern "ediff-difference-vector-Ancestor")) - )) - - -;;; General utilities - -;; this uses comparison-func to decide who is a member -(defun ediff-member (elt lis comparison-func) - (while (and lis (not (funcall comparison-func (car lis) elt))) - (setq lis (cdr lis))) - lis) - -;; this uses comparison-func to decide who is a member, and this determines how -;; intersection looks like -(defun ediff-intersection (lis1 lis2 comparison-func) - (let ((result (list 'a))) - (while lis1 - (if (ediff-member (car lis1) lis2 comparison-func) - (nconc result (list (car lis1)))) - (setq lis1 (cdr lis1))) - (cdr result))) - - -;; eliminates duplicates using comparison-func -(defun ediff-union (lis1 lis2 comparison-func) - (let ((result (list 'a))) - (while lis1 - (or (ediff-member (car lis1) (cdr result) comparison-func) - (nconc result (list (car lis1)))) - (setq lis1 (cdr lis1))) - (while lis2 - (or (ediff-member (car lis2) (cdr result) comparison-func) - (nconc result (list (car lis2)))) - (setq lis2 (cdr lis2))) - (cdr result))) - -;; eliminates duplicates using comparison-func -(defun ediff-set-difference (lis1 lis2 comparison-func) - (let ((result (list 'a))) - (while lis1 - (or (ediff-member (car lis1) (cdr result) comparison-func) - (ediff-member (car lis1) lis2 comparison-func) - (nconc result (list (car lis1)))) - (setq lis1 (cdr lis1))) - (cdr result))) - -(defun ediff-copy-list (list) - (if (consp list) - ;;;(let ((res nil)) - ;;; (while (consp list) (push (pop list) res)) - ;;; (prog1 (nreverse res) (setcdr res list))) - (let (res elt) - (while (consp list) - (setq elt (car list) - res (cons elt res) - list (cdr list))) - (nreverse res)) - (car list))) - - -;; don't report error if version control package wasn't found -;;(ediff-load-version-control 'silent) - -(run-hooks 'ediff-load-hook) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-util.el ends here
--- a/lisp/ediff/ediff-vers.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,368 +0,0 @@ -;;; ediff-vers.el --- version control interface to Ediff - -;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;;; Code: - -;; Compiler pacifier -(defvar rcs-default-co-switches) -(defvar sc-mode) -(defvar cvs-shell) -(defvar cvs-program) -(defvar cvs-cookie-handle) -(defvar ediff-temp-file-prefix) - -(and noninteractive - (eval-when-compile - (load "pcl-cvs" 'noerror) - (load "rcs" 'noerror) - (load "generic-sc" 'noerror) - (load "vc" 'noerror))) -;; end pacifier - -;; VC.el support -(defun ediff-vc-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then compare current buffer with REV1. -;; If the current buffer is named `F', the version is named `F.~REV~'. -;; If `F.~REV~' already exists, it is used instead of being re-created. - (let (file1 file2 rev1buf rev2buf) - (save-excursion - (vc-version-other-window rev1) - (setq rev1buf (current-buffer) - file1 (buffer-file-name))) - (save-excursion - (or (string= rev2 "") ; use current buffer - (vc-version-other-window rev2)) - (setq rev2buf (current-buffer) - file2 (buffer-file-name))) - (setq startup-hooks - (cons (` (lambda () - (delete-file (, file1)) - (or (, (string= rev2 "")) (delete-file (, file2))) - )) - startup-hooks)) - (ediff-buffers - rev1buf rev2buf - startup-hooks - 'ediff-revision))) - -;; RCS.el support -(defun rcs-ediff-view-revision (&optional rev) -;; View previous RCS revision of current file. -;; With prefix argument, prompts for a revision name. - (interactive (list (if current-prefix-arg - (read-string "Revision: ")))) - (let* ((filename (buffer-file-name (current-buffer))) - (switches (append '("-p") - (if rev (list (concat "-r" rev)) nil))) - (buff (concat (file-name-nondirectory filename) ".~" rev "~"))) - (message "Working ...") - (setq filename (expand-file-name filename)) - (with-output-to-temp-buffer buff - (let ((output-buffer (ediff-rcs-get-output-buffer filename buff))) - (delete-windows-on output-buffer) - (save-excursion - (set-buffer output-buffer) - (apply 'call-process "co" nil t nil - ;; -q: quiet (no diagnostics) - (append switches rcs-default-co-switches - (list "-q" filename))))) - (message "") - buff))) - -(defun ediff-rcs-get-output-buffer (file name) - ;; Get a buffer for RCS output for FILE, make it writable and clean it up. - ;; Optional NAME is name to use instead of `*RCS-output*'. - ;; This is a modified version from rcs.el v1.1. I use it here to make - ;; Ediff immune to changes in rcs.el - (let* ((default-major-mode 'fundamental-mode) ; no frills! - (buf (get-buffer-create name))) - (save-excursion - (set-buffer buf) - (setq buffer-read-only nil - default-directory (file-name-directory (expand-file-name file))) - (erase-buffer)) - buf)) - -(defun ediff-rcs-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then use current buffer. - (let ((rev2buf (if (string= rev2 "") - (current-buffer) - (rcs-ediff-view-revision rev2))) - (rev1buf (rcs-ediff-view-revision rev1))) - - ;; rcs.el doesn't create temp version files, so we don't have to delete - ;; anything in startup hooks to ediff-buffers - (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision) - )) - - -;; GENERIC-SC.el support - -(defun generic-sc-get-latest-rev () - (cond ((eq sc-mode 'CCASE) - (eval "main/LATEST")) - (t (eval "")))) - -(defun ediff-generic-sc-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on versions of the current buffer. -;; If REV2 is "" then compare current buffer with REV1. -;; If the current buffer is named `F', the version is named `F.~REV~'. -;; If `F.~REV~' already exists, it is used instead of being re-created. - (let (rev1buf rev2buf) - (save-excursion - (if (or (not rev1) (string= rev1 "")) - (setq rev1 (generic-sc-get-latest-rev))) - (sc-visit-previous-revision rev1) - (setq rev1buf (current-buffer))) - (save-excursion - (or (string= rev2 "") ; use current buffer - (sc-visit-previous-revision rev2)) - (setq rev2buf (current-buffer))) - (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision))) - - -;;; Merge with Version Control - -(defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev &optional startup-hooks) -;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (save-excursion - (vc-version-other-window rev1) - (setq buf1 (current-buffer))) - (save-excursion - (or (string= rev2 "") - (vc-version-other-window rev2)) - (setq buf2 (current-buffer))) - (if ancestor-rev - (save-excursion - (or (string= ancestor-rev "") - (vc-version-other-window ancestor-rev)) - (setq ancestor-buf (current-buffer)))) - (setq startup-hooks - (cons - (` (lambda () - (delete-file (, (buffer-file-name buf1))) - (or (, (string= rev2 "")) - (delete-file (, (buffer-file-name buf2)))) - (or (, (string= ancestor-rev "")) - (, (not ancestor-rev)) - (delete-file (, (buffer-file-name ancestor-buf)))) - )) - startup-hooks)) - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions)) - )) - -(defun ediff-rcs-merge-internal (rev1 rev2 ancestor-rev - &optional startup-hooks) - ;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (setq buf1 (rcs-ediff-view-revision rev1) - buf2 (if (string= rev2 "") - (current-buffer) - (rcs-ediff-view-revision rev2)) - ancestor-buf (if ancestor-rev - (if (string= ancestor-rev "") - (current-buffer) - (rcs-ediff-view-revision ancestor-rev)))) - ;; rcs.el doesn't create temp version files, so we don't have to delete - ;; anything in startup hooks to ediff-buffers - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions)))) - -(defun ediff-generic-sc-merge-internal (rev1 rev2 ancestor-rev - &optional startup-hooks) - ;; If ANCESTOR-REV non-nil, merge with ancestor - (let (buf1 buf2 ancestor-buf) - (save-excursion - (if (string= rev1 "") - (setq rev1 (generic-sc-get-latest-rev))) - (sc-visit-previous-revision rev1) - (setq buf1 (current-buffer))) - (save-excursion - (or (string= rev2 "") - (sc-visit-previous-revision rev2)) - (setq buf2 (current-buffer))) - (if ancestor-rev - (save-excursion - (or (string= ancestor-rev "") - (sc-visit-previous-revision ancestor-rev)) - (setq ancestor-buf (current-buffer)))) - (if ancestor-rev - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf - startup-hooks 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers buf1 buf2 startup-hooks 'ediff-merge-revisions)))) - - -;; PCL-CVS.el support - -(defun ediff-pcl-cvs-internal (rev1 rev2 &optional startup-hooks) -;; Run Ediff on a pair of revisions of the current buffer. -;; If REV1 is "", use the latest revision. -;; If REV2 is "", use the current buffer as the second file to compare. - (let ((orig-buf (current-buffer)) - orig-file-name buf1 buf2 file1 file2) - - (or (setq orig-file-name (buffer-file-name (current-buffer))) - (error "Current buffer is not visiting any file")) - (if (string= rev1 "") (setq rev1 nil)) ; latest revision - (setq buf1 (ediff-pcl-cvs-view-revision orig-file-name rev1) - buf2 (if (string= rev2 "") - orig-buf - (ediff-pcl-cvs-view-revision orig-file-name rev2)) - file1 (buffer-file-name buf1) - file2 (buffer-file-name buf2)) - (setq startup-hooks - (cons (` (lambda () - (delete-file (, file1)) - (or (, (string= rev2 "")) (delete-file (, file2))) - )) - startup-hooks)) - (ediff-buffers buf1 buf2 startup-hooks 'ediff-revision))) - -;; This function is the standard Ediff's interface to pcl-cvs. -;; Works like with other interfaces: runs ediff on versions of the file in the -;; current buffer. -(defun ediff-pcl-cvs-merge-internal (rev1 rev2 ancestor-rev - &optional startup-hooks) -;; Ediff-merge appropriate revisions of the selected file. -;; If REV1 is "" then use the latest revision. -;; If REV2 is "" then merge current buffer's file with REV1. -;; If ANCESTOR-REV is "" then use current buffer's file as ancestor. -;; If ANCESTOR-REV is nil, then merge without the ancestor. - (let ((orig-buf (current-buffer)) - orig-file-name buf1 buf2 ancestor-buf) - - (or (setq orig-file-name (buffer-file-name (current-buffer))) - (error "Current buffer is not visiting any file")) - (if (string= rev1 "") (setq rev1 nil)) ; latest revision - - (setq buf1 (ediff-pcl-cvs-view-revision orig-file-name rev1)) - (setq buf2 (if (string= rev2 "") - orig-buf - (ediff-pcl-cvs-view-revision orig-file-name rev2))) - (if (stringp ancestor-rev) - (setq ancestor-buf - (if (string= ancestor-rev "") - orig-buf - (ediff-pcl-cvs-view-revision orig-file-name ancestor-rev)))) - - (setq startup-hooks - (cons - (` (lambda () - (delete-file (, (buffer-file-name buf1))) - (or (, (string= rev2 "")) - (delete-file (, (buffer-file-name buf2)))) - (or (, (string= ancestor-rev "")) - (, (not ancestor-rev)) - (delete-file (, (buffer-file-name ancestor-buf)))) - )) - startup-hooks)) - - (if ancestor-buf - (ediff-merge-buffers-with-ancestor - buf1 buf2 ancestor-buf startup-hooks - 'ediff-merge-revisions-with-ancestor) - (ediff-merge-buffers - buf1 buf2 startup-hooks 'ediff-merge-revisions)) - )) - -(defun ediff-pcl-cvs-view-revision (file rev) -;; if rev = "", get the latest revision - (let ((temp-name (make-temp-name - (concat ediff-temp-file-prefix - "ediff_" rev)))) - (cvs-kill-buffer-visiting temp-name) - (if rev - (message "Retrieving revision %s..." rev) - (message "Retrieving latest revision...")) - (let ((res (call-process cvs-shell nil nil nil "-c" - (concat cvs-program " update -p " - (if rev - (concat "-r " rev " ") - "") - file - " > " temp-name)))) - (if (and res (not (and (integerp res) (zerop res)))) - (error "Failed to retrieve revision: %s" res)) - - (if rev - (message "Retrieving revision %s... Done." rev) - (message "Retrieving latest revision... Done.")) - (find-file-noselect temp-name)))) - - -(defun cvs-run-ediff-on-file-descriptor (tin) -;; This is a replacement for cvs-emerge-mode -;; Run after cvs-update. -;; Ediff-merge appropriate revisions of the selected file. - (let* ((fileinfo (tin-cookie cvs-cookie-handle tin)) - (type (cvs-fileinfo->type fileinfo)) - (tmp-file - (cvs-retrieve-revision-to-tmpfile fileinfo)) - ancestor-file) - - (or (memq type '(MERGED CONFLICT MODIFIED)) - (error - "Can only merge `Modified', `Merged' or `Conflict' files")) - - (cond ((memq type '(MERGED CONFLICT)) - (setq ancestor-file - (cvs-retrieve-revision-to-tmpfile - fileinfo - ;; revision - (cvs-fileinfo->base-revision fileinfo))) - (ediff-merge-buffers-with-ancestor - (find-file-noselect tmp-file) - (find-file-noselect (cvs-fileinfo->backup-file fileinfo)) - (find-file-noselect ancestor-file) - nil ; startup-hooks - 'ediff-merge-revisions-with-ancestor)) - ((eq type 'MODIFIED) - (ediff-merge-buffers - (find-file-noselect tmp-file) - (find-file-noselect (cvs-fileinfo->full-path fileinfo)) - nil ; startup-hooks - 'ediff-merge-revisions))) - (if (stringp tmp-file) (delete-file tmp-file)) - (if (stringp ancestor-file) (delete-file ancestor-file)))) - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -(provide 'ediff-vers) - -;;; ediff-vers.el ends here
--- a/lisp/ediff/ediff-wind.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1276 +0,0 @@ -;;; ediff-wind.el --- window manipulation utilities - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(provide 'ediff-wind) - -;; Compiler pacifier -(defvar icon-title-format) -(defvar top-toolbar-height) -(defvar bottom-toolbar-height) -(defvar left-toolbar-height) -(defvar right-toolbar-height) -(defvar left-toolbar-width) -(defvar right-toolbar-width) -(defvar default-menubar) -(defvar frame-icon-title-format) -(defvar ediff-diff-status) - -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) - (or (featurep 'ediff-help) - (load "ediff-help.el" nil nil 'nosuffix)) - (or (featurep 'ediff-tbar) - (load "ediff-tbar.el" 'noerror nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) - -;; be careful with ediff-tbar -(if ediff-xemacs-p - (condition-case nil - (require 'ediff-tbar) - (error - (defun ediff-compute-toolbar-width () 0))) - (defun ediff-compute-toolbar-width () 0)) - -(defgroup ediff-window nil - "Ediff window manipulation" - :prefix "ediff-" - :group 'ediff - :group 'frames) - - -(defcustom ediff-window-setup-function (if (ediff-window-display-p) - 'ediff-setup-windows-multiframe - 'ediff-setup-windows-plain) - "*Function called to set up windows. -Ediff provides a choice of two functions: ediff-setup-windows-plain, for -doing everything in one frame, and ediff-setup-windows-multiframe, -which sets the control panel in a separate frame. Also, if the latter -function detects that one of the buffers A/B is seen in some other frame, -it will try to keep that buffer in that frame. - -If you don't like the two functions provided---write your own one. -The basic guidelines: - 1. It should leave the control buffer current and the control window - selected. - 2. It should set ediff-window-A, ediff-window-B, ediff-window-C, - and ediff-control-window to contain window objects that display - the corresponding buffers. - 3. It should accept the following arguments: - buffer-A, buffer-B, buffer-C, control-buffer - Buffer C may not be used in jobs that compare only two buffers. -If you plan to do something fancy, take a close look at how the two -provided functions are written." - :type 'function - :group 'ediff-window) - -;; indicates if we are in a multiframe setup -(ediff-defvar-local ediff-multiframe nil "") - -;; Share of the frame occupied by the merge window (buffer C) -(ediff-defvar-local ediff-merge-window-share 0.45 "") - -;; The control window. -(ediff-defvar-local ediff-control-window nil "") -;; Official window for buffer A -(ediff-defvar-local ediff-window-A nil "") -;; Official window for buffer B -(ediff-defvar-local ediff-window-B nil "") -;; Official window for buffer C -(ediff-defvar-local ediff-window-C nil "") -;; Ediff's window configuration. -;; Used to minimize the need to rearrange windows. -(ediff-defvar-local ediff-window-config-saved "" "") - -;; Association between buff-type and ediff-window-* -(defconst ediff-window-alist - '((A . ediff-window-A) - (?A . ediff-window-A) - (B . ediff-window-B) - (?B . ediff-window-B) - (C . ediff-window-C) - (?C . ediff-window-C))) - - -(defcustom ediff-split-window-function 'split-window-vertically - "*The function used to split the main window between buffer-A and buffer-B. -You can set it to a horizontal split instead of the default vertical split -by setting this variable to `split-window-horizontally'. -You can also have your own function to do fancy splits. -This variable has no effect when buffer-A/B are shown in different frames. -In this case, Ediff will use those frames to display these buffers." - :type 'function - :group 'ediff-window) - -(defcustom ediff-merge-split-window-function 'split-window-horizontally - "*The function used to split the main window between buffer-A and buffer-B. -You can set it to a vertical split instead of the default horizontal split -by setting this variable to `split-window-vertically'. -You can also have your own function to do fancy splits. -This variable has no effect when buffer-A/B/C are shown in different frames. -In this case, Ediff will use those frames to display these buffers." - :type 'function - :group 'ediff-window) - -(defconst ediff-control-frame-parameters - (list - '(name . "Ediff") - ;;'(unsplittable . t) - '(minibuffer . nil) - '(user-position . t) ; Emacs only - '(vertical-scroll-bars . nil) ; Emacs only - '(scrollbar-width . 0) ; XEmacs only - '(menu-bar-lines . 0) ; Emacs only - ;; don't lower and auto-raise - '(auto-lower . nil) - '(auto-raise . t) - ;; this blocks queries from window manager as to where to put - ;; ediff's control frame. we put the frame outside the display, - ;; so the initial frame won't jump all over the screen - (cons 'top (if (fboundp 'ediff-display-pixel-height) - (1+ (ediff-display-pixel-height)) - 3000)) - (cons 'left (if (fboundp 'ediff-display-pixel-width) - (1+ (ediff-display-pixel-width)) - 3000)) - ) - "Frame parameters for displaying Ediff Control Panel. -Do not specify width and height here. These are computed automatically.") - -;; position of the mouse; used to decide whether to warp the mouse into ctl -;; frame -(ediff-defvar-local ediff-mouse-pixel-position nil "") - -;; not used for now -(defvar ediff-mouse-pixel-threshold 30 - "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.") - -(defcustom ediff-grab-mouse t - "*If t, Ediff will always grab the mouse and put it in the control frame. -If 'maybe, Ediff will do it sometimes, but not after operations that require -relatively long time. If nil, the mouse will be entirely user's -responsibility." - :type 'boolean - :group 'ediff-window) - -(defcustom ediff-control-frame-position-function 'ediff-make-frame-position - "Function to call to determine the desired location for the control panel. -Expects three parameters: the control buffer, the desired width and height -of the control frame. It returns an association list -of the form \(\(top . <position>\) \(left . <position>\)\)" - :type 'function - :group 'ediff-window) - -(defcustom ediff-control-frame-upward-shift (if ediff-xemacs-p 42 14) - "*The upward shift of control frame from the top of buffer A's frame. -Measured in pixels. -This is used by the default control frame positioning function, -`ediff-make-frame-position'. This variable is provided for easy -customization of the default." - :type 'integer - :group 'ediff-window) - -(defcustom ediff-narrow-control-frame-leftward-shift (if ediff-xemacs-p 7 3) - "*The leftward shift of control frame from the right edge of buf A's frame. -Measured in characters. -This is used by the default control frame positioning function, -`ediff-make-frame-position' to adjust the position of the control frame -when it shows the short menu. This variable is provided for easy -customization of the default." - :type 'integer - :group 'ediff-window) - -(defcustom ediff-wide-control-frame-rightward-shift 7 - "*The rightward shift of control frame from the left edge of buf A's frame. -Measured in characters. -This is used by the default control frame positioning function, -`ediff-make-frame-position' to adjust the position of the control frame -when it shows the full menu. This variable is provided for easy -customization of the default." - :type 'integer - :group 'ediff-window) - - -;; Wide frame display - -;; t means Ediff is using wide display -(ediff-defvar-local ediff-wide-display-p nil "") -;; keeps frame config for toggling wide display -(ediff-defvar-local ediff-wide-display-orig-parameters nil - "Frame parameters to be restored when the user wants to toggle the wide -display off.") -(ediff-defvar-local ediff-wide-display-frame nil - "Frame to be used for wide display.") -(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display - "The value is a function that is called to create a wide display. -The function is called without arguments. It should resize the frame in -which buffers A, B, and C are to be displayed, and it should save the old -frame parameters in `ediff-wide-display-orig-parameters'. -The variable `ediff-wide-display-frame' should be set to contain -the frame used for the wide display.") - -;; Frame used for the control panel in a windowing system. -(ediff-defvar-local ediff-control-frame nil "") - -(defcustom ediff-prefer-iconified-control-frame nil - "*If t, keep control panel iconified when help message is off. -This has effect only on a windowing system. -If t, hitting `?' to toggle control panel off iconifies it. - -This is only useful in Emacs and only for certain kinds of window managers, -such as TWM and its derivatives, since the window manager must permit -keyboard input to go into icons. XEmacs completely ignores keyboard input -into icons, regardless of the window manager." - :type 'boolean - :group 'ediff-window) - -;;; Functions - -(defun ediff-get-window-by-clicking (wind prev-wind wind-number) - (let (event) - (message - "Select windows by clicking. Please click on Window %d " wind-number) - (while (not (ediff-mouse-event-p (setq event (ediff-read-event)))) - (if (sit-for 1) ; if sequence of events, wait till the final word - (beep 1)) - (message "Please click on Window %d " wind-number)) - (ediff-read-event) ; discard event - (setq wind (if ediff-xemacs-p - (event-window event) - (posn-window (event-start event)))) - )) - - -;; Select the lowest window on the frame. -(defun ediff-select-lowest-window () - (if ediff-xemacs-p - (select-window (frame-lowest-window)) - (let* ((lowest-window (selected-window)) - (bottom-edge (car (cdr (cdr (cdr (window-edges)))))) - (last-window (save-excursion - (other-window -1) (selected-window))) - (window-search t)) - (while window-search - (let* ((this-window (next-window)) - (next-bottom-edge - (car (cdr (cdr (cdr (window-edges this-window))))))) - (if (< bottom-edge next-bottom-edge) - (progn - (setq bottom-edge next-bottom-edge) - (setq lowest-window this-window))) - - (select-window this-window) - (if (eq last-window this-window) - (progn - (select-window lowest-window) - (setq window-search nil)))))))) - - -;;; Common window setup routines - -;; Set up the window configuration. If POS is given, set the points to -;; the beginnings of the buffers. -;; When 3way comparison is added, this will have to choose the appropriate -;; setup function based on ediff-job-name -(defun ediff-setup-windows (buffer-A buffer-B buffer-C control-buffer) - ;; Make sure we are not in the minibuffer window when we try to delete - ;; all other windows. - (run-hooks 'ediff-before-setup-windows-hook) - (if (eq (selected-window) (minibuffer-window)) - (other-window 1)) - - ;; in case user did a no-no on a tty - (or (ediff-window-display-p) - (setq ediff-window-setup-function 'ediff-setup-windows-plain)) - - (or (ediff-keep-window-config control-buffer) - (funcall - (ediff-with-current-buffer control-buffer ediff-window-setup-function) - buffer-A buffer-B buffer-C control-buffer)) - (run-hooks 'ediff-after-setup-windows-hook)) - -;; Just set up 3 windows. -;; Usually used without windowing systems -;; With windowing, we want to use dedicated frames. -(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer) - (ediff-with-current-buffer control-buffer - (setq ediff-multiframe nil)) - (if ediff-merge-job - (ediff-setup-windows-plain-merge - buffer-A buffer-B buffer-C control-buffer) - (ediff-setup-windows-plain-compare - buffer-A buffer-B buffer-C control-buffer))) - -(defun ediff-setup-windows-plain-merge (buf-A buf-B buf-C control-buffer) - ;; skip dedicated and unsplittable frames - (ediff-destroy-control-frame control-buffer) - (let ((window-min-height 1) - split-window-function - merge-window-share merge-window-lines - wind-A wind-B wind-C) - (ediff-with-current-buffer control-buffer - (setq merge-window-share ediff-merge-window-share - ;; this lets us have local versions of ediff-split-window-function - split-window-function ediff-split-window-function)) - (delete-other-windows) - (split-window-vertically) - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - - ;; go to the upper window and split it betw A, B, and possibly C - (other-window 1) - (setq merge-window-lines - (max 2 (round (* (window-height) merge-window-share)))) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - - ;; XEmacs used to have a lot of trouble with display - ;; It did't set things right unless we tell it to sit still - ;; 19.12 seems ok. - ;;(if ediff-xemacs-p (sit-for 0)) - - (split-window-vertically (max 2 (- (window-height) merge-window-lines))) - (if (eq (selected-window) wind-A) - (other-window 1)) - (setq wind-C (selected-window)) - (switch-to-buffer buf-C) - - (select-window wind-A) - (funcall split-window-function) - - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (ediff-with-current-buffer control-buffer - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C)) - - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - )) - - -;; This function handles all comparison jobs, including 3way jobs -(defun ediff-setup-windows-plain-compare (buf-A buf-B buf-C control-buffer) - ;; skip dedicated and unsplittable frames - (ediff-destroy-control-frame control-buffer) - (let ((window-min-height 1) - split-window-function wind-width-or-height - three-way-comparison - wind-A-start wind-B-start wind-A wind-B wind-C) - (ediff-with-current-buffer control-buffer - (setq wind-A-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds)) - wind-B-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds)) - ;; this lets us have local versions of ediff-split-window-function - split-window-function ediff-split-window-function - three-way-comparison ediff-3way-comparison-job)) - (delete-other-windows) - (split-window-vertically) - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - - ;; go to the upper window and split it betw A, B, and possibly C - (other-window 1) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - (if three-way-comparison - (setq wind-width-or-height - (/ (if (eq split-window-function 'split-window-vertically) - (window-height wind-A) - (window-width wind-A)) - 3))) - - ;; XEmacs used to have a lot of trouble with display - ;; It did't set things right unless we told it to sit still - ;; 19.12 seems ok. - ;;(if ediff-xemacs-p (sit-for 0)) - - (funcall split-window-function wind-width-or-height) - - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (if three-way-comparison - (progn - (funcall split-window-function) ; equally - (if (eq (selected-window) wind-B) - (other-window 1)) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)))) - - (ediff-with-current-buffer control-buffer - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C)) - - ;; It is unlikely that we will want to implement 3way window comparison. - ;; So, only buffers A and B are used here. - (if ediff-windows-job - (progn - (set-window-start wind-A wind-A-start) - (set-window-start wind-B wind-B-start))) - - (ediff-select-lowest-window) - (ediff-setup-control-buffer control-buffer) - )) - - -;; dispatch an appropriate window setup function -(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf) - (ediff-with-current-buffer control-buf - (setq ediff-multiframe t)) - (if ediff-merge-job - (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf) - (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf))) - -(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; 1. Never use frames that have dedicated windows in them---it is bad to -;;; destroy dedicated windows. -;;; 2. If A and B are in the same frame but C's frame is different--- use one -;;; frame for A and B and use a separate frame for C. -;;; 3. If C's frame is non-existent, then: if the first suitable -;;; non-dedicated frame is different from A&B's, then use it for C. -;;; Otherwise, put A,B, and C in one frame. -;;; 4. If buffers A, B, C are is separate frames, use them to display these -;;; buffers. - - ;; Skip dedicated or iconified frames. - ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) - - (let* ((window-min-height 1) - (wind-A (ediff-get-visible-buffer-window buf-A)) - (wind-B (ediff-get-visible-buffer-window buf-B)) - (wind-C (ediff-get-visible-buffer-window buf-C)) - (frame-A (if wind-A (window-frame wind-A))) - (frame-B (if wind-B (window-frame wind-B))) - (frame-C (if wind-C (window-frame wind-C))) - ;; on wide display, do things in one frame - (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) - ;; this lets us have local versions of ediff-split-window-function - (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) - (orig-wind (selected-window)) - (orig-frame (selected-frame)) - (use-same-frame (or force-one-frame - ;; A and C must be in one frame - (eq frame-A (or frame-C orig-frame)) - ;; B and C must be in one frame - (eq frame-B (or frame-C orig-frame)) - ;; A or B is not visible - (not (frame-live-p frame-A)) - (not (frame-live-p frame-B)) - ;; A or B is not suitable for display - (not (ediff-window-ok-for-display wind-A)) - (not (ediff-window-ok-for-display wind-B)) - ;; A and B in the same frame, and no good frame - ;; for C - (and (eq frame-A frame-B) - (not (frame-live-p frame-C))) - )) - ;; use-same-frame-for-AB implies wind A and B are ok for display - (use-same-frame-for-AB (and (not use-same-frame) - (eq frame-A frame-B))) - (merge-window-share (ediff-with-current-buffer control-buf - ediff-merge-window-share)) - merge-window-lines - designated-minibuffer-frame - done-A done-B done-C) - - ;; buf-A on its own - (if (and (window-live-p wind-A) - (null use-same-frame) ; implies wind-A is suitable - (null use-same-frame-for-AB)) - (progn ; bug A on its own - ;; buffer buf-A is seen in live wind-A - (select-window wind-A) - (delete-other-windows) - (setq wind-A (selected-window)) - (setq done-A t))) - - ;; buf-B on its own - (if (and (window-live-p wind-B) - (null use-same-frame) ; implies wind-B is suitable - (null use-same-frame-for-AB)) - (progn ; buf B on its own - ;; buffer buf-B is seen in live wind-B - (select-window wind-B) - (delete-other-windows) - (setq wind-B (selected-window)) - (setq done-B t))) - - ;; buf-C on its own - (if (and (window-live-p wind-C) - (ediff-window-ok-for-display wind-C) - (null use-same-frame)) ; buf C on its own - (progn - ;; buffer buf-C is seen in live wind-C - (select-window wind-C) - (delete-other-windows) - (setq wind-C (selected-window)) - (setq done-C t))) - - (if (and use-same-frame-for-AB ; implies wind A and B are suitable - (window-live-p wind-A)) - (progn - ;; wind-A must already be displaying buf-A - (select-window wind-A) - (delete-other-windows) - (setq wind-A (selected-window)) - - (funcall split-window-function) - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (setq done-A t - done-B t))) - - (if use-same-frame - (let ((window-min-height 1)) - (if (and (eq frame-A frame-B) - (eq frame-B frame-C) - (frame-live-p frame-A)) - (select-frame frame-A) - ;; avoid dedicated and non-splittable windows - (ediff-skip-unsuitable-frames)) - (delete-other-windows) - (setq merge-window-lines - (max 2 (round (* (window-height) merge-window-share)))) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - - (split-window-vertically - (max 2 (- (window-height) merge-window-lines))) - (if (eq (selected-window) wind-A) - (other-window 1)) - (setq wind-C (selected-window)) - (switch-to-buffer buf-C) - - (select-window wind-A) - - (funcall split-window-function) - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (setq done-A t - done-B t - done-C t) - )) - - (or done-A ; Buf A to be set in its own frame, - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-A was not set up yet as it wasn't visible, - ;; and use-same-frame = nil, use-same-frame-for-AB = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - )) - (or done-B ; Buf B to be set in its own frame, - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-B was not set up yet as it wasn't visible - ;; and use-same-frame = nil, use-same-frame-for-AB = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - )) - - (or done-C ; Buf C to be set in its own frame, - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-C was not set up yet as it wasn't visible - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)) - )) - - (ediff-with-current-buffer control-buf - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C) - (setq frame-A (window-frame ediff-window-A) - designated-minibuffer-frame - (window-frame (minibuffer-window frame-A)))) - - (ediff-setup-control-frame control-buf designated-minibuffer-frame) - )) - - -;; Window setup for all comparison jobs, including 3way comparisons -(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; If a buffer is seen in a frame, use that frame for that buffer. -;;; If it is not seen, use the current frame. -;;; If both buffers are not seen, they share the current frame. If one -;;; of the buffers is not seen, it is placed in the current frame (where -;;; ediff started). If that frame is displaying the other buffer, it is -;;; shared between the two buffers. -;;; However, if we decide to put both buffers in one frame -;;; and the selected frame isn't splittable, we create a new frame and -;;; put both buffers there, event if one of this buffers is visible in -;;; another frame. - - ;; Skip dedicated or iconified frames. - ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) - - (let* ((window-min-height 1) - (wind-A (ediff-get-visible-buffer-window buf-A)) - (wind-B (ediff-get-visible-buffer-window buf-B)) - (wind-C (ediff-get-visible-buffer-window buf-C)) - (frame-A (if wind-A (window-frame wind-A))) - (frame-B (if wind-B (window-frame wind-B))) - (frame-C (if wind-C (window-frame wind-C))) - (ctl-frame-exists-p (ediff-with-current-buffer control-buf - (frame-live-p ediff-control-frame))) - ;; on wide display, do things in one frame - (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) - ;; this lets us have local versions of ediff-split-window-function - (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) - (three-way-comparison - (ediff-with-current-buffer control-buf ediff-3way-comparison-job)) - (orig-wind (selected-window)) - (use-same-frame (or force-one-frame - (eq frame-A frame-B) - (not (ediff-window-ok-for-display wind-A)) - (not (ediff-window-ok-for-display wind-B)) - (if three-way-comparison - (or (eq frame-A frame-C) - (eq frame-B frame-C) - (not (ediff-window-ok-for-display wind-C)) - (not (frame-live-p frame-A)) - (not (frame-live-p frame-B)) - (not (frame-live-p frame-C)))) - (and (not (frame-live-p frame-B)) - (or ctl-frame-exists-p - (eq frame-A (selected-frame)))) - (and (not (frame-live-p frame-A)) - (or ctl-frame-exists-p - (eq frame-B (selected-frame)))))) - wind-A-start wind-B-start - designated-minibuffer-frame - done-A done-B done-C) - - (ediff-with-current-buffer control-buf - (setq wind-A-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'A ediff-narrow-bounds)) - wind-B-start (ediff-overlay-start - (ediff-get-value-according-to-buffer-type - 'B ediff-narrow-bounds)))) - - (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own - (progn - ;; buffer buf-A is seen in live wind-A - (select-window wind-A) ; must be displaying buf-A - (delete-other-windows) - (setq wind-A (selected-window)) - (setq done-A t))) - - (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own - (progn - ;; buffer buf-B is seen in live wind-B - (select-window wind-B) ; must be displaying buf-B - (delete-other-windows) - (setq wind-B (selected-window)) - (setq done-B t))) - - (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own - (progn - ;; buffer buf-C is seen in live wind-C - (select-window wind-C) ; must be displaying buf-C - (delete-other-windows) - (setq wind-C (selected-window)) - (setq done-C t))) - - (if use-same-frame - (let (wind-width-or-height) ; this affects 3way setups only - (if (and (eq frame-A frame-B) (frame-live-p frame-A)) - (select-frame frame-A) - ;; avoid dedicated and non-splittable windows - (ediff-skip-unsuitable-frames)) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - - (if three-way-comparison - (setq wind-width-or-height - (/ - (if (eq split-window-function 'split-window-vertically) - (window-height wind-A) - (window-width wind-A)) - 3))) - - (funcall split-window-function wind-width-or-height) - (if (eq (selected-window) wind-A) - (other-window 1)) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - - (if three-way-comparison - (progn - (funcall split-window-function) ; equally - (if (memq (selected-window) (list wind-A wind-B)) - (other-window 1)) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)))) - (setq done-A t - done-B t - done-C t) - )) - - (or done-A ; Buf A to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-A was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - )) - (or done-B ; Buf B to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-B was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - )) - - (if three-way-comparison - (or done-C ; Buf C to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-C was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-C) - (setq wind-C (selected-window)) - ))) - - (ediff-with-current-buffer control-buf - (setq ediff-window-A wind-A - ediff-window-B wind-B - ediff-window-C wind-C) - - (setq frame-A (window-frame ediff-window-A) - designated-minibuffer-frame - (window-frame (minibuffer-window frame-A)))) - - ;; It is unlikely that we'll implement a version of ediff-windows that - ;; would compare 3 windows at once. So, we don't use buffer C here. - (if ediff-windows-job - (progn - (set-window-start wind-A wind-A-start) - (set-window-start wind-B wind-B-start))) - - (ediff-setup-control-frame control-buf designated-minibuffer-frame) - )) - -;; skip unsplittable frames and frames that have dedicated windows. -;; create a new splittable frame if none is found -(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable) - (if (ediff-window-display-p) - (let (last-window) - (while (and (not (eq (selected-window) last-window)) - (or - (ediff-frame-has-dedicated-windows (selected-frame)) - (ediff-frame-iconified-p (selected-frame)) - (< (frame-height (selected-frame)) - (* 3 window-min-height)) - (if ok-unsplittable - nil - (ediff-frame-unsplittable-p (selected-frame))))) - ;; remember where started - (or last-window (setq last-window (selected-window))) - ;; try new window - (other-window 1 t)) - (if (eq (selected-window) last-window) - ;; fed up, no appropriate frame - (progn - (select-frame (make-frame '((unsplittable))))))))) - -(defun ediff-frame-has-dedicated-windows (frame) - (let ((cur-fr (selected-frame)) - ans) - (select-frame frame) - (walk-windows - (function (lambda (wind) - (if (window-dedicated-p wind) - (setq ans t)))) - 'ignore-minibuffer - frame) - (select-frame cur-fr) - ans)) - -;; window is ok, if it is only one window on the frame, not counting the -;; minibuffer, or none of the frame's windows is dedicated. -;; The idea is that it is bad to destroy dedicated windows while creating an -;; ediff window setup -(defun ediff-window-ok-for-display (wind) - (and - (window-live-p wind) - (or - ;; only one window - (eq wind (next-window wind 'ignore-minibuffer (window-frame wind))) - ;; none is dedicated - (not (ediff-frame-has-dedicated-windows (window-frame wind))) - ))) - -;; Prepare or refresh control frame -(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame) - (let ((window-min-height 1) - ctl-frame-iconified-p dont-iconify-ctl-frame deiconify-ctl-frame - ctl-frame old-ctl-frame lines - ;; user-grabbed-mouse - fheight fwidth adjusted-parameters) - - (ediff-with-current-buffer ctl-buffer - (if ediff-xemacs-p (set-buffer-menubar nil)) - ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse)) - (run-hooks 'ediff-before-setup-control-frame-hook)) - - (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame)) - (ediff-with-current-buffer ctl-buffer - (setq ctl-frame (if (frame-live-p old-ctl-frame) - old-ctl-frame - (make-frame ediff-control-frame-parameters)) - ediff-control-frame ctl-frame)) - - (setq ctl-frame-iconified-p (ediff-frame-iconified-p ctl-frame)) - (select-frame ctl-frame) - (if (window-dedicated-p (selected-window)) - () - (delete-other-windows) - (switch-to-buffer ctl-buffer)) - - ;; must be before ediff-setup-control-buffer - ;; just a precaution--we should be in ctl-buffer already - (ediff-with-current-buffer ctl-buffer - (make-local-variable 'frame-title-format) - (make-local-variable 'frame-icon-title-format) ; XEmacs - (make-local-variable 'icon-title-format)) ; Emacs - - (ediff-setup-control-buffer ctl-buffer) - (setq dont-iconify-ctl-frame - (not (string= ediff-help-message ediff-brief-help-message))) - (setq deiconify-ctl-frame - (and (eq this-command 'ediff-toggle-help) - dont-iconify-ctl-frame)) - - ;; 1 more line for the modeline - (setq lines (1+ (count-lines (point-min) (point-max))) - fheight lines - fwidth (max (+ (ediff-help-message-line-length) 2) - (ediff-compute-toolbar-width)) - adjusted-parameters - (list - ;; possibly change surrogate minibuffer - (cons 'minibuffer - (minibuffer-window - designated-minibuffer-frame)) - (cons 'width fwidth) - (cons 'height fheight)) - ) - (if ediff-use-long-help-message - (setq adjusted-parameters - (cons '(auto-raise . nil) adjusted-parameters))) - - ;; In XEmacs, buffer menubar needs to be killed before frame parameters - ;; are changed. - (if ediff-xemacs-p - (progn - (set-specifier top-toolbar-height (list ctl-frame 2)) - (sit-for 0) - (set-specifier top-toolbar-height (list ctl-frame 0)) - ;;(set-specifier bottom-toolbar-height (list ctl-frame 0)) - (set-specifier left-toolbar-width (list ctl-frame 0)) - (set-specifier right-toolbar-width (list ctl-frame 0)) - )) - - ;; Under OS/2 (emx) we have to call modify frame parameters twice, in order - ;; to make sure that at least once we do it for non-iconified frame. If - ;; appears that in the OS/2 port of Emacs, one can't modify frame - ;; parameters of iconified frames. As a precaution, we do likewise for - ;; windows-nt. - (if (memq system-type '(emx windows-nt windows-95)) - (modify-frame-parameters ctl-frame adjusted-parameters)) - - ;; make or zap toolbar (if not requested) - (ediff-make-bottom-toolbar ctl-frame) - - (goto-char (point-min)) - - (modify-frame-parameters ctl-frame adjusted-parameters) - (make-frame-visible ctl-frame) - - ;; This works around a bug in 19.25 and earlier. There, if frame gets - ;; iconified, the current buffer changes to that of the frame that - ;; becomes exposed as a result of this iconification. - ;; So, we make sure the current buffer doesn't change. - (select-frame ctl-frame) - (ediff-refresh-control-frame) - - (cond ((and ediff-prefer-iconified-control-frame - (not ctl-frame-iconified-p) (not dont-iconify-ctl-frame)) - (iconify-frame ctl-frame)) - ((or deiconify-ctl-frame (not ctl-frame-iconified-p)) - (raise-frame ctl-frame))) - - (set-window-dedicated-p (selected-window) t) - - ;; Now move the frame. We must do it separately due to an obscure bug in - ;; XEmacs - (modify-frame-parameters - ctl-frame - (funcall ediff-control-frame-position-function ctl-buffer fwidth fheight)) - - ;; synchronize so the cursor will move to control frame - ;; per RMS suggestion - (if (ediff-window-display-p) - (let ((count 7)) - (sit-for .1) - (while (and (not (frame-visible-p ctl-frame)) (> count 0)) - (setq count (1- count)) - (sit-for .3)))) - - (or (ediff-frame-iconified-p ctl-frame) - ;; don't warp the mouse, unless ediff-grab-mouse = t - (ediff-reset-mouse ctl-frame - (or (eq this-command 'ediff-quit) - (not (eq ediff-grab-mouse t))))) - - (if ediff-xemacs-p - (ediff-with-current-buffer ctl-buffer - (make-local-hook 'select-frame-hook) - (add-hook 'select-frame-hook 'ediff-xemacs-select-frame-hook nil t) - )) - - (ediff-with-current-buffer ctl-buffer - (run-hooks 'ediff-after-setup-control-frame-hook)) - )) - - -(defun ediff-destroy-control-frame (ctl-buffer) - (ediff-with-current-buffer ctl-buffer - (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame)) - (let ((ctl-frame ediff-control-frame)) - (if ediff-xemacs-p - (set-buffer-menubar default-menubar)) - (setq ediff-control-frame nil) - (delete-frame ctl-frame) - ))) - (ediff-skip-unsuitable-frames) - ;;(ediff-reset-mouse nil) - ) - - -;; finds a good place to clip control frame -(defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height) - (ediff-with-current-buffer ctl-buffer - (let* ((frame-A (window-frame ediff-window-A)) - (frame-A-parameters (frame-parameters frame-A)) - (frame-A-top (eval (cdr (assoc 'top frame-A-parameters)))) - (frame-A-left (eval (cdr (assoc 'left frame-A-parameters)))) - (frame-A-width (frame-width frame-A)) - (ctl-frame ediff-control-frame) - horizontal-adjustment upward-adjustment - ctl-frame-top ctl-frame-left) - - ;; Multiple control frames are clipped based on the value of - ;; ediff-control-buffer-number. This is done in order not to obscure - ;; other active control panels. - (setq horizontal-adjustment (* 2 ediff-control-buffer-number) - upward-adjustment (* -14 ediff-control-buffer-number)) - - (setq ctl-frame-top - (- frame-A-top upward-adjustment ediff-control-frame-upward-shift) - ctl-frame-left - (+ frame-A-left - (if ediff-use-long-help-message - (* (ediff-frame-char-width ctl-frame) - (+ ediff-wide-control-frame-rightward-shift - horizontal-adjustment)) - (- (* frame-A-width (ediff-frame-char-width frame-A)) - (* (ediff-frame-char-width ctl-frame) - (+ ctl-frame-width - ediff-narrow-control-frame-leftward-shift - horizontal-adjustment)))))) - (setq ctl-frame-top - (min ctl-frame-top - (- (ediff-display-pixel-height) - (* 2 ctl-frame-height - (ediff-frame-char-height ctl-frame)))) - ctl-frame-left - (min ctl-frame-left - (- (ediff-display-pixel-width) - (* ctl-frame-width (ediff-frame-char-width ctl-frame))))) - ;; keep ctl frame within the visible bounds - (setq ctl-frame-top (max ctl-frame-top 1) - ctl-frame-left (max ctl-frame-left 1)) - - (list (cons 'top ctl-frame-top) - (cons 'left ctl-frame-left)) - ))) - -(defun ediff-xemacs-select-frame-hook () - (if (and (equal (selected-frame) ediff-control-frame) - (not ediff-use-long-help-message)) - (raise-frame ediff-control-frame))) - -(defun ediff-make-wide-display () - "Construct an alist of parameters for the wide display. -Saves the old frame parameters in `ediff-wide-display-orig-parameters'. -The frame to be resized is kept in `ediff-wide-display-frame'. -This function modifies only the left margin and the width of the display. -It assumes that it is called from within the control buffer." - (if (not (fboundp 'ediff-display-pixel-width)) - (error "Can't determine display width.")) - (let* ((frame-A (window-frame ediff-window-A)) - (frame-A-params (frame-parameters frame-A)) - (cw (ediff-frame-char-width frame-A)) - (wd (- (/ (ediff-display-pixel-width) cw) 5))) - (setq ediff-wide-display-orig-parameters - (list (cons 'left (max 0 (eval (cdr (assoc 'left frame-A-params))))) - (cons 'width (cdr (assoc 'width frame-A-params)))) - ediff-wide-display-frame frame-A) - (modify-frame-parameters frame-A (list (cons 'left cw) - (cons 'width wd))))) - - - -;; Revise the mode line to display which difference we have selected -;; Also resets modelines of buffers A/B, since they may be clobbered by -;; anothe invocations of Ediff. -(defun ediff-refresh-mode-lines () - (let (buf-A-state-diff buf-B-state-diff buf-C-state-diff buf-C-state-merge) - - (if (ediff-valid-difference-p) - (setq - buf-C-state-diff (ediff-get-state-of-diff ediff-current-difference 'C) - buf-C-state-merge (ediff-get-state-of-merge ediff-current-difference) - buf-A-state-diff (ediff-get-state-of-diff ediff-current-difference 'A) - buf-B-state-diff (ediff-get-state-of-diff ediff-current-difference 'B) - buf-A-state-diff (if buf-A-state-diff - (format "[%s] " buf-A-state-diff) - "") - buf-B-state-diff (if buf-B-state-diff - (format "[%s] " buf-B-state-diff) - "") - buf-C-state-diff (if (and (ediff-buffer-live-p ediff-buffer-C) - (or buf-C-state-diff buf-C-state-merge)) - (format "[%s%s%s] " - (or buf-C-state-diff "") - (if buf-C-state-merge - (concat " " buf-C-state-merge) - "") - (if (ediff-get-state-of-ancestor - ediff-current-difference) - " AncestorEmpty" - "") - ) - "")) - (setq buf-A-state-diff "" - buf-B-state-diff "" - buf-C-state-diff "")) - - ;; control buffer format - (setq mode-line-format - (if (ediff-narrow-control-frame-p) - (list " " mode-line-buffer-identification) - (list "-- " mode-line-buffer-identification " Quick Help"))) - ;; control buffer id - (setq mode-line-buffer-identification - (if (ediff-narrow-control-frame-p) - (ediff-make-narrow-control-buffer-id 'skip-name) - (ediff-make-wide-control-buffer-id))) - ;; Force mode-line redisplay - (force-mode-line-update) - - (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame)) - (ediff-refresh-control-frame)) - - (ediff-with-current-buffer ediff-buffer-A - (setq ediff-diff-status buf-A-state-diff) - (ediff-strip-mode-line-format) - (setq mode-line-format - (list " A: " 'ediff-diff-status mode-line-format)) - (force-mode-line-update)) - (ediff-with-current-buffer ediff-buffer-B - (setq ediff-diff-status buf-B-state-diff) - (ediff-strip-mode-line-format) - (setq mode-line-format - (list " B: " 'ediff-diff-status mode-line-format)) - (force-mode-line-update)) - (if ediff-3way-job - (ediff-with-current-buffer ediff-buffer-C - (setq ediff-diff-status buf-C-state-diff) - (ediff-strip-mode-line-format) - (setq mode-line-format - (list " C: " 'ediff-diff-status mode-line-format)) - (force-mode-line-update))) - (if (ediff-buffer-live-p ediff-ancestor-buffer) - (ediff-with-current-buffer ediff-ancestor-buffer - (ediff-strip-mode-line-format) - ;; we keep the second dummy string in the mode line format of the - ;; ancestor, since for other buffers Ediff prepends 2 strings and - ;; ediff-strip-mode-line-format expects that. - (setq mode-line-format - (list " Ancestor: " - (cond ((not (stringp buf-C-state-merge)) - "") - ((string-match "prefer-A" buf-C-state-merge) - "[=diff(B)] ") - ((string-match "prefer-B" buf-C-state-merge) - "[=diff(A)] ") - (t "")) - mode-line-format)))) - )) - - -(defun ediff-refresh-control-frame () - (if ediff-emacs-p - ;; set frame/icon titles for Emacs - (modify-frame-parameters - ediff-control-frame - (list (cons 'title (ediff-make-base-title)) - (cons 'icon-name (ediff-make-narrow-control-buffer-id)) - )) - ;; set frame/icon titles for XEmacs - (setq frame-title-format (ediff-make-base-title) - frame-icon-title-format (ediff-make-narrow-control-buffer-id)) - ;; force an update of the frame title - (modify-frame-parameters ediff-control-frame '(())))) - - -(defun ediff-make-narrow-control-buffer-id (&optional skip-name) - (concat - (if skip-name - " " - (ediff-make-base-title)) - (cond ((< ediff-current-difference 0) - (format " _/%d" ediff-number-of-differences)) - ((>= ediff-current-difference ediff-number-of-differences) - (format " $/%d" ediff-number-of-differences)) - (t - (format " %d/%d" - (1+ ediff-current-difference) - ediff-number-of-differences))))) - -(defun ediff-make-base-title () - (concat - (cdr (assoc 'name ediff-control-frame-parameters)) - ediff-control-buffer-suffix)) - -(defun ediff-make-wide-control-buffer-id () - (cond ((< ediff-current-difference 0) - (list (format "%%b At start of %d diffs" - ediff-number-of-differences))) - ((>= ediff-current-difference ediff-number-of-differences) - (list (format "%%b At end of %d diffs" - ediff-number-of-differences))) - (t - (list (format "%%b diff %d of %d" - (1+ ediff-current-difference) - ediff-number-of-differences))))) - - - -;; If buff is not live, return nil -(defun ediff-get-visible-buffer-window (buff) - (if (ediff-buffer-live-p buff) - (if ediff-xemacs-p - (get-buffer-window buff t) - (get-buffer-window buff 'visible)))) - - -;;; Functions to decide when to redraw windows - -(defun ediff-keep-window-config (control-buf) - (and (eq control-buf (current-buffer)) - (/= (buffer-size) 0) - (ediff-with-current-buffer control-buf - (let ((ctl-wind ediff-control-window) - (A-wind ediff-window-A) - (B-wind ediff-window-B) - (C-wind ediff-window-C)) - - (and - (ediff-window-visible-p A-wind) - (ediff-window-visible-p B-wind) - ;; if buffer C is defined then take it into account - (or (not ediff-3way-job) - (ediff-window-visible-p C-wind)) - (eq (window-buffer A-wind) ediff-buffer-A) - (eq (window-buffer B-wind) ediff-buffer-B) - (or (not ediff-3way-job) - (eq (window-buffer C-wind) ediff-buffer-C)) - (string= ediff-window-config-saved - (format "%S%S%S%S%S%S%S" - ctl-wind A-wind B-wind C-wind - ediff-split-window-function - (ediff-multiframe-setup-p) - ediff-wide-display-p))))))) - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -;;; ediff-wind.el ends here
--- a/lisp/ediff/ediff.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1304 +0,0 @@ -;;; ediff.el --- a comprehensive visual interface to diff & patch - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> -;; Created: February 2, 1994 -;; Keywords: comparing, merging, patching, version control. - -(defconst ediff-version "2.671" "The current version of Ediff") -(defconst ediff-date "September 23, 1997" "Date of last update") - - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Never read that diff output again! -;; Apply patch interactively! -;; Merge with ease! - -;; This package provides a convenient way of simultaneous browsing through -;; the differences between a pair (or a triple) of files or buffers. The -;; files being compared, file-A, file-B, and file-C (if applicable) are -;; shown in separate windows (side by side, one above the another, or in -;; separate frames), and the differences are highlighted as you step -;; through them. You can also copy difference regions from one buffer to -;; another (and recover old differences if you change your mind). - -;; Ediff also supports merging operations on files and buffers, including -;; merging using ancestor versions. Both comparison and merging operations can -;; be performed on directories, i.e., by pairwise comparison of files in those -;; directories. - -;; In addition, Ediff can apply a patch to a file and then let you step -;; though both files, the patched and the original one, simultaneously, -;; difference-by-difference. You can even apply a patch right out of a -;; mail buffer, i.e., patches received by mail don't even have to be saved. -;; Since Ediff lets you copy differences between buffers, you can, in -;; effect, apply patches selectively (i.e., you can copy a difference -;; region from file_orig to file, thereby undoing any particular patch that -;; you don't like). - -;; Ediff is aware of version control, which lets the user compare -;; files with their older versions. Ediff can also work with remote and -;; compressed files. Details are given below. - -;; Finally, Ediff supports directory-level comparison, merging and patching. -;; See the on-line manual for details. - -;; This package builds upon the ideas borrowed from emerge.el and several -;; Ediff's functions are adaptations from emerge.el. Much of the functionality -;; Ediff provides is also influenced by emerge.el. - -;; The present version of Ediff supersedes Emerge. It provides a superior user -;; interface and has numerous major features not found in Emerge. In -;; particular, it can do patching, and 2-way and 3-way file comparison, -;; merging, and directory operations. - - - -;;; Bugs: - -;; 1. The undo command doesn't restore deleted regions well. That is, if -;; you delete all characters in a difference region and then invoke -;; `undo', the reinstated text will most likely be inserted outside of -;; what Ediff thinks is the current difference region. (This problem -;; doesn't seem to exist with XEmacs.) -;; -;; If at any point you feel that difference regions are no longer correct, -;; you can hit '!' to recompute the differences. - -;; 2. On a monochrome display, the repertoire of faces with which to -;; highlight fine differences is limited. By default, Ediff is using -;; underlining. However, if the region is already underlined by some other -;; overlays, there is no simple way to temporarily remove that residual -;; underlining. This problem occurs when a buffer is highlighted with -;; hilit19.el or font-lock.el packages. If this residual highlighting gets -;; in the way, you can do the following. Both font-lock.el and hilit19.el -;; provide commands for unhighlighting buffers. You can either place these -;; commands in `ediff-prepare-buffer-hook' (which will unhighlight every -;; buffer used by Ediff) or you can execute them interactively, at any time -;; and on any buffer. - - -;;; Acknowledgements: - -;; Ediff was inspired by Dale R. Worley's <drw@math.mit.edu> emerge.el. -;; Ediff would not have been possible without the help and encouragement of -;; its many users. See Ediff on-line Info for the full list of those who -;; helped. Improved defaults in Ediff file-name reading commands. - -;;; Code: - -(provide 'ediff) - -;; Compiler pacifier -(defvar cvs-cookie-handle) -(defvar ediff-last-dir-patch) -(defvar ediff-patch-default-directory) - -(and noninteractive - (eval-when-compile - (load-library "dired") - (load-library "info") - (load "pcl-cvs" 'noerror))) -(eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) - (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) - (or (featurep 'ediff-ptch) - (load "ediff-ptch.el" nil nil 'nosuffix)) - (or (featurep 'ediff-vers) - (load "ediff-vers.el" nil nil 'nosuffix)) - )) -;; end pacifier - -(require 'ediff-init) -(require 'ediff-mult) ; required because of the registry stuff - -(defgroup ediff nil - "A comprehensive visual interface to diff & patch" - :tag "Ediff" - :group 'tools) - - -(defcustom ediff-use-last-dir nil - "*If t, Ediff will use previous directory as default when reading file name." - :type 'boolean - :group 'ediff) - -;; Last directory used by an Ediff command for file-A. -(defvar ediff-last-dir-A nil) -;; Last directory used by an Ediff command for file-B. -(defvar ediff-last-dir-B nil) -;; Last directory used by an Ediff command for file-C. -(defvar ediff-last-dir-C nil) -;; Last directory used by an Ediff command for the ancestor file. -(defvar ediff-last-dir-ancestor nil) -;; Last directory used by an Ediff command as the output directory for merge. -(defvar ediff-last-merge-autostore-dir) - - -;; Used as a startup hook to set `_orig' patch file read-only. -(defun ediff-set-read-only-in-buf-A () - (ediff-with-current-buffer ediff-buffer-A - (toggle-read-only 1))) - -;; Return a plausible default for ediff's first file: -;; In dired, return the file name under the point, unless it is a directory -;; If the buffer has a file name, return that file name. -(defun ediff-get-default-file-name () - (cond ((eq major-mode 'dired-mode) - (let ((f (dired-get-filename nil 'no-error))) - (if (and (stringp f) (not (file-directory-p f))) - f))) - ((buffer-file-name (current-buffer)) - (file-name-nondirectory (buffer-file-name (current-buffer)))) - )) - -;;; Compare files/buffers - -;;;###autoload -(defun ediff-files (file-A file-B &optional startup-hooks) - "Run Ediff on a pair of files, FILE-A and FILE-B." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B f) - (list (setq f (ediff-read-file-name - "File A to compare" dir-A - (ediff-get-default-file-name))) - (ediff-read-file-name "File B to compare" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f)) - ))) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - nil ; file-C - startup-hooks - 'ediff-files)) - -;;;###autoload -(defun ediff-files3 (file-A file-B file-C &optional startup-hooks) - "Run Ediff on three files, FILE-A, FILE-B, and FILE-C." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B dir-C f ff) - (list (setq f (ediff-read-file-name - "File A to compare" dir-A - (ediff-get-default-file-name))) - (setq ff (ediff-read-file-name "File B to compare" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons - (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f))) - (ediff-read-file-name "File C to compare" - (setq dir-C (if ediff-use-last-dir - ediff-last-dir-C - (file-name-directory ff))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory ff) - dir-C)) - file-name-history)) - ff)) - ))) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - (if (file-directory-p file-C) - (expand-file-name - (file-name-nondirectory file-A) file-C) - file-C) - startup-hooks - 'ediff-files3)) - -;;;###autoload -(defalias 'ediff3 'ediff-files3) - - -;; Visit FILE and arrange its buffer to Ediff's liking. -;; FILE is actually a variable symbol that must contain a true file name. -;; BUFFER-NAME is a variable symbol, which will get the buffer object into -;; which FILE is read. -;; LAST-DIR is the directory variable symbol where FILE's -;; directory name should be returned. HOOKS-VAR is a variable symbol that will -;; be assigned the hook to be executed after `ediff-startup' is finished. -;; `ediff-find-file' arranges that the temp files it might create will be -;; deleted. -(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var) - (let* ((file (symbol-value file-var)) - (file-magic (ediff-filename-magic-p file)) - (temp-file-name-prefix (file-name-nondirectory file))) - (cond ((not (file-readable-p file)) - (error "File `%s' does not exist or is not readable" file)) - ((file-directory-p file) - (error "File `%s' is a directory" file))) - - ;; some of the commands, below, require full file name - (setq file (expand-file-name file)) - - ;; Record the directory of the file - (if last-dir - (set last-dir (expand-file-name (file-name-directory file)))) - - ;; Setup the buffer - (set buffer-name (find-file-noselect file)) - - (ediff-with-current-buffer (symbol-value buffer-name) - (widen) ; Make sure the entire file is seen - (cond (file-magic ; file has a handler, such as jka-compr-handler or - ;;; ange-ftp-hook-function--arrange for temp file - (ediff-verify-file-buffer 'magic) - (setq file - (ediff-make-temp-file - (current-buffer) temp-file-name-prefix)) - (set hooks-var (cons (` (lambda () (delete-file (, file)))) - (symbol-value hooks-var)))) - ;; file processed via auto-mode-alist, a la uncompress.el - ((not (equal (file-truename file) - (file-truename (buffer-file-name)))) - (setq file - (ediff-make-temp-file - (current-buffer) temp-file-name-prefix)) - (set hooks-var (cons (` (lambda () (delete-file (, file)))) - (symbol-value hooks-var)))) - (t ;; plain file---just check that the file matches the buffer - (ediff-verify-file-buffer)))) - (set file-var file))) - -(defun ediff-files-internal (file-A file-B file-C startup-hooks job-name) - (let (buf-A buf-B buf-C) - (message "Reading file %s ... " file-A) - ;;(sit-for 0) - (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks) - (message "Reading file %s ... " file-B) - ;;(sit-for 0) - (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks) - (if (stringp file-C) - (progn - (message "Reading file %s ... " file-C) - ;;(sit-for 0) - (ediff-find-file - 'file-C 'buf-C - (if (eq job-name 'ediff-merge-files-with-ancestor) - 'ediff-last-dir-ancestor 'ediff-last-dir-C) - 'startup-hooks))) - (ediff-setup buf-A file-A - buf-B file-B - buf-C file-C - startup-hooks - (list (cons 'ediff-job-name job-name))))) - - -;;;###autoload -(defalias 'ediff 'ediff-files) - - -;;;###autoload -(defun ediff-buffers (buffer-A buffer-B &optional startup-hooks job-name) - "Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B." - (interactive - (let (bf) - (list (setq bf (read-buffer "Buffer A to compare: " - (ediff-other-buffer "") t)) - (read-buffer "Buffer B to compare: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - (or job-name (setq job-name 'ediff-buffers)) - (ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name)) - -;;;###autoload -(defalias 'ebuffers 'ediff-buffers) - - -;;;###autoload -(defun ediff-buffers3 (buffer-A buffer-B buffer-C - &optional startup-hooks job-name) - "Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C." - (interactive - (let (bf bff) - (list (setq bf (read-buffer "Buffer A to compare: " - (ediff-other-buffer "") t)) - (setq bff (read-buffer "Buffer B to compare: " - (progn - ;; realign buffers so that two visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)) - (read-buffer "Buffer C to compare: " - (progn - ;; realign buffers so that three visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer (list bf bff))) - t) - ))) - (or job-name (setq job-name 'ediff-buffers3)) - (ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name)) - -;;;###autoload -(defalias 'ebuffers3 'ediff-buffers3) - - - -(defun ediff-buffers-internal (buf-A buf-B buf-C startup-hooks job-name) - (let* ((buf-A-file-name (buffer-file-name (get-buffer buf-A))) - (buf-B-file-name (buffer-file-name (get-buffer buf-B))) - (buf-C-is-alive (ediff-buffer-live-p buf-C)) - (buf-C-file-name (if buf-C-is-alive - (buffer-file-name (get-buffer buf-B)))) - file-A file-B file-C) - (if (not (ediff-buffer-live-p buf-A)) - (error "Buffer %S doesn't exist" buf-A)) - (if (not (ediff-buffer-live-p buf-B)) - (error "Buffer %S doesn't exist" buf-B)) - (let ((ediff-job-name job-name)) - (if (and ediff-3way-comparison-job - (not buf-C-is-alive)) - (error "Buffer %S doesn't exist" buf-C))) - (if (stringp buf-A-file-name) - (setq buf-A-file-name (file-name-nondirectory buf-A-file-name))) - (if (stringp buf-B-file-name) - (setq buf-B-file-name (file-name-nondirectory buf-B-file-name))) - (if (stringp buf-C-file-name) - (setq buf-C-file-name (file-name-nondirectory buf-C-file-name))) - - (setq file-A (ediff-make-temp-file buf-A buf-A-file-name) - file-B (ediff-make-temp-file buf-B buf-B-file-name)) - (if buf-C-is-alive - (setq file-C (ediff-make-temp-file buf-C buf-C-file-name))) - - (ediff-setup (get-buffer buf-A) file-A - (get-buffer buf-B) file-B - (if buf-C-is-alive (get-buffer buf-C)) - file-C - (cons (` (lambda () - (delete-file (, file-A)) - (delete-file (, file-B)) - (if (stringp (, file-C)) (delete-file (, file-C))) - )) - startup-hooks) - (list (cons 'ediff-job-name job-name)) - ))) - - -;;; Directory and file group operations - -;; Get appropriate default name for directory: -;; If ediff-use-last-dir, use ediff-last-dir-A. -;; In dired mode, use the directory that is under the point (if any); -;; otherwise, use default-directory -(defun ediff-get-default-directory-name () - (cond (ediff-use-last-dir ediff-last-dir-A) - ((eq major-mode 'dired-mode) - (let ((f (dired-get-filename nil 'noerror))) - (if (and (stringp f) (file-directory-p f)) - f - default-directory))) - (t default-directory))) - - -;;;###autoload -(defun ediff-directories (dir1 dir2 regexp) - "Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to compare:" dir-A nil)) - (ediff-read-file-name "Directory B to compare:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 nil regexp 'ediff-files 'ediff-directories - )) - -;;;###autoload -(defalias 'edirs 'ediff-directories) - - -;;;###autoload -(defun ediff-directory-revisions (dir1 regexp) - "Run Ediff on a directory, DIR1, comparing its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." - (interactive - (let ((dir-A (ediff-get-default-directory-name))) - (list (ediff-read-file-name - "Directory to compare with revision:" dir-A nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directory-revisions-internal - dir1 regexp 'ediff-revision 'ediff-directory-revisions - )) - -;;;###autoload -(defalias 'edir-revisions 'ediff-directory-revisions) - - -;;;###autoload -(defun ediff-directories3 (dir1 dir2 dir3 regexp) - "Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that -have the same name in all three. The last argument, REGEXP, is a regular -expression that can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to compare:" dir-A nil)) - (setq f (ediff-read-file-name "Directory B to compare:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil)) - (ediff-read-file-name "Directory C to compare:" - (if ediff-use-last-dir - ediff-last-dir-C - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3 - )) - -;;;###autoload -(defalias 'edirs3 'ediff-directories3) - -;;;###autoload -(defun ediff-merge-directories (dir1 dir2 regexp) - "Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have -the same name in both. The third argument, REGEXP, is a regular expression that -can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to merge:" dir-A nil)) - (ediff-read-file-name "Directory B to merge:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories - )) - -;;;###autoload -(defalias 'edirs-merge 'ediff-merge-directories) - -;;;###autoload -(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp) - "Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors. -Ediff merges files that have identical names in DIR1, DIR2. If a pair of files -in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge -without ancestor. The fourth argument, REGEXP, is a regular expression that -can be used to filter out certain file names." - (interactive - (let ((dir-A (ediff-get-default-directory-name)) - f) - (list (setq f (ediff-read-file-name "Directory A to merge:" dir-A nil)) - (setq f (ediff-read-file-name "Directory B to merge:" - (if ediff-use-last-dir - ediff-last-dir-B - (ediff-strip-last-dir f)) - nil)) - (ediff-read-file-name "Ancestor directory:" - (if ediff-use-last-dir - ediff-last-dir-C - (ediff-strip-last-dir f)) - nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directories-internal - dir1 dir2 ancestor-dir regexp - 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor - )) - -;;;###autoload -(defun ediff-merge-directory-revisions (dir1 regexp) - "Run Ediff on a directory, DIR1, merging its files with their revisions. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." - (interactive - (let ((dir-A (ediff-get-default-directory-name))) - (list (ediff-read-file-name - "Directory to merge with revisions:" dir-A nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directory-revisions-internal - dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions - )) - -;;;###autoload -(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions) - -;;;###autoload -(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp) - "Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors. -The second argument, REGEXP, is a regular expression that filters the file -names. Only the files that are under revision control are taken into account." - (interactive - (let ((dir-A (ediff-get-default-directory-name))) - (list (ediff-read-file-name - "Directory to merge with revisions and ancestors:" dir-A nil) - (read-string "Filter through regular expression: " - nil 'ediff-filtering-regexp-history) - ))) - (ediff-directory-revisions-internal - dir1 regexp 'ediff-merge-revisions-with-ancestor - 'ediff-merge-directory-revisions-with-ancestor - )) - -;;;###autoload -(defalias - 'edir-merge-revisions-with-ancestor - 'ediff-merge-directory-revisions-with-ancestor) - -;;;###autoload -(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor) - -;; Run ediff-action (ediff-files, ediff-merge, ediff-merge-with-ancestors) -;; on a pair of directories (three directories, in case of ancestor). -;; The third argument, REGEXP, is a regular expression that can be used to -;; filter out certain file names. -;; JOBNAME is the symbol indicating the meta-job to be performed. -;; MERGE-DIR is the directory in which to store merged files. -(defun ediff-directories-internal (dir1 dir2 dir3 regexp action jobname - &optional startup-hooks) - ;; ediff-read-file-name is set to attach a previously entered file name if - ;; the currently entered file is a directory. This code takes care of that. - (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1)) - dir2 (if (file-directory-p dir2) dir2 (file-name-directory dir2))) - - (if (stringp dir3) - (setq dir3 (if (file-directory-p dir3) dir3 (file-name-directory dir3)))) - - (cond ((string= dir1 dir2) - (error "Directories A and B are the same: %s" dir1)) - ((and (eq jobname 'ediff-directories3) - (string= dir1 dir3)) - (error "Directories A and C are the same: %s" dir1)) - ((and (eq jobname 'ediff-directories3) - (string= dir2 dir3)) - (error "Directories B and C are the same: %s" dir1))) - - (let (diffs ; var where ediff-intersect-directories returns the diff list - merge-autostore-dir - file-list meta-buf) - (if (and ediff-autostore-merges (ediff-merge-metajob jobname)) - (setq merge-autostore-dir - (ediff-read-file-name "Directory to save merged files:" - (if ediff-use-last-dir - ediff-last-merge-autostore-dir - (ediff-strip-last-dir dir1)) - nil))) - ;; verify we are not merging into an orig directory - (if (stringp merge-autostore-dir) - (cond ((and (stringp dir1) (string= merge-autostore-dir dir1)) - (or (y-or-n-p "Merge directory same as directory A, sure? ") - (error "Directory merge aborted"))) - ((and (stringp dir2) (string= merge-autostore-dir dir2)) - (or (y-or-n-p "Merge directory same as directory B, sure? ") - (error "Directory merge aborted"))) - ((and (stringp dir3) (string= merge-autostore-dir dir3)) - (or (y-or-n-p - "Merge directory same as ancestor directory, sure? ") - (error "Directory merge aborted"))))) - - (setq file-list (ediff-intersect-directories - jobname 'diffs - regexp dir1 dir2 dir3 merge-autostore-dir)) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons (` (lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function (quote (, action))) - ;; set ediff-dir-difference-list - (setq ediff-dir-difference-list (quote (, diffs))))) - startup-hooks)) - (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action - file-list - "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer - jobname - startup-hooks)) - (ediff-show-meta-buffer meta-buf) - )) - -(defun ediff-directory-revisions-internal (dir1 regexp action jobname - &optional startup-hooks) - (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1))) - - (let (file-list meta-buf merge-autostore-dir) - (if (and ediff-autostore-merges (ediff-merge-metajob jobname)) - (setq merge-autostore-dir - (ediff-read-file-name "Directory to save merged files:" - (if ediff-use-last-dir - ediff-last-merge-autostore-dir - (ediff-strip-last-dir dir1)) - nil))) - ;; verify merge-autostore-dir != dir1 - (if (and (stringp merge-autostore-dir) - (stringp dir1) - (string= merge-autostore-dir dir1)) - (or (y-or-n-p - "Directory for saving merges is the same as directory A. Sure? ") - (error "Merge of directory revisions aborted"))) - - (setq file-list - (ediff-get-directory-files-under-revision - jobname regexp dir1 merge-autostore-dir)) - (setq startup-hooks - ;; this sets various vars in the meta buffer inside - ;; ediff-prepare-meta-buffer - (cons (` (lambda () - ;; tell what to do if the user clicks on a session record - (setq ediff-session-action-function (quote (, action))) - )) - startup-hooks)) - (setq meta-buf (ediff-prepare-meta-buffer - 'ediff-filegroup-action - file-list - "*Ediff Session Group Panel" - 'ediff-redraw-directory-group-buffer - jobname - startup-hooks)) - (ediff-show-meta-buffer meta-buf) - )) - - -;;; Compare regions and windows - -;;;###autoload -(defun ediff-windows-wordwise (dumb-mode &optional wind-A wind-B startup-hooks) - "Compare WIND-A and WIND-B, which are selected by clicking, wordwise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." - (interactive "P") - (ediff-windows dumb-mode wind-A wind-B - startup-hooks 'ediff-windows-wordwise 'word-mode)) - -;;;###autoload -(defun ediff-windows-linewise (dumb-mode &optional wind-A wind-B startup-hooks) - "Compare WIND-A and WIND-B, which are selected by clicking, linewise. -With prefix argument, DUMB-MODE, or on a non-windowing display, works as -follows: -If WIND-A is nil, use selected window. -If WIND-B is nil, use window next to WIND-A." - (interactive "P") - (ediff-windows dumb-mode wind-A wind-B - startup-hooks 'ediff-windows-linewise nil)) - -;; Compare WIND-A and WIND-B, which are selected by clicking. -;; With prefix argument, DUMB-MODE, or on a non-windowing display, -;; works as follows: -;; If WIND-A is nil, use selected window. -;; If WIND-B is nil, use window next to WIND-A. -(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode) - (if (or dumb-mode (not (ediff-window-display-p))) - (setq wind-A (ediff-get-next-window wind-A nil) - wind-B (ediff-get-next-window wind-B wind-A)) - (setq wind-A (ediff-get-window-by-clicking wind-A nil 1) - wind-B (ediff-get-window-by-clicking wind-B wind-A 2))) - - (let ((buffer-A (window-buffer wind-A)) - (buffer-B (window-buffer wind-B)) - beg-A end-A beg-B end-B) - - (save-excursion - (save-window-excursion - (sit-for 0) ; sync before using window-start/end -- a precaution - (select-window wind-A) - (setq beg-A (window-start) - end-A (window-end)) - (select-window wind-B) - (setq beg-B (window-start) - end-B (window-end)))) - (ediff-regions-internal - buffer-A beg-A end-A buffer-B beg-B end-B - startup-hooks job-name word-mode nil))) - -;;;###autoload -(defun ediff-regions-wordwise (buffer-A buffer-B &optional startup-hooks) - "Run Ediff on a pair of regions in two different buffers. -Regions \(i.e., point and mark\) are assumed to be set in advance. -This function is effective only for relatively small regions, up to 200 -lines. For large regions, use `ediff-regions-linewise'." - (interactive - (let (bf) - (list (setq bf (read-buffer "Region's A buffer: " - (ediff-other-buffer "") t)) - (read-buffer "Region's B buffer: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - (if (not (ediff-buffer-live-p buffer-A)) - (error "Buffer %S doesn't exist" buffer-A)) - (if (not (ediff-buffer-live-p buffer-B)) - (error "Buffer %S doesn't exist" buffer-B)) - - - (let (reg-A-beg reg-A-end reg-B-beg reg-B-end) - (save-excursion - (set-buffer buffer-A) - (setq reg-A-beg (region-beginning) - reg-A-end (region-end)) - (set-buffer buffer-B) - (setq reg-B-beg (region-beginning) - reg-B-end (region-end))) - - (ediff-regions-internal - (get-buffer buffer-A) reg-A-beg reg-A-end - (get-buffer buffer-B) reg-B-beg reg-B-end - startup-hooks 'ediff-regions-wordwise 'word-mode nil))) - -;;;###autoload -(defun ediff-regions-linewise (buffer-A buffer-B &optional startup-hooks) - "Run Ediff on a pair of regions in two different buffers. -Regions \(i.e., point and mark\) are assumed to be set in advance. -Each region is enlarged to contain full lines. -This function is effective for large regions, over 100-200 -lines. For small regions, use `ediff-regions-wordwise'." - (interactive - (let (bf) - (list (setq bf (read-buffer "Region A's buffer: " - (ediff-other-buffer "") t)) - (read-buffer "Region B's buffer: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - (if (not (ediff-buffer-live-p buffer-A)) - (error "Buffer %S doesn't exist" buffer-A)) - (if (not (ediff-buffer-live-p buffer-B)) - (error "Buffer %S doesn't exist" buffer-B)) - - (let (reg-A-beg reg-A-end reg-B-beg reg-B-end) - (save-excursion - (set-buffer buffer-A) - (setq reg-A-beg (region-beginning) - reg-A-end (region-end)) - ;; enlarge the region to hold full lines - (goto-char reg-A-beg) - (beginning-of-line) - (setq reg-A-beg (point)) - (goto-char reg-A-end) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq reg-A-end (point)) - - (set-buffer buffer-B) - (setq reg-B-beg (region-beginning) - reg-B-end (region-end)) - ;; enlarge the region to hold full lines - (goto-char reg-B-beg) - (beginning-of-line) - (setq reg-B-beg (point)) - (goto-char reg-B-end) - (end-of-line) - (or (eobp) (forward-char)) ; include the newline char - (setq reg-B-end (point)) - ) ; save excursion - - (ediff-regions-internal - (get-buffer buffer-A) reg-A-beg reg-A-end - (get-buffer buffer-B) reg-B-beg reg-B-end - startup-hooks 'ediff-regions-linewise nil nil))) ; no word mode - -;; compare region beg-A to end-A of buffer-A -;; to regions beg-B -- end-B in buffer-B. -(defun ediff-regions-internal (buffer-A beg-A end-A buffer-B beg-B end-B - startup-hooks job-name word-mode - setup-parameters) - (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer)) - overl-A overl-B - file-A file-B) - - ;; in case beg/end-A/B aren't markers--make them into markers - (ediff-with-current-buffer buffer-A - (setq beg-A (move-marker (make-marker) beg-A) - end-A (move-marker (make-marker) end-A))) - (ediff-with-current-buffer buffer-B - (setq beg-B (move-marker (make-marker) beg-B) - end-B (move-marker (make-marker) end-B))) - - (if (and (eq buffer-A buffer-B) - (or (and (< beg-A end-B) (<= beg-B beg-A)) ; b-B b-A e-B - (and (< beg-B end-A) (<= end-A end-B)))) ; b-B e-A e-B - (progn - (with-output-to-temp-buffer ediff-msg-buffer - (princ " -You have requested to compare overlapping regions of the same buffer. - -In this case, Ediff's highlighting may be confusing---in the same window, -you may see highlighted regions that belong to different regions. - -Continue anyway? (y/n) ")) - - (if (y-or-n-p "Continue anyway? ") - () - (error "%S aborted" job-name)))) - - ;; make file-A - (if word-mode - (ediff-wordify beg-A end-A buffer-A tmp-buffer) - (ediff-copy-to-buffer beg-A end-A buffer-A tmp-buffer)) - (setq file-A (ediff-make-temp-file tmp-buffer "regA")) - - ;; make file-B - (if word-mode - (ediff-wordify beg-B end-B buffer-B tmp-buffer) - (ediff-copy-to-buffer beg-B end-B buffer-B tmp-buffer)) - (setq file-B (ediff-make-temp-file tmp-buffer "regB")) - - (setq overl-A (ediff-make-bullet-proof-overlay beg-A end-A buffer-A)) - (setq overl-B (ediff-make-bullet-proof-overlay beg-B end-B buffer-B)) - (ediff-setup buffer-A file-A - buffer-B file-B - nil nil ; buffer & file C - (cons (` (lambda () - (delete-file (, file-A)) - (delete-file (, file-B)))) - startup-hooks) - (append - (list (cons 'ediff-word-mode word-mode) - (cons 'ediff-narrow-bounds (list overl-A overl-B)) - (cons 'ediff-job-name job-name)) - setup-parameters) - ) - )) - - -;;; Merge files and buffers - -;;;###autoload -(defalias 'ediff-merge 'ediff-merge-files) - -(defsubst ediff-merge-on-startup () - (ediff-do-merge 0) - (ediff-with-current-buffer ediff-buffer-C - (set-buffer-modified-p nil))) - -;;;###autoload -(defun ediff-merge-files (file-A file-B &optional startup-hooks) - "Merge two files without ancestor." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B f) - (list (setq f (ediff-read-file-name - "File A to merge" dir-A - (ediff-get-default-file-name))) - (ediff-read-file-name "File B to merge" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f)) - ))) - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - nil ; file-C - startup-hooks - 'ediff-merge-files)) - -;;;###autoload -(defun ediff-merge-files-with-ancestor (file-A file-B file-ancestor - &optional startup-hooks) - "Merge two files with ancestor." - (interactive - (let ((dir-A (if ediff-use-last-dir - ediff-last-dir-A - default-directory)) - dir-B dir-ancestor f ff) - (list (setq f (ediff-read-file-name - "File A to merge" dir-A - (ediff-get-default-file-name))) - (setq ff (ediff-read-file-name "File B to merge" - (setq dir-B - (if ediff-use-last-dir - ediff-last-dir-B - (file-name-directory f))) - (progn - (setq file-name-history - (cons - (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory f) - dir-B)) - file-name-history)) - f))) - (ediff-read-file-name "Ancestor file" - (setq dir-ancestor - (if ediff-use-last-dir - ediff-last-dir-ancestor - (file-name-directory ff))) - (progn - (setq file-name-history - (cons (ediff-abbreviate-file-name - (expand-file-name - (file-name-nondirectory ff) - dir-ancestor)) - file-name-history)) - ff)) - ))) - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (ediff-files-internal file-A - (if (file-directory-p file-B) - (expand-file-name - (file-name-nondirectory file-A) file-B) - file-B) - file-ancestor - startup-hooks - 'ediff-merge-files-with-ancestor)) - -;;;###autoload -(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor) - -;;;###autoload -(defun ediff-merge-buffers (buffer-A buffer-B &optional startup-hooks job-name) - "Merge buffers without ancestor." - (interactive - (let (bf) - (list (setq bf (read-buffer "Buffer A to merge: " - (ediff-other-buffer "") t)) - (read-buffer "Buffer B to merge: " - (progn - ;; realign buffers so that two visible bufs will be - ;; at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)))) - - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (or job-name (setq job-name 'ediff-merge-buffers)) - (ediff-buffers-internal - buffer-A buffer-B nil startup-hooks job-name)) - -;;;###autoload -(defun ediff-merge-buffers-with-ancestor (buffer-A - buffer-B buffer-ancestor - &optional startup-hooks job-name) - "Merge buffers with ancestor." - (interactive - (let (bf bff) - (list (setq bf (read-buffer "Buffer A to merge: " - (ediff-other-buffer "") t)) - (setq bff (read-buffer "Buffer B to merge: " - (progn - ;; realign buffers so that two visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer bf)) - t)) - (read-buffer "Ancestor buffer: " - (progn - ;; realign buffers so that three visible - ;; bufs will be at the top - (save-window-excursion (other-window 1)) - (ediff-other-buffer (list bf bff))) - t) - ))) - - (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks)) - (or job-name (setq job-name 'ediff-merge-buffers-with-ancestor)) - (ediff-buffers-internal - buffer-A buffer-B buffer-ancestor startup-hooks job-name)) - - -;;;###autoload -(defun ediff-merge-revisions (&optional file startup-hooks) - "Run Ediff by merging two revisions of a file. -The file is the optional FILE argument or the file visited by the current -buffer." - (interactive) - (if (stringp file) (find-file file)) - (let (rev1 rev2) - (setq rev1 - (read-string - (format - "Version 1 to merge (default: %s's latest version): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - rev2 - (read-string - (format - "Version 2 to merge (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer")))) - (ediff-load-version-control) - ;; ancestor-revision=nil - (funcall - (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) - rev1 rev2 nil startup-hooks))) - - -;;;###autoload -(defun ediff-merge-revisions-with-ancestor (&optional file startup-hooks) - "Run Ediff by merging two revisions of a file with a common ancestor. -The file is the the optional FILE argument or the file visited by the current -buffer." - (interactive) - (if (stringp file) (find-file file)) - (let (rev1 rev2 ancestor-rev) - (setq rev1 - (read-string - (format - "Version 1 to merge (default: %s's latest version): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - rev2 - (read-string - (format - "Version 2 to merge (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - ancestor-rev - (read-string - (format - "Ancestor version (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer")))) - (ediff-load-version-control) - (funcall - (intern (format "ediff-%S-merge-internal" ediff-version-control-package)) - rev1 rev2 ancestor-rev startup-hooks))) - -;;;###autoload -(defun run-ediff-from-cvs-buffer (pos) - "Run Ediff-merge on appropriate revisions of the selected file. -First run after `M-x cvs-update'. Then place the cursor on a line describing a -file and then run `run-ediff-from-cvs-buffer'." - (interactive "d") - (ediff-load-version-control) - (let ((tin (tin-locate cvs-cookie-handle pos))) - (if tin - (cvs-run-ediff-on-file-descriptor tin) - (error "There is no file to merge")))) - - -;;; Apply patch - -;;;###autoload -(defun ediff-patch-file () - "Run Ediff by patching SOURCE-FILENAME." - ;; This now returns the control buffer - (interactive) - (let (source-dir source-file patch-buf) - (require 'ediff-ptch) - (setq patch-buf (ediff-get-patch-buffer)) - (setq source-dir (cond (ediff-use-last-dir ediff-last-dir-patch) - ((and (not ediff-patch-default-directory) - (buffer-file-name patch-buf)) - (file-name-directory - (expand-file-name - (buffer-file-name patch-buf)))) - (t default-directory))) - (setq source-file - ;; the default is the directory, not the visited file name - (ediff-read-file-name - "Which file to patch? " source-dir (ediff-get-default-file-name))) - (ediff-dispatch-file-patching-job patch-buf source-file))) - -;;;###autoload -(defun ediff-patch-buffer () - "Run Ediff by patching BUFFER-NAME." - (interactive) - (let (patch-buf) - (require 'ediff-ptch) - (setq patch-buf (ediff-get-patch-buffer)) - (ediff-patch-buffer-internal - patch-buf - (read-buffer "Which buffer to patch? " - (cond ((eq patch-buf (current-buffer)) - (ediff-other-buffer (current-buffer))) - (t (current-buffer))) - 'must-match)))) - -;;;###autoload -(defalias 'epatch 'ediff-patch-file) -;;;###autoload -(defalias 'epatch-buffer 'ediff-patch-buffer) - - - - -;;; Versions Control functions - -;;;###autoload -(defun ediff-revision (&optional file startup-hooks) - "Run Ediff by comparing versions of a file. -The file is an optional FILE argument or the file visited by the current -buffer. Use `vc.el' or `rcs.el' depending on `ediff-version-control-package'." - ;; if buffer is non-nil, use that buffer instead of the current buffer - (interactive "P") - (if (stringp file) (find-file file)) - (let (rev1 rev2) - (setq rev1 - (read-string - (format "Version 1 to compare (default: %s's latest version): " - (if (stringp file) - (file-name-nondirectory file) "current buffer"))) - rev2 - (read-string - (format "Version 2 to compare (default: %s): " - (if (stringp file) - (file-name-nondirectory file) "current buffer")))) - (ediff-load-version-control) - (funcall - (intern (format "ediff-%S-internal" ediff-version-control-package)) - rev1 rev2 startup-hooks) - )) - - -;;;###autoload -(defalias 'erevision 'ediff-revision) - - -;; Test if version control package is loaded and load if not -;; Is SILENT is non-nil, don't report error if package is not found. -(defun ediff-load-version-control (&optional silent) - (require 'ediff-vers) - (or (featurep ediff-version-control-package) - (if (locate-library (symbol-name ediff-version-control-package)) - (progn - (message "") ; kill the message from `locate-library' - (require ediff-version-control-package)) - (or silent - (error "Version control package %S.el not found. Use vc.el instead" - ediff-version-control-package))))) - - -;;;###autoload -(defun ediff-version () - "Return string describing the version of Ediff. -When called interactively, displays the version." - (interactive) - (if (interactive-p) - (message (ediff-version)) - (format "Ediff %s of %s" ediff-version ediff-date))) - - -;;;###autoload -(defun ediff-documentation (&optional node) - "Display Ediff's manual. -With optional NODE, goes to that node." - (interactive) - (let ((ctl-window ediff-control-window) - (ctl-buf ediff-control-buffer)) - - (ediff-skip-unsuitable-frames) - (condition-case nil - (progn - (pop-to-buffer (get-buffer-create "*info*")) - (info (if ediff-xemacs-p "ediff.info" "ediff")) - (if node - (Info-goto-node node) - (message "Type `i' to search for a specific topic")) - (raise-frame (selected-frame))) - (error (beep 1) - (with-output-to-temp-buffer ediff-msg-buffer - (princ ediff-BAD-INFO)) - (if (window-live-p ctl-window) - (progn - (select-window ctl-window) - (set-window-buffer ctl-window ctl-buf))))))) - - - - -;;; Local Variables: -;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;;; End: - -(require 'ediff-util) - -;;; ediff.el ends here
--- a/lisp/efs/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,314 +0,0 @@ -############################################################################### -# -# File: Makefile -# Release: $efs release: 1.15 $ -# Version: $Revision: 1.9 $ -# RCS: -# Description: Makefile for byte-compiling efs and dired. -# Author: Andy Norman, HPLabs, Bristol, UK. -# Created: Sat Jan 30 00:18:56 1993 -# Language: Text (make script) -# -############################################################################### - -## Installation Instructions -############################ -# 1. Edit the configuration variables below. -# EMACS should be the name of the emacs program on your system. -# VERSION should be the emacs version. This must be one of: -# 18 for all versions of Emacs 18. -# 19 for all versions of the original GNU Emacs from FSF between -# 19.1 and 19.22, inclusive. -# 19.23 for version 19.23 and later of the original GNU Emacs from FSF -# l19.11 for XEmacs 19.11 trhu 19.14 -# x19.15 for XEmacs 19.15 -# x20 for XEmacs 20.1 and later -# LISPDIR should be the directory in which you want the .elc -# files installed. -# BDIR should be the directory containing the .elc files for the -# byte-compiler. Although efs byte-compiles and works with the -# Emacs V18 byte-compiler, it is strongly recommended to use -# Jamie Zawinski's V19 byte-compiler. This byte-compiler is -# standard with Lucid Emacs, XEmacs, and GNU Emacs V19, so in this -# case you can set BDIR to nothing. -# VMDIR should be set to the directory containing the .elc files for -# VM. If you aren't using VM, then set this to nothing. -# -# 2. To byte-compile the entire package, except for VM support (efs-vm.el), -# run make VERSION, where VERSION is the emacs version that you are -# compiling for. It must be one of: -# 18 for Emacs 18 -# 19 for the original GNU Emacs from FSF, versions 19.1 through -# 19.22, inclusive -# 19.23 for the original GNU Emacs from FSF, version 19.23 and later. -# l19.11 for Lucid XEmacs 19.11 thru 19.14 -# x19.15 for XEmacs 19.15 -# x20 for XEmacs 20.1 and later -# -# If you have set the VERSION variable correctly, then typing just -# make will suffice. -# -# 3. To byte-compile everything, including VM support, run make all. -# -# 4. To byte-compile all the efs files, except for VM support, -# run make efs. -# -# 5. To byte-compile only the core efs files run make core. -# -# 6. To byte compile an efs-XXX.el file, run make XXX. -# This means that VM support can be compiled by running make vm. -# -# 7. To byte compile only dired, run make dired. -# -# 8. To byte-compile only efs-auto.el, for autoloading efs, run make auto. -# - -## Edit these variables according to your configuration. - -# Name of Emacs program -EMACS=xemacs -# Emacs version. This must be set to one of 18, 19, 19.23, -# l19.11, x19.15 -VERSION=x19.15 -# Current working directory -CWD=`pwd` -# Directory in which to install the lisp files -LISPDIR= -# Directory in which to install the info files -INFODIR= -# Directory in which to install the Texinfo file -TEXIDIR= -# Directory containing byte-compiler. This is used by fixup.el -BDIR= -# Directory containing VM's .elc files. -VMDIR= -# Bourne shell executable, please. -SHELL=/bin/sh - -###### It should not be necessary to edit anything below this line. ###### - -COREOBJS = efs-defun.elc efs-ovwrt.elc efs-fnh.elc efs-cu.elc efs-netrc.elc \ - efs.elc efs-dired.elc efs-report.elc \ - efs-cp-p.elc \ - efs-dump.elc -CORESRC = efs-defun.el efs-ovwrt.el efs-fnh.el efs-cu.el efs-netrc.el \ - efs.el efs-dired.el efs-report.el \ - efs-cp-p.el \ - efs-dump.el -DOBJS = default-dir.elc dired.elc dired-mob.elc dired-oas.elc \ - dired-rgxp.elc dired-shell.elc dired-vir.elc dired-xy.elc \ - dired-grep.elc dired-uu.elc \ - dired-cmpr.elc dired-diff.elc dired-help.elc dired-sex.elc -DSRC = default-dir.el dired.el dired-mob.el dired-oas.el \ - dired-rgxp.el dired-shell.el dired-vir.el dired-xy.el \ - dired-grep.el dired-uu.el \ - dired-cmpr.el dired-diff.el dired-help.el dired-sex.el -EFSOBJS = $(COREOBJS) efs-auto.elc \ - efs-cms.elc efs-cms-knet.elc efs-dos-distinct.elc efs-nos-ve.elc \ - efs-gwp.elc efs-kerberos.elc efs-hell.elc efs-ka9q.elc \ - efs-mpe.elc efs-mts.elc efs-mvs.elc efs-netware.elc \ - efs-pc.elc efs-ti-explorer.elc efs-ti-twenex.elc \ - efs-tops-20.elc efs-dl.elc efs-guardian.elc efs-coke.elc \ - efs-vms.elc efs-vos.elc efs-plan9.elc efs-ms-unix.elc -EFSSRC = $(CORESRC) efs-auto.el \ - efs-cms.el efs-cms-knet.el efs-dos-distinct.el efs-nos-ve.el \ - efs-gwp.el efs-kerberos.el efs-hell.el efs-ka9q.el \ - efs-mpe.el efs-mts.el efs-mvs.el efs-netware.el \ - efs-pc.el efs-ti-explorer.el efs-ti-twenex.el \ - efs-tops-20.el efs-dl.el efs-guardian.el efs-coke.el \ - efs-vms.el efs-vos.el efs-plan9.el efs-ms-unix.el -VMOBJS = efs-vm.elc -VMSRC = efs-vm.el -MULEOBJS = dired-mule.elc efs-dired-mule.elc -MULESRC = dired-mule.el efs-dired-mule.el -GEOBJS = dired-fsf.elc \ - passwd.elc diff.elc auto-save.elc \ - $(MULEOBJS) -GESRC = dired-fsf.el \ - passwd.el diff.el auto-save.el \ - $(MULESRC) -XEOBJS = dired-faces.elc dired-xemacs.elc \ - $(VMOBJS) -XESRC = dired-faces.el dired-xemacs.el \ - $(VMSRC) $(MULESRC) -OBJS = $(DOBJS) $(EFSOBJS) $(VMOBJS) $(GEOBJS) $(XEOBJS) \ - efs-18.elc efs-19.elc efs-19.23.elc \ - efs-l19.11.elc efs-x19.15.elc \ - emacs-19.elc fn-handler.elc \ - reporter.elc - -# fixup.el is never byte-compiled. It would do no harm, but be a waste -# of time. - -## Specify new rules. - -.SUFFIXES: .elc .el .texi .info - -.el.elc: - BDIR=$(BDIR) CWD=$(CWD) VMDIR=$(VMDIR) \ - $(EMACS) -batch -no-site-file -l $(CWD)/fixup -f batch-byte-compile $(CWD)/$< - -.texi.info: - $(EMACS) -batch -f batch-texinfo-format $(CWD)/$< - -## targets - -# What lazy fingers buys you -default: $(VERSION) dired - -# .elc files depend on .el source -# Do this in this brain-dead way because different makes do pattern -# rules differently. grumble grumble... -# -# dired -dired.elc: dired.el -dired-mob.elc: dired-mob.el -dired-oas.elc: dired-oas.el -dired-rgxp.elc: dired-rgxp.el -dired-shell.elc: dired-shell.el -dired-vir.elc: dired-vir.el -dired-xy.elc: dired-xy.el -dired-grep.elc: dired-grep.el -dired-uu.elc: dired-uu.el -dired-fsf.elc: dired-fsf.el -dired-cmpr.elc: dired-cmpr.el -dired-help.elc: dired-help.el -dired-diff.elc: dired-diff.el -dired-sex.elc: dired-sex.el -dired-mule.elc: dired-mule.el -dired-xemacs.elc: dired-xemacs.el -dired-faces.elc: dired-faces.el -default-dir.elc: default-dir.el -diff.elc: diff.el -# efs core files -efs.elc: efs.el -efs-defun.elc: efs-defun.el -efs-cp-p.elc: efs-cp-p.el -efs-cu.elc: efs-cu.el -efs-netrc.elc: efs-netrc.el -efs-auto.elc: efs-auto.el -efs-dired.elc: efs-dired.el -efs-dired-mule.elc: efs-dired-mule.el -efs-report.elc: efs-report.el -efs-ovwrt.elc: efs-ovwrt.el -efs-fnh.elc: efs-fnh.el -# efs multi-OS and FTP server support -efs-cms.elc: efs-cms.el -efs-cms-knet.elc: efs-cms-knet.el -efs-coke.elc: efs-coke.el -efs-dos-distinct.elc: efs-dos-distinct.el -efs-nos-ve.elc: efs-nos-ve.el -efs-gwp.elc: efs-gwp.el -efs-hell.elc: efs-hell.el -efs-ka9q.elc: efs-ka9q.el -efs-kerberos.elc: efs-kerberos.el -efs-mpe.elc: efs-mpe.el -efs-mts.elc: efs-mts.el -efs-mvs.elc: efs-mvs.el -efs-netware.elc: efs-netware.el -efs-pc.elc: efs-pc.el -efs-ti-explorer.elc: efs-ti-explorer.el -efs-ti-twenex.elc: efs-ti-twenex.el -efs-tops-20.elc: efs-tops-20.el -efs-dl.elc: efs-dl.el -efs-vms.elc: efs-vms.el -efs-vos.elc: efs-vos.el -efs-guardian.elc: efs-guardian.el -efs-plan9.elc: efs-plan9.el -efs-ms-unix.elc: efs-ms-unix.el -# efs support for different Emacs versions -efs-18.elc: efs-18.el -efs-19.elc: efs-19.el -efs-19.23.elc: efs-19.23.el -efs-l19.11.elc: efs-l19.11.el -efs-x19.15.elc: efs-x19.15.el -# efs vm support -efs-vm.elc: efs-vm.el -# backward compatibility files -fn-handler.elc: fn-handler.el -emacs-19.elc: emacs-19.el -# auto-save package -auto-save.elc: auto-save.el - -# Core targets -core: $(COREOBJS) - -# Extra perks -auto: core efs-auto.elc -cms: core efs-cms.elc -cms-knet: core efs-cms-knet.elc -dos-distinct: core efs-dos-distinct.elc -nos-ve: core efs-nos-ve.elc -gwp: core efs-gwp.elc -hell: core efs-hell.elc -ka9q: core efs-ka9q.elc -kerberos: core efs-kerberos.elc -mpe: core efs-mpe.elc -mts: core efs-mts.elc -mvs: core efs-mvs.elc -netware: core efs-netware.elc -pc: core efs-pc.elc -ti-explorer: core efs-ti-explorer.elc -ti-twenex: core efs-ti-twenex.elc -tops-20: core efs-tops-20.elc -dl: core efs-dl.elc -vms: core efs-vms.elc -vos: core efs-vos.elc -guardian: core efs-guardian.elc -plan9: core efs-plan9.elc -coke: core efs-coke.elc -vm: core $(VMOBJS) - -# The grand tour -efs: $(EFSOBJS) -dired: $(DOBJS) -all: $(OBJS) -info: efs.info - -# Making for a specific emacs version -18: emacs-19.elc fn-handler.elc efs dired efs-18.elc dired-mule.elc \ - efs-dired-mule.elc reporter.elc passwd.elc diff.elc auto-save.elc -19: fn-handler.elc efs dired efs-19.elc $(GEOBJS) -19.23: efs dired efs-19.23.elc $(GEOBJS) -l19.11: efs dired efs-l19.11.elc $(XEOBJS) -x19.15: efs dired efs-x19.15.elc $(XEOBJS) -x20: efs dired efs-x19.15.elc $(XEOBJS) $(MULEOBJS) - -# Installation -install: - @echo "Installing in $(LISPDIR)..." - cp *.elc $(LISPDIR) - cp efs.info $(INFODIR) -install_src: - @echo "Installing in $(LISPDIR)..." - cp `ls *.el | grep -v "fixup"` $(LISPDIR) - cp efs.texi $(TEXIDIR) -install_xemacs: - @echo "Installing source in $(LISPDIR)..." - cp $(EFSSRC) $(DSRC) $(XESRC) efs-x19.15.el $(LISPDIR) - cp Makefile README fixup.el $(LISPDIR) - cp efs.texi $(TEXIDIR) -diff_xemacs: - for f in $(EFSSRC) $(DSRC) $(XESRC) efs-x19.15.el \ - Makefile README fixup.el; do \ - if [ -e $(LISPDIR)/$$f ]; \ - then\ - diff -c $(LISPDIR)/$$f $$f; \ - else \ - diff -c /dev/null $$f; \ - fi \ - done -install_all: install_src install -clean: - rm -f $(OBJS) - -autoloads: auto-autoloads.el - -auto-autoloads.el: $(EFSSRC) $(DSRC) efs-x19.15.el $(XESRC) $(MULESRC) - $(EMACS) -batch -q -no-site-file \ - -eval '(setq autoload-target-directory "'`pwd`'/")' \ - -eval '(setq autoload-package-name "efs")' \ - -l autoload \ - -f batch-update-autoloads $? - -## end of Makefile ##
--- a/lisp/efs/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -This version of EFS was modified for integration with XEmacs by -Mike Sperber <sperber@informatik.uni-tuebingen.de>. -He is the current maintainer of this version of EFS. - -A Few Things That You Should Know About EFS: --------------------------------------------- - -For documentation, see the first page of the file efs.el. If you -access FTP via a gateway, then be sure to read the documentation in -efs.el on how to configure efs to use a gateway. To find the section -on user customization variables in efs.el, search for the first -occurrence of the string ">>>>". TeXinfo documentation is -forthcoming. - -The file CHANGES contains a description of changes to EFS from the -previous release to this release. It also tells you where you can get -the latest version of efs. - -The file LISTS contains a description of mailing lists relevant to -efs. It too tells you where you can get the latest version of efs. -We encourage users to join these lists. - -EFS and archie.el: ------------------- - -To use archie.el (by Jack Repenning) with efs, you need at least -archie.el V3.0.1. Problems using efs with archie may be posted to the -efs mailing lists.
--- a/lisp/efs/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,268 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'efs-autoloads) (error "Already loaded")) - -;;;### (autoloads nil "default-dir" "efs/default-dir.el") - -(defvar default-directory-function nil "\ -A function to call to compute the default-directory for the current buffer. -If this is nil, the function default-directory will return the value of the -variable default-directory. -Buffer local.") - -;;;*** - -;;;### (autoloads (dired-jump-back-other-frame dired-jump-back-other-window dired-jump-back dired-noselect dired-other-frame dired-other-window dired default-directory) "dired" "efs/dired.el") - -(autoload 'default-directory "dired" "\ - Returns the default-directory for the current buffer. -Will use the variable default-directory-function if it non-nil." nil nil) - -(defvar dired-compression-method 'compress "\ -*Type of compression program to use. -Give as a symbol. -Currently-recognized methods are: gzip pack compact compress. -To change this variable use \\[dired-do-compress] with a zero prefix.") - -(defvar dired-compression-method-alist '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") (pack ".z" ("pack" "-f") ("unpack")) (compact ".C" ("compact") ("uncompact"))) "\ -*Association list of compression method descriptions. - Each element of the table should be a list of the form - - (compress-type extension (compress-args) (decompress-args) force-flag) - - where - `compress-type' is a unique symbol in the alist to which - `dired-compression-method' can be set; - `extension' is the file extension (as a string) used by files compressed - by this method; - `compress-args' is a list of the path of the compression program and - flags to pass as separate arguments; - `decompress-args' is a list of the path of the decompression - program and flags to pass as separate arguments. - `force-flag' is the switch to pass to the command to force overwriting - of existing files. - - For example: - - (setq dired-compression-method-alist - (cons '(frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\") \"-f\") - dired-compression-method-alist)) - => ((frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\")) - (gzip \".gz\" (\"gzip\") (\"gunzip\")) - ...) - - See also: dired-compression-method <V>") - -(defvar dired-ls-program "ls" "\ -*Absolute or relative name of the ls program used by dired.") - -(defvar dired-listing-switches "-al" "\ -*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -(defvar dired-chown-program (if (memq system-type '(hpux dgux usg-unix-v linux)) "chown" "/etc/chown") "\ -*Name of chown command (usually `chown' or `/etc/chown').") - -(defvar dired-gnutar-program nil "\ -*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") - -(defvar dired-unshar-program nil "\ -*Set to the name of the unshar program, if you have it.") - -(defvar dired-local-variables-file ".dired" "\ -*If non-nil, filename for local variables for Dired. -If Dired finds a file with that name in the current directory, it will -temporarily insert it into the dired buffer and run `hack-local-variables'. - -Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on -local variables.") - -(defvar dired-kept-versions 2 "\ -*When cleaning directory, number of versions to keep.") - -(defvar dired-find-subdir nil "\ -*Determines whether dired tries to lookup a subdir in existing buffers. -If non-nil, dired does not make a new buffer for a directory if it can be -found (perhaps as subdir) in some existing dired buffer. If there are several -dired buffers for a directory, then the most recently used one is chosen. - -Dired avoids switching to the current buffer, so that if you have -a normal and a wildcard buffer for the same directory, C-x d RET will -toggle between those two.") - -(defvar dired-use-file-transformers t "\ -*Determines whether dired uses file transformers. -If non-nil `dired-do-shell-command' will apply file transformers to file names. -See \\[describe-function] for dired-do-shell-command for more information.") - -(defvar dired-dwim-target nil "\ -*If non-nil, dired tries to guess a default target directory. -This means that if there is a dired buffer displayed in the next window, -use its current subdir, instead of the current subdir of this dired buffer. -The target is put in the prompt for file copy, rename, etc.") - -(defvar dired-copy-preserve-time nil "\ -*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\<dired-mode-map> -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -(defvar dired-no-confirm nil "\ -*If non-nil, a list of symbols for commands dired should not confirm. -It can be a sublist of - - '(byte-compile chgrp chmod chown compress copy delete hardlink load - move print shell symlink uncompress recursive-delete kill-file-buffer - kill-dired-buffer patch create-top-dir revert-subdirs) - -The meanings of most of the symbols are obvious. A few exceptions: - - 'compress applies to compression or decompression by any of the - compression program in `dired-compression-method-alist'. - - 'kill-dired-buffer applies to offering to kill dired buffers for - directories which have been deleted. - - 'kill-file-buffer applies to offering to kill buffers visiting files - which have been deleted. - - 'recursive-delete applies to recursively deleting non-empty - directories, and all of their contents. - - 'create-top-dir applies to `dired-up-directory' creating a new top level - directory for the dired buffer. - - 'revert-subdirs applies to re-reading subdirectories which have - been modified on disk. - -Note that this list also applies to remote files accessed with efs -or ange-ftp.") - -(defvar dired-backup-if-overwrite nil "\ -*Non-nil if Dired should ask about making backups before overwriting files. -Special value 'always suppresses confirmation.") - -(defvar dired-omit-files nil "\ -*If non-nil un-interesting files will be omitted from this dired buffer. -Use \\[dired-omit-toggle] to see these files. (buffer local)") - -(defvar dired-mail-reader 'vm "\ -*Mail reader used by dired for dired-read-mail (\\[dired-read-mail]). -The symbols 'rmail and 'vm are the only two allowed values.") - -(defvar dired-refresh-automatically t "\ -*If non-nil, refresh dired buffers automatically after file operations.") - -(define-key ctl-x-map "d" 'dired) - -(autoload 'dired "dired" "\ -\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) -Dired displays a list of files in DIRNAME (which may also have -shell wildcards appended to select certain files). If DIRNAME is a cons, -its first element is taken as the directory name and the resr as an explicit -list of files to make directory entries for. -\\<dired-mode-map>You can move around in it with the usual commands. -You can flag files for deletion with \\[dired-flag-file-deletion] and then -delete them by typing \\[dired-expunge-deletions]. -Type \\[dired-describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." t nil) - -(define-key ctl-x-4-map "d" 'dired-other-window) - -(autoload 'dired-other-window "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but selects in another window." t nil) - -(define-key ctl-x-5-map "d" 'dired-other-frame) - -(autoload 'dired-other-frame "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." t nil) - -(autoload 'dired-noselect "dired" "\ -Like `dired' but returns the dired buffer as value, does not select it." nil nil) - -(define-key ctl-x-map "\C-j" 'dired-jump-back) - -(autoload 'dired-jump-back "dired" "\ -Jump back to dired. -If in a file, dired the current directory and move to file's line. -If in dired already, pop up a level and goto old directory's line. -In case the proper dired file line cannot be found, refresh the dired - buffer and try again." t nil) - -(define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) - -(autoload 'dired-jump-back-other-window "dired" "\ -Like \\[dired-jump-back], but to other window." t nil) - -(define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) - -(autoload 'dired-jump-back-other-frame "dired" "\ -Like \\[dired-jump-back], but in another frame." t nil) - -;;;*** - -;;;### (autoloads (efs-ftp-path) "efs-cu" "efs/efs-cu.el") - -(defvar efs-path-root-regexp "^/[^/:]+:" "\ -Regexp to match the `/user@host:' root of an efs full path.") - -(autoload 'efs-ftp-path "efs-cu" "\ -Parse PATH according to efs-path-regexp. -Returns a list (HOST USER PATH), or nil if PATH does not match the format." nil nil) - -;;;*** - -;;;### (autoloads (remote-path-file-handler-function) "efs-dump" "efs/efs-dump.el") - -(or (assoc efs-path-root-regexp file-name-handler-alist) (setq file-name-handler-alist (cons (cons efs-path-root-regexp 'remote-path-file-handler-function) file-name-handler-alist))) - -(autoload 'remote-path-file-handler-function "efs-dump" "\ -Function to call special file handlers for remote files." nil nil) - -;;;*** - -;;;### (autoloads nil "efs-fnh" "efs/efs-fnh.el") - -(defvar allow-remote-paths t "\ -*Set this to nil if you don't want remote paths to access -remote files.") - -;;;*** - -;;;### (autoloads (efs-root-file-name-completion efs-root-file-name-all-completions efs-set-passwd) "efs-netrc" "efs/efs-netrc.el") - -(autoload 'efs-set-passwd "efs-netrc" "\ -For a given HOST and USER, set or change the associated PASSWORD." t nil) - -(autoload 'efs-root-file-name-all-completions "efs-netrc" nil nil nil) - -(autoload 'efs-root-file-name-completion "efs-netrc" nil nil nil) - -;;;*** - -;;;### (autoloads (efs-report-bug) "efs-report" "efs/efs-report.el") - -(autoload 'efs-report-bug "efs-report" "\ -Submit a bug report for efs." t nil) - -;;;*** - -;;;### (autoloads (efs-file-handler-function efs-nslookup-host efs-display-ftp-activity) "efs" "efs/efs.el") - -(autoload 'efs-display-ftp-activity "efs" "\ -Displays the number of active background ftp sessions in the modeline. -Uses the variable `efs-mode-line-format' to determine how this will be -displayed." t nil) - -(autoload 'efs-nslookup-host "efs" "\ -Attempt to resolve the given HOSTNAME using nslookup if possible." t nil) - -(autoload 'efs-file-handler-function "efs" "\ -Function to call special file handlers for remote files." nil nil) - -;;;*** - -(provide 'efs-autoloads)
--- a/lisp/efs/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Thu Oct 9 20:52:10 1997 - -;;; Code: - -(custom-put 'environment 'custom-loads '("dired-faces")) -(custom-put 'dired 'custom-loads '("dired-faces")) - -;;; custom-load.el ends here
--- a/lisp/efs/default-dir.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,418 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: default-dir.el -;; RCS: -;; Version: #Revision: 1.5 $ -;; Description: Defines the function default-directory, for fancy handling -;; of the initial contents in the minibuffer when reading -;; file names. -;; Authors: Sebastian Kremer <sk@thp.uni-koeln.de> -;; Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Sun Jul 18 11:38:06 1993 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; This program 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 1, or (at your option) -;; any later version. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'default-dir) -(require 'efs-ovwrt) - -(defconst default-dir-emacs-variant - (cond ((string-match "XEmacs" emacs-version) 'xemacs) - ((>= (string-to-int (substring emacs-version 0 2)) 19) 'fsf-19) - (t 'fsf-18))) - -(defconst default-dir-find-file-takes-coding-system - (and (eq default-dir-emacs-variant 'xemacs) - (>= (string-to-int (substring emacs-version 0 2)) 20))) - -;;;###autoload -(defvar default-directory-function nil - "A function to call to compute the default-directory for the current buffer. -If this is nil, the function default-directory will return the value of the -variable default-directory. -Buffer local.") -(make-variable-buffer-local 'default-directory-function) - -;; As a bonus we give shell-command history if possible. -(defvar shell-command-history nil - "History list of previous shell commands.") - -(defun default-directory () - " Returns the default-directory for the current buffer. -Will use the variable default-directory-function if it non-nil." - (if default-directory-function - (funcall default-directory-function) - (if (eq default-dir-emacs-variant 'xemacs) - (abbreviate-file-name default-directory t) - (abbreviate-file-name default-directory)))) - -;;; Overloads - -(cond - ((or (featurep 'mule) - (boundp 'MULE)) - - (defun default-dir-find-file (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file: " (default-directory))) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file file coding-system)) - - (defun default-dir-find-file-other-window (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other window: " (default-directory))) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-other-window file coding-system)) - - (defun default-dir-find-file-read-only (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only: " (default-directory) nil t)) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-read-only file coding-system)) - - (if (fboundp 'find-file-read-only-other-window) - (progn - (defun default-dir-find-file-read-only-other-window - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name - "Find file read-only in other window: " - (default-directory) nil t)) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-read-only-other-window file - coding-system)))) - - (if (fboundp 'find-file-other-frame) - (progn - (defun default-dir-find-file-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other frame: " - (default-directory))) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-other-frame file - coding-system)))) - - (if (fboundp 'find-file-read-only-other-frame) - (progn - (defun default-dir-find-file-read-only-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only in other frame: " - (default-directory) nil t)) - (and current-prefix-arg - (read-coding-system "Coding-system: ")))) - (default-dir-real-find-file-read-only-other-frame file - coding-system))))) - - (default-dir-find-file-takes-coding-system - ;; This lossage is due to the fact that XEmacs 20.x without mule - ;; still accepts an optional argument for find-file related - ;; functions. Things like advice.el insist on passing nil for - ;; optional arguments, and the interaction screws things up. - ;; Therefore these functions accept an optional dummy coding-system - ;; argument. - - (defun default-dir-find-file (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file: " (default-directory))))) - (default-dir-real-find-file file)) - - (defun default-dir-find-file-other-window (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other window: " (default-directory))))) - (default-dir-real-find-file-other-window file)) - - (defun default-dir-find-file-read-only (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only: " (default-directory) nil t)))) - (default-dir-real-find-file-read-only file)) - - (if (fboundp 'find-file-read-only-other-window) - (progn - (defun default-dir-find-file-read-only-other-window - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name - "Find file read-only in other window: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-window file)))) - - (if (fboundp 'find-file-other-frame) - (progn - (defun default-dir-find-file-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other frame: " - (default-directory))))) - (default-dir-real-find-file-other-frame file)))) - - (if (fboundp 'find-file-read-only-other-frame) - (progn - (defun default-dir-find-file-read-only-other-frame - (file &optional coding-system) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only in other frame: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-frame file))))) - - (t - - (defun default-dir-find-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file: " (default-directory))))) - (default-dir-real-find-file file)) - - (defun default-dir-find-file-other-window (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other window: " (default-directory))))) - (default-dir-real-find-file-other-window file)) - - (defun default-dir-find-file-read-only (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only: " (default-directory) nil t)))) - (default-dir-real-find-file-read-only file)) - - (if (fboundp 'find-file-read-only-other-window) - (progn - (defun default-dir-find-file-read-only-other-window (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name - "Find file read-only in other window: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-window file)))) - - (if (fboundp 'find-file-other-frame) - (progn - (defun default-dir-find-file-other-frame (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file in other frame: " - (default-directory))))) - (default-dir-real-find-file-other-frame file)))) - - (if (fboundp 'find-file-read-only-other-frame) - (progn - (defun default-dir-find-file-read-only-other-frame (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Find file read-only in other frame: " - (default-directory) nil t)))) - (default-dir-real-find-file-read-only-other-frame file)))))) - - - -(efs-overwrite-fn "default-dir" 'find-file 'default-dir-find-file) -(efs-overwrite-fn "default-dir" 'find-file-other-window - 'default-dir-find-file-other-window) -(if (fboundp 'find-file-other-frame) - (efs-overwrite-fn "default-dir" 'find-file-other-frame - 'default-dir-find-file-other-frame)) -(efs-overwrite-fn "default-dir" 'find-file-read-only - 'default-dir-find-file-read-only) -(if (fboundp 'find-file-read-only-other-window) - (efs-overwrite-fn "default-dir" 'find-file-read-only-other-window - 'default-dir-find-file-read-only-other-window)) -(if (fboundp 'find-file-read-only-other-frame) - (efs-overwrite-fn "default-dir" 'find-file-read-only-other-frame - 'default-dir-find-file-read-only-other-frame)) - - -(defun default-dir-load-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Load file: " (default-directory) nil t)))) - (default-dir-real-load-file file)) - -(efs-overwrite-fn "default-dir" 'load-file 'default-dir-load-file) - -(condition-case nil - (require 'view-less) - (error (require 'view))) - -(defun default-dir-view-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "View file: " (default-directory) nil t)))) - (default-dir-real-view-file file)) - -(efs-overwrite-fn "default-dir" 'view-file 'default-dir-view-file) - -(if (fboundp 'view-file-other-window) - (progn - (defun default-dir-view-file-other-window (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "View file in other window: " - (default-directory) nil t)))) - (default-dir-real-view-file-other-window file)) - (efs-overwrite-fn "default-dir" 'view-file-other-window - 'default-dir-view-file-other-window))) - -(if (fboundp 'view-file-other-frame) - (progn - (defun default-dir-view-file-other-frame (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "View file in other frame: " - (default-directory) nil t)))) - (default-dir-real-view-file-other-frame file)) - (efs-overwrite-fn "default-dir" 'view-file-other-frame - 'default-dir-view-file-other-frame))) - - -(defun default-dir-shell-command (command &optional output-buffer) - "Documented as original" - (interactive - (list - (let ((prompt (format "Shell command in %s: " (default-directory)))) - (cond - ((eq default-dir-emacs-variant 'xemacs) - (read-shell-command "Shell command: ")) - ((eq default-dir-emacs-variant 'fsf-19) - (read-from-minibuffer prompt nil nil nil 'shell-command-history)) - ((featurep 'gmhist) - (let ((minibuffer-history-symbol 'shell-command-history)) - (read-string prompt))) - (t (read-string prompt)))) - current-prefix-arg)) - (let ((default-directory (expand-file-name (default-directory)))) - (default-dir-real-shell-command command output-buffer))) - -(efs-overwrite-fn "default-dir" 'shell-command 'default-dir-shell-command) - -(defun default-dir-cd (dir) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Change default directory: " (default-directory))))) - (default-dir-real-cd dir)) - -(efs-overwrite-fn "default-dir" 'cd 'default-dir-cd) - -(defun default-dir-set-visited-file-name (filename) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Set visited file name: " (default-directory))))) - (default-dir-real-set-visited-file-name filename)) - -(efs-overwrite-fn "default-dir" 'set-visited-file-name - 'default-dir-set-visited-file-name) - -(defun default-dir-insert-file (filename &rest args) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Insert file: " (default-directory) nil t)))) - (apply 'default-dir-real-insert-file filename args)) - -(efs-overwrite-fn "default-dir" 'insert-file 'default-dir-insert-file) - -(defun default-dir-append-to-file (start end filename &rest args) - "Documented as original" - (interactive - (progn - (or (mark) (error "The mark is not set now")) - (list - (min (mark) (point)) - (max (mark) (point)) - (expand-file-name - (read-file-name "Append to file: " (default-directory)))))) - (apply 'default-dir-real-append-to-file start end filename args)) - -(efs-overwrite-fn "default-dir" 'append-to-file 'default-dir-append-to-file) - -(defun default-dir-delete-file (file) - "Documented as original" - (interactive - (list - (expand-file-name - (read-file-name "Delete file: " (default-directory) nil t)))) - (default-dir-real-delete-file file)) - -(efs-overwrite-fn "default-dir" 'delete-file 'default-dir-delete-file) - -;;; end of default-dir.el
--- a/lisp/efs/dired-cmpr.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,315 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-cmpr.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for compressing marked files. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-cmpr) -(require 'dired) - -;;; Entry points. - -(defun dired-do-compress (&optional arg files) - "Compress or uncompress marked (or next ARG) files. -With a zero prefix, prompts for a new value of `dired-compression-method'." - (interactive - (let ((arg (prefix-numeric-value current-prefix-arg)) - files) - (if (zerop arg) - (let ((new (completing-read - (format "Set compression method (currently %s): " - dired-compression-method) - (mapcar - (function - (lambda (x) - (cons (symbol-name (car x)) nil))) - dired-compression-method-alist) - nil t))) - (or (string-equal new "") - (setq dired-compression-method (intern new)))) - (setq files (dired-get-marked-files nil current-prefix-arg)) - (or (memq 'compress dired-no-confirm) - (let* ((dir (dired-current-directory)) - (rfiles (mapcar (function - (lambda (fn) - (dired-make-relative fn dir t))) - files)) - (prompt "") - (comp 0) - (uncomp nil) - (total (length files)) - elt) - (mapcar (function - (lambda (fn) - (if (listp (setq elt - (dired-make-compressed-filename fn))) - (let* ((method (car (nth 3 elt))) - (count (assoc method uncomp))) - (if count - (setcdr count (1+ (cdr count))) - (setq uncomp (cons (cons method 1) uncomp)))) - (setq comp (1+ comp))))) - files) - (if (/= comp 0) - (setq prompt - (format "%s %d" - (car - (nth 2 - (assq dired-compression-method - dired-compression-method-alist))) - comp))) - (if uncomp - (let ((case-fold-search t) - method) - (or (string-equal prompt "") - (setq prompt (concat prompt "; "))) - (setq uncomp - (sort - (mapcar - (function - (lambda (elt) - (setq method (car elt)) - (if (string-equal method "gzip") - (setq method "gunzip") - (or (string-match "^un" method) - (setq method (concat "un" method)))) - (setcar elt method) - elt)) - uncomp) - (function - (lambda (x y) - (string< (car x) (car y)))))) - (setq prompt - (concat prompt - (mapconcat - (function - (lambda (elt) - (format "%s %d" (car elt) (cdr elt)))) - uncomp ", "))))) - (cond - ((= (length rfiles) 1) - (setq prompt (format "%s %s? " - ;; Don't need the number 1 - (substring prompt 0 -2) - (car rfiles)))) - ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp)) - (setq prompt (format "%s? Total: %d file%s " prompt total - (dired-plural-s total)))) - ((setq prompt (format "%s file%s? " prompt - (dired-plural-s total))))) - (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) - (setq arg 0))))) - (list arg files))) - - (if (not (zerop arg)) - (dired-create-files - 'dired-compress-file - "Compress or Uncompress" - files - (function - (lambda (fn) - (let ((cfn (dired-make-compressed-filename fn))) - (if (stringp cfn) - cfn - (substring fn 0 (- (length (nth 1 cfn)))))))) - dired-keep-marker-compress nil t))) - -(defun dired-compress-subdir-files (&optional uncompress) - "Compress all uncompressed files in the current subdirectory. -With a prefix argument uncompresses all compressed files." - (interactive "P") - (let ((dir (dired-current-directory)) - files methods uncomp elt) - (save-excursion - (save-restriction - (narrow-to-region (dired-subdir-min) (dired-subdir-max)) - (dired-map-dired-file-lines - (function - (lambda (f) - (if uncompress - (and (listp (setq uncomp (dired-make-compressed-filename f))) - (let ((program (car (nth 3 uncomp)))) - (setq files (cons f files)) - (if (setq elt (assoc program methods)) - (setcdr elt (1+ (cdr elt))) - (setq methods (cons (cons program 1) methods))))) - (and (stringp (dired-make-compressed-filename f)) - (setq files (cons f files))))))))) - (if files - (let ((total (length files)) - (rfiles (mapcar - (function - (lambda (fn) - (dired-make-relative fn dir t))) - files)) - prompt) - (if uncompress - (progn - (setq prompt (mapconcat - (function - (lambda (x) - (format "%s %d" - (if (string-equal (car x) "gzip") - "gunzip" - (if (string-match "^un" (car x)) - (car x) - (concat "un" (car x)))) - (cdr x)))) - methods ", ")) - (cond - ((= total 1) - (setq prompt - (concat (substring prompt 0 -1) (car rfiles) "? "))) - ((= (length methods) 1) - (setq prompt - (format "%s file%s? " prompt (dired-plural-s total)))) - (t - (setq prompt (format "%s? Total: %d file%s " prompt total - (dired-plural-s total)))))) - (setq prompt - (if (= total 1) - (format "%s %s? " dired-compression-method (car rfiles)) - (format "%s %d file%s? " - dired-compression-method total - (dired-plural-s total))))) - (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) - (dired-create-files - 'dired-compress-file - "Compress or Uncompress" - files - (function - (lambda (fn) - (let ((cfn (dired-make-compressed-filename fn))) - (if (stringp cfn) - cfn - (substring fn 0 (- (length (nth 1 cfn)))))))) - dired-keep-marker-compress nil t))) - (message "No files need %scompressing in %s." - (if uncompress "un" "") - (dired-abbreviate-file-name dir))))) - -(defun dired-compress-file (file ok-flag) - ;; Compress or uncompress FILE. - ;; If ok-flag is non-nil, it is OK to overwrite an existing - ;; file. How well this actually works may depend on the compression - ;; program. - ;; Return the name of the compressed or uncompressed file. - (let ((handler (find-file-name-handler file 'dired-compress-file))) - (if handler - (funcall handler 'dired-compress-file file ok-flag) - (let ((compressed-fn (dired-make-compressed-filename file)) - (err-buff (get-buffer-create " *dired-check-process output*"))) - (save-excursion - (set-buffer err-buff) - (erase-buffer) - (cond ((file-symlink-p file) - (signal 'file-error (list "Error compressing file" - file "a symbolic link"))) - ((listp compressed-fn) - (message "Uncompressing %s..." file) - (let* ((data (nth 3 compressed-fn)) - (ret - (apply 'call-process - (car data) file t nil - (append (cdr data) - (and ok-flag - (list (nth 4 compressed-fn))) - (list file))))) - (if (or (and (integerp ret) (/= ret 0)) - (not (bobp))) - (signal 'file-error - (nconc - (list "Error uncompressing file" - file) - (and (not (bobp)) - (list - (progn - (goto-char (point-min)) - (buffer-substring - (point) (progn (end-of-line) - (point)))))))))) - (message "Uncompressing %s...done" file) - (dired-remove-file file) - (let ((to (substring file 0 - (- (length (nth 1 compressed-fn)))))) - ;; rename any buffers - (and (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) - (let ((modflag (buffer-modified-p))) - ;; kills write-file-hooks - (set-visited-file-name to) - (set-buffer-modified-p modflag)))) - to)) - ((stringp compressed-fn) - (message "Compressing %s..." file) - (let* ((data (assq dired-compression-method - dired-compression-method-alist)) - (compr-args (nth 2 data)) - (ret - (apply 'call-process - (car compr-args) file t nil - (append (cdr compr-args) - (and ok-flag - (list (nth 4 data))) - (list file))))) - (if (or (and (integerp ret) (/= ret 0)) - (not (bobp))) - (signal 'file-error - (nconc - (list "Error compressing file" - file) - (and (not (bobp)) - (list - (progn - (goto-char (point-min)) - (buffer-substring - (point) (progn (end-of-line) - (point)))))))))) - (message "Compressing %s...done" file) - (dired-remove-file file) - ;; rename any buffers - (and (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) - (let ((modflag (buffer-modified-p))) - ;; kills write-file-hooks - (set-visited-file-name compressed-fn) - (set-buffer-modified-p modflag)))) - compressed-fn) - (t (error "Strange error in dired-compress-file.")))))))) - -(defun dired-make-compressed-filename (name &optional method) - ;; If NAME is in the syntax of a compressed file (according to - ;; dired-compression-method-alist), return the data (a list) from this - ;; alist on how to uncompress it. Otherwise, return a string, the - ;; compressed form of this file name. This is computed using the optional - ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of - ;; dired-compression-method is used. - (let ((handler (find-file-name-handler - name 'dired-make-compressed-filename))) - (if handler - (funcall handler 'dired-make-compressed-filename name method) - (let ((alist dired-compression-method-alist) - (len (length name)) - ext ext-len result) - (while alist - (if (and (> len - (setq ext-len (length (setq ext (nth 1 (car alist)))))) - (string-equal ext (substring name (- ext-len)))) - (setq result (car alist) - alist nil) - (setq alist (cdr alist)))) - (or result - (concat name - (nth 1 (or (assq (or method dired-compression-method) - dired-compression-method-alist) - (error "Unknown compression method: %s" - (or method dired-compression-method)))))) - )))) - -;;; end of dired-cmpr.el
--- a/lisp/efs/dired-diff.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,164 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-diff.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: Support for diff and related commands. -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Fri Jun 24 08:50:20 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or -;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -;;; MA 02139, USA. - -(provide 'dired-diff) -(require 'dired) - -(defvar emerge-last-dir-input) -(defvar emerge-last-dir-output) -(defvar emerge-last-dir-ancestor) -(defvar diff-switches) - -(defun dired-diff-read-file-name (prompt) - ;; Read and return a file name for diff. - (let* ((mark-active t) - (default (and (mark) - (save-excursion - (goto-char (mark)) - (dired-get-filename nil t))))) - (read-file-name (format "%s %s with: %s" - prompt (dired-get-filename 'no-dir) - (if default - (concat "[" - (dired-make-relative - default - (dired-current-directory) t) - "] ") - "")) - (default-directory) default t))) - -(defun dired-diff-read-switches (switchprompt) - ;; Read and return a list of switches - (or (boundp 'diff-switches) - (require 'diff)) ; Make sure that `diff-switches' is defined. - (let* ((default (if (listp diff-switches) - (mapconcat 'identity diff-switches " ") - diff-switches)) - (switches - (read-string (format switchprompt default) default))) - (let (result (start 0)) - (while (string-match "\\(\\S-+\\)" switches start) - (setq result (cons (substring switches (match-beginning 1) - (match-end 1)) - result) - start (match-end 0))) - (nreverse result)))) - -(defun dired-diff (file &optional switches) - "Compare file at point with file FILE using `diff'. -FILE defaults to the file at the mark. -The prompted-for file is the first file given to `diff'. -With a prefix allows the switches for the diff program to be edited." - (interactive - (list - (dired-diff-read-file-name "Diff") - (and current-prefix-arg (dired-diff-read-switches "Options for diff: ")))) - (if switches - (diff file (dired-get-filename) switches) - (diff file (dired-get-filename)))) - -(defun dired-backup-diff (&optional switches) - "Diff this file with its backup file or vice versa. -Uses the latest backup, if there are several numerical backups. -If this file is a backup, diff it with its original. -The backup file is the first file given to `diff'." - (interactive (list (and current-prefix-arg - (dired-diff-read-switches "Diff with switches: ")))) - (if switches - (diff-backup (dired-get-filename) switches) - (diff-backup (dired-get-filename)))) - -(defun dired-emerge (arg file out-file) - "Merge file at point with FILE using `emerge'. -FILE defaults to the file at the mark." - (interactive - (let ((file (dired-diff-read-file-name "Merge"))) - (list - current-prefix-arg - file - (and current-prefix-arg (emerge-read-file-name - "Output file" - emerge-last-dir-output - (dired-abbreviate-file-name file) file))))) - (emerge-files arg file (dired-get-filename) out-file)) - -(defun dired-emerge-with-ancestor (arg file ancestor file-out) - "Merge file at point with FILE, using a common ANCESTOR file. -FILE defaults to the file at the mark." - (interactive - (let ((file (dired-diff-read-file-name "Merge"))) - (list - current-prefix-arg - file - (emerge-read-file-name "Ancestor file" emerge-last-dir-ancestor nil file) - (and current-prefix-arg (emerge-read-file-name - "Output file" - emerge-last-dir-output - (dired-abbreviate-file-name file) file))))) - (emerge-files-with-ancestor arg file (dired-get-filename) - ancestor file-out)) - -(defun dired-ediff (file) - "Ediff file at point with FILE. -FILE defaults to the file at the mark." - (interactive (list (dired-diff-read-file-name "Ediff"))) - (ediff-files file (dired-get-filename))) - -(defun dired-epatch (file) - "Patch file at point using `epatch'." - (interactive - (let ((file (dired-get-filename))) - (list - (and (or (memq 'patch dired-no-confirm) - (y-or-n-p (format "Patch %s? " - (file-name-nondirectory file)))) - file)))) - (if file - (ediff-patch-file file) - (message "No file patched."))) - -;;; Autoloads - -;;; Diff (diff) - -(autoload 'diff "diff" "Diff two files." t) -(autoload 'diff-backup "diff" - "Diff this file with its backup or vice versa." t) - -;;; Emerge - -(autoload 'emerge-files "emerge" "Merge two files." t) -(autoload 'emerge-files-with-ancestor "emerge" - "Merge two files having a common ancestor." t) -(autoload 'emerge-read-file-name "emerge") - -;; Ediff - -(autoload 'ediff-files "ediff" "Ediff two files." t) -(autoload 'ediff-patch-file "ediff" "Patch a file." t) - -;;; end of dired-diff.el
--- a/lisp/efs/dired-faces.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-faces.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: rudimentary face customization support for dired -;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de> -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'dired-faces) - -(require 'custom) - -;;; Variables - -(defgroup dired nil - "Directory editing." - :group 'environment) - -(defcustom dired-do-highlighting t - "Set if we should use highlighting according to filetype." - :type 'boolean - :group 'dired) - -(defcustom dired-do-interactive-permissions t - "Set if we should allow interactive chmod." - :type 'boolean - :group 'dired) - -(defface dired-face-marked '((((class color)) - (:background "PaleVioletRed")) - (t (:underline t))) - "Face used for marked files." - :group 'dired) - -(defface dired-face-flagged '((((class color)) - (:background "LightSlateGray")) - (t (:underline t))) - "Face used for flagged files." - :group 'dired) - -(defface dired-face-directory '((t (:bold t))) - "Face used for directories." - :group 'dired) - -(defface dired-face-executable '((((class color)) - (:foreground "SeaGreen")) - (t (:bold t))) - "Face used for executables." - :group 'dired) - -(defface dired-face-setuid '((((class color)) - (:foreground "Red")) - (t (:bold t))) - "Face used for setuid executables." - :group 'dired) - -(defface dired-face-boring '((((class color)) - (:foreground "Gray65")) - (((class grayscale)) - (:foreground "Gray65"))) - "Face used for unimportant files." - :group 'dired) - -(defface dired-face-permissions '((t (:background "grey75" - :foreground "black"))) - "Face used for interactive permissions." - :group 'dired) - -(defface dired-face-socket '((((class color)) - (:foreground "magenta")) - (t (:bold nil))) - "Face used to indicate sockets." - :group 'dired) - -(defface dired-face-symlink '((((class color)) - (:foreground "cyan")) - (t (:bold t))) - "Face used to indicate symbolic links." - :group 'dired) - -;;; end of dired-faces.el
--- a/lisp/efs/dired-grep.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,482 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-grep.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: Support for running grep on marked files in a dired buffer. -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Tue Jul 13 22:59:37 1993 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Copyright (C) 1993 Sandy Rutherford - -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or -;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -;;; MA 02139, USA. - -;;; The user-level command in this file is dired-grep-file. The command -;;; grep is defined in compile.el. This file does not change that command. - -;;; Requirements and provisions - -(provide 'dired-grep) -(or (fboundp 'file-local-copy) (require 'emacs-19)) -(or (fboundp 'generate-new-buffer) (require 'emacs-19)) -(require 'dired) - -;;; Variables - -(defvar dired-grep-program "grep" - "Name of program to use to grep files. -When used with the \"-n\" flag, program must precede each match with \"###:\", -where \"###\" is the line number of the match. -If there are grep programs which don't do this, we'll try to think of -some way to accomodate them.") - -(defvar dired-grep-switches nil - "*Switches to pass to the grep program. -This may be either a string or a list of strings. It is not necessary to -include \"-n\" as that switch is always used.") - -(defvar dired-grep-zcat-program "zcat" - "Name of program to cat compressed files.") - -(defvar dired-grep-compressed-file ".\\.\\(gz\\|[zZ]\\)$" - "Regexp to match names of compressed files.") - -(defvar dired-grep-pop-up-buffer t - "*If non-nil, the grep output is displayed in the other window upon -completion of the grep process.") - -(defvar dired-grep-results-buffer "*Dired Grep*" - "Name of buffer where grep results are logged.") - -(defvar dired-grep-mode-hook nil - "Hook run after going into grep-mode") - -(defvar grep-history nil - "History of previous grep patterns used.") - -(defvar dired-grep-parse-flags-cache nil) -(defvar dired-grep-parse-flags-cache-result nil) - -(defvar dired-grep-mode-map nil - "Keymap for dired-grep-mode buffers.") - -(if dired-grep-mode-map - () - (setq dired-grep-mode-map (make-keymap)) - (suppress-keymap dired-grep-mode-map) - (define-key dired-grep-mode-map "[" 'backward-page) - (define-key dired-grep-mode-map "]" 'forward-page) - (define-key dired-grep-mode-map ">" 'dired-grep-next-hit) - (define-key dired-grep-mode-map "<" 'dired-grep-previous-hit) - (define-key dired-grep-mode-map "n" 'dired-grep-advertized-next-hit) - (define-key dired-grep-mode-map "p" 'dired-grep-advertized-previous-hit) - (define-key dired-grep-mode-map "k" 'dired-grep-delete-line) - (define-key dired-grep-mode-map "d" 'dired-grep-delete-page) - (define-key dired-grep-mode-map "^" 'dired-grep-delete-preceding-pages) - (define-key dired-grep-mode-map "f" 'dired-grep-find-file) - (define-key dired-grep-mode-map "e" 'dired-grep-find-file) - (define-key dired-grep-mode-map "m" 'dired-grep-delete-misses) - (define-key dired-grep-mode-map "o" 'dired-grep-find-file-other-window) - (define-key dired-grep-mode-map "v" 'dired-grep-view-file) - (define-key dired-grep-mode-map "w" 'dired-grep-delete-grep-for) - (define-key dired-grep-mode-map "\C-_" 'dired-grep-undo) - (define-key dired-grep-mode-map "\C-xu" 'dired-grep-undo)) - -;;; Entry functions from dired.el - -(defun dired-grep (pattern flags) - ;; grep the file on the current line for PATTERN, using grep flags FLAGS. - ;; Return nil on success. Offending filename otherwise. - (let* ((file (dired-get-filename)) - (result (dired-grep-file pattern file flags))) - (and result - (progn - (dired-log (buffer-name (current-buffer)) (concat result "\n")) - file)))) - -(defun dired-do-grep (pattern &optional flags arg) - "Grep marked files for a pattern. With a \C-u prefix prompts for grep flags." - (interactive - (let* ((switches (if (consp current-prefix-arg) - (read-string "Switches for grep: ") - dired-grep-switches)) - (prompt (format "grep %sfor pattern" - (if (stringp switches) - (if (string-equal switches "") - switches - (concat switches " ")) - (if switches - (concat (mapconcat 'identity switches " ") " ") - "")))) - (pattern (dired-read-with-history (concat prompt ": ") - nil 'grep-history))) - (list pattern switches - (and (not (consp current-prefix-arg)) current-prefix-arg)))) - (dired-map-over-marks-check - (function - (lambda () - (dired-grep pattern flags))) - arg 'grep (concat "grep " flags (if flags " \"" "\"") pattern "\"") t)) - -;;; Utility functions - -(defun dired-grep-get-results-buffer () - ;; Return the buffer object of the dired-grep-results-buffer, creating and - ;; initializing it if necessary. - (let ((buffer (get-buffer dired-grep-results-buffer))) - (or buffer - (save-excursion - (set-buffer (setq buffer (get-buffer-create dired-grep-results-buffer))) - (dired-grep-mode) - buffer)))) - -;; Only define if undefined, in case efs has got to it already. -(or (fboundp 'dired-grep-delete-local-temp-file) - (defun dired-grep-delete-local-temp-file (file) - (condition-case nil (delete-file file) (error nil)))) - -;;; Commands in the dired-grep-results-buffer buffer. - -(defun dired-grep-mode () - "\\<dired-grep-mode-map>Mode for perusing grep output generated from dired. -The output is divided into pages, one page per grepped file. - -Summary of commands: - -Move to next grep hit \\[dired-grep-advertized-next-hit], \\[dired-grep-next-hit] -Move to previous grep hit \\[dired-grep-advertized-previous-hit], \\[dired-grep-previous-hit] -Move to output for next file \\[forward-page] -Move to output for previous file \\[backward-page] - -Delete the current grep line \\[dired-grep-delete-line] -Delete all output for current file \\[dired-grep-delete-page] -Delete all preceding pages \\[dired-grep-delete-preceding-pages] -Delete all pages for files with no hits \\[dired-grep-delete-misses] -Delete all pages which grep for the - same pattern as the current page \\[dired-grep-delete-grep-for] - -Find current grep hit in file \\[dired-grep-find-file] -Find current grep hit in other window \\[dired-grep-find-file-other-window] -View current grep hit \\[dired-grep-view-file] - -Undo changes to the grep buffer \\[dired-grep-undo] - -Keybindings: -\\{dired-grep-mode-map}" - (kill-all-local-variables) - (use-local-map dired-grep-mode-map) - (setq major-mode 'dired-grep-mode - mode-name "Dired-Grep" - buffer-read-only t) - (set (make-local-variable 'page-delimiter) "\n\n") - (run-hooks 'dired-grep-mode-hook)) - -(defun dired-grep-current-file-and-line () - ;; Returns a list \(FILENAME . LINE\) corresponding to the filename - ;; and line number associated with the position of the point in a - ;; grep buffer. Returns nil if there is none. - (save-excursion - (let (file line) - (and - (progn - (beginning-of-line) - (looking-at "[0-9]+:")) - (progn - (setq line (string-to-int (buffer-substring (point) - (1- (match-end 0))))) - (if (search-backward "\n\n" nil 'move) (forward-char 2)) - (looking-at "Hits for ")) - (progn - (forward-line 1) - (looking-at " ")) - (progn - (setq file (buffer-substring (match-end 0) - (progn (end-of-line) (1- (point))))) - (cons file line)))))) - -(defun dired-grep-find-file () - (interactive) - (let ((file (dired-grep-current-file-and-line))) - (if file - (progn - (find-file (car file)) - (goto-line (cdr file)) - (recenter '(4))) - (error "No file specified by this line.")))) - -(defun dired-grep-find-file-other-window () - (interactive) - (let ((file (dired-grep-current-file-and-line))) - (if file - (progn - (find-file-other-window (car file)) - (goto-line (cdr file)) - (recenter '(4))) - (error "No file specified by this line.")))) - -(defun dired-grep-view-file () - (interactive) - (let ((file (dired-grep-current-file-and-line))) - (if file - (let* ((fun (function - (lambda () (goto-line (cdr file)) (recenter '(4))))) - (view-hook - (if (boundp 'view-hook) - (if (and (listp view-hook) - (not (eq (car view-hook) 'lambda))) - (cons fun view-hook) - (list fun view-hook)) - fun))) - (view-file (car file))) - (error "No file specified by this line.")))) - -(defun dired-grep-next-hit (arg) - "Moves to the next, or next ARGth, grep hit." - (interactive "p") - (forward-line 1) - (if (re-search-forward "^[0-9]" nil 'move arg) - (goto-char (match-beginning 0)) - (error "No further grep hits"))) - -(defun dired-grep-previous-hit (arg) - "Moves to the previous, or previous ARGth, grep hit." - (interactive "p") - (beginning-of-line) - (or (re-search-backward "^[0-9]" nil 'move arg) - (error "No further grep hits"))) - -;; These are only so we can get a decent looking help buffer. -(fset 'dired-grep-advertized-next-hit 'dired-grep-next-hit) -(fset 'dired-grep-advertized-previous-hit 'dired-grep-previous-hit) - -(defun dired-grep-delete-page (arg) - "Deletes the current and ARG - 1 following grep output pages. -If ARG is negative, deletes preceding pages." - (interactive "p") - (let ((done 0) - (buffer-read-only nil) - (backward (< arg 0)) - start) - (if backward (setq arg (- arg))) - (while (and (< done arg) (not (if backward (bobp) (eobp)))) - (or (looking-at "^\n") - (if (search-backward "\n\n" nil 'move) (forward-char 1))) - (setq start (point)) - (if (search-forward "\n\n" nil 'move) (forward-char -1)) - (delete-region start (point)) - (and (bobp) (not (eobp)) (delete-char 1)) - (if backward (skip-chars-backward "\n")) - (setq done (1+ done))))) - -(defun dired-grep-delete-preceding-pages () - "Deletes the current, and all preceding pages from the grep buffer." - (interactive) - (let ((buffer-read-only nil)) - (if (looking-at "^\n") - (forward-char 1) - (search-forward "\n\n" nil 'move)) - (delete-region (point-min) (point)))) - -(defun dired-grep-delete-line (arg) - "Deletes the current line and ARG following lines from the grep buffer. -Only operates on lines which correspond to file lines for grep hits." - (interactive "p") - (let ((opoint (point)) - (buffer-read-only nil) - (backward (< arg 0)) - (done 0)) - (beginning-of-line) - (if backward (setq arg (- arg))) - (if (looking-at "[0-9]+:") - (while (< done arg) - (delete-region (point) (progn (forward-line 1) (point))) - (if backward (forward-line -1)) - (if (looking-at "[0-9]+:") - (setq done (1+ done)) - (setq done arg))) - ;; Do nothing. - (goto-char opoint)))) - -(defun dired-grep-delete-grep-for () - "Deletes all pages which grep some file for the pattern of the current page." - (interactive) - (save-excursion - ;; In case we happen to be right at the beginning of a page. - (or (eobp) (eolp) (forward-char 1)) - (forward-page -1) ; gets to the beginning of the page. - (let* ((eol (save-excursion (end-of-line) (point))) - (line (and (search-forward " grep " eol t) - (buffer-substring (point) eol)))) - (if line - (progn - (goto-char (point-min)) - (while (not (eobp)) - (let* ((eol (save-excursion (end-of-line) (point))) - (this-line (and (search-forward " grep " eol t) - (buffer-substring (point) eol)))) - (if (equal line this-line) - (progn - (dired-grep-delete-page 1) - (skip-chars-forward "\n")) - (or (eobp) (forward-page 1)))))))))) - -(defun dired-grep-delete-misses () - "Delete all pages for which there were no grep hits. -Deletes pages for which grep failed because of an error too." - (interactive) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "Grep failed \\|No hits ") - (progn - (dired-grep-delete-page 1) - (skip-chars-forward "\n")) - (forward-page 1))))) - -(defun dired-grep-undo () - "Undoes deletions in a grep buffer." - (interactive) - (let (buffer-read-only) - (undo))) - -;;; Commands for grepping files. - -(defun dired-grep-parse-flags (string) - ;; Breaks a string of switches into a list. - (if (equal dired-grep-parse-flags-cache string) - dired-grep-parse-flags-cache-result - (let ((length (length string)) - (pointer 0) - (start 0) - (result nil)) - (while (and (< pointer length) (= (aref string pointer) ?\ )) - (setq pointer (1+ pointer))) - (while (< pointer length) - (setq start pointer) - (while (and (< pointer length) (/= (aref string pointer) ?\ )) - (setq pointer (1+ pointer))) - (setq result (cons (substring string start pointer) result)) - (while (and (< pointer length) (= (aref string pointer) ?\ )) - (setq pointer (1+ pointer)))) - (setq dired-grep-parse-flags-cache string - dired-grep-parse-flags-cache-result (nreverse result))))) - -(defun dired-grep-file (pattern file &optional flags) - "Grep for PATTERN in FILE. -Optional FLAGS are flags to pass to the grep program. -When used interactively, will prompt for FLAGS if a prefix argument is used." - (interactive - (let* ((switches (if (consp current-prefix-arg) - (read-string "Switches for grep: ") - dired-grep-switches)) - (prompt (format "grep %sfor pattern" - (if (stringp switches) - (if (string-match switches "^ *$") - "" - (concat switches " ")) - (if switches - (concat (mapconcat 'identity switches " ") " ") - "")))) - (pattern (dired-read-with-history (concat prompt ": ") - nil 'grep-history)) - (file (read-file-name (concat prompt " \"" pattern "\" in file :")))) - (list pattern file switches))) - (setq file (expand-file-name file)) - (if (listp flags) - (setq flags (mapconcat 'identity flags " ")) - (if (string-match "^ +$" flags) - (setq flags ""))) - (let ((file-buff (get-file-buffer file))) - (if (and file-buff (buffer-modified-p file-buff)) - (if (y-or-n-p (format "Save buffer %s? " (buffer-name file-buff))) - (save-excursion - (set-buffer file-buff) - (save-buffer))))) - (let ((buffer (dired-grep-get-results-buffer)) - (compressed (string-match dired-grep-compressed-file file)) - failed temp-file jka-compr-compression-info-list) - (setq temp-file - (condition-case err - (file-local-copy file) - (error (progn (setq failed (format "%s" err)) nil)))) - (or failed - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (let ((buffer-read-only nil) - pos-1 pos-2) - (or (bobp) (insert "\n")) - (setq pos-1 (point)) - (insert "Hits for grep ") - (or (string-equal flags "") (insert flags " ")) - (insert "\"" pattern "\" in\n " file ":\n") - (setq pos-2 (point)) - (condition-case err - (apply - 'call-process - (if compressed "sh" dired-grep-program) - (or temp-file file) - buffer t - (if compressed - (list "-c" (concat dired-grep-zcat-program - " |" dired-grep-program - " " flags " -n '" pattern "'")) - (append (dired-grep-parse-flags flags) - (list "-n" pattern)))) - (error (setq failed (format "%s" err)))) - (if failed - (progn - (if (= pos-2 (point-max)) - (progn - (goto-char (1- pos-2)) - (delete-char -1) - (insert "."))) - (goto-char pos-1) - (delete-char 4) - (insert "Grep failed") - failed) - (if (= pos-2 (point-max)) - (progn - (goto-char pos-1) - (delete-char 1) - (insert "No h") - (forward-line 1) - (end-of-line) - (delete-char -1) - (insert ".")) - (goto-char pos-2) - (or (looking-at "[0-9]+:") - (setq failed (buffer-substring pos-2 - (progn (end-of-line) - (point)))))))))) - (let ((curr-wind (selected-window))) - (unwind-protect - (progn - (pop-to-buffer buffer) - (goto-char (point-max))) - (select-window curr-wind))) - (if temp-file - (dired-grep-delete-local-temp-file temp-file)) - failed)) - -;;; Run the load hook - -(run-hooks 'dired-grep-load-hook) - -;;; end of dired-grep.el
--- a/lisp/efs/dired-help.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,398 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-help.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Obtaining help for dired -;; Modified: Sun Nov 20 21:10:47 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-help) -(require 'dired) -(autoload 'reporter-submit-bug-report "reporter") -(defvar reporter-version) ; For the byte-compiler. - -;;; Constants - -(defconst dired-bug-address "efs-bugs@cuckoo.hpl.hp.com") - -(defvar dired-documentation nil) - -;;; Functions - -(defun dired-documentation () - (or dired-documentation - (let ((18-p (string-equal "18." (substring emacs-version 0 3))) - (var-help-key (substitute-command-keys - (if (featurep 'ehelp) - "\\[electric-describe-variable]" - "\\[describe-variable]"))) - (standard-output (get-buffer-create " dired-help-temp"))) - (save-excursion - (set-buffer standard-output) - (unwind-protect - (setq dired-documentation - (substitute-command-keys - (format "\\<dired-mode-map>The Directory Editor: - -For more detailed help, type \\[universal-argument] \\[dired-describe-mode] to start the info -documentation browser. - -In dired, you can edit a list of the files in a directory \(and optionally -its subdirectories in the `ls -lR' format\). - -Editing a directory means that you can visit, rename, copy, compress, -load, byte-compile files. You can change files' attributes, run shell -commands on files, or insert subdirectories into the edit buffer. You can -\"flag\" files for deletion or \"mark\" files for later commands, either one -file at a time or by all files matching certain criteria \(e.g., files that -match a certain regexp\). - -You move throughout the buffer using the usual cursor motion commands. -Letters no longer insert themselves, but execute commands instead. The -digits (0-9) are prefix arguments. - -Most commands operate either on all marked files or on the current file if -no files are marked. Use a numeric prefix argument to operate on the next -ARG files (or previous ARG if ARG < 0). Use the prefix argument `1' to -operate on the current file only. Prefix arguments override marks. Commands -which run a sub-process on a group of files will display a list of files -for which the sub-process failed. Typing \\[dired-why] will try to tell -you what went wrong. - -When editing several directories in one buffer, each directory acts as a -page, so \\[backward-page] and \\[forward-page] can be used to move between directories. - -Summary of commands: - -Motion Commands - move up to previous line \\[dired-next-line] - move down to next line \\[dired-previous-line] - move up to previous directory line \\[dired-prev-dirline] - move down to next directory line \\[dired-next-dirline] - move up to previous subdirectory \\[dired-advertised-prev-subdir] - move down to next subdirectory \\[dired-advertised-next-subdir] - move to parent directory \\[dired-up-directory] - move to first child subdirectory \\[dired-down-directory] - -Immediate Actions on Files - visit current file \\[dired-advertised-find-file] - visit current file in other window \\[dired-find-file-other-window] - visit current file in other frame %s - display current file \\[universal-argument] \\[dired-find-file-other-window] - create a new subdirectory \\[dired-create-directory] - recover file from auto-save \\[dired-recover-file] - -Marking & Unmarking Files - mark a file or subdirectory for later commands \\[dired-mark] - unmark a file or all files of a subdirectory \\[dired-unmark] - unmark all marked files in a buffer \\[dired-unmark-all-files] - count marks in buffer 0 \\[dired-unmark-all-files] - mark all directories \\[dired-mark-directories] - mark all executable files \\[dired-mark-executables] - mark file names matching a regular expression \\[dired-mark-files-regexp] - -Commands on Files Marked or Specified by the Prefix - rename a file or move files to another directory \\[dired-do-rename] - copy files \\[dired-do-copy] - delete marked (as opposed to flagged) files \\[dired-do-delete] - compress or uncompress files \\[dired-do-compress] - uuencode or uudecode files \\[dired-do-uucode] - grep files \\[dired-do-grep] - search for regular expression \\[dired-do-tags-search] - query replace by regular expression \\[dired-do-tags-query-replace] - byte-compile files \\[dired-do-byte-compile] - load files \\[dired-do-load] - shell command on files \\[dired-do-shell-command] - operate shell command separately on each file \\[universal-argument] \\[dired-do-shell-command] - do as above, but in each file's directory \\[universal-argument] \\[universal-argument] \\[dired-do-shell-command] - -Flagging Files for Deletion (unmark commands remove delete flags) - flag file for deletion \\[dired-flag-file-deletion] - backup and remove deletion flag \\[dired-backup-unflag] - flag all backup files (file names ending in ~) \\[dired-flag-backup-files] - flag all auto-save files \\[dired-flag-auto-save-files] - clean directory of numeric backups \\[dired-clean-directory] - execute the deletions requested (flagged files) \\[dired-expunge-deletions] - -Modifying the Dired Buffer - insert a subdirectory in this buffer \\[dired-maybe-insert-subdir] - removing a subdir listing \\[dired-kill-subdir] - relist single file, marked files, or subdir \\[dired-do-redisplay] - re-read all directories (retains all marks) \\[revert-buffer] - toggle sorting of current subdir by name/date \\[dired-sort-toggle-or-edit] - report on current ls switches 0 \\[dired-sort-toggle-or-edit] - edit ls switches for current subdir 1 \\[dired-sort-toggle-or-edit] - edit default ls switches for new subdirs 2 \\[dired-sort-toggle-or-edit] - sort all subdirs by name/date \\[universal-argument] \\[dired-sort-toggle-or-edit] - edit the ls switches for all subdirs \\[universal-argument] \\[universal-argument] \\[dired-sort-toggle-or-edit] - -Hiding File Lines - toggle file omission in current subdir \\[dired-omit-toggle] - kill marked file lines \\[dired-do-kill-file-lines] - -Help on Dired - dired help (what you're reading) \\[dired-describe-mode] - dired summary (short help) \\[dired-summary] - dired info (full dired info manual) \\[universal-argument] \\[dired-describe-mode] - apropos for dired commands \\[dired-apropos] - apropos for dired variables \\[universal-argument] \\[dired-apropos] - -Regular Expression Commands - mark files with a regular expression \\[dired-mark-files-regexp] - copy marked files by regexp \\[dired-do-copy-regexp] - rename marked files by regexp \\[dired-do-rename-regexp] - omit files by regexp \\[dired-omit-expunge] - downcase file names (rename to lowercase) \\[dired-downcase] - upcase files names (rename to uppercase) \\[dired-upcase] - -Comparing Files - diff file at point with file at mark \\[dired-diff] - diff file with its backup \\[dired-backup-diff] - merge file at point with file at mark \\[dired-emerge] - same as above but use a common ancestor \\[dired-emerge-with-ancestor] - ediff file at point with file at mark \\[dired-ediff] - patch file at point \\[dired-epatch] - -Mouse Commands -%s - -Miscellaneous - quit dired \\[dired-quit] - insert current directory in minibuffer \\[dired-get-target-directory] - -If the dired buffer gets confused, you can either type \\[revert-buffer] to read all -directories again, type \\[dired-do-redisplay] to relist a single file, the marked -files, or a subdirectory, or type \\[dired-build-subdir-alist] to parse -the directory tree in the buffer again. - -Customization Variables: -Use %s to obtain more information. - -%s - -Hook Variables: -Use %s to obtain more information. - -%s - -Keybindings: -\\{dired-mode-map}" - - ;; arguments to format - (if 18-p - "Unavailable in Emacs 18" - " \\[dired-find-file-other-frame]") - (if 18-p - " Unavailable in Emacs 18" - "\ - find file with mouse \\[dired-mouse-find-file] - mark file at mouse \\[dired-mouse-mark] - flag for deletion file at mouse \\[dired-mouse-flag] - menu of commands to visit a file \\[dired-visit-popup-menu] - menu of operations to do on a file \\[dired-do-popup-menu] - insert directory of mouse in minibuffer \\[dired-mouse-get-target] -") - var-help-key - (progn - (erase-buffer) - (dired-format-columns-of-files - (sort - (all-completions - "dired-" obarray - (function - (lambda (sym) - (and (user-variable-p sym) - (not (dired-hook-variable-p - sym)))))) - 'string<) t) - (buffer-string)) - var-help-key - (progn - (erase-buffer) - (dired-format-columns-of-files - (sort - (all-completions - "dired-" obarray - (function - (lambda (sym) - (dired-hook-variable-p sym)))) - 'string<) t) - (buffer-string))))) - (kill-buffer " dired-help-temp")))))) - -;;; Commands - -(defun dired-describe-mode (&optional info) - "Detailed description of dired mode. -With a prefix, runs the info documentation browser for dired." - (interactive "P") - ;; Getting dired documentation can be a bit slow. - (if info - (info "dired") - (message "Building dired help...") - (let* ((buff (get-buffer-create "*Help*")) - (standard-output buff) - (mess (dired-documentation))) - (message "Building dired help... done") - (if (featurep 'ehelp) - (with-electric-help - (function - (lambda () - (princ mess) - nil))) ; return nil so ehelp puts us at the top of the buffer. - (with-output-to-temp-buffer (buffer-name buff) - (princ mess) - (print-help-return-message)))))) - -(defun dired-apropos (string &optional var-p) - "Does command apropos for dired commands. -With prefix does apropos for dired variables." - (interactive - (list - (if current-prefix-arg - (read-string "Dired variable apropos (regexp): ") - (read-string "Dired command apropos (regexp): ")) - current-prefix-arg)) - (message "Doing dired %s apropos..." (if var-p "variable" "command")) - (if (featurep 'ehelp) - (with-electric-help - (function - (lambda () - (dired-apropos-internal string var-p) - nil))) - (with-output-to-temp-buffer "*Help*" - (dired-apropos-internal string var-p) - (or (print-help-return-message) - (message "Doing dired %s apropos...done" - (if var-p "variable" "command")))))) - -(defun dired-apropos-internal (string &optional var-p) - (let ((case-fold-search t) - (names (sort (all-completions "dired-" obarray - (if var-p - 'user-variable-p - 'commandp)) - 'string<)) - doc) - (mapcar - (function - (lambda (x) - (and (if var-p (user-variable-p (intern x)) (commandp (intern x))) - (progn - (setq doc (if var-p - (get (intern x) 'variable-documentation) - (documentation (intern x)))) - (and doc (setq doc (substring doc 0 (string-match "\n" doc)))) - (or (string-match string x) - (and doc (string-match string doc)))) - (progn - (princ x) - (if var-p (princ " <V>:") - (princ " <F>:") - (princ (make-string (max 2 (- 30 (length x))) ?\ )) - (princ (dired-help-key-description (intern x)))) - (princ "\n ") - (princ doc) - (princ "\n"))))) - names))) - -(defun dired-help-key-description (fun) - ;; Returns a help string of keys for fun. - (let ((res (mapconcat 'key-description - (where-is-internal fun dired-mode-map) ", "))) - (if (string-equal res "") - "\(not on any keys\)" - res))) - -(defun dired-summary () - "Display summary of basic dired commands in the minibuffer." - (interactive) - (let ((del (where-is-internal 'dired-flag-file-deletion dired-mode-map)) - (und (where-is-internal 'dired-unmark dired-mode-map)) - (exp (where-is-internal 'dired-expunge-deletions dired-mode-map)) - (fin (where-is-internal 'dired-advertised-find-file dired-mode-map)) - (oth (where-is-internal 'dired-find-file-other-window dired-mode-map)) - (ren (where-is-internal 'dired-do-rename dired-mode-map)) - (cop (where-is-internal 'dired-do-copy dired-mode-map)) - (hel (where-is-internal 'dired-describe-mode dired-mode-map))) - (if (member "d" del) - (setq del "d-elete") - (setq del (substitute-command-keys - "\\<dired-mode-map>\\[dired-flag-file-deletion] delete"))) - (if (member "u" und) - (setq und "u-ndelete") - (setq und (substitute-command-keys - "\\<dired-mode-map>\\[dired-unmark] undelete"))) - (if (member "x" exp) - (setq exp "x-punge") - (setq exp (substitute-command-keys - "\\<dired-mode-map>\\[dired-expunge-deletions] expunge"))) - (if (member "f" fin) - (setq fin "f-ind") - (setq fin (substitute-command-keys - "\\<dired-mode-map>\\[dired-advertised-find-file] find"))) - (if (member "o" oth) - (setq oth "o-ther window") - (setq oth - (substitute-command-keys - "\\<dired-mode-map>\\[dired-find-file-other-window] other window") - )) - (if (member "R" ren) - (setq ren "R-ename") - (setq ren (substitute-command-keys - "\\<dired-mode-map>\\[dired-do-rename] rename"))) - (if (member "C" cop) - (setq cop "C-opy") - (setq cop (substitute-command-keys - "\\<dired-mode-map>\\[dired-do-copy] copy"))) - (if (member "h" hel) - (setq hel "h-elp") - (setq hel (substitute-command-keys - "\\<dired-mode-map>\\[describe-mode] help"))) - (message "%s, %s, %s, %s. %s, %s, %s, %s" - del und exp fin oth ren cop hel))) - -(defun dired-hook-variable-p (sym) - ;; Returns t if SYM is a hook variable. Just looks at its name. - (let ((name (symbol-name sym))) - (and (>= (length name) 6) - (or (string-equal (substring name -5) "-hook") - (string-equal (substring name -6) "-hooks"))))) - -;;; Submitting bug reports. - -(defun dired-report-bug () - "Submit a bug report for dired." - (interactive) - (let ((reporter-prompt-for-summary-p t)) - (or (boundp 'reporter-version) - (setq reporter-version - "Your version of reporter is obsolete. Please upgrade.")) - (reporter-submit-bug-report - dired-bug-address "Dired" - (cons - 'dired-version - (nconc - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions "dired-" obarray 'user-variable-p)) - 'string-lessp)) - (list 'reporter-version))) - (function - (lambda () - (save-excursion - (mail-position-on-field "subject") - (beginning-of-line) - (skip-chars-forward "^:\n") - (if (looking-at ": Dired;") - (progn - (goto-char (match-end 0)) - (delete-char -1) - (insert " " dired-version " bug:"))))))))) - -;;; end of dired-help.el
--- a/lisp/efs/dired-mob.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-mob.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: Commands for marking files from another buffer. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-mob) -(require 'dired) -(autoload 'compilation-buffer-p "compile") -(autoload 'compile-reinitialize-errors "compile") - -;; For the byte-compiler -(defvar compilation-error-list) - -;;; Utilities - -(defun dired-mark-these-files (file-list from) - ;; Mark the files in FILE-LIST. Relative filenames are taken to be - ;; in the current dired directory. - ;; FROM is a string (used for logging) describing where FILE-LIST - ;; came from. - ;; Logs files that were not found and displays a success or failure - ;; message. - (message "Marking files %s..." from) - (let ((total (length file-list)) - (cur-dir (dired-current-directory)) - file failures) - (while file-list - (setq file (expand-file-name (car file-list) cur-dir) - file-list (cdr file-list)) - ;;(message "Marking file `%s'" file) - (save-excursion - (if (dired-goto-file file) - (dired-mark 1) ; supplying a prefix keeps it from checking - ; for a subdir. - (setq failures (cons (dired-make-relative file) failures)) - (dired-log (buffer-name (current-buffer)) - "Cannot mark this file (not found): %s\n" file)))) - (dired-update-mode-line-modified t) - (if failures - (dired-log-summary - (buffer-name (current-buffer)) - (format "Failed to mark %d of %d files %s %s" - (length failures) total from failures) failures) - (message "Marked %d file%s %s." total (dired-plural-s total) from)))) - -;;; User commands - -(defun dired-mark-files-from-other-dired-buffer (buf) - "Mark files that are marked in the other Dired buffer. -I.e, mark those files in this Dired buffer that have the same -non-directory part as the marked files in the Dired buffer in the other -window." - (interactive (list (window-buffer (next-window)))) - (if (eq (get-buffer buf) (current-buffer)) - (error "Other dired buffer is the same")) - (or (stringp buf) (setq buf (buffer-name buf))) - (let ((other-files (save-excursion - (set-buffer buf) - (or (eq major-mode 'dired-mode) - (error "%s is not a dired buffer" buf)) - (dired-get-marked-files 'no-dir)))) - (dired-mark-these-files other-files (concat "from buffer " buf)))) - -(defun dired-mark-files-compilation-buffer (&optional buf) - "Mark the files mentioned in the `*compilation*' buffer. -With a prefix, you may specify the other buffer." - (interactive - (list - (let ((buff (let ((owin (selected-window)) - found) - (unwind-protect - (progn - (other-window 1) - (while (null (or found (eq (selected-window) owin))) - (if (compilation-buffer-p - (window-buffer (selected-window))) - (setq found (current-buffer))) - (other-window 1))) - (select-window owin)) - found))) - (if (or current-prefix-arg (null buff)) - (let ((minibuffer-history - (delq nil - (mapcar - (function - (lambda (b) - (and (compilation-buffer-p b) (buffer-name b)))) - (buffer-list))))) - (read-buffer "Use buffer: " - (or buff (car minibuffer-history)))) - buff)))) - (let ((dired-dir (directory-file-name default-directory)) - files) - (save-window-excursion - (set-buffer buf) - (compile-reinitialize-errors nil (point-max)) - (let ((alist compilation-error-list) - f d elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (and (consp (setq elt (car (cdr elt)))) - (stringp (setq d (car elt))) - (stringp (setq f (cdr elt))) - (progn - (setq d (expand-file-name d)) - (dired-in-this-tree d dired-dir)) - (progn - (setq f (expand-file-name f d)) - (not (member f files))) - (setq files (cons f files)))))) - (dired-mark-these-files - files - (concat "From compilation buffer " - (if (stringp buf) buf (buffer-name buf)))))) - -;;; end of dired-mob.el
--- a/lisp/efs/dired-mule.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-mule.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: MULE support for dired. -;; Created: Sun Jul 17 14:45:12 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Acknowledgements: -;; -;; Ishikawa Ichiro for sending MULE patches and information. - -(require 'dired) - -(defun dired-find-file (&optional coding-system) - "In dired, visit the file or directory named on this line." - (interactive "ZCoding-system: ") - (find-file (dired-get-filename) coding-system)) - -(defun dired-find-file-other-window (&optional display coding-system) - "In dired, visit this file or directory in another window. -With a prefix, the file is displayed, but the window is not selected." - (interactive "P\nZCoding-system: ") - (if display - (dired-display-file coding-system) - (find-file-other-window (dired-get-filename) coding-system))) - -(defun dired-display-file (&optional coding-system) - "In dired, displays this file or directory in the other window." - (interactive "ZCoding-system: ") - (display-buffer - (find-file-noselect (dired-get-filename) coding-system))) - -;;; end of dired-mule.el
--- a/lisp/efs/dired-oas.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-oas.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: dired odds and sods. Dired functions not usually needed. -;; This file is not a reference to the Organization of -;; American States. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Don't require or provide anything, as this file is just an archive. - -(defun dired-sort-on-size () - "Sorts a dired listing on file size. -If your ls cannot sort on size, this is useful as `dired-after-readin-hook': - \(setq dired-after-readin-hook 'dired-sort-on-size\)" - (require 'sort) - (goto-char (point-min)) - (dired-goto-next-file) ; skip `total' line - (beginning-of-line) - (sort-subr t 'forward-line 'end-of-line 'dired-get-file-size)) - -(defun dired-directories-of (files) - ;; Return unique list of parent directories of FILES. - (let (dirs dir file) - (while files - (setq file (car files) - files (cdr files) - dir (file-name-directory file)) - (or (member dir dirs) - (setq dirs (cons dir dirs)))) - dirs)) - -(defun dired-parse-ls-show () - (interactive) - (let (inode s mode size uid gid nlink time name sym) - (if (dired-parse-ls) - (message "%s" (list inode s mode nlink uid gid size time name sym)) - (message "Not on a file line.")))) - -(defun dired-files-same-directory (file-list &optional absolute) - "If all files in LIST are in the same directory return it, otherwise nil. -Returned name has no trailing slash. \"Same\" means file-name-directory of -the files are string=. File names in LIST must all be absolute or all be -relative. Implicitly, relative file names are in default-directory. If -optional ABS is non-nil, the returned name will be absolute, otherwise the -returned name will be absolute or relative as per the files in LIST." - (let ((dir (file-name-directory (car file-list)))) - (if (memq nil (mapcar (function - (lambda (file) - (string= dir (file-name-directory file)))) - file-list)) - nil - (directory-file-name - (if (or (not absolute) (and dir (file-name-absolute-p dir))) - (or dir "") - (concat default-directory dir))))))
--- a/lisp/efs/dired-rgxp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,267 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-rgxp.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for running commands on files whose names -;; match a regular expression. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-rgxp) -(require 'dired) - -;;; Variables - -(defvar dired-flagging-regexp nil) -;; Last regexp used to flag files. - -;;; Utility functions - -(defun dired-do-create-files-regexp - (file-creator operation arg regexp newname &optional whole-path marker-char) - ;; Create a new file for each marked file using regexps. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-get-marked-files. - ;; Matches each marked file against REGEXP and constructs the new - ;; filename from NEWNAME (like in function replace-match). - ;; Optional arg WHOLE-PATH means match/replace the whole pathname - ;; instead of only the non-directory part of the file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - (let* ((fn-list (dired-get-marked-files nil arg)) - (name-constructor - (if whole-path - (list 'lambda '(from) - (list 'let - (list (list 'to - (list 'dired-string-replace-match - regexp 'from newname))) - (list 'or 'to - (list 'dired-log - '(buffer-name (current-buffer)) - "%s: %s did not match regexp %s\n" - operation 'from regexp)) - 'to)) - (list 'lambda '(from) - (list 'let - (list (list 'to - (list 'dired-string-replace-match regexp - '(file-name-nondirectory from) - newname))) - (list 'or 'to - (list 'dired-log '(buffer-name (current-buffer)) - "%s: %s did not match regexp %s\n" - operation '(file-name-nondirectory from) - regexp)) - '(and to - (expand-file-name - to (file-name-directory from))))))) - (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) - (query (list 'lambda '(from to) - (list 'let - (list (list 'help-form - rename-regexp-help-form)) - (list 'dired-query - '(quote dired-file-creator-query) - operation-prompt - '(dired-abbreviate-file-name from) - '(dired-abbreviate-file-name to)))))) - (dired-create-files - file-creator operation fn-list name-constructor marker-char query))) - -(defun dired-mark-read-regexp (operation) - ;; Prompt user about performing OPERATION. - ;; Read and return list of: regexp newname arg whole-path. - (let* ((whole-path - (equal 0 (prefix-numeric-value current-prefix-arg))) - (arg - (if whole-path nil current-prefix-arg)) - (regexp - (dired-read-with-history - (concat (if whole-path "Path " "") operation " from (regexp): ") - dired-flagging-regexp 'dired-regexp-history)) - (newname - (read-string - (concat (if whole-path "Path " "") operation " " regexp " to: ") - (and (not whole-path) (dired-dwim-target-directory))))) - (list regexp newname arg whole-path))) - -;;; Marking file names matching a regexp. - -(defun dired-mark-files-regexp (regexp &optional marker-char omission-files-p) - "\\<dired-mode-map>Mark all files matching REGEXP for use in later commands. - -A prefix argument \\[universal-argument] means to unmark them instead. - -A prefix argument 0 means to mark the files that would me omitted by \\[dired-omit-toggle]. -A prefix argument 1 means to unmark the files that would be omitted by \\[dired-omit-toggle]. - -REGEXP is an Emacs regexp, not a shell wildcard. Thus, use \"\\.o$\" for -object files--just `.o' will mark more than you might think. The files \".\" -and \"..\" are never marked. -" - (interactive - (let ((unmark (and (not (eq current-prefix-arg 0)) current-prefix-arg)) - (om-files-p (memq current-prefix-arg '(0 1))) - regexp) - (if om-files-p - (setq regexp (dired-omit-regexp)) - (setq regexp (dired-read-with-history - (concat (if unmark "Unmark" "Mark") - " files (regexp): ") nil - 'dired-regexp-history))) - (list regexp (if unmark ?\ ) om-files-p))) - (let ((dired-marker-char (or marker-char dired-marker-char))) - (dired-mark-if - (and (not (looking-at dired-re-dot)) - (not (eolp)) ; empty line - (let ((fn (dired-get-filename nil t))) - (and fn (string-match regexp (file-name-nondirectory fn))))) - (if omission-files-p - "omission candidate file" - "matching file")))) - -(defun dired-flag-files-regexp (regexp) - "In dired, flag all files containing the specified REGEXP for deletion. -The match is against the non-directory part of the filename. Use `^' - and `$' to anchor matches. Exclude subdirs by hiding them. -`.' and `..' are never flagged." - (interactive (list (dired-read-with-history - "Flag for deletion (regexp): " nil - 'dired-regexp-history))) - (dired-mark-files-regexp regexp dired-del-marker)) - -(defun dired-mark-extension (extension &optional marker-char) - "Mark all files with a certain extension for use in later commands. -A `.' is not prepended to the string entered." - ;; EXTENSION may also be a list of extensions instead of a single one. - ;; Optional MARKER-CHAR is marker to use. - (interactive "sMark files with extension: \nP") - (or (listp extension) - (setq extension (list extension))) - (dired-mark-files-regexp - (concat ".";; don't match names with nothing but an extension - "\\(" - (mapconcat 'regexp-quote extension "\\|") - "\\)$") - marker-char)) - -(defun dired-flag-extension (extension) - "In dired, flag all files with a certain extension for deletion. -A `.' is not prepended to the string entered." - (interactive "sFlag files with extension: ") - (dired-mark-extension extension dired-del-marker)) - -(defun dired-cleanup (program) - "Flag for deletion dispensable files created by PROGRAM. -See variable `dired-cleanup-alist'." - (interactive - (list - (let ((dired-cleanup-history (append dired-cleanup-history - (mapcar 'car dired-cleanup-alist)))) - (dired-completing-read - "Cleanup files for: " dired-cleanup-alist nil t nil - 'dired-cleanup-history)))) - (dired-flag-extension (cdr (assoc program dired-cleanup-alist)))) - -;;; Commands on marked files whose names also match a regexp. - -(defun dired-do-rename-regexp (regexp newname &optional arg whole-path) - "Rename marked files containing REGEXP to NEWNAME. -As each match is found, the user must type a character saying - what to do with it. For directions, type \\[help-command] at that time. -NEWNAME may contain \\=\\<n> or \\& as in `query-replace-regexp'. -REGEXP defaults to the last regexp used. -With a zero prefix arg, renaming by regexp affects the complete - pathname - usually only the non-directory part of file names is used - and changed." - (interactive (dired-mark-read-regexp "Rename")) - (dired-do-create-files-regexp - (function dired-rename-file) - "Rename" arg regexp newname whole-path dired-keep-marker-rename)) - -(defun dired-do-copy-regexp (regexp newname &optional arg whole-path) - "Copy all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "Copy")) - (dired-do-create-files-regexp - (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg regexp newname whole-path dired-keep-marker-copy)) - -(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) - "Hardlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "HardLink")) - (dired-do-create-files-regexp - (function add-name-to-file) - "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink)) - -(defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) - "Symlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "SymLink")) - (dired-do-create-files-regexp - (function make-symbolic-link) - "SymLink" arg regexp newname whole-path dired-keep-marker-symlink)) - -(defun dired-do-relsymlink-regexp (regexp newname &optional whole-path) - "RelSymlink all marked files containing REGEXP to NEWNAME. -See functions `dired-rename-regexp' and `dired-do-relsymlink' - for more info." - (interactive (dired-mark-read-regexp "RelSymLink")) - (dired-do-create-files-regexp - (function dired-make-relative-symlink) - "RelSymLink" nil regexp newname whole-path dired-keep-marker-symlink)) - -;;;; Modifying the case of file names. - -(defun dired-create-files-non-directory - (file-creator basename-constructor operation arg) - ;; Perform FILE-CREATOR on the non-directory part of marked files - ;; using function BASENAME-CONSTRUCTOR, with query for each file. - ;; OPERATION like in dired-create-files, ARG like in dired-get-marked-files. - (let (rename-non-directory-query) - (dired-create-files - file-creator - operation - (dired-get-marked-files nil arg) - (function - (lambda (from) - (let ((to (concat (file-name-directory from) - (funcall basename-constructor - (file-name-nondirectory from))))) - (and (let ((help-form (format "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) - (dired-query 'rename-non-directory-query - (concat operation " `%s' to `%s'") - (dired-make-relative from) - (dired-make-relative to))) - to)))) - dired-keep-marker-rename))) - -(defun dired-rename-non-directory (basename-constructor operation arg) - (dired-create-files-non-directory - (function dired-rename-file) - basename-constructor operation arg)) - -(defun dired-upcase (&optional arg) - "Rename all marked (or next ARG) files to upper case." - (interactive "P") - (dired-rename-non-directory (function upcase) "Rename upcase" arg)) - -(defun dired-downcase (&optional arg) - "Rename all marked (or next ARG) files to lower case." - (interactive "P") - (dired-rename-non-directory (function downcase) "Rename downcase" arg)) - -;;; end of dired-rgxp.el
--- a/lisp/efs/dired-sex.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-sex.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Marking files according to sexpressions. Sorry. -;; Created: Wed Sep 14 01:30:43 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'dired-sex) -(require 'dired) - -(defvar dired-sexpr-history-symbol nil - "History of sexpr used to mark files in dired.") - -;;; Marking files according to sexpr's - -(defmacro dired-parse-ls () - ;; Sets vars - ;; inode s mode nlink uid gid size time name sym - ;; (probably let-bound in caller) according to current file line. - ;; Returns t for succes, nil if this is no file line. - ;; Upon success, all variables are set, either to nil or the - ;; appropriate value, so they need not be initialized. - ;; Moves point within the current line to the end of the file name. - '(let ((bol (progn (beginning-of-line) (point))) - (eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if (re-search-forward dired-re-month-and-time eol t) - (let ((mode-len 10) ; length of mode string - (tstart (progn (goto-char (match-beginning 0)) - (skip-chars-forward " ") - (point))) - (fstart (match-end 0)) - pos) - (goto-char (1+ bol)) - (skip-chars-forward " \t") - ;; This subdir had better have been created with the current - ;; setting of actual switches. Otherwise, we can't parse. - (cond - ((and (or (memq ?k dired-internal-switches) - (memq ?s dired-internal-switches)) - (memq ?i dired-internal-switches)) - (setq pos (point)) - (skip-chars-forward "0-9") - (if (setq inode (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point))))) - (progn - (skip-chars-forward " ") - (setq pos (point)) - (skip-chars-forward "0-9") - (setq s (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point)))))) - (setq s nil))) - ((or (memq ?s dired-internal-switches) - (memq ?k dired-internal-switches)) - (setq pos (point)) - (skip-chars-forward "0-9") - (setq s (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point)))) - inode nil)) - ((memq ?i dired-internal-switches) - (setq pos (point)) - (skip-chars-forward "0-9") - (setq inode (and (/= pos (point)) (string-to-int - (buffer-substring - pos (point)))) - s nil)) - (t - (setq s nil - inode nil))) - (skip-chars-forward " 0-9") ; in case of junk - (setq mode (buffer-substring (point) (+ mode-len (point)))) - (forward-char mode-len) - (setq nlink (read (current-buffer))) - (or (integerp nlink) (setq nlink nil)) - (setq uid (buffer-substring (point) (progn - (skip-chars-forward "^ ") - (point)))) - (goto-char tstart) - (skip-chars-backward " ") - (setq pos (point)) - (skip-chars-backward "0-9") - (if (= pos (point)) - (setq size nil) - (setq size (string-to-int (buffer-substring (point) pos)))) - (skip-chars-backward " ") - ;; if no gid is displayed, gid will be set to uid - ;; but user will then not reference it anyway in PREDICATE. - (setq gid (buffer-substring (point) (progn - (skip-chars-backward "^ ") - (point))) - time (buffer-substring tstart - (progn - (goto-char fstart) - (skip-chars-backward " ") - (point))) - name (buffer-substring - fstart - (or (dired-move-to-end-of-filename t) - (point))) - sym (and (looking-at "[/*@#=|]? -> ") - (buffer-substring (match-end 0) - eol))) - t)))) ; return t if parsing was a success - - -(defun dired-mark-sexp (predicate &optional unflag-p) - "Mark files for which PREDICATE returns non-nil. -With a prefix arg, unflag those files instead. - -PREDICATE is a lisp expression that can refer to the following symbols: - - inode [integer] the inode of the file (only for ls -i output) - s [integer] the size of the file for ls -s output - (ususally in blocks or, with -k, in KByte) - mode [string] file permission bits, e.g. \"-rw-r--r--\" - nlink [integer] number of links to file - uid [string] owner - gid [string] group (If the gid is not displayed by ls, - this will still be set (to the same as uid)) - size [integer] file size in bytes - time [string] the time that ls displays, e.g. \"Feb 12 14:17\" - name [string] the name of the file - sym [string] if file is a symbolic link, the linked-to name, else nil. - -For example, use - - (equal 0 size) - -to mark all zero length files." - ;; Using sym="" instead of nil avoids the trap of - ;; (string-match "foo" sym) into which a user would soon fall. - ;; No! Want to be able look for symlinks pointing to the empty string. - ;; Can happen. Also, then I can do an (if sym ...) structure. --sandy - ;; Give `equal' instead of `=' in the example, as this works on - ;; integers and strings. - (interactive - (list - (read - (dired-read-with-history "Mark if (lisp expr): " nil - 'dired-sexpr-history)) - current-prefix-arg)) - (message "%s" predicate) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)) - inode s mode nlink uid gid size time name sym) - (dired-mark-if (save-excursion - (and (dired-parse-ls) - (eval predicate))) - (format "'%s file" predicate))) - (dired-update-mode-line-modified t)) - -;;; end of dired-sex.el
--- a/lisp/efs/dired-shell.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,861 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-shell.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for running shell commands on marked files. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-shell) -(require 'dired) -(autoload 'comint-mode "comint") - -;;; Variables - -(defvar dired-postscript-print-command - (condition-case nil - (progn - (require 'ps-print) - (concat ps-lpr-command - " " - (ps-flatten-list (mapcar 'ps-eval-switch ps-lpr-switches)))) - (error - (concat - (if (boundp 'lpr-command) - lpr-command - (if (memq system-type - '(usg-unix-v hpux silicon-graphics-unix)) - "lp" - "lpr")) - (if (and (boundp 'lpr-switches) lpr-switches) - (concat " " - (mapconcat 'identity lpr-switches " ") - " ") - " ")))) - "Command to print a postscript file.") - -(defvar dired-text-print-command (concat dired-postscript-print-command "-p ") - "Command to print a text file.") - -(defvar dired-print-program-alist - (list - (cons "\\.gif$" (concat "giftoppm * | ppmtopgm | pnmtops | " - dired-postscript-print-command)) - (cons "\\.\\(fts\\|FTS\\)$" (concat "fitstopgm * | pnmtops | " - dired-postscript-print-command)) - ;; People with colour printers won't want the g-flag in djpeg - (cons "\\.\\(JPG\\|jpg\\)$" (concat "djpeg -Pg * | pnmtops | " - dired-postscript-print-command)) - (cons "\\.ps\\.\\(gz\\|Z\\)$" (concat "zcat * | " - dired-postscript-print-command)) - (cons "\\.ps$" dired-postscript-print-command) - (cons "\\.\\(gz\\|Z\\)$" (concat "zcat * | " - dired-postscript-print-command)) - (cons "\\.dvi$" "dvips") - (cons ".*" dired-text-print-command)) - "Alist of regexps and print commands. -This is used by `dired-do-print' to determine the default print command for -printing the marked files.") - -(defvar dired-auto-shell-command-alist nil - "*Alist of regexps and command lists to guess shell commands. -Each element of this list should be a list of regular expression, and a list -of guesses for shell commands to be used if the file name matches the regular -expression. The list of guesses is evalled. This alist is appended to the front -of dired-default-auto-shell-command-alist before prompting for each shell -command.") - -(defvar dired-default-auto-shell-command-alist - (list - - ;; Archiving - '("\\.tar$" - (if dired-gnutar-program - (concat dired-gnutar-program " xvf") - "tar xvf") - (if dired-gnutar-program - (concat dired-gnutar-program " tvf") - "tar tvf")) - ;; regexps for compressed archives must come before the .Z rule to - ;; be recognized: - '("\\.tar\\.\\([zZ]\\|gz\\)\\|\\.tgz$" ; .tgz is for DOS - (if dired-gnutar-program - (concat dired-gnutar-program " zxvf") - "zcat * | tar xvf -") - (if dired-gnutar-program - (concat dired-gnutar-program " ztvf") - "zcat * | tar tvf -")) - '("\\.shar.[zZ]$" (if dired-unshar-program - (concat "zcat * | " dired-unshar-program) - "zcat * | sh")) - '("\\.zoo$" "zoo x//") - '("\\.zip$" "unzip" "unzip -v") - '("\\.lzh$" "lharc x") - '("\\.arc$" "arc x") - '("\\.shar$" (if dired-unshar-program dired-unshar-program "sh")) - - ;; Encoding/compressing - '("\\.uu$" "uudecode") - '("\\.hqx$" "mcvert") - - ;; Executing (in the generalized sense) - '("\\.sh$" "sh") ; execute shell scripts - '("^[Mm]akefile$" "make -f *") - '("\\.diff$" "patch -t <") - - ;; Displaying (assumes X) - '("\\.xbm$" "bitmap") ; view X11 bitmaps - '("\\.gp$" "gnuplot") - '("\\.gif$" "xv") ; view gif pictures - '("\\.fig$" "xfig") ; edit fig pictures - '("\\.ps$" "ghostview") - - ;; Typesetting. For printing documents, see dired-print-program-alist. - '("\\.tex$" "latex" "tex") - '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi") - (if (eq window-system 'x) - (if dired-use-file-transformers - '("\\.dvi$" "xdvi" "dvips -o *b.ps *") - '("\\.dvi$" "xdvi" "dvips")) - (if dired-use-file-transformers - '("\\.dvi$" "dvips -o *b.ps *") - '("\\.dvi$" "dvips"))) - - ;; The last word. Things that cannot be grokked with a regexp. - '("." (if (> (length files) 1) - "tar cvf " - (and (= (length files) 1) (file-directory-p - (expand-file-name - (car files) - (dired-current-directory))) - (concat "tar cvf " (file-name-nondirectory - (directory-file-name (car files))) - ".tar")))) - ) - "Default for variable `dired-auto-shell-command-alist' (which see). -Set this to nil to turn off shell command guessing.") - -;; Might use {,} for bash or csh: -(defvar dired-shell-prefix "" - "Prepended to marked files in dired shell commands.") -(defvar dired-shell-postfix "" - "Appended to marked files in dired shell commands.") -(defvar dired-shell-separator " " - "Separates marked files in dired shell commands.") - -(defvar dired-file-wildcard ?* - "Wildcard character used by dired shell commands. -Indicates where file names should be inserted.") - -(defvar dired-shell-command-separators '(?\ ?| ?> ?< ?& ?;) - "Defines the start of a string specifying a word in a shell command.") - -(defvar dired-trans-map - (list - (cons ?f 'identity) - (cons ?n 'file-name-nondirectory) - (cons ?d 'file-name-directory) - (cons ?b 'dired-file-name-base) - (cons ?e 'dired-file-name-extension) - (cons ?v 'dired-file-name-sans-rcs-extension) - (cons ?z 'dired-file-name-sans-compress-extension)) - "Alist that associates keys with file transformer functions -Each transformer function should be a funcion of one argument, the file name. -The keys are characters.") - -(defvar dired-shell-failure-marker ?! - "*A marker to mark files on which shell commands fail. -If nil, such files are not marked.") - -;;; Internal variables - -;; Make sure this gets defined. -(defvar shell-command-history nil - "History list of previous shell commands.") - -(defvar dired-print-history nil - "History of commands used to print files.") - -(defvar dired-shell-input-start) ; only defined in shell output buffers - -;;; Utility functions and Macros - -(defun dired-shell-quote (filename) - ;; Quote a file name for inferior shell (see variable shell-file-name). - ;; Quote everything except POSIX filename characters. - ;; This should be safe enough even for really weird shells. - (let ((result "") (start 0) end) - (while (string-match "[^---0-9a-zA-Z_./]" filename start) - (setq end (match-beginning 0) - result (concat result (substring filename start end) - "\\" (substring filename end (1+ end))) - start (1+ end))) - (concat result (substring filename start)))) - -(defun dired-uniquefy-list (list) - ;; Returns list, after removing 2nd and higher occurrences - ;; of all elements. Tests elements with equal. Retains the relative - ;; order of the elements. - ;; For small lists, this way is probably faster than sorting. - (let (result) - (while list - (or (member (car list) result) - (setq result (nconc result (list (car list))))) - (setq list (cdr list))) - result)) - -(defun dired-read-shell-command (prompt arg files) - ;; Read a dired shell command prompting with PROMPT (using read-string). - ;; ARG is the prefix arg and may be used to indicate in the prompt which - ;; files are affected. - (dired-mark-pop-up - nil 'shell files - (function - (lambda (prompt files) - (let* ((default (car shell-command-history)) - (guesses (dired-guess-default files)) - (len (length guesses)) - cmd) - (or (zerop len) - (setq prompt (format "%s{%d guess%s} " - prompt len (if (= len 1) "" "es")))) - (if default (setq prompt (concat prompt "[" default "] "))) - (put 'guesses 'no-default t) ; for gmhist, in case. - (setq guesses (nconc guesses (copy-sequence shell-command-history)) - cmd (dired-read-with-history prompt nil 'guesses)) - (if (string-match "^[ \t\n]*$" cmd) - (if default - (setq cmd default) - (error "No shell command given."))) - (setq shell-command-history - (dired-uniquefy-list - (cons cmd shell-command-history))) - cmd))) - (format prompt (dired-mark-prompt arg files)) files)) - -(defmacro dired-trans-subst (transformers filename dir) -;; Applies each transformer supplied in the string TRANSFORMERS in sequence -;; to FILE and returns the concatenation of the results. Also unquotes \\'s. -;; Returns a string if no file transformations were done, otherwise a list -;; consisting of a single string. - (` (let* ((transformers (, transformers)) - (filename (, filename)) - (len (length transformers)) - (pos 0) - (last 0) - (transformed nil) - (quoted nil) - char result trans) - (while (< pos len) - (setq char (aref transformers pos)) - (cond - (quoted (setq pos (1+ pos) - quoted nil)) - ((= ?\\ char) - (setq quoted t - result (concat result (substring transformers last pos)) - pos (1+ pos) - last pos)) - ((and (null quoted) (= char dired-file-wildcard)) - (setq pos (1+ pos) - trans (and (< pos len) - dired-use-file-transformers - (assq (aref transformers pos) - dired-trans-map)) - transformed t) - (if trans - (setq result (concat result - (substring transformers last (1- pos)) - (funcall (cdr trans) filename)) - pos (1+ pos) - last pos) - (setq result (concat result (substring transformers last (1- pos)) - (dired-make-relative filename (, dir) t)) - last pos))) - ((setq pos (1+ pos))))) - (if result - (progn - (setq result (dired-shell-quote - (concat result (substring transformers last)))) - (if transformed (list result) result)) - transformers)))) - -(defun dired-trans-filenames (transformers files dir) - ;; Applies a transformer string to a list of filenames, - ;; concatenating them into a string. The result will be prefixed - ;; by dired-shell-prefix, the filenames separated by dired-shell-separator, - ;; and postfixed by dired-shell-postfix. - ;; Returns a list if filename subst. was done. A string otherwise. - (let ((list files) - (res nil) - trans) - (while list - (setq trans (dired-trans-subst transformers (car list) dir)) - (if (listp trans) - (setq res (nconc res trans) - list (cdr list)) - (setq res trans - list nil))) - (if (listp res) - (list - (if (> (length files) 1) - (concat dired-shell-prefix - (mapconcat 'identity res dired-shell-separator) - dired-shell-postfix) - (car res))) - res))) - -(defun dired-trans-command (command files dir) - ;; Do all of the trans substitutions in COMMAND for the list - ;; of files FILES. FILES must be a list of *absolute* pathnames. - ;; DIR is an absolute directory wrto which filenames may be relativized. - (let ((len (length command)) - (start 0) - (pos 0) - (last 0) - result char transed transform) - (while (< pos len) - ;; read over word separators. - (while (and (< pos len) (memq (aref command pos) - dired-shell-command-separators)) - (setq pos (1+ pos))) - (setq start pos) - ;; read a word - (while (and (< pos len) (not (memq (setq char (aref command pos)) - dired-shell-command-separators))) - (setq pos (1+ pos)) - ;; look out for quoted separators - (and (= ?\\ char) (< pos len) (or (memq (setq char (aref command pos)) - dired-shell-command-separators) - (= ?\\ char)) - (setq pos (1+ pos)))) - (setq transform (if (= start pos) - "" - (dired-trans-filenames (substring command start pos) - files dir)) - ;; remember if we did any transforming - transed (or transed (listp transform)) - result (concat result - (substring command last start) - (if (listp transform) - (car transform) - transform)) - last pos)) - (if transed - ;; just return result - result - ;; add the filenames at the end. - (let ((fns (if (> (length files) 1) - (concat dired-shell-prefix - (mapconcat - (function - (lambda (fn) - (dired-shell-quote - (dired-make-relative fn dir t)))) - files dired-shell-separator) - dired-shell-postfix) - (dired-shell-quote - (dired-make-relative (car files) dir t))))) - (concat result " " fns))))) - -(defun dired-shell-stuff-it (command file-list dir on-each) - ;; Make up a shell command line from COMMAND and FILE-LIST. - ;; If ON-EACH is t, COMMAND should be applied to each file, else - ;; simply concat all files and apply COMMAND to this. - ;; If ON-EACH is 'dir, the command is run in the directory of each file - ;; In this case FILE-LIST must be a list of full paths. - ;; FILE-LIST's elements will be quoted for the shell. - (cond - ((eq on-each 'dir) - (let ((subshell-dir nil) - (list file-list) - (result nil)) - (while list - (let ((cmd (dired-trans-command command (list (car list)) - (file-name-directory (car list)))) - (fdir (dired-shell-quote (file-name-directory (car list))))) - (setq result - (apply 'concat - result - (if subshell-dir - (if (string-equal dir subshell-dir) - (list "\; " cmd) - (if (string-equal dir fdir) - (progn - (setq subshell-dir nil) - (list "\)\; " cmd)) - (setq subshell-dir fdir) - (list "\)\; \(cd " - fdir - "\; " - cmd))) - (if (string-equal fdir dir) - (list (and result "\; ") - cmd) - (setq subshell-dir fdir) - (list (and result "\; ") - "\(cd " - fdir - "\; " - cmd))))) - (setq list (cdr list)))) - (concat result (and subshell-dir ")")))) - (on-each - (mapconcat (function - (lambda (fn) - (dired-trans-command command (list fn) dir))) - file-list "; ")) - - (t (dired-trans-command command file-list dir)))) - -(defun dired-guess-default (files) - ;; Guess a list of possible shell commands for FILES. - (and dired-default-auto-shell-command-alist - files - (let ((alist (append dired-auto-shell-command-alist - dired-default-auto-shell-command-alist)) - guesses) - (while alist - (let* ((elt (car alist)) - (regexp (car elt))) - (setq guesses - (nconc guesses - (catch 'missed - (mapcar (function - (lambda (file) - (or (string-match regexp file) - (throw 'missed nil)))) - files) - (delq nil (mapcar 'eval (cdr elt))))))) - (setq alist (cdr alist))) - (dired-uniquefy-list guesses)))) - -(defun dired-shell-unhandle-file-name (filename) - "Turn a file name into a form that can be sent to a shell process. -This is particularly usefull if we are sending file names to a remote shell." - (let ((handler (find-file-name-handler filename 'dired-shell-unhandle-file-name))) - (if handler - (funcall handler 'dired-shell-unhandle-file-name filename) - filename))) - -;;; Actually running the shell command - -(defun dired-run-shell-command-closeout (buffer &optional message) - ;; Report on the number of lines produced by a shell command. - (if (get-buffer buffer) - (save-excursion - (set-buffer buffer) - (if (zerop (buffer-size)) - (progn - (if message - (message "Shell command completed with no output. %s" - message) - (message "Shell command completed with no output.")) - (kill-buffer buffer)) - (set-window-start (display-buffer buffer) 1) - (if message - (message "Shell command completed. %s" message) - (message "Shell command completed.")))))) - -(defun dired-rsc-filter (proc string) - ;; Do save-excursion by hand so that we can leave point - ;; numerically unchanged despite an insertion immediately - ;; after it. - (let* ((obuf (current-buffer)) - (buffer (process-buffer proc)) - opoint - (window (get-buffer-window buffer)) - (pos (window-start window))) - (unwind-protect - (progn - (set-buffer buffer) - (setq opoint (point)) - (goto-char (point-max)) - (insert-before-markers string)) - ;; insert-before-markers moved this marker: set it back. - (set-window-start window pos) - ;; Finish our save-excursion. - (goto-char opoint) - (set-buffer obuf)))) - -(defun dired-rsc-sentinel (process signal) - ;; Sentinel function used by dired-run-shell-command - (if (memq (process-status process) '(exit signal)) - (let ((buffer (get-buffer (process-buffer process)))) - (if buffer - (save-excursion - (set-buffer buffer) - (if (zerop (buffer-size)) - (message - "Dired & shell command completed with no output.") - (let ((lines (count-lines dired-shell-input-start - (point-max)))) - (message - "Dired & shell command completed with %d line%s of output." - lines (dired-plural-s lines)))) - (setq mode-line-process nil))) - (delete-process process)))) - -(defun dired-shell-call-process (command dir &optional in-background) - ;; Call a shell command as a process in the current buffer. - ;; The process should try to run in DIR. DIR is also - ;; used to lookup a file-name-handler. - ;; Must return the process object if IN-BACKGROUND is non-nil, - ;; otherwise the process exit status. - (let ((handler (find-file-name-handler dir 'dired-shell-call-process))) - (if handler - (funcall handler 'dired-shell-call-process command dir in-background) - (let ((process-connection-type ; don't waste pty's - (null (null in-background)))) - (setq default-directory dir) - (if in-background - (progn - (setq mode-line-process '(": %s")) - (start-process "Shell" (current-buffer) - shell-file-name "-c" command)) - (call-process shell-file-name nil t nil "-c" command)))))) - -(defun dired-run-shell-command (command dir in-background &optional append) - ;; COMMAND is shell command - ;; DIR is directory in which to do the shell command. - ;; If IN-BACKGROUND is non-nil, the shell command is run in the background. - ;; If it is a string, this is written as header into the output buffer - ;; before the command is run. - ;; If APPEND is non-nil, the results are appended to the contents - ;; of *shell-command* buffer, without erasing its previous contents. - (save-excursion - (if in-background - (let* ((buffer (get-buffer-create - "*Background Shell Command Output*")) - (n 2) - proc) - ;; No reason why we can't run two+ background commands. - (while (get-buffer-process buffer) - (setq buffer (get-buffer-create - (concat "*Background Shell Command Output*<" - (int-to-string n) ">")) - n (1+ n))) - (set-buffer buffer) - (or (eq major-mode 'comint-mode) - (progn - (comint-mode) - (set (make-local-variable 'comint-prompt-regexp) - "^[^\n]*\\? *"))) - (display-buffer buffer) - (barf-if-buffer-read-only) - ;; If will kill a process, query first. - - (set (make-local-variable 'dired-shell-input-start) (point-min)) - (if append - (progn - (goto-char (point-max)) - (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) - (erase-buffer) - (if (stringp in-background) - (progn - (insert in-background) - (set (make-local-variable 'dired-shell-input-start) - (point))))) - (setq proc (dired-shell-call-process command dir t)) - (set-marker (process-mark proc) (point)) - (set-process-sentinel proc 'dired-rsc-sentinel) - (set-process-filter proc 'dired-rsc-filter) - nil) ; return - (let ((buffer (get-buffer-create "*Shell Command Output*"))) - (set-buffer buffer) - (barf-if-buffer-read-only) - (set (make-local-variable 'dired-shell-input-start) (point-min)) - (if append - (progn - (goto-char (point-max)) - (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) - (erase-buffer)) - (dired-shell-call-process command dir))))) - -;;; User commands - -(defun dired-do-shell-command (command arg files &optional in-background) - ;; ARG = (16) means operate on each file, in its own directory. - ;; ARG = (4) means operate on each file, but in the current - ;; default-directory. - "Run a shell command COMMAND on the marked files. -If no files are marked or a non-zero numeric prefix arg is given, -the next ARG files are used. Use prefix 1 to indicate the current file. - -Normally the shell command is executed in the current dired subdirectory. -This is the directory in the dired buffer which currently contains the point. -One shell command is run for all of the files. -e.g. cmd file1 file2 file3 ... -If the total length of of the command exceeds 10000 characters, the files will -be bunched to forms commands shorter than this length, and successive commands -will be sent. - -With a prefix of \\[universal-argument], a separate command for each file will -be executed. - -With a prefix of \\[universal-argument] \\[universal-argument], a separate command will be sent for each file, -and the command will be executed in the directory of that file. The explicit -command will be of the form - - cd dir; cmd file - -When prompting for the shell command, dired will always indicate the directory -in which the command will be executed. - -The following documentation depends on the settings of `dired-file-wildcard', -`dired-shell-command-separators', `dired-trans-map', `dired-shell-prefix', -`dired-shell-separator', and `dired-shell-postfix'. See the documentation for -these variables. Below, I will assume default settings for these variables. - -If the shell command contains a *, then the list of files is substituted for *. -The filenames will be written as relative to the directory in which the shell -command is executing. If there is no *, and the command does not end in &, -then the files are appended to the end of the command. If the command ends in -a &, then the files are inserted before the &. - -If `dired-use-file-transformers' is non-nil, then certain 2-character -sequences represent parts of the file name. -The default transformers are: -*f = full file name -*n = file name without directory -*d = file name's directory - This will end in a \"/\" in unix. -*e = file names extension - By default this the part of the file name without directory, which - proceeds the first \".\". If \".\" is the first character of the name, - then this \".\" is ignored. The definition of extension can - be customized with `dired-filename-re-ext'. -*b = file base name - This is the part of the file name without directory that precedes - the extension. -*v = file name with out version control extension (i.e. \",v\") -*z = file name without compression extension - (i.e. \".Z\", \".z\", or \".gz\") - -Shell commands are divided into words separated by spaces. Then for each -word the file name transformers are applied to the list of files, the result -concatenated together and substituted for the word in the shell command. - -For example - cmd -a *f -b *d*b.fizzle applied to /foo/bar and /la/di/da results in - cmd -a /foo/bar /la/di/da -b /foo/bar.fizzle /la/di/da.fizzle - -The \"on-each\" prefixes \\[universal-argument] and 0, also apply while -using file transformers. As well, when using file-transformers * still -represents the file name relative to the current directory. Not that this -differs from *f, which always represents the full pathname. - -A \"\\\" can always be used to quote any character having special meaning. -For example, if the current directory is /la, then *n applied -to /la/di/da returns la, whereas *\\n returns di/dan. Similarly, -\"*d\\ *n\" returns \"/la/di da\". - -The prefix character for file name transformers is always the same as -`dired-file-wildcard'." - - (interactive - (let ((on-each (or (equal '(4) current-prefix-arg) - (equal '(16) current-prefix-arg))) - (files (dired-get-marked-files - nil (and (not (consp current-prefix-arg)) - current-prefix-arg))) - (dir (and (not (equal current-prefix-arg '(16))) - (dired-current-directory)))) - (list - (dired-read-shell-command - (concat (if dir - (format "! in %s " (dired-abbreviate-file-name dir)) - "cd <dir>; ! ") - "on " - (if on-each "each ") - "%s: ") - (and (not on-each) current-prefix-arg) - (if dir - (mapcar (function - (lambda (fn) - (dired-make-relative fn dir t))) - files) - files)) - current-prefix-arg files nil))) - - ;; Check for background commands - (if (string-match "[ \t]*&[ \t]*$" command) - (setq command (substring command 0 (match-beginning 0)) - in-background t)) - - ;; Look out for remote file names. - - (let* ((on-each (or (equal arg '(4)) (and (equal arg '(16)) 'dir))) - (ufiles (mapcar 'dired-shell-unhandle-file-name files)) - (dir (dired-current-directory)) - (udir (dired-shell-unhandle-file-name dir))) - - (save-excursion ; in case `shell-command' changes buffer - (cond - - ((null ufiles) - ;; Just run as a command on no files. - (if in-background - (dired-run-shell-command command dir t) - (dired-run-shell-command command dir nil) - (dired-run-shell-command-closeout "*Shell Command Output*"))) - - (in-background - ;; Can't use dired-bunch-files for background shell commands. - ;; as we will create a bunch of process running simultaneously. - ;; A better solution needs to be found. - (dired-run-shell-command - (dired-shell-stuff-it command ufiles udir on-each) - dir (if (equal arg '(16)) - (concat "cd <dir>; \"" command "\"\n\n") - (concat "\"" command "\" in " dir "\n\n")))) - (on-each - (let ((buff (get-buffer "*Shell Command Output*")) - failures this-command this-dir ufile return message) - (if buff - (save-excursion - (set-buffer buff) - (erase-buffer))) - (while ufiles - (setq ufile (car ufiles)) - (if (eq on-each 'dir) - (setq this-dir (dired-shell-quote (file-name-directory (directory-file-name ufile))) - this-command (concat "cd " this-dir "; " command)) - (setq this-command command) - (or this-dir (setq this-dir udir))) - (setq return - (dired-run-shell-command - (dired-shell-stuff-it this-command (list ufile) this-dir nil) - this-dir nil t)) - (if (and (integerp return) (/= return 0)) - (save-excursion - (let ((file (nth (- (length files) (length (member ufile ufiles))) files))) - (if (and dired-shell-failure-marker - (dired-goto-file file)) - (let ((dired-marker-char dired-shell-failure-marker)) - (dired-mark 1))) - (setq failures (cons file failures))))) - (setq ufiles (cdr ufiles))) - (if failures - (let ((num (length failures))) - (setq message - (if dired-shell-failure-marker - (format - "Marked %d failure%s with %c." - num (dired-plural-s num) - dired-shell-failure-marker) - "Failed on %d file%s." num - (dired-plural-s num))) - (dired-log - (current-buffer) - "Shell command %s failed (non-zero exit status) for:\n %s" - command failures) - (dired-log (current-buffer) t))) - (dired-run-shell-command-closeout "*Shell Command Output*" message))) - - (t - (dired-bunch-files - (- 10000 (length command)) - (function (lambda (&rest ufiles) - (dired-run-shell-command - (dired-shell-stuff-it command ufiles udir nil) - dir nil) - nil)) ; for the sake of nconc in dired-bunch-files - nil ufiles) - (dired-run-shell-command-closeout "*Shell Command Output*")))) - ;; Update any directories - (or in-background - (let ((dired-no-confirm '(revert-subdirs))) - (dired-verify-modtimes))))) - -(defun dired-do-background-shell-command (command arg files) - "Like \\[dired-do-shell-command], but starts command in background. -Note that you can type input to the command in its buffer. -This requires background.el from the comint package to work." - ;; With the version in emacs-19.el, you can alternatively just - ;; append an `&' to any shell command to make it run in the - ;; background, but you can't type input to it. - (interactive - (let ((on-each (or (equal '(4) current-prefix-arg) - (equal '(16) current-prefix-arg))) - (files (dired-get-marked-files - nil (and (not (consp current-prefix-arg)) - current-prefix-arg))) - (dir (and (not (equal current-prefix-arg '(16))) - (dired-current-directory)))) - (list - (dired-read-shell-command - (concat "& " - (if dir - (format "in %s " (dired-abbreviate-file-name dir)) - "cd <dir>; ") - "on " - (if on-each "each ") - "%s: ") - (and (not on-each) current-prefix-arg) - (if dir - (mapcar (function - (lambda (fn) - (dired-make-relative fn dir t))) - files) - files)) - current-prefix-arg files))) - (dired-do-shell-command command arg files t)) - -;;; Printing files - -(defun dired-do-print (&optional arg command files) - "Print the marked (or next ARG) files. -Uses the shell command coming from variable `dired-print-program-alist'." - (interactive - (progn - (if dired-print-history - (setq dired-print-history (dired-uniquefy-list dired-print-history)) - (setq dired-print-history (mapcar 'cdr dired-print-program-alist))) - (let* ((files (dired-get-marked-files nil current-prefix-arg)) - (rel-files (mapcar (function - (lambda (fn) - (dired-make-relative - fn - (dired-current-directory) t))) - files)) - (alist dired-print-program-alist) - (first (car files)) - (dired-print-history (copy-sequence dired-print-history)) - elt initial command) - ;; For gmhist - (put 'dired-print-history 'no-default t) - (if first - (while (and alist (not initial)) - (if (string-match (car (car alist)) first) - (setq initial (cdr (car alist))) - (setq alist (cdr alist))))) - (if (and initial (setq elt (member initial dired-print-history))) - (setq dired-print-history (nconc - (delq (car elt) dired-print-history) - (list initial)))) - (setq command - (dired-mark-read-string - "Print %s with: " - initial 'print current-prefix-arg rel-files - 'dired-print-history)) - (list current-prefix-arg command files)))) - (or files - (setq files (dired-get-marked-files nil arg))) - (while files - (dired-print-file command (car files)) - (setq files (cdr files)))) - -(defun dired-print-file (command file) - ;; Using COMMAND, print FILE. - (let ((handler (find-file-name-handler file 'dired-print-file))) - (if handler - (funcall handler 'dired-print-file command file) - (let ((rel-file (dired-make-relative file (dired-current-directory) t))) - (message "Spooling %s..." rel-file) - (shell-command (dired-trans-command command (list file) "")) - (message "Spooling %s...done" rel-file))))) - -;;; end of dired-shell.el
--- a/lisp/efs/dired-uu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-uu.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for uuencoding/uudecoding marked files. -;; Author: Sandy Rutherford <sandy@math.ubc.ca> -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-uu) -(require 'dired) - -(defvar dired-uu-files-to-decode nil) -;; Fluid var to pass data inside dired-create-files. - -(defun dired-uucode-file (file ok-flag) - ;; uuencode or uudecode FILE. - ;; Don't really support the ok-flag, but needed for compatibility - (let ((handler (find-file-name-handler file 'dired-uucode-file))) - (cond (handler - (funcall handler 'dired-uucode-file file ok-flag)) - ((or (file-symlink-p file) (file-directory-p file)) - nil) - (t - (if (assoc file dired-uu-files-to-decode) - (let ((default-directory (file-name-directory file))) - (if (dired-check-process - (concat "Uudecoding " file) shell-file-name "-c" - (format "uudecode %s" file)) - (signal 'file-error (list "Error uudecoding" file)))) - (let ((nfile (concat file ".uu"))) - (if (dired-check-process - (concat "Uuencoding " file) shell-file-name "-c" - (format "uuencode %s %s > %s" - file (file-name-nondirectory file) nfile)) - (signal 'file-error (list "Error uuencoding" file))))))))) - -(defun dired-uucode-out-file (file) - ;; Returns the name of the output file for the uuencoded FILE. - (let ((buff (get-buffer-create " *dired-check-process output*")) - (case-fold-search t)) - (save-excursion - (set-buffer buff) - (erase-buffer) - (if (string-equal "18." (substring emacs-version 0 3)) - (call-process "head" file buff nil "-n" "1") - (insert-file-contents file nil 0 80)) - (goto-char (point-min)) - (if (looking-at "begin [0-9]+ \\([^\n]*\\)\n") - (expand-file-name - (buffer-substring (match-beginning 1) (match-end 1)) - (file-name-directory file)) - nil)))) - -(defun dired-do-uucode (&optional arg files to-decode) - "Uuencode or uudecode marked (or next ARG) files." - (interactive - (let* ((dir (dired-current-directory)) - (files (dired-get-marked-files nil current-prefix-arg)) - (arg (prefix-numeric-value current-prefix-arg)) - (total (length files)) - rfiles decoders ofile decode encode hint-p) - (mapcar - (function - (lambda (fn) - (if (setq ofile (dired-uucode-out-file fn)) - (setq decoders (cons (cons fn ofile) decoders))))) - files) - (setq decode (length decoders) - encode (- total decode) - hint-p (not (or (zerop decode) (zerop encode)))) - (setq rfiles - (mapcar - (function - (lambda (fn) - (if hint-p - (concat - (if (assoc fn decoders) " [de] " " [en] ") - (dired-make-relative fn dir t)) - (dired-make-relative fn dir t)))) - files)) - (or (memq 'uuencode dired-no-confirm) - (dired-mark-pop-up nil 'uuencode rfiles 'y-or-n-p - (cond - ((null decoders) - (if (= encode 1) - (format "Uuencode %s? " (car rfiles)) - (format "Uuencode %d file%s? " - encode (dired-plural-s encode)))) - ((zerop encode) - (if (= decode 1) - (format "Uudecode %s? " (car rfiles)) - (format "Uudecode %d file%s? " - decode (dired-plural-s decode)))) - (t - (format "Uudecode %d and uuencode %d file%s? " - decode encode (dired-plural-s encode))))) - (setq arg 0)) - (list arg files decoders))) - (let ((dired-uu-files-to-decode to-decode) - out-file) - (if (not (zerop arg)) - (dired-create-files - 'dired-uucode-file - "Uuencode or Uudecode" - files - (function - (lambda (fn) - (if (setq out-file (assoc fn dired-uu-files-to-decode)) - (cdr out-file) - (concat fn ".uu")))) - dired-keep-marker-uucode nil t)))) - -;;; end of dired-uu.el
--- a/lisp/efs/dired-vir.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-vir.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Virtual dired mode for browsing ls -lR listings. -;; Author: Sebastian Kremer <sk@thp.uni-koeln.de> -;; Created: 7-Mar-1991 16:00 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-vir) -(require 'dired) - -(defun dired-virtual (dirname &optional switches) - "Put this buffer into Virtual Dired mode. - -In Virtual Dired mode, all commands that do not actually consult the -filesystem will work. - -This is useful if you want to peruse and move around in an ls -lR -output file, for example one you got from an ftp server. With -efs, you can even dired a directory containing an ls-lR file, -visit that file and turn on virtual dired mode. But don't try to save -this file, as dired-virtual indents the listing and thus changes the -buffer. - -If you have save a Dired buffer in a file you can use \\[dired-virtual] to -resume it in a later session. - -Type \\<dired-mode-map>\\[revert-buffer] in the -Virtual Dired buffer and answer `y' to convert the virtual to a real -dired buffer again. You don't have to do this, though: you can relist -single subdirs using \\[dired-do-redisplay]. -" - - ;; DIRNAME is the top level directory of the buffer. It will become - ;; its `default-directory'. If nil, the old value of - ;; default-directory is used. - - ;; Optional SWITCHES are the ls switches to use. - - ;; Shell wildcards will be used if there already is a `wildcard' - ;; line in the buffer (thus it is a saved Dired buffer), but there - ;; is no other way to get wildcards. Insert a `wildcard' line by - ;; hand if you want them. - - (interactive - (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) - (goto-char (point-min)) - (or (looking-at " ") - ;; if not already indented, do it now: - (indent-region (point-min) (point-max) 2)) - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name (file-name-as-directory dirname))) - (setq default-directory dirname) ; contains no wildcards - (let ((wildcard (save-excursion - (goto-char (point-min)) - (forward-line 1) - (and (looking-at "^ wildcard ") - (buffer-substring (match-end 0) - (progn (end-of-line) (point))))))) - (if wildcard - (setq dirname (expand-file-name wildcard default-directory)))) - ;; If raw ls listing (not a saved old dired buffer), give it a - ;; decent subdir headerline: - (goto-char (point-min)) - (or (looking-at dired-subdir-regexp) - (dired-insert-headerline default-directory)) - (dired-mode dirname (or switches dired-listing-switches)) - (setq mode-name "Virtual Dired" - revert-buffer-function 'dired-virtual-revert) - (set (make-local-variable 'dired-subdir-alist) nil) - (dired-build-subdir-alist) - (goto-char (point-min)) - (dired-insert-set-properties (point-min) (point-max)) - (dired-initial-position dirname)) - -(defun dired-virtual-guess-dir () - - ;; Guess and return appropriate working directory of this buffer, - ;; assumed to be in Dired or ls -lR format. - ;; The guess is based upon buffer contents. - ;; If nothing could be guessed, returns nil. - - (let ((regexp "^\\( \\)?\\([^ \n\r]*\\)\\(:\\)[\n\r]") - (subexpr 2)) - (goto-char (point-min)) - (cond ((looking-at regexp) - ;; If a saved dired buffer, look to which dir and - ;; perhaps wildcard it belongs: - (let ((dir (buffer-substring (match-beginning subexpr) - (match-end subexpr)))) - (file-name-as-directory dir))) - ;; Else no match for headerline found. It's a raw ls listing. - ;; In raw ls listings the directory does not have a headerline - ;; try parent of first subdir, if any - ((re-search-forward regexp nil t) - (file-name-directory - (directory-file-name - (file-name-as-directory - (buffer-substring (match-beginning subexpr) - (match-end subexpr)))))) - (t ; if all else fails - nil)))) - - -(defun dired-virtual-revert (&optional arg noconfirm) - (if (not - (y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? ")) - (error "Cannot revert a Virtual Dired buffer.") - (setq mode-name "Dired" - revert-buffer-function 'dired-revert) - (revert-buffer))) - -;; A zero-arg version of dired-virtual. -;; You need my modified version of set-auto-mode for the -;; `buffer-contents-mode-alist'. -;; Or you use infer-mode.el and infer-mode-alist, same syntax. -(defun dired-virtual-mode () - "Put current buffer into virtual dired mode (see `dired-virtual'). -Useful on `buffer-contents-mode-alist' (which see) with the regexp - - \"^ \\(/[^ /]+\\)/?+:$\" - -to put saved dired buffers automatically into virtual dired mode. - -Also useful for `auto-mode-alist' (which see) like this: - - \(setq auto-mode-alist (cons '(\"[^/]\\.dired$\" . dired-virtual-mode) - auto-mode-alist)\) -" - (interactive) - (dired-virtual (dired-virtual-guess-dir))) - -;;; end of dired-vir.el
--- a/lisp/efs/dired-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,752 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-xemacs.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: dired functions for XEmacs -;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de> -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'dired-xemacs) -(require 'dired) -(require 'dired-faces) - -(require 'backquote) - - -;;; Variables not meant for user editing - -;; kludge -(defun dired-demarkify-regexp (re) - (if (string-equal (substring re 0 (length dired-re-maybe-mark)) - dired-re-maybe-mark) - (concat "^" (substring re - (length dired-re-maybe-mark) - (length re))) - re)) - -(defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir)) -(defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym)) -(defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe)) - -(defvar dired-re-raw-boring (dired-omit-regexp) - "Regexp to match backup, autosave and otherwise boring files.") - -(defvar dired-re-raw-socket (concat "^" dired-re-inode-size "s")) - -(defvar dired-re-raw-setuid - (concat "^" dired-re-inode-size - "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") - "setuid plain file (even if not executable)") - -(defvar dired-re-raw-setgid - (concat "^" dired-re-inode-size - "-[-r][-w][-x][-r][-w][sS][-r][-w][xst]") - "setgid plain file (even if not executable)") - -(defvar dired-re-pre-permissions "^[^-d]? ?[0-9 ]*[-d]" - "Regexp matching the preamble to file permissions part of a dired line. -This shouldn't match socket or symbolic link lines (which aren't editable).") - -(defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-Ssx][-r][-w][-xstT]" - "Regexp matching the file permissions part of a dired line.") - -;;; Setup - -(setq dired-modeline-tracking-cmds '(mouse-track)) - - -;;; Menus - -(defvar dired-subdir-menu nil "The Subdir menu for dired") -(defvar dired-mark-menu nil "The Mark menu for dired") -(defvar dired-do-menu nil "The Do menu for dired") -(defvar dired-regexp-menu nil "The Regexp menu for dired") -(defvar dired-look-menu nil "The Look menu for dired") -(defvar dired-sort-menu nil "The Sort menu for dired") -(defvar dired-help-menu nil "The Help menu for dired") - -(defvar dired-menubar-menus - '(("Subdir" . dired-subdir-menu) - ("Mark" . dired-mark-menu) - ("Do" . dired-do-menu) - ("Regexp" . dired-regexp-menu) - ("Look" . dired-look-menu) - ("Sort" . dired-sort-menu)) - "All the dired menus.") - -(defvar dired-visit-popup-menu nil "The Visit popup for dired") -(defvar dired-do-popup-menu nil "The Do popup for dired") - -(defun dired-setup-menus () - (setq - dired-visit-popup-menu - '(["Find File" dired-find-file t] - ["Find in Other Window" dired-find-file-other-window t] - ["Find in Other Frame" dired-find-file-other-frame t] - ["View File" dired-view-file t] - ["Display in Other Window" dired-display-file t])) - - (setq - dired-do-popup-menu - '(["Copy to..." dired-do-copy t] - ["Rename to..." dired-do-rename t] - ["Compress/Uncompress" dired-do-compress t] - ["Uuencode/Uudecode" dired-do-uucode t] - ["Change Mode..." dired-do-chmod t] - ["Change Owner..." dired-do-chown t] - ["Change Group..." dired-do-chgrp t] - ["Load" dired-do-load t] - ["Byte-compile" dired-do-byte-compile t] - ["Hardlink to..." dired-do-hardlink t] - ["Symlink to..." dired-do-symlink t] - ["Shell Command..." dired-do-shell-command t] - ["Background Shell Command..." dired-do-background-shell-command t] - ["Delete" dired-do-delete t])) - - (setq - dired-subdir-menu - (list - ["Next Subdir" dired-next-subdir t] - ["Prev Subdir" dired-prev-subdir t] - ["Next Dirline" dired-next-dirline t] - ["Prev Dirline" dired-prev-dirline t] - ["Up Dir" dired-up-directory t] - ["Down Dir" dired-down-directory t] - ["Insert This Subdir" dired-maybe-insert-subdir t] - ["Create Directory..." dired-create-directory t] - ["Kill This Subdir" dired-kill-subdir t] - "-- Commands on All Files in Subdir --" - ["Redisplay Subdir" dired-redisplay-subdir t] - ["Mark Files" dired-mark-subdir-files t] - ["Flag Files for Deletion" dired-flag-subdir-files t] - ["Compress Uncompressed Files" dired-compress-subdir-files t] - (vector "Uncompress Compressed Files" - '(let ((current-prefix-arg t)) - (dired-compress-subdir-files)) - ':keys (dired-key-description 'dired-compress-subdir-files - 'universal-argument)))) - - (setq - dired-mark-menu - (list - ["Next Marked" dired-next-marked-file t] - ["Previous Marked" dired-prev-marked-file t] - ["Change Marks..." dired-change-marks t] - ["Unmark All" dired-unmark-all-files t] - (vector "Toggle marks..." - '(let ((current-prefix-arg t)) - (call-interactively 'dired-change-marks)) - ':keys (dired-key-description 'dired-change-marks - 'universal-argument)) - ["Mark Symlinks" dired-mark-symlinks t] - ["Mark Directories" dired-mark-directories t] - ["Mark Old Backups" dired-clean-directory t] - ["Mark Executables" dired-mark-executables t] - ["Flag Backup Files" dired-flag-backup-files t] - ["Flag Auto-save Files" dired-flag-auto-save-files t] - ["Set new marker char" dired-set-marker-char t] - ["Restore marker char" dired-restore-marker-char t] - ["Marker stack left" dired-marker-stack-left t] - ["Marker stack right" dired-marker-stack-right t] - "---" - ["Mark Files from Other Dired" dired-mark-files-from-other-dired-buffer t] - ["Mark Files from Compile Buffer..." dired-mark-files-compilation-buffer t])) - - (setq - dired-do-menu - '(["Copy to..." dired-do-copy t] - ["Rename to..." dired-do-rename t] - ["Expunge File Flagged for Deletion" dired-expunge-deletions t] - ["Compress/Uncompress" dired-do-compress t] - ["Uuencode/Uudecode" dired-do-uucode t] - ["Print..." dired-do-print t] - ["Change Mode..." dired-do-interactive-chmod t] - ["Change Owner..." dired-do-chown t] - ["Change Group..." dired-do-chgrp t] - ["Byte-compile" dired-do-byte-compile t] - ["Hardlink to..." dired-do-hardlink t] - ["Symlink to..." dired-do-symlink t] - ["Shell Command..." dired-do-shell-command t] - ["Background Shell Command..." dired-do-background-shell-command t] - ["Delete Marked Files" dired-do-delete t] - ["Visit file menu >" dired-visit-popup-menu-internal t] - ["Operate on file menu >" dired-do-popup-menu-internal t])) - - (setq - dired-regexp-menu - (list - ["Mark..." dired-mark-files-regexp t] - ["Mark Files with Extension..." dired-mark-extension t] - ["Flag..." dired-flag-files-regexp t] - ["Flag Files with Extension..." dired-flag-extension t] - ["Downcase" dired-downcase t] - ["Upcase" dired-upcase t] - ["Copy..." dired-do-copy-regexp t] - ["Rename..." dired-do-rename-regexp t] - ["Hardlink..." dired-do-hardlink-regexp t] - ["Symlink..." dired-do-symlink-regexp t] - ["Relative Symlink..." dired-do-relsymlink-regexp t] - "---" - ["Add Omit Regex..." dired-add-omit-regexp t] - (vector "Remove Omit Regex..." - '(let ((current-prefix-arg 1)) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp 1)) - (vector "Add Omit Extension..." - '(let ((current-prefix-arg '(4))) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument)) - (vector "Remove Omit Extension..." - '(let ((current-prefix-arg '(16))) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp - 'universal-argument 'universal-argument)) - (vector "Show Omit Regex" - '(let ((current-prefix-arg 0)) - (call-interactively 'dired-add-omit-regexp)) - ':keys (dired-key-description 'dired-add-omit-regexp 0)))) - - (setq - dired-look-menu - '(["Grep for..." dired-do-grep t] - ["Tags Search for..." dired-do-tags-search t] - ["Tags Query Replace..." dired-do-tags-query-replace t] - "---" - ["Diff File..." dired-diff t] - ["Diff with Backup" dired-backup-diff t] - ["Merge Files..." dired-emerge t] - ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t] - ["Ediff Files..." dired-ediff t] - ["Patch File" dired-epatch t])) - - (setq - dired-sort-menu - (list - ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t] - (vector "Show Current Switches" - '(dired-sort-toggle-or-edit 0) - ':keys (dired-key-description 'dired-sort-toggle-or-edit 0)) - (vector "Edit Switches for Current Subdir..." - '(dired-sort-toggle-or-edit 1) - ':keys (dired-key-description 'dired-sort-toggle-or-edit 1)) - (vector "Edit Default Switches for Inserted Subdirs..." - '(dired-sort-toggle-or-edit 2) - ':keys (dired-key-description 'dired-sort-toggle-or-edit 2)) - (vector "Sort Entire Buffer by Date" - '(dired-sort-toggle-or-edit 'date) - ':keys (dired-key-description 'dired-sort-toggle-or-edit - 'universal-argument)) - (vector "Sort Entire Buffer by Name" - '(dired-sort-toggle-or-edit 'name) - ':keys (dired-key-description 'dired-sort-toggle-or-edit - 'universal-argument)) - (vector "Edit Switches for Entire Buffer..." - '(dired-sort-toggle-or-edit '(16)) - ':keys (dired-key-description 'dired-sort-toggle-or-edit - 'universal-argument)) - "---" - ["Hide All Subdirs" dired-hide-all t] - ["Hide Subdir" dired-hide-subdir t] - ["Toggle Omit" dired-omit-toggle t] - ["Kill Marked Lines" dired-do-kill-file-lines t] - (vector "Redisplay Killed Lines" - '(dired-do-kill-file-lines 0) - ':keys (dired-key-description 'dired-do-kill-file-lines "0")))) - (setq - dired-help-menu - (list - ["Dired Summary Help" dired-summary t] - ["Describe Dired" dired-describe-mode t] - (vector "Dired Info Manual" - '(dired-describe-mode t) - ':keys (dired-key-description 'dired-describe-mode - 'universal-argument)) - ["Dired Command Apropos" dired-apropos t] - (vector "Dired Variable Apropos" - '(let ((current-prefix-arg t)) - (call-interactively 'dired-apropos)) - ':keys (dired-key-description 'dired-apropos 'universal-argument)) - ["Report Dired Bug" dired-report-bug t]))) - -(defun dired-install-menubar () - "Installs the Dired menu at the menubar." - (if (null dired-help-menu) - (dired-setup-menus)) - (if (and (featurep 'menubar) current-menubar) - (progn - (let ((buffer-menubar (copy-sequence current-menubar))) - (delete (assoc "Edit" buffer-menubar) buffer-menubar) - (set-buffer-menubar buffer-menubar) - (mapcar - (function - (lambda (pair) - (let ((name (car pair)) - (menu (symbol-value (cdr pair)))) - (add-submenu nil (cons name menu))))) - dired-menubar-menus)) - (add-menu-button '("Help") (list "---")) - (add-submenu '("Help") (cons "Dired" dired-help-menu))))) - -(add-hook 'dired-mode-hook 'dired-install-menubar) - -;;; Mouse functions - -(defun dired-mouse-file-action (event fun) - "In dired, apply function FUN to the file or directory name you click on." - (save-excursion - (set-buffer (window-buffer (event-window event))) - (if dired-subdir-alist - (save-excursion - (goto-char (event-point event)) - (funcall fun)) - (error - (concat "dired-subdir-alist seems to be mangled. " - (substitute-command-keys - "\\<dired-mode-map>Try dired-revert (\\[dired-revert]).")))))) - -(defun dired-mouse-find-file (event) - "In dired, visit the file or directory name you click on." - (interactive "e") - (dired-mouse-file-action event 'dired-find-file)) - -(defun dired-mouse-display-file (event) - "In dired, display the file or directory name you click on." - (interactive "e") - (dired-mouse-file-action event 'dired-display-file)) - -(defun dired-mouse-find-file-other-window (event) - "In dired, visit the file or directory name you click on in another window." - (interactive "e") - (dired-mouse-file-action event 'dired-find-file-other-window)) - -(defun dired-mouse-find-file-other-frame (event) - "In dired, visit the file or directory name you click on in another frame." - (interactive "e") - (dired-mouse-file-action event 'dired-find-file-other-frame)) - -(defun dired-mouse-mark (event) - "In dired, mark the file name that you click on. -If the file name is already marked, this unmarks it." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (if dired-subdir-alist - (save-excursion - (goto-char (event-point event)) - (beginning-of-line) - (if (looking-at dired-re-mark) - (dired-unmark 1) - (dired-mark 1))) - (error - (concat "dired-subdir-alist seems to be mangled. " - (substitute-command-keys - "\\<dired-mode-map>Try dired-revert (\\[dired-revert]).")))))) - -(defun dired-mouse-flag (event) - "In dired, flag for deletion the file name that you click on. -If the file name is already flag, this unflags it." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (if dired-subdir-alist - (save-excursion - (goto-char (event-point event)) - (beginning-of-line) - (if (char-equal (following-char) dired-del-marker) - (dired-unflag 1) - (dired-flag-file-deletion 1))) - (error - (concat "dired-subdir-alist seems to be mangled. " - (substitute-command-keys - "\\<dired-mode-map>Try dired-revert (\\[dired-revert]).")))))) - -(defun dired-mouse-get-target (event) - "In dired, put a copy of the selected directory in the active minibuffer." - (interactive "e") - (let ((obuff (current-buffer)) - mb) - (set-buffer (window-buffer (event-window event))) - (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window))) - (let (dir) - (goto-char (event-point event)) - (setq dir (dired-current-directory)) - (select-window mb) - (set-buffer (window-buffer mb)) - (erase-buffer) - (insert dir)) - (set-buffer obuff) - (if mb - (error "No directory specified") - (error "No active minibuffer"))))) - -(defun dired-visit-popup-menu (event) - "Popup a menu to visit the moused file." - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (save-excursion - (goto-char (event-point event)) - (dired-visit-popup-menu-internal event)))) - -(defun dired-visit-popup-menu-internal (event) - (interactive "e") - (let ((fn (dired-get-filename 'no-dir))) - (popup-menu - (cons (concat "Visit " fn " with") dired-visit-popup-menu)) - ;; this looks like a kludge to me ... - (while (popup-up-p) - (dispatch-event (next-event))))) - -(defun dired-do-popup-menu (event) - "Pop up a menu to do an operation on the moused file." - (interactive "e") - (let ((obuff (current-buffer))) - (unwind-protect - (progn - (set-buffer (window-buffer (event-window event))) - (dired-save-excursion - (goto-char (event-point event)) - (dired-do-popup-menu-internal event))) - (set-buffer obuff)))) - -(defun dired-do-popup-menu-internal (event) - (interactive "e") - (let ((fn (dired-get-filename 'no-dir)) - (current-prefix-arg 1)) - (popup-menu - (cons (concat "Do operation on " fn) dired-do-popup-menu)) - (while (popup-up-p) - (dispatch-event (next-event))))) - -(defvar dired-filename-local-map - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'dired-filename-local-map) - (define-key map [button2] 'dired-mouse-find-file) - (define-key map [(shift button2)] 'dired-mouse-display-file) - (define-key map [(meta button2)] 'dired-mouse-find-file-other-frame) - (define-key map [button3] 'dired-visit-popup-menu) - (define-key map [(control button2)] 'dired-do-popup-menu) - (define-key map [(shift button1)] 'dired-mouse-mark) - (define-key map [(control shift button1)] 'dired-mouse-flag) - map) - "Keymap used to activate actions on files in dired.") - -;; Make this defined everywhere in the dired buffer. -(define-key dired-mode-map '(meta button3) 'dired-mouse-get-target) - -;;; Extent managment - -(defun dired-set-text-properties (start end &optional face) - (let ((filename-extent (make-extent start end))) - (set-extent-face filename-extent (or face 'default)) - (set-extent-property filename-extent 'dired-file-name t) - (set-extent-property filename-extent 'start-open t) - (set-extent-property filename-extent 'end-open t) - (set-extent-property filename-extent 'keymap dired-filename-local-map) - (set-extent-property filename-extent 'highlight t) - (set-extent-property - filename-extent 'help-echo - (concat - "button2 finds, button3 visits, " - "C-button2 file ops, [C-]shift-button1 marks/flags.")) - filename-extent)) - -(defun dired-insert-set-properties (beg end) - ;; Sets the extents for the file names and their properties - (save-excursion - (goto-char beg) - (beginning-of-line) - (let ((eol (save-excursion (end-of-line) (point))) - (bol (point)) - start) - (while (< (point) end) - (setq eol (save-excursion (end-of-line) (point))) - - (if dired-do-interactive-permissions - (dired-make-permissions-interactive (point))) - - (if (dired-manual-move-to-filename nil bol eol) - (progn - (setq start (point)) - (dired-manual-move-to-end-of-filename nil bol eol) - (dired-set-text-properties - start - (point) - (save-excursion - (beginning-of-line) - (cond - ((null dired-do-highlighting) nil) - ((looking-at dired-re-raw-dir) 'dired-face-directory) - ((looking-at dired-re-raw-sym) 'dired-face-symlink) - ((or (looking-at dired-re-raw-setuid) - (looking-at dired-re-raw-setgid)) 'dired-face-setuid) - ((looking-at dired-re-raw-exe) 'dired-face-executable) - ((looking-at dired-re-raw-socket) 'dired-face-socket) - ((save-excursion - (goto-char start) - (re-search-forward dired-re-raw-boring eol t)) - 'dired-face-boring)))))) - - (setq bol (1+ eol)) - (goto-char bol))))) - -(defun dired-remove-text-properties (start end) - ;; Removes text properties. Called in popup buffers. - (map-extents - (function - (lambda (extent maparg) - (if (extent-property extent 'dired-file-name) - (delete-extent extent)) - nil)) - nil start end)) - -(defun dired-highlight-filename-mark (extent) - (let ((mark - (save-excursion - (skip-chars-backward "^\n\r") - (following-char))) - (face (extent-face extent))) - (if (char-equal mark ?\ ) - (if (consp face) - (set-extent-face extent (cadr face))) - (let ((new-face - (cond - ((char-equal dired-default-marker mark) - 'dired-face-marked) - ((char-equal dired-del-marker mark) - 'dired-face-flagged) - (t 'default)))) - (set-extent-face - extent - (if (consp face) - (list new-face (cadr face)) - (list new-face face))))))) - -(defun dired-move-to-filename (&optional raise-error bol eol) - (or bol (setq bol (save-excursion - (skip-chars-backward "^\n\r") - (point)))) - (or eol (setq eol (save-excursion - (skip-chars-forward "^\n\r") - (point)))) - (goto-char bol) - (let ((extent - (map-extents - (function - (lambda (extent maparg) - (if (extent-property extent 'dired-file-name) - extent - nil))) - nil bol eol))) - (if extent - (progn - (if dired-do-highlighting - (dired-highlight-filename-mark extent)) - (goto-char (extent-start-position extent))) - (if raise-error - (error "No file on this line") - nil)))) - - -(defun dired-move-to-end-of-filename (&optional no-error bol eol) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* - ;; line if at all. So, it should be called only after - ;; (dired-move-to-filename t). - ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (and - (null no-error) - selective-display - (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) - (eq (char-after (1- bol)) ?\r) - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (let ((filename-extent (map-extents - (function - (lambda (e p) (and (extent-property e p) e))) - (current-buffer) bol eol 'dired-file-name))) - (if filename-extent - (goto-char (extent-end-position filename-extent)) - (and (null no-error) (error "No file on this line"))))) - -;;; Interactive chmod -;;; (based on ideas from Russell Ritchie's dired-chmod.el) - -(defun dired-do-interactive-chmod (new-attribute) - (let* ((file (dired-get-filename)) - (operation (concat "chmod " new-attribute " " file)) - (failure (apply (function dired-check-process) - operation - "chmod" new-attribute (list file)))) - (dired-do-redisplay) - (if failure - (dired-log-summary (buffer-name (current-buffer)) - (format "%s: error" operation) nil) - (forward-char 1)))) - -(defun dired-chmod-popup-menu (event menu) - (save-excursion - (set-buffer (window-buffer (event-window event))) - (save-excursion - (goto-char (event-point event)) - (popup-menu menu) - ;; this looks like a kludge to me ... - (while (popup-up-p) - (dispatch-event (next-event)))))) - -;; This is probably overdoing it. -;; Someone give me lexical scoping here ... - -(defun dired-setup-chmod-keymap (domain id keys &optional toggle-keys) - (let* ((names - (mapcar - (function - (lambda (key) - (let ((name (intern (concat "dired-" - (list domain ?- key))))) - (eval - `(defun ,name () - (interactive) - (dired-do-interactive-chmod ,(concat (list domain ?+ key))))) - name))) - keys)) - (prefix (concat "dired-" (list domain) "-" (list id))) - (remove-name (intern (concat prefix "-remove"))) - (toggle-name (intern (concat prefix "-toggle"))) - (mouse-toggle-name (intern (concat prefix "-mouse-toggle"))) - (mouse-menu-name (intern (concat prefix "-menu")))) - - (eval - `(defun ,remove-name () - (interactive) - (cond ,@(mapcar (function - (lambda (key) - `((looking-at ,(regexp-quote (char-to-string key))) - (dired-do-interactive-chmod - ,(concat (list domain ?- key)))))) - keys)))) - - (eval - `(defun ,toggle-name () - (interactive) - (cond ((looking-at "-") (dired-do-interactive-chmod - ,(concat (list domain ?+ (car keys))))) - ,@(let ((l (or toggle-keys keys)) - (c '())) - (while l - (setq c - (cons - `((looking-at (regexp-quote (char-to-string ,(car l)))) - (dired-do-interactive-chmod - ,(if (null (cdr l)) - (concat (list domain ?- (car l))) - (concat (list domain ?+ (cadr l)))))) - c)) - (setq l (cdr l))) - (reverse c)) - (t (dired-do-interactive-chmod - ,(concat (list domain ?+ (car keys)))))))) - - (eval - `(defun ,mouse-toggle-name (event) - (interactive "e") - (save-excursion - (set-buffer (window-buffer (event-window event))) - (save-excursion - (goto-char (event-point event)) - (,toggle-name))))) - - (let ((menu '()) - (loop-keys keys) - (loop-names names)) - (while loop-keys - (setq menu - (cons (vector (concat (list ?+ (car loop-keys))) - (car loop-names) - t) - menu)) - (setq loop-keys (cdr loop-keys) - loop-names (cdr loop-names))) - (setq menu (append menu (list (vector "Toggle" toggle-name t) - (vector "Clear" remove-name t)))) - (setq menu (cons (char-to-string domain) menu)) - - (eval - `(defun ,mouse-menu-name (event) - (interactive "e") - (dired-chmod-popup-menu event ',menu)))) - - (let ((keymap (make-sparse-keymap))) - (let ((loop-keys (cons ?. (cons ?- keys))) - (loop-names (cons toggle-name (cons remove-name names)))) - (while loop-keys - (define-key keymap (car loop-keys) (car loop-names)) - (setq loop-keys (cdr loop-keys) - loop-names (cdr loop-names)))) - - (define-key keymap 'button2 mouse-toggle-name) - (define-key keymap 'button3 mouse-menu-name) - keymap))) - -(defvar dired-u-r-keymap nil "internal keymap for dired") -(defvar dired-u-w-keymap nil "internal keymap for dired") -(defvar dired-u-x-keymap nil "internal keymap for dired") -(defvar dired-g-r-keymap nil "internal keymap for dired") -(defvar dired-g-w-keymap nil "internal keymap for dired") -(defvar dired-g-x-keymap nil "internal keymap for dired") -(defvar dired-o-r-keymap nil "internal keymap for dired") -(defvar dired-o-w-keymap nil "internal keymap for dired") -(defvar dired-o-x-keymap nil "internal keymap for dired") - - -(defun dired-setup-chmod-keymaps () - (setq - dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r)) - dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w)) - dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?x ?s) '(?x)) - dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r)) - dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w)) - dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?x ?s) '(?x)) - dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r)) - dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w)) - dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?x ?s ?t) '(?x)))) - -(defun dired-make-permissions-interactive (beg) - (save-excursion - (goto-char beg) - (buffer-substring (point) (save-excursion (end-of-line) (point))) - (if (and (re-search-forward dired-re-pre-permissions - (save-excursion (end-of-line) (point)) - t) - (looking-at dired-re-permissions)) - (let ((p (point))) - (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap) - (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap) - (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap) - (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap) - (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap) - (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap) - (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap) - (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap) - (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap))))) - -(defun dired-activate-permissions (extent keymap) - (set-extent-face extent 'dired-face-permissions) - (set-extent-property extent 'keymap keymap) - (set-extent-property extent 'highlight t) - (set-extent-property - extent 'help-echo - "button2 toggles, button3 changes otherwise.")) - -(dired-setup-chmod-keymaps) - -;;; end of dired-xemacs.el
--- a/lisp/efs/dired-xy.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired-xy.el -;; Dired Version: #Revision: 7.9 $ -;; RCS: -;; Description: Commands for reading mail from dired. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Requirements and provisions -(provide 'dired-xy) -(require 'dired) - -;;; Special request: Will an mh-e user please write some mh support in here? - -(defun dired-read-mail (&optional arg) - "Reads the current file as a mail folder. -Uses the setting of `dired-mail-reader' to determine which reader to use. -Possibilities are VM or RMAIL. With a prefix arg, visits the folder read-only\; -this only works with VM." - (interactive "P") - (cond - ((eq dired-mail-reader 'vm) - (dired-vm arg)) - ((eq dired-mail-reader 'rmail) - (dired-rmail)) ; doesn't take read-only arg. - (t (error "Never heard of the mail reader %s" dired-mail-reader)))) - -;; Read-only folders only work in VM 5, not in VM 4. -(defun dired-vm (&optional read-only) - "Run VM on this file. -With prefix arg, visit folder read-only (this requires at least VM 5). -See also variable `dired-vm-read-only-folders'." - (interactive "P") - (let ((dir (dired-current-directory)) - (fil (dired-get-filename))) - ;; take care to supply 2nd arg only if requested - may still run VM 4! - (require 'vm) ; vm-visit-folder may not be an autoload - (setq this-command 'vm-visit-folder) ; for vm window config - (if read-only - (vm-visit-folder fil t) - (vm-visit-folder fil)) - ;; so that pressing `v' inside VM does prompt within current directory: - (set (make-local-variable 'vm-folder-directory) dir))) - -(defun dired-rmail () - "Run RMAIL on this file." - (interactive) - (rmail (dired-get-filename))) - -;; end of dired-xy.el -
--- a/lisp/efs/dired.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6470 +0,0 @@ - ; -*- Emacs-Lisp -*- -;; DIRED commands for Emacs. -;; Copyright (C) 1985, 1986, 1991 Free Software Foundation, Inc. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: dired.el -;; RCS: -;; Dired Version: #Revision: 7.9 $ -;; Description: The DIRectory EDitor is for manipulating, and running -;; commands on files in a directory. -;; Authors: FSF, -;; Sebastian Kremer <sk@thp.uni-koeln.de>, -;; Sandy Rutherford <sandy@ibm550.sissa.it> -;; Cast of thousands... -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; This program 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 1, or (at your option) -;; any later version. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; Rewritten in 1990/1991 to add tree features, file marking and -;; sorting by Sebastian Kremer <sk@thp.uni-koeln.de>. -;; 7-1993: Added special features for efs interaction and upgraded to Emacs 19. -;; Sandy Rutherford <sandy@ibm550.sissa.it> - -;;; Dired Version - -(defconst dired-version (substring "#Revision: 7.9 $" 11 -2) - "The revision number of Tree Dired (as a string). - -Don't forget to mention this when reporting bugs to: - - efs-bugs@cuckoo.hpl.hp.com") - -;; Global key bindings: -;; -------------------- -;; -;; By convention, dired uses the following global key-bindings. -;; These may or may not already be set up in your local emacs. If not -;; then you will need to add them to your .emacs file, or the system -;; default.el file. We don't set them automatically here, as users may -;; have individual preferences. -;; -;; (define-key ctl-x-map "d" 'dired) -;; (define-key ctl-x-4-map "d" 'dired-other-window) -;; (define-key ctl-x-map "\C-j" 'dired-jump-back) -;; (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) -;; -;; For V19 emacs only. (Make sure that the ctl-x-5-map exists.) -;; (define-key ctl-x-5-map "d" 'dired-other-frame) -;; (define-key Ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) - - -;;; Grok the current emacs version -;; -;; Hopefully these two variables provide us with enough version sensitivity. - -;; Make sure that we have a frame-width function -(or (fboundp 'frame-width) (fset 'frame-width 'screen-width)) - -;;; Requirements and provisions - -(provide 'dired) -(require 'backquote) ; For macros. - -;; Compatibility requirements for the file-name-handler-alist. -;; Testing against the string `Lucid' breaks InfoDock. How many years has -;; it been since Lucid went away? -(let ((lucid-p (string-match "XEmacs" emacs-version)) - ver subver) - (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) - (error "dired does not work with emacs version %s" emacs-version)) - (setq ver (string-to-int (substring emacs-version (match-beginning 1) - (match-end 1))) - subver (string-to-int (substring emacs-version (match-beginning 2) - (match-end 2)))) - (cond - ((= ver 18) - (require 'emacs-19) - (require 'fn-handler)) - ((and (= ver 19) (if lucid-p (< subver 10) (< subver 23))) - (require 'fn-handler)) - ((< ver 18) - (error "dired does not work with emacs version %s" emacs-version)))) - -;; We duplicate default-dir stuff to avoid its overwrites unless -;; they are explicitly requested. - -(defvar default-directory-function nil - "A function to call to compute the default-directory for the current buffer. -If this is nil, the function default-directory will return the value of the -variable default-directory. -Buffer local.") -(make-variable-buffer-local 'default-directory-function) - -;;;###autoload -(defun default-directory () - " Returns the default-directory for the current buffer. -Will use the variable default-directory-function if it non-nil." - (if default-directory-function - (funcall default-directory-function) - (if (string-match "XEmacs" emacs-version) - (abbreviate-file-name default-directory t) - (abbreviate-file-name default-directory)))) - -;;;;---------------------------------------------------------------- -;;;; Customizable variables -;;;;---------------------------------------------------------------- -;; -;; The funny comments are for autoload.el, to automagically update -;; loaddefs. - -;;; Variables for compressing files. - -;;;###autoload -(defvar dired-compression-method 'compress - "*Type of compression program to use. -Give as a symbol. -Currently-recognized methods are: gzip pack compact compress. -To change this variable use \\[dired-do-compress] with a zero prefix.") - -;;;###autoload -(defvar dired-compression-method-alist - '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") - ;; Put compress before pack, so that it wins out if we are using - ;; efs to work on a case insensitive OS. The -f flag does - ;; two things in compress. No harm in giving it twice. - (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") - ;; pack support may not work well. pack is too chatty and there is no way - ;; to force overwrites. - (pack ".z" ("pack" "-f") ("unpack")) - (compact ".C" ("compact") ("uncompact"))) - - "*Association list of compression method descriptions. - Each element of the table should be a list of the form - - \(compress-type extension (compress-args) (decompress-args) force-flag\) - - where - `compress-type' is a unique symbol in the alist to which - `dired-compression-method' can be set; - `extension' is the file extension (as a string) used by files compressed - by this method; - `compress-args' is a list of the path of the compression program and - flags to pass as separate arguments; - `decompress-args' is a list of the path of the decompression - program and flags to pass as separate arguments. - `force-flag' is the switch to pass to the command to force overwriting - of existing files. - - For example: - - \(setq dired-compression-method-alist - \(cons '\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\) \"-f\"\) - dired-compression-method-alist\)\) - => \(\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\)\) - \(gzip \".gz\" \(\"gzip\"\) \(\"gunzip\"\)\) - ...\) - - See also: dired-compression-method <V>") - -;;; Variables for the ls program. - -;;;###autoload -(defvar dired-ls-program "ls" - "*Absolute or relative name of the ls program used by dired.") - -;;;###autoload -(defvar dired-listing-switches "-al" - "*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -(defvar dired-ls-F-marks-symlinks - (memq system-type '(aix-v3 hpux silicon-graphics-unix)) - ;; Both SunOS and Ultrix have system-type berkeley-unix. But - ;; SunOS doesn't mark symlinks, but Ultrix does. Therefore, - ;; can't grok this case. - "*Informs dired about how ls -lF marks symbolic links. -Set this to t if `dired-ls-program' with -lF marks the name of the symbolic -link itself with a trailing @. - -For example: If foo is a link pointing to bar, and \"ls -F bar\" gives - - ... bar -> foo - -set this variable to nil. If it gives - - ... bar@ -> foo - -set this variable to t. - -Dired checks if there is really a @ appended. Thus, if you have a -marking ls program on one host and a non-marking on another host, and -don't care about symbolic links which really end in a @, you can -always set this variable to t. - -If you use efs, it will make this variable buffer-local, and control -it according to its assessment of how the remote host marks symbolic -links.") - -(defvar dired-show-ls-switches nil - "*If non-nil dired will show the dired ls switches on the modeline. -If nil, it will indicate how the files are sorted by either \"by name\" or -\"by date\". If it is unable to recognize the sorting defined by the switches, -then the switches will be shown explicitly on the modeline, regardless of the -setting of this variable.") - -;;; Variables for other unix utility programs. - -;; For most program names, don't use absolute paths so that dired -;; uses the user's value of the environment variable PATH. chown is -;; an exception as it is not always in the PATH. - -;;;###autoload -(defvar dired-chown-program - (if (memq system-type '(hpux dgux usg-unix-v linux)) "chown" "/etc/chown") - "*Name of chown command (usually `chown' or `/etc/chown').") - -;;;###autoload -(defvar dired-gnutar-program nil - "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") - -;;;###autoload -(defvar dired-unshar-program nil - "*Set to the name of the unshar program, if you have it.") - -;;; Markers - -(defvar dired-keep-marker-rename t - ;; Use t as default so that moved files `take their markers with them' - "*Controls marking of renamed files. -If t, files keep their previous marks when they are renamed. -If a character, renamed files (whether previously marked or not) -are afterward marked with that character.") - -(defvar dired-keep-marker-compress t - "*Controls marking of compressed or uncompressed files. -If t, files keep their previous marks when they are compressed. -If a character, compressed or uncompressed files (whether previously -marked or not) are afterward marked with that character.") - -(defvar dired-keep-marker-uucode ?U - "*Controls marking of uuencoded or uudecoded files. -If t, files keep their previous marks when they are uuencoded. -If a character, uuencoded or uudecoded files (whether previously -marked or not) are afterward marked with that character.") - -(defvar dired-keep-marker-copy ?C - "*Controls marking of copied files. -If t, copied files are marked if and as the corresponding original files were. -If a character, copied files are unconditionally marked with that character.") - -(defvar dired-keep-marker-hardlink ?H - "*Controls marking of newly made hard links. -If t, they are marked if and as the files linked to were marked. -If a character, new links are unconditionally marked with that character.") - -(defvar dired-keep-marker-symlink ?S - "*Controls marking of newly made symbolic links. -If t, they are marked if and as the files linked to were marked. -If a character, new links are unconditionally marked with that character.") - -(defvar dired-keep-marker-kill ?K - "*When killed file lines are redisplayed, they will have this marker. -Setting this to nil means that they will not have any marker.") - -(defvar dired-failed-marker-shell ?! - "*If non-nil, a character with which to mark files of failed shell commands. -Applies to the command `dired-do-shell-command'. Files for which the shell -command has a nonzero exit status will be marked with this character") - -;;; Behavioral Variables - -;;;###autoload -(defvar dired-local-variables-file ".dired" - "*If non-nil, filename for local variables for Dired. -If Dired finds a file with that name in the current directory, it will -temporarily insert it into the dired buffer and run `hack-local-variables'. - -Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on -local variables.") - -;; Usually defined in files.el. Define here anyway, to be safe. -;;;###autoload -(defvar dired-kept-versions 2 - "*When cleaning directory, number of versions to keep.") - -;;;###autoload -(defvar dired-find-subdir nil - "*Determines whether dired tries to lookup a subdir in existing buffers. -If non-nil, dired does not make a new buffer for a directory if it can be -found (perhaps as subdir) in some existing dired buffer. If there are several -dired buffers for a directory, then the most recently used one is chosen. - -Dired avoids switching to the current buffer, so that if you have -a normal and a wildcard buffer for the same directory, C-x d RET will -toggle between those two.") - -;;;###autoload -(defvar dired-use-file-transformers t - "*Determines whether dired uses file transformers. -If non-nil `dired-do-shell-command' will apply file transformers to file names. -See \\[describe-function] for dired-do-shell-command for more information.") - -;;;###autoload -(defvar dired-dwim-target nil - "*If non-nil, dired tries to guess a default target directory. -This means that if there is a dired buffer displayed in the next window, -use its current subdir, instead of the current subdir of this dired buffer. -The target is put in the prompt for file copy, rename, etc.") - -;;;###autoload -(defvar dired-copy-preserve-time nil - "*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\<dired-mode-map> -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -;;;###autoload -(defvar dired-no-confirm nil - "*If non-nil, a list of symbols for commands dired should not confirm. -It can be a sublist of - - '(byte-compile chgrp chmod chown compress copy delete hardlink load - move print shell symlink uncompress recursive-delete kill-file-buffer - kill-dired-buffer patch create-top-dir revert-subdirs) - -The meanings of most of the symbols are obvious. A few exceptions: - - 'compress applies to compression or decompression by any of the - compression program in `dired-compression-method-alist'. - - 'kill-dired-buffer applies to offering to kill dired buffers for - directories which have been deleted. - - 'kill-file-buffer applies to offering to kill buffers visiting files - which have been deleted. - - 'recursive-delete applies to recursively deleting non-empty - directories, and all of their contents. - - 'create-top-dir applies to `dired-up-directory' creating a new top level - directory for the dired buffer. - - 'revert-subdirs applies to re-reading subdirectories which have - been modified on disk. - -Note that this list also applies to remote files accessed with efs -or ange-ftp.") - -;;;###autoload -(defvar dired-backup-if-overwrite nil - "*Non-nil if Dired should ask about making backups before overwriting files. -Special value 'always suppresses confirmation.") - -;;;###autoload -(defvar dired-omit-files nil - "*If non-nil un-interesting files will be omitted from this dired buffer. -Use \\[dired-omit-toggle] to see these files. (buffer local)") -(make-variable-buffer-local 'dired-omit-files) - -;;;###autoload -(defvar dired-mail-reader 'vm - "*Mail reader used by dired for dired-read-mail \(\\[dired-read-mail]\). -The symbols 'rmail and 'vm are the only two allowed values.") - -(defvar dired-verify-modtimes t - "*If non-nil dired will revert dired buffers for modified subdirectories. -See also dired-no-confirm <V>.") - -;;;###autoload -(defvar dired-refresh-automatically t - "*If non-nil, refresh dired buffers automatically after file operations.") - -;;; File name regular expressions and extensions. - -(defvar dired-trivial-filenames "\\`\\.\\.?\\'\\|\\`#" - "*Regexp of files to skip when finding first file of a directory listing. -A value of nil means move to the subdir line. -A value of t means move to first file.") - -(defvar dired-cleanup-alist - (list - '("tex" ".toc" ".log" ".aux" ".dvi") - '("latex" ".toc" ".log" ".aux" ".idx" ".lof" ".lot" ".glo" ".dvi") - '("bibtex" ".blg" ".bbl") - '("texinfo" ".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" - ".tp" ".tps" ".vr" ".vrs") - '("patch" ".rej" ".orig") - '("backups" "~") - (cons "completion-ignored-extensions" completion-ignored-extensions)) - "*Alist of extensions for temporary files created by various programs. -Used by `dired-cleanup'.") - -(defvar dired-omit-extensions - (let ((alist dired-cleanup-alist) - x result) - (while alist - (setq x (cdr (car alist)) - alist (cdr alist)) - (while x - (or (member (car x) result) - (setq result (cons (car x) result))) - (setq x (cdr x)))) - result) - "*List of extensions for file names that will be omitted (buffer-local). -This only has effect when the subdirectory is in omission mode. -To make omission mode the default, set `dired-omit-files' to t. -See also `dired-omit-extensions'.") -(make-variable-buffer-local 'dired-omit-extensions) - -(defvar dired-omit-regexps '("\\`#" "\\`\\.") - "*File names matching these regexp may be omitted (buffer-local). -This only has effect when the subdirectory is in omission mode. -To make omission mode the default, set `dired-omit-files' to t. -This only has effect when `dired-omit-files' is t. -See also `dired-omit-extensions'.") -(make-variable-buffer-local 'dired-omit-regexps) - -(defvar dired-filename-re-ext "\\..+\\'" ; start from the first dot. last dot? - "*Defines what is the extension of a file name. -\(match-beginning 0\) for this regexp in the file name without directory will -be taken to be the start of the extension.") - -;;; Hook variables - -(defvar dired-load-hook nil - "Run after loading dired. -You can customize key bindings or load extensions with this.") - -(defvar dired-grep-load-hook nil - "Run after loading dired-grep.") - -(defvar dired-mode-hook nil - "Run at the very end of dired-mode.") - -(defvar dired-before-readin-hook nil - "Hook run before a dired buffer is newly read in, created,or reverted.") - -(defvar dired-after-readin-hook nil - "Hook run after each listing of a file or directory. -The buffer is narrowed to the new listing.") - -(defvar dired-setup-keys-hook nil - "Hook run when dired sets up its keymap. -This happens the first time that `dired-mode' is called, and runs after -`dired-mode-hook'. This hook can be used to make alterations to the -dired keymap.") - -;;; Internal variables -;; -;; If you set these, know what you are doing. - -;;; Marker chars. - -(defvar dired-marker-char ?* ; the answer is 42 - ; life the universe and everything - ;; so that you can write things like - ;; (let ((dired-marker-char ?X)) - ;; ;; great code using X markers ... - ;; ) - ;; For example, commands operating on two sets of files, A and B. - ;; Or marking files with digits 0-9. This could implicate - ;; concentric sets or an order for the marked files. - ;; The code depends on dynamic scoping on the marker char. - "In dired, character used to mark files for later commands.") -(make-variable-buffer-local 'dired-marker-char) - -(defconst dired-default-marker dired-marker-char) -;; Stores the default value of dired-marker-char when dynamic markers -;; are being used. - -(defvar dired-del-marker ?D - "Character used to flag files for deletion.") - -;; \017=^O for Omit - other packages can chose other control characters. -(defvar dired-omit-marker-char ?\017) -;; Marker used for omitted files. Shouldn't be used by anything else. - -(defvar dired-kill-marker-char ?\C-k) -;; Marker used by dired-do-kill. Shouldn't be used by anything else. - -;;; State variables - -(defvar dired-mode-line-modified "-%s%s%s-" - "*Format string to show the modification status of the buffer.") - -(defvar dired-del-flags-number 0) -(make-variable-buffer-local 'dired-del-flags-number) -(defvar dired-marks-number 0) -(make-variable-buffer-local 'dired-marks-number) -(defvar dired-other-marks-number 0) -(make-variable-buffer-local 'dired-other-marks-number) - -(defvar dired-marked-files nil - "List of filenames from last `dired-copy-filename-as-kill' call.") - -(defvar dired-directory nil - "The directory name or shell wildcard that was used as argument to `ls'. -Local to each dired buffer. May be a list, in which case the car is the -directory name and the cdr is the actual files to list.") -(make-variable-buffer-local 'dired-directory) - -(defvar dired-internal-switches nil - "The actual (buffer-local) value of `dired-listing-switches'. -The switches are represented as a list of characters.") -(make-variable-buffer-local 'dired-internal-switches) - -(defvar dired-subdir-alist nil - "Association list of subdirectories and their buffer positions. -Each subdirectory has an element: (DIRNAME . STARTMARKER). -The order of elements is the reverse of the order in the buffer.") -(make-variable-buffer-local 'dired-subdir-alist) - -(defvar dired-curr-subdir-min 0) -;; Cache for modeline tracking of the cursor -(make-variable-buffer-local 'dired-curr-subdir-min) - -(defvar dired-curr-subdir-max 0) -;; Cache for modeline tracking of the cursor -(make-variable-buffer-local 'dired-curr-subdir-max) - -(defvar dired-subdir-omit nil) -;; Controls whether the modeline shows Omit. -(make-variable-buffer-local 'dired-subdir-omit) - -(defvar dired-in-query nil) -;; let-bound to t when dired is in the process of querying the user. -;; This is to keep asynch messaging from clobbering the query prompt. - -(defvar dired-overwrite-confirmed nil) -;; Fluid variable used to remember if a bunch of overwrites have been -;; confirmed. - -(defvar dired-overwrite-backup-query nil) -;; Fluid var used to remember if backups have been requested for overwrites. - -(defvar dired-file-creator-query nil) -;; Fluid var to remember responses to file-creator queries. - -(defvar dired-omit-silent nil) -;; This is sometimes let-bound to t if messages would be annoying, -;; e.g., in dired-awrh.el. Binding to 0, only suppresses -;; \"(Nothing to omit)\" message. - -(defvar dired-buffers nil - ;; Enlarged by dired-advertise - ;; Queried by function dired-buffers-for-dir. When this detects a - ;; killed buffer, it is removed from this list. - "Alist of directories and their associated dired buffers.") - -(defvar dired-sort-mode nil - "Whether Dired sorts by name, date, etc. -\(buffer-local\)") -;; This is nil outside dired buffers so it can be used in the modeline -(make-variable-buffer-local 'dired-sort-mode) - -(defvar dired-marker-stack nil - "List of previously used dired marker characters.") -(make-variable-buffer-local 'dired-marker-stack) - -(defvar dired-marker-stack-pointer 0) -;; Points to the current marker in the stack -(make-variable-buffer-local 'dired-marker-stack-pointer) - -(defvar dired-marker-stack-cursor ?\ ; space - "Character to use as a cursor in the dired marker stack.") - -(defconst dired-marker-string "" - "String version of `dired-marker-stack'.") -(make-variable-buffer-local 'dired-marker-string) - -(defvar dired-modeline-tracking-cmds nil) -;; List of commands after which the modeline gets updated. - -;;; Config. variables not usually considered fair game for the user. - -(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? - -(defvar dired-log-buffer "*Dired log*") -;; Name of buffer used to log dired messages and errors. - -;;; Assoc. lists - -;; For pop ups and user input for file marking -(defvar dired-query-alist - '((?\y . y) (?\040 . y) ; `y' or SPC means accept once - (?n . n) (?\177 . n) ; `n' or DEL skips once - (?! . yes) ; `!' accepts rest - (?q. no) (?\e . no) ; `q' or ESC skips rest - ;; None of these keys quit - use C-g for that. - )) - -(defvar dired-sort-type-alist - ;; alist of sort flags, and the sort type, as a symbol. - ;; Don't put ?r in here. It's handled separately. - '((?t . date) (?S . size) (?U . unsort) (?X . ext))) - -;;; Internal regexps for examining ls listings. -;; -;; Many of these regexps must be tested at beginning-of-line, but are also -;; used to search for next matches, so neither omitting "^" nor -;; replacing "^" by "\n" (to make it slightly faster) will work. - -(defvar dired-re-inode-size "[ \t0-9]*") -;; Regexp for optional initial inode and file size. -;; Must match output produced by ls' -i and -s flags. - -(defvar dired-re-mark "^[^ \n\r]") -;; Regexp matching a marked line. -;; Important: the match ends just after the marker. - -(defvar dired-re-maybe-mark "^. ") - -(defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) -;; Matches directory lines - -(defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) -;; Matches symlink lines - -(defvar dired-re-exe;; match ls permission string of an executable file - (mapconcat (function - (lambda (x) - (concat dired-re-maybe-mark dired-re-inode-size x))) - '("-[-r][-w][xs][-r][-w].[-r][-w]." - "-[-r][-w].[-r][-w][xs][-r][-w]." - "-[-r][-w].[-r][-w].[-r][-w][xst]") - "\\|")) - -(defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' -;; . and .. files - -(defvar dired-re-month-and-time - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct\\|Nov\\|" - ; June and July are for HP-UX 9.0 - "Dec\\) [ 0-3][0-9]\\(" - " [012][0-9]:[0-6][0-9] \\|" ; time - " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo, - ; HP-UX, A/UX - " [12][90][0-9][0-9] \\)" ; year on AIX - )) -;; This regexp MUST match all the way to first character of the filename. -;; You can loosen it to taste, but then you might bomb on filenames starting -;; with a space. This will have to be modified for non-english month names. - -(defvar dired-subdir-regexp - "\\([\n\r]\n\\|\\`\\). \\([^\n\r]+\\)\\(:\\)\\(\\.\\.\\.\r\\|[\n\r]\\)") - ;; Regexp matching a maybe hidden subdirectory line in ls -lR output. - ;; Subexpression 2 is the subdirectory proper, no trailing colon. - ;; Subexpression 3 must end right before the \n or \r at the end of - ;; the subdir heading. Matches headings after indentation has been done. - -(defvar dired-unhandle-add-files nil) -;; List of files that the dired handler function need not add to dired buffers. -;; This is because they have already been added, most likely in -;; dired-create-files. This is because dired-create-files add files with -;; special markers. - -;;; history variables - -(defvar dired-regexp-history nil - "History list of regular expressions used in Dired commands.") - -(defvar dired-chmod-history nil - "History of arguments to chmod in dired.") - -(defvar dired-chown-history nil - "History of arguments to chown in dired.") - -(defvar dired-chgrp-history nil - "History of arguments to chgrp in dired.") - -(defvar dired-cleanup-history nil - "History of arguments to dired-cleanup.") - -(defvar dired-goto-file-history nil) -;; History for dired-goto-file and dired-goto-subdir -(put 'dired-goto-file-history 'cursor-end t) ; for gmhist - -(defvar dired-history nil) -;; Catch-all history variable for dired file ops without -;; their own history. - -(defvar dired-op-history-alist - ;; alist of dired file operations and history symbols - '((chgrp . dired-chgrp-history) (chown . dired-chown-history) - (chmod . dired-chmod-history) )) - -;;; Tell the byte-compiler that we know what we're doing. -;;; Do we? - -(defvar file-name-handler-alist) -(defvar inhibit-file-name-operation) -(defvar inhibit-file-name-handlers) -(defvar efs-dired-host-type) - - -;;;;------------------------------------------------------------------ -;;;; Utilities -;;;;------------------------------------------------------------------ - -;;; Macros -;; -;; Macros must be defined before they are used - for the byte compiler. - -(defmacro dired-get-subdir-min (elt) - ;; Returns the value of the subdir minumum for subdir with entry ELT in - ;; dired-subdir-alist. - (list 'nth 1 elt)) - -(defmacro dired-save-excursion (&rest body) - ;; Saves excursions of the point (not buffer) in dired buffers. - ;; It tries to be robust against deletion of the region about the point. - ;; Note that this assumes only dired-style deletions. - (let ((temp-bolm (make-symbol "bolm")) - (temp-fnlp (make-symbol "fnlp")) - (temp-offset-bol (make-symbol "offset-bol"))) - (` (let (((, temp-bolm) (make-marker)) - (, temp-fnlp) (, temp-offset-bol)) - (let ((bol (save-excursion (skip-chars-backward "^\n\r") (point)))) - (set-marker (, temp-bolm) bol) - (setq (, temp-offset-bol) (- (point) bol) - (, temp-fnlp) (memq (char-after bol) '(?\n\ ?\r)))) - (unwind-protect - (progn - (,@ body)) - ;; Use the marker to try to find the right line, then move to - ;; the proper column. - (goto-char (, temp-bolm)) - (and (not (, temp-fnlp)) - (memq (char-after (point)) '(?\n ?\r)) - ;; The line containing the point got deleted. Note that this - ;; logic only works if we don't delete null lines, but we never - ;; do. - (forward-line 1)) ; don't move into a hidden line. - (skip-chars-forward "^\n\r" (+ (point) (, temp-offset-bol)))))))) - -(put 'dired-save-excursion 'lisp-indent-hook 0) - -(defun dired-substitute-marker (pos old new) - ;; Change marker, re-fontify - (subst-char-in-region pos (1+ pos) old new) - (dired-move-to-filename)) - -(defmacro dired-mark-if (predicate msg) - ;; Mark all files for which CONDITION evals to non-nil. - ;; CONDITION is evaluated on each line, with point at beginning of line. - ;; MSG is a noun phrase for the type of files being marked. - ;; It should end with a noun that can be pluralized by adding `s'. - ;; Return value is the number of files marked, or nil if none were marked. - (let ((temp-pt (make-symbol "pt")) - (temp-count (make-symbol "count")) - (temp-msg (make-symbol "msg"))) - (` (let (((, temp-msg) (, msg)) - ((, temp-count) 0) - (, temp-pt) buffer-read-only) - (save-excursion - (if (, temp-msg) (message "Marking %ss..." (, temp-msg))) - (goto-char (point-min)) - (while (not (eobp)) - (if (and (, predicate) - (not (char-equal (following-char) dired-marker-char))) - (progn - ;; Doing this rather than delete-char, insert - ;; avoids re-computing markers - (setq (, temp-pt) (point)) - (dired-substitute-marker - (, temp-pt) - (following-char) dired-marker-char) - (setq (, temp-count) (1+ (, temp-count))))) - (forward-line 1)) - (if (, temp-msg) - (message "%s %s%s %s%s." - (, temp-count) - (, temp-msg) - (dired-plural-s (, temp-count)) - (if (eq dired-marker-char ?\040) "un" "") - (if (eq dired-marker-char dired-del-marker) - "flagged" "marked")))) - (and (> (, temp-count) 0) (, temp-count)))))) - -(defmacro dired-map-over-marks (body arg &optional show-progress) -;; Perform BODY with point somewhere on each marked line -;; and return a list of BODY's results. -;; If no marked file could be found, execute BODY on the current line. -;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) -;; files instead of the marked files. -;; If ARG is t, only apply to marked files. If there are no marked files, -;; the result is a noop. -;; If ARG is otherwise non-nil, use current file instead. -;; If optional third arg SHOW-PROGRESS evaluates to non-nil, -;; redisplay the dired buffer after each file is processed. -;; No guarantee is made about the position on the marked line. -;; BODY must ensure this itself if it depends on this. -;; Search starts at the beginning of the buffer, thus the car of the list -;; corresponds to the line nearest to the buffer's bottom. This -;; is also true for (positive and negative) integer values of ARG. -;; To avoid code explosion, BODY should not be too long as it is -;; expanded four times. -;; -;; Warning: BODY must not add new lines before point - this may cause an -;; endless loop. -;; This warning should not apply any longer, sk 2-Sep-1991 14:10. - (let ((temp-found (make-symbol "found")) - (temp-results (make-symbol "results")) - (temp-regexp (make-symbol "regexp")) - (temp-curr-pt (make-symbol "curr-pt")) - (temp-next-position (make-symbol "next-position"))) - (` (let (buffer-read-only case-fold-search (, temp-found) (, temp-results)) - (dired-save-excursion - (if (and (, arg) (not (eq (, arg) t))) - (if (integerp (, arg)) - (and (not (zerop (, arg))) - (progn;; no save-excursion, want to move point. - (dired-repeat-over-lines - arg - (function (lambda () - (if (, show-progress) (sit-for 0)) - (setq (, temp-results) - (cons (, body) - (, temp-results)))))) - (if (< (, arg) 0) - (nreverse (, temp-results)) - (, temp-results)))) - ;; non-nil, non-integer ARG means use current file: - (list (, body))) - (let (((, temp-regexp) - (concat "^" (regexp-quote (char-to-string - dired-marker-char)))) - (, temp-curr-pt) (, temp-next-position)) - (save-excursion - (goto-char (point-min)) - ;; remember position of next marked file before BODY - ;; can insert lines before the just found file, - ;; confusing us by finding the same marked file again - ;; and again and... - (setq (, temp-next-position) - (and (re-search-forward (, temp-regexp) nil t) - (point-marker)) - (, temp-found) (not (null (, temp-next-position)))) - (while (, temp-next-position) - (setq (, temp-curr-pt) (goto-char (, temp-next-position)) - ;; need to get next position BEFORE body - (, temp-next-position) - (and (re-search-forward (, temp-regexp) nil t) - (point-marker))) - (goto-char (, temp-curr-pt)) - (if (, show-progress) (sit-for 0)) - (setq (, temp-results) (cons (, body) (, temp-results))))) - (if (, temp-found) - (, temp-results) - ;; Do current file, unless arg is t - (and (not (eq (, arg) t)) - (list (, body))))))))))) - -;;; General utility functions - -(defun dired-buffer-more-recently-used-p (buffer1 buffer2) - "Return t if BUFFER1 is more recently used than BUFFER2." - (if (equal buffer1 buffer2) - nil - (let ((more-recent nil) - (list (buffer-list))) - (while (and list - (not (setq more-recent (equal buffer1 (car list)))) - (not (equal buffer2 (car list)))) - (setq list (cdr list))) - more-recent))) - -(defun dired-file-modtime (file) - ;; Return the modtime of FILE, which is assumed to be already expanded - ;; by expand-file-name. - (let ((handler (find-file-name-handler file 'dired-file-modtime))) - (if handler - (funcall handler 'dired-file-modtime file) - (nth 5 (file-attributes file))))) - -(defun dired-set-file-modtime (file alist) - ;; Set the modtime for FILE in the subdir alist ALIST. - (let ((handler (find-file-name-handler file 'dired-set-file-modtime))) - (if handler - (funcall handler 'dired-set-file-modtime file alist) - (let ((elt (assoc file alist))) - (if elt - (setcar (nthcdr 4 elt) (nth 5 (file-attributes file)))))))) - -(defun dired-map-over-marks-check (fun arg op-symbol operation - &optional show-progress no-confirm) - ;; Map FUN over marked files (with second ARG like in dired-map-over-marks) - ;; and display failures. - - ;; FUN takes zero args. It returns non-nil (the offending object, e.g. - ;; the short form of the filename) for a failure and probably logs a - ;; detailed error explanation using function `dired-log'. - - ;; OP-SYMBOL is s symbol representing the operation. - ;; eg. 'compress - - ;; OPERATION is a string describing the operation performed (e.g. - ;; "Compress"). It is used with `dired-mark-pop-up' to prompt the user - ;; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. - ;; `Failed to compress 1 of 2 files - type y to see why ("foo")') - - ;; SHOW-PROGRESS if non-nil means redisplay dired after each file. - - (if (or no-confirm (dired-mark-confirm op-symbol operation arg)) - (let* ((total-list;; all of FUN's return values - (dired-map-over-marks (funcall fun) arg show-progress)) - (total (length total-list)) - (failures (delq nil total-list)) - (count (length failures))) - (if (not failures) - (message "%s: %d file%s." operation total (dired-plural-s total)) - (message "Failed to %s %d of %d file%s - type y to see why %s" - operation count total (dired-plural-s total) - ;; this gives a short list of failed files in parens - ;; which may be sufficient for the user even - ;; without typing `W' for the process' diagnostics - failures) - ;; end this bunch of errors: - (dired-log-summary - (buffer-name (current-buffer)) - (format - "Failed to %s %d of %d file%s" - operation count total (dired-plural-s total)) - failures))))) - -(defun dired-make-switches-string (list) -;; Converts a list of cracters to a string suitable for passing to ls. - (concat "-" (mapconcat 'char-to-string list ""))) - -(defun dired-make-switches-list (string) -;; Converts a string of ls switches to a list of characters. - (delq ?- (mapcar 'identity string))) - -;; Cloning replace-match to work on strings instead of in buffer: -;; The FIXEDCASE parameter of replace-match is not implemented. -(defun dired-string-replace-match (regexp string newtext - &optional literal global) - ;; Replace first match of REGEXP in STRING with NEWTEXT. - ;; If it does not match, nil is returned instead of the new string. - ;; Optional arg LITERAL means to take NEWTEXT literally. - ;; Optional arg GLOBAL means to replace all matches. - (if global - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result - (substring string start mb) - (if literal - newtext - (dired-expand-newtext string newtext))) - start me)) - (if mb ; matched at least once - (concat result (substring string start)) - nil)) - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (dired-expand-newtext string newtext)) - (substring string (match-end 0)))))) - -(defun dired-expand-newtext (string newtext) - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c - (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t - (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - -(defun dired-in-this-tree (file dir) - ;;Is FILE part of the directory tree starting at DIR? - (let ((len (length dir))) - (and (>= (length file) len) - (string-equal (substring file 0 len) dir)))) - -(defun dired-tree-lessp (dir1 dir2) - ;; Lexicographic order on pathname components, like `ls -lR': - ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, - ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, - ;; or DIR1 and DIR2 are in the same parentdir and their last - ;; components are string-lessp. - ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. - ;; string-lessp could arguably be replaced by file-newer-than-file-p - ;; if dired-internal-switches contained `t'. - (let ((dir1 (file-name-as-directory dir1)) - (dir2 (file-name-as-directory dir2)) - (start1 1) - (start2 1) - comp1 comp2 end1 end2) - (while (progn - (setq end1 (string-match "/" dir1 start1) - comp1 (substring dir1 start1 end1) - end2 (string-match "/" dir2 start2) - comp2 (substring dir2 start2 end2)) - (and end1 end2 (string-equal comp1 comp2))) - (setq start1 (1+ end1) - start2 (1+ end2))) - (if (eq (null end1) (null end2)) - (string-lessp comp1 comp2) - (null end1)))) - -;; So that we can support case-insensitive systems. -(fset 'dired-file-name-lessp 'string-lessp) - - -;;;; ------------------------------------------------------------------ -;;;; Initializing Dired -;;;; ------------------------------------------------------------------ - -;;; Set the minor mode alist - -(or (equal (assq 'dired-sort-mode minor-mode-alist) - '(dired-sort-mode dired-sort-mode)) - ;; Test whether this has already been done in case dired is reloaded - ;; There may be several elements with dired-sort-mode as car. - (setq minor-mode-alist - ;; cons " Omit" in first, so that it doesn't - ;; get stuck between the directory and sort mode on the - ;; mode line. - (cons '(dired-sort-mode dired-sort-mode) - (cons '(dired-subdir-omit " Omit") - (cons '(dired-marker-stack dired-marker-string) - minor-mode-alist))))) - -;;; Keymaps - -(defvar dired-mode-map nil - "Local keymap for dired-mode buffers.") -(defvar dired-regexp-map nil - "Dired keymap for commands that use regular expressions.") -(defvar dired-diff-map nil - "Dired keymap for diff and related commands.") -(defvar dired-subdir-map nil - "Dired keymap for commands that act on subdirs, or the files within them.") - -(defvar dired-keymap-grokked nil - "Set to t after dired has grokked the global keymap.") - -(defun dired-key-description (cmd &rest prefixes) - ;; Return a key description string for a menu. If prefixes are given, - ;; they should be either strings, integers, or 'universal-argument. - (let ((key (where-is-internal cmd dired-mode-map t))) - (if key - (key-description - (apply 'vconcat - (append - (mapcar - (function - (lambda (x) - (cond ((eq x 'universal-argument) - (where-is-internal 'universal-argument - dired-mode-map t)) - ((integerp x) (int-to-string x)) - (t x)))) - prefixes) - (list key)))) - ""))) - -(defun dired-grok-keys (to-command from-command) - ;; Assigns to TO-COMMAND the keys for the global binding of FROM-COMMAND. - ;; Does not clobber anything in the local keymap. In emacs 19 should - ;; use substitute-key-definition, but I believe that this will - ;; clobber things in the local map. - (let ((keys (where-is-internal from-command))) - (while keys - (condition-case nil - (if (eq (global-key-binding (car keys)) (key-binding (car keys))) - (local-set-key (car keys) to-command)) - (error nil)) - (setq keys (cdr keys))))) - -(defun dired-grok-keymap () - ;; Initialize the dired keymaps. - ;; This is actually done the first time that dired-mode runs. - ;; We do it this late, to be sure that the user's global-keymap has - ;; stabilized. - (if dired-keymap-grokked - () ; we've done it - ;; Watch out for dired being invoked from the command line. - ;; This is a bit kludgy, but so is the emacs startup sequence IMHO. - (if (and term-setup-hook (boundp 'command-line-args-left)) - (progn - (if (string-equal "18." (substring emacs-version 0 3)) - (funcall term-setup-hook) - (run-hooks 'term-setup-hook)) - (setq term-setup-hook nil))) - (setq dired-keymap-grokked t) - (run-hooks 'dired-setup-keys-hook) - (dired-grok-keys 'dired-next-line 'next-line) - (dired-grok-keys 'dired-previous-line 'previous-line) - (dired-grok-keys 'dired-undo 'undo) - (dired-grok-keys 'dired-undo 'advertised-undo) - (dired-grok-keys 'dired-scroll-up 'scroll-up) - (dired-grok-keys 'dired-scroll-down 'scroll-down) - (dired-grok-keys 'dired-beginning-of-buffer 'beginning-of-buffer) - (dired-grok-keys 'dired-end-of-buffer 'end-of-buffer) - (dired-grok-keys 'dired-next-subdir 'forward-paragraph) - (dired-grok-keys 'dired-prev-subdir 'backward-paragraph))) - -;; The regexp-map is used for commands using regexp's. -(if dired-regexp-map - () - (setq dired-regexp-map (make-sparse-keymap)) - (define-key dired-regexp-map "C" 'dired-do-copy-regexp) - ;; Not really a regexp, but does transform file names. - (define-key dired-regexp-map "D" 'dired-downcase) - (define-key dired-regexp-map "H" 'dired-do-hardlink-regexp) - (define-key dired-regexp-map "R" 'dired-do-rename-regexp) - (define-key dired-regexp-map "S" 'dired-do-symlink-regexp) - (define-key dired-regexp-map "U" 'dired-upcase) - (define-key dired-regexp-map "Y" 'dired-do-relsymlink-regexp) - (define-key dired-regexp-map "c" 'dired-cleanup) - (define-key dired-regexp-map "d" 'dired-flag-files-regexp) - (define-key dired-regexp-map "e" 'dired-mark-extension) - (define-key dired-regexp-map "m" 'dired-mark-files-regexp) - (define-key dired-regexp-map "o" 'dired-add-omit-regexp) - (define-key dired-regexp-map "x" 'dired-flag-extension)) ; a string, rather - ; than a regexp. - -(if dired-diff-map - () - (setq dired-diff-map (make-sparse-keymap)) - (define-key dired-diff-map "d" 'dired-diff) - (define-key dired-diff-map "b" 'dired-backup-diff) - (define-key dired-diff-map "m" 'dired-emerge) - (define-key dired-diff-map "a" 'dired-emerge-with-ancestor) - (define-key dired-diff-map "e" 'dired-ediff) - (define-key dired-diff-map "p" 'dired-epatch)) - -(if dired-subdir-map - () - (setq dired-subdir-map (make-sparse-keymap)) - (define-key dired-subdir-map "n" 'dired-redisplay-subdir) - (define-key dired-subdir-map "m" 'dired-mark-subdir-files) - (define-key dired-subdir-map "d" 'dired-flag-subdir-files) - (define-key dired-subdir-map "z" 'dired-compress-subdir-files)) - -(fset 'dired-regexp-prefix dired-regexp-map) -(fset 'dired-diff-prefix dired-diff-map) -(fset 'dired-subdir-prefix dired-subdir-map) -(fset 'efs-dired-prefix (function (lambda () - (interactive) - (error "efs-dired not loaded yet")))) - -;; the main map -(if dired-mode-map - nil - ;; Force `f' rather than `e' in the mode doc: - (fset 'dired-advertised-find-file 'dired-find-file) - (fset 'dired-advertised-next-subdir 'dired-next-subdir) - (fset 'dired-advertised-prev-subdir 'dired-prev-subdir) - (setq dired-mode-map (make-keymap)) - (suppress-keymap dired-mode-map) - ;; Commands to mark certain categories of files - (define-key dired-mode-map "~" 'dired-flag-backup-files) - (define-key dired-mode-map "#" 'dired-flag-auto-save-files) - (define-key dired-mode-map "*" 'dired-mark-executables) - (define-key dired-mode-map "." 'dired-clean-directory) - (define-key dired-mode-map "/" 'dired-mark-directories) - (define-key dired-mode-map "@" 'dired-mark-symlinks) - (define-key dired-mode-map "," 'dired-mark-rcs-files) - (define-key dired-mode-map "\M-(" 'dired-mark-sexp) - (define-key dired-mode-map "\M-d" 'dired-mark-files-from-other-dired-buffer) - (define-key dired-mode-map "\M-c" 'dired-mark-files-compilation-buffer) - ;; Upper case keys (except ! and &) for operating on the marked files - (define-key dired-mode-map "A" 'dired-do-tags-search) - (define-key dired-mode-map "B" 'dired-do-byte-compile) - (define-key dired-mode-map "C" 'dired-do-copy) - (define-key dired-mode-map "E" 'dired-do-grep) - (define-key dired-mode-map "F" 'dired-do-find-file) - (define-key dired-mode-map "G" 'dired-do-chgrp) - (define-key dired-mode-map "H" 'dired-do-hardlink) - (define-key dired-mode-map "I" 'dired-do-insert-subdir) - (define-key dired-mode-map "K" 'dired-do-kill-file-lines) - (define-key dired-mode-map "L" 'dired-do-load) - (define-key dired-mode-map "M" 'dired-do-chmod) - (define-key dired-mode-map "N" 'dired-do-redisplay) - (define-key dired-mode-map "O" 'dired-do-chown) - (define-key dired-mode-map "P" 'dired-do-print) - (define-key dired-mode-map "Q" 'dired-do-tags-query-replace) - (define-key dired-mode-map "R" 'dired-do-rename) - (define-key dired-mode-map "S" 'dired-do-symlink) - (define-key dired-mode-map "T" 'dired-do-total-size) - (define-key dired-mode-map "U" 'dired-do-uucode) - (define-key dired-mode-map "W" 'dired-copy-filenames-as-kill) - (define-key dired-mode-map "X" 'dired-do-delete) - (define-key dired-mode-map "Y" 'dired-do-relsymlink) - (define-key dired-mode-map "Z" 'dired-do-compress) - (define-key dired-mode-map "!" 'dired-do-shell-command) - (define-key dired-mode-map "&" 'dired-do-background-shell-command) - ;; Make all regexp commands share a `%' prefix: - (define-key dired-mode-map "%" 'dired-regexp-prefix) - ;; Lower keys for commands not operating on all the marked files - (define-key dired-mode-map "a" 'dired-apropos) - (define-key dired-mode-map "c" 'dired-change-marks) - (define-key dired-mode-map "d" 'dired-flag-file-deletion) - (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion-backup) - (define-key dired-mode-map "e" 'dired-find-file) - (define-key dired-mode-map "f" 'dired-advertised-find-file) - (define-key dired-mode-map "g" 'revert-buffer) - (define-key dired-mode-map "h" 'dired-describe-mode) - (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) - (define-key dired-mode-map "k" 'dired-kill-subdir) - (define-key dired-mode-map "m" 'dired-mark) - (define-key dired-mode-map "o" 'dired-find-file-other-window) - (define-key dired-mode-map "q" 'dired-quit) - (define-key dired-mode-map "r" 'dired-read-mail) - (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) - (define-key dired-mode-map "t" 'dired-get-target-directory) - (define-key dired-mode-map "u" 'dired-unmark) - (define-key dired-mode-map "v" 'dired-view-file) - (define-key dired-mode-map "w" (if (fboundp 'find-file-other-frame) - 'dired-find-file-other-frame - 'dired-find-file-other-window)) - (define-key dired-mode-map "x" 'dired-expunge-deletions) - (define-key dired-mode-map "y" 'dired-why) - (define-key dired-mode-map "+" 'dired-create-directory) - (define-key dired-mode-map "`" 'dired-recover-file) - ;; dired-jump-back Should be in the global map, but put them here - ;; too anyway. - (define-key dired-mode-map "\C-x\C-j" 'dired-jump-back) - (define-key dired-mode-map "\C-x4\C-j" 'dired-jump-back-other-window) - (define-key dired-mode-map "\C-x5\C-j" 'dired-jump-back-other-frame) - ;; Comparison commands - (define-key dired-mode-map "=" 'dired-diff-prefix) - ;; moving - (define-key dired-mode-map "<" 'dired-prev-dirline) - (define-key dired-mode-map ">" 'dired-next-dirline) - (define-key dired-mode-map " " 'dired-next-line) - (define-key dired-mode-map "n" 'dired-next-line) - (define-key dired-mode-map "\C-n" 'dired-next-line) - (define-key dired-mode-map "p" 'dired-previous-line) - (define-key dired-mode-map "\C-p" 'dired-previous-line) - (define-key dired-mode-map "\C-v" 'dired-scroll-up) - (define-key dired-mode-map "\M-v" 'dired-scroll-down) - (define-key dired-mode-map "\M-<" 'dired-beginning-of-buffer) - (define-key dired-mode-map "\M->" 'dired-end-of-buffer) - (define-key dired-mode-map "\C-m" 'dired-advertised-find-file) - ;; motion by subdirectories - (define-key dired-mode-map "^" 'dired-up-directory) - (define-key dired-mode-map "\M-\C-u" 'dired-up-directory) - (define-key dired-mode-map "\M-\C-d" 'dired-down-directory) - (define-key dired-mode-map "\M-\C-n" 'dired-advertised-next-subdir) - (define-key dired-mode-map "\M-\C-p" 'dired-advertised-prev-subdir) - (define-key dired-mode-map "\C-j" 'dired-goto-subdir) - ;; move to marked files - (define-key dired-mode-map "\M-p" 'dired-prev-marked-file) - (define-key dired-mode-map "\M-n" 'dired-next-marked-file) - ;; hiding - (define-key dired-mode-map "$" 'dired-hide-subdir) - (define-key dired-mode-map "\M-$" 'dired-hide-all) - ;; omitting - (define-key dired-mode-map "\C-o" 'dired-omit-toggle) - ;; markers - (define-key dired-mode-map "\(" 'dired-set-marker-char) - (define-key dired-mode-map "\)" 'dired-restore-marker-char) - (define-key dired-mode-map "'" 'dired-marker-stack-left) - (define-key dired-mode-map "\\" 'dired-marker-stack-right) - ;; misc - (define-key dired-mode-map "\C-i" 'dired-mark-prefix) - (define-key dired-mode-map "?" 'dired-summary) - (define-key dired-mode-map "\177" 'dired-backup-unflag) - (define-key dired-mode-map "\C-_" 'dired-undo) - (define-key dired-mode-map "\C-xu" 'dired-undo) - (define-key dired-mode-map "\M-\C-?" 'dired-unmark-all-files) - ;; The subdir map - (define-key dired-mode-map "|" 'dired-subdir-prefix) - ;; efs submap - (define-key dired-mode-map "\M-e" 'efs-dired-prefix)) - - - -;;;;------------------------------------------------------------------ -;;;; The dired command -;;;;------------------------------------------------------------------ - -;;; User commands: -;;; All of these commands should have a binding in the global keymap. - -;;;###autoload (define-key ctl-x-map "d" 'dired) -;;;###autoload -(defun dired (dirname &optional switches) - "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) -Dired displays a list of files in DIRNAME (which may also have -shell wildcards appended to select certain files). If DIRNAME is a cons, -its first element is taken as the directory name and the resr as an explicit -list of files to make directory entries for. -\\<dired-mode-map>\ -You can move around in it with the usual commands. -You can flag files for deletion with \\[dired-flag-file-deletion] and then -delete them by typing \\[dired-expunge-deletions]. -Type \\[dired-describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." - ;; Cannot use (interactive "D") because of wildcards. - (interactive (dired-read-dir-and-switches "")) - (switch-to-buffer (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) -;;;###autoload -(defun dired-other-window (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." - (interactive (dired-read-dir-and-switches "in other window ")) - (switch-to-buffer-other-window (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame) -;;;###autoload -(defun dired-other-frame (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." - (interactive (dired-read-dir-and-switches "in other frame ")) - (switch-to-buffer-other-frame (dired-noselect dirname switches))) - -;;;###autoload -(defun dired-noselect (dir-or-list &optional switches) - "Like `dired' but returns the dired buffer as value, does not select it." - (or dir-or-list (setq dir-or-list (expand-file-name default-directory))) - ;; This loses the distinction between "/foo/*/" and "/foo/*" that - ;; some shells make: - (let (dirname) - (if (consp dir-or-list) - (setq dirname (car dir-or-list)) - (setq dirname dir-or-list)) - (setq dirname (expand-file-name (directory-file-name dirname))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (if (consp dir-or-list) - (setq dir-or-list (cons dirname (cdr dir-or-list))) - (setq dir-or-list dirname)) - (dired-internal-noselect dir-or-list switches))) - -;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). -;;;###autoload (define-key ctl-x-map "\C-j" 'dired-jump-back) -;;;###autoload -(defun dired-jump-back () - "Jump back to dired. -If in a file, dired the current directory and move to file's line. -If in dired already, pop up a level and goto old directory's line. -In case the proper dired file line cannot be found, refresh the dired - buffer and try again." - (interactive) - (let* ((file (if (eq major-mode 'dired-mode) - (directory-file-name (dired-current-directory)) - buffer-file-name)) - (dir (if file - (file-name-directory file) - default-directory))) - (dired dir) - (if file (dired-really-goto-file file)))) - -;;;###autoload (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) -;;;###autoload -(defun dired-jump-back-other-window () - "Like \\[dired-jump-back], but to other window." - (interactive) - (let* ((file (if (eq major-mode 'dired-mode) - (directory-file-name (dired-current-directory)) - buffer-file-name)) - (dir (if file - (file-name-directory file) - default-directory))) - (dired-other-window dir) - (if file (dired-really-goto-file file)))) - -;;;###autoload (define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) -;;;###autoload -(defun dired-jump-back-other-frame () - "Like \\[dired-jump-back], but in another frame." - (interactive) - (let* ((file (if (eq major-mode 'dired-mode) - (directory-file-name (dired-current-directory)) - buffer-file-name)) - (dir (if file - (file-name-directory file) - default-directory))) - (dired-other-frame dir) - (if file (dired-really-goto-file file)))) - -;;; Dired mode - -;; Dired mode is suitable only for specially formatted data. -(put 'dired-mode 'mode-class 'special) - -(defun dired-mode (&optional dirname switches) - "\\<dired-mode-map>Dired mode is for \"editing\" directory trees. - -For a simple one-line help message, type \\[dired-summary] -For a moderately detailed description of dired mode, type \\[dired-describe-mode] -For the full dired info tree, type \\[universal-argument] \\[dired-describe-mode]" - ;; Not to be called interactively (e.g. dired-directory will be set - ;; to default-directory, which is wrong with wildcards). - (kill-all-local-variables) - (use-local-map dired-mode-map) - (setq major-mode 'dired-mode - mode-name "Dired" - case-fold-search nil - buffer-read-only t - selective-display t ; for subdirectory hiding - selective-display-ellipses nil ; for omit toggling - mode-line-buffer-identification '("Dired: %12b") - mode-line-modified (format dired-mode-line-modified "--" "--" "-") - dired-directory (expand-file-name (or dirname default-directory)) - dired-internal-switches (dired-make-switches-list - (or switches dired-listing-switches))) - (dired-advertise) ; default-directory is already set - (set (make-local-variable 'revert-buffer-function) - (function dired-revert)) - (set (make-local-variable 'default-directory-function) - 'dired-current-directory) - (set (make-local-variable 'page-delimiter) - "\n\n") - (set (make-local-variable 'list-buffers-directory) - dired-directory) - ;; Will only do something in Emacs 19. - (add-hook (make-local-variable 'kill-buffer-hook) - 'dired-unadvertise-current-buffer) - ;; Same here - (if window-system - (add-hook (make-local-variable 'post-command-hook) - (function - (lambda () - (if (memq this-command dired-modeline-tracking-cmds) - (dired-update-mode-line t)))))) - (dired-sort-other dired-internal-switches t) - (dired-hack-local-variables) - (run-hooks 'dired-mode-hook) - ;; Run this after dired-mode-hook, in case that hook makes changes to - ;; the keymap. - (dired-grok-keymap)) - -;;; Internal functions for starting dired - -(defun dired-read-dir-and-switches (str) - ;; For use in interactive. - (reverse (list - (if current-prefix-arg - (read-string "Dired listing switches: " - dired-listing-switches)) - (let ((default-directory (default-directory))) - (read-file-name (format "Dired %s(directory): " str) - nil default-directory nil))))) - -(defun dired-hack-local-variables () - "Parse, bind or evaluate any local variables for current dired buffer. -See variable `dired-local-variables-file'." - (if (and dired-local-variables-file - (file-exists-p dired-local-variables-file)) - (let (buffer-read-only opoint ) - (save-excursion - (goto-char (point-max)) - (setq opoint (point-marker)) - (insert "\^L\n") - (insert-file-contents dired-local-variables-file)) - (let ((buffer-file-name dired-local-variables-file)) - (condition-case err - (hack-local-variables) - (error (message "Error in dired-local-variables-file: %s" err) - (sit-for 1)))) - ;; Must delete it as (eobp) is often used as test for last - ;; subdir in dired.el. - (delete-region opoint (point-max)) - (set-marker opoint nil)))) - -;; Separate function from dired-noselect for the sake of dired-vms.el. -(defun dired-internal-noselect (dir-or-list &optional switches mode) - ;; If there is an existing dired buffer for DIRNAME, just leave - ;; buffer as it is (don't even call dired-revert). - ;; This saves time especially for deep trees or with efs. - ;; The user can type `g'easily, and it is more consistent with find-file. - ;; But if SWITCHES are given they are probably different from the - ;; buffer's old value, so call dired-sort-other, which does - ;; revert the buffer. - ;; If the user specifies a directory with emacs startup, eg. - ;; emacs ~, dir-or-list may be unexpanded at this point. - - (let* ((dirname (expand-file-name (if (consp dir-or-list) - (car dir-or-list) - dir-or-list))) - (buffer (dired-find-buffer-nocreate dir-or-list mode)) - ;; note that buffer already is in dired-mode, if found - (new-buffer-p (not buffer)) - (old-buf (current-buffer)) - wildcard) - (or buffer - (let ((default-major-mode 'fundamental-mode)) - ;; We don't want default-major-mode to run hooks and set auto-fill - ;; or whatever, now that dired-mode does not - ;; kill-all-local-variables any longer. - (setq buffer (create-file-buffer (directory-file-name dirname))))) - (set-buffer buffer) - (if (not new-buffer-p) ; existing buffer ... - (progn - (if switches - (dired-sort-other - (if (stringp switches) - (dired-make-switches-list switches) - switches))) - (if dired-verify-modtimes (dired-verify-modtimes)) - (if (and dired-find-subdir - (not (string-equal (dired-current-directory) - (file-name-as-directory dirname)))) - (dired-initial-position dirname))) - ;; Else a new buffer - (if (file-directory-p dirname) - (setq default-directory dirname - wildcard (consp dir-or-list)) - (setq default-directory (file-name-directory dirname) - wildcard t)) - (or switches (setq switches dired-listing-switches)) - (dired-mode dirname switches) - ;; default-directory and dired-internal-switches are set now - ;; (buffer-local), so we can call dired-readin: - (let ((failed t)) - (unwind-protect - (progn (dired-readin dir-or-list buffer wildcard) - (setq failed nil)) - ;; dired-readin can fail if parent directories are inaccessible. - ;; Don't leave an empty buffer around in that case. - (if failed (kill-buffer buffer)))) - ;; No need to narrow since the whole buffer contains just - ;; dired-readin's output, nothing else. The hook can - ;; successfully use dired functions (e.g. dired-get-filename) - ;; as the subdir-alist has been built in dired-readin. - (run-hooks 'dired-after-readin-hook) - ;; I put omit-expunge after the dired-after-readin-hook - ;; in case that hook marks files. Does this make sense? Also, users - ;; might want to set dired-omit-files in some incredibly clever - ;; way depending on the contents of the directory... I don't know... - (if dired-omit-files - (dired-omit-expunge nil t)) - (goto-char (point-min)) - (dired-initial-position dirname)) - (set-buffer old-buf) - buffer)) - -(defun dired-find-buffer-nocreate (dir-or-list &optional mode) - ;; Returns a dired buffer for DIR-OR-LIST. DIR-OR-LIST may be wildcard, - ;; or a directory and alist of files. - ;; If dired-find-subdir is non-nil, is satisfied with a dired - ;; buffer containing DIR-OR-LIST as a subdirectory. If there is more - ;; than one candidate, returns the most recently used. - (if dired-find-subdir - (let ((buffers (sort (delq (current-buffer) - (dired-buffers-for-dir dir-or-list t)) - (function dired-buffer-more-recently-used-p)))) - (or (car buffers) - ;; Couldn't find another buffer. Will the current one do? - ;; It is up dired-initial-position to actually go to the subdir. - (and (or (equal dir-or-list dired-directory) ; covers wildcards - (and (stringp dir-or-list) - (not (string-equal - dir-or-list - (expand-file-name default-directory))) - (assoc (file-name-as-directory dir-or-list) - dired-subdir-alist))) - (current-buffer)))) - ;; Else just look through the buffer list. - (let (found (blist (buffer-list))) - (or mode (setq mode 'dired-mode)) - (save-excursion - (while blist - (set-buffer (car blist)) - (if (and (eq major-mode mode) - (equal dired-directory dir-or-list)) - (setq found (car blist) - blist nil) - (setq blist (cdr blist))))) - found))) - -(defun dired-initial-position (dirname) - ;; Where point should go in a new listing of DIRNAME. - ;; Point assumed at beginning of new subdir line. - (end-of-line) - (if dired-find-subdir (dired-goto-subdir dirname)) - (if dired-trivial-filenames (dired-goto-next-nontrivial-file)) - (dired-update-mode-line t)) - -(defun dired-readin (dir-or-list buffer &optional wildcard) - ;; Read in a new dired buffer - ;; dired-readin differs from dired-insert-subdir in that it accepts - ;; wildcards, erases the buffer, and builds the subdir-alist anew - ;; (including making it buffer-local and clearing it first). - ;; default-directory and dired-internal-switches must be buffer-local - ;; and initialized by now. - ;; Thus we can test (equal default-directory dirname) instead of - ;; (file-directory-p dirname) and save a filesystem transaction. - ;; This is wrong, if dired-before-readin-hook changes default-directory - ;; Also, we can run this hook which may want to modify the switches - ;; based on default-directory, e.g. with efs to a SysV host - ;; where ls won't understand -Al switches. - (let (dirname other-dirs) - (if (consp dir-or-list) - (setq dir-or-list (dired-frob-dir-list dir-or-list) - other-dirs (cdr dir-or-list) - dir-or-list (car dir-or-list) - dirname (car dir-or-list)) - (setq dirname dir-or-list)) - (setq dirname (expand-file-name dirname)) - (if (consp dir-or-list) - (setq dir-or-list (cons dirname (cdr dir-or-list)))) - (save-excursion - (set-buffer buffer) - (run-hooks 'dired-before-readin-hook) - (message "Reading directory %s..." dirname) - (let (buffer-read-only) - (widen) - (erase-buffer) - (dired-readin-insert dir-or-list wildcard) - (dired-indent-listing (point-min) (point-max)) - ;; We need this to make the root dir have a header line as all - ;; other subdirs have: - (goto-char (point-min)) - (dired-insert-headerline (expand-file-name default-directory))) - (message "Reading directory %s...done" dirname) - (set-buffer-modified-p nil) - ;; Must first make alist buffer local and set it to nil because - ;; dired-build-subdir-alist will call dired-clear-alist first - (setq dired-subdir-alist nil) - (if (memq ?R dired-internal-switches) - (dired-build-subdir-alist) - ;; no need to parse the buffer if listing is not recursive - (dired-simple-subdir-alist)) - (if other-dirs - (mapcar - (function - (lambda (x) - (if (dired-in-this-tree (car x) dirname) - (dired-insert-subdir x)))) - other-dirs))))) - -;;; Subroutines of dired-readin - -(defun dired-readin-insert (dir-or-list &optional wildcard) - ;; Just insert listing for the passed-in directory or - ;; directory-and-file list, assuming a clean buffer. - (let* ((switches (dired-make-switches-string dired-internal-switches)) - (dir-is-list (consp dir-or-list)) - (dirname (if dir-is-list (car dir-or-list) dir-or-list))) - (if wildcard - (progn - (or (file-readable-p - (if dir-is-list - dirname - (directory-file-name (file-name-directory dirname)))) - (error "Directory %s inaccessible or nonexistent" dirname)) - ;; else assume it contains wildcards - (dired-insert-directory dir-or-list switches t) - (save-excursion - ;; insert wildcard instead of total line: - (goto-char (point-min)) - (if dir-is-list - (insert "list wildcard\n") - (insert "wildcard " (file-name-nondirectory dirname) "\n")))) - (dired-insert-directory dir-or-list switches nil t)))) - -(defun dired-insert-directory (dir-or-list switches &optional wildcard full-p) - ;; Do the right thing whether dir-or-list is atomic or not. If it is, - ;; insert all files listed in the cdr -- the car is the passed-in directory - ;; list. - (let ((opoint (point)) - (insert-directory-program dired-ls-program)) - (if (consp dir-or-list) - (mapcar - (function - (lambda (x) - (insert-directory x switches wildcard))) - (cdr dir-or-list)) - (insert-directory dir-or-list switches wildcard full-p)) - (dired-insert-set-properties opoint (point))) - (setq dired-directory dir-or-list)) - -(defun dired-frob-dir-list (dir-list) - (let* ((top (file-name-as-directory (expand-file-name (car dir-list)))) - (tail (cdr dir-list)) - (result (list (list top))) - elt dir) - (setq tail - (mapcar - (function - (lambda (x) - (directory-file-name (expand-file-name x top)))) - tail)) - (while tail - (setq dir (file-name-directory (car tail))) - (if (setq elt (assoc dir result)) - (nconc elt (list (car tail))) - (nconc result (list (list dir (car tail))))) - (setq tail (cdr tail))) - result)) - -(defun dired-insert-headerline (dir);; also used by dired-insert-subdir - ;; Insert DIR's headerline with no trailing slash, exactly like ls - ;; would, and put cursor where dired-build-subdir-alist puts subdir - ;; boundaries. - (save-excursion (insert " " (directory-file-name dir) ":\n"))) - -(defun dired-verify-modtimes () - ;; Check the modtimes of all subdirs. - (let ((alist dired-subdir-alist) - on-disk in-mem badies) - (while alist - (and (setq in-mem (nth 4 (car alist))) - (setq on-disk (dired-file-modtime (car (car alist)))) - (not (equal in-mem on-disk)) - (setq badies (cons (cons (car (car alist)) - (nth 3 (car alist))) - badies))) - (setq alist (cdr alist))) - (and badies - (let* ((ofile (dired-get-filename nil t)) - (osub (and (null ofile) (dired-get-subdir))) - (opoint (point)) - (ocol (current-column))) - (unwind-protect - (and - (or (memq 'revert-subdirs dired-no-confirm) - (save-window-excursion - (let ((flist (mapcar - (function - (lambda (f) - (dired-abbreviate-file-name (car f)))) - badies))) - (switch-to-buffer (current-buffer)) - (dired-mark-pop-up - "*Stale Subdirectories*" 'revert-subdirs - flist 'y-or-n-p - (if (= (length flist) 1) - (concat "Subdirectory " (car flist) - " has changed on disk. Re-list? ") - "Subdirectories have changed on disk. Re-list? ")) - ))) - (while badies - (dired-insert-subdir (car (car badies)) - (cdr (car badies)) nil t) - (setq badies (cdr badies)))) - ;; We can't use dired-save-excursion here, because we are - ;; rewriting the entire listing, and not just changing a single - ;; file line. - (or (if ofile - (dired-goto-file ofile) - (if osub - (dired-goto-subdir osub))) - (progn - (goto-char opoint) - (beginning-of-line) - (skip-chars-forward "^\n\r" (+ (point) ocol)))) - (dired-update-mode-line t) - (dired-update-mode-line-modified t)))))) - -(defun dired-indent-listing (start end) - ;; Indent a dired listing. - (let (indent-tabs-mode) - (indent-rigidly start end 2) - ;; Quote any null lines that shouldn't be. - (save-excursion - (goto-char start) - (while (search-forward "\n\n" end t) - (forward-char -2) - (if (looking-at dired-subdir-regexp) - (goto-char (match-end 3)) - (progn - (forward-char 1) - (insert " "))))))) - - -;;;; ------------------------------------------------------------ -;;;; Reverting a dired buffer, or specific file lines within it. -;;;; ------------------------------------------------------------ - -(defun dired-revert (&optional arg noconfirm) - ;; Reread the dired buffer. Must also be called after - ;; dired-internal-switches have changed. - ;; Should not fail even on completely garbaged buffers. - ;; Preserves old cursor, marks/flags, hidden-p. - (widen) ; just in case user narrowed - (let ((opoint (point)) - (ofile (dired-get-filename nil t)) - (hidden-subdirs (dired-remember-hidden)) - ;; switches for top-level dir - (oswitches (or (nth 3 (nth (1- (length dired-subdir-alist)) - dired-subdir-alist)) - (delq ?R (copy-sequence dired-internal-switches)))) - ;; all other subdirs - (old-subdir-alist (cdr (reverse dired-subdir-alist))) - (omitted-subdirs (dired-remember-omitted)) - ;; do this after dired-remember-hidden, since this unhides - (mark-alist (dired-remember-marks (point-min) (point-max))) - (kill-files-p (save-excursion - (goto-char (point)) - (search-forward - (concat (char-to-string ?\r) - (regexp-quote - (char-to-string - dired-kill-marker-char))) - nil t))) - buffer-read-only) - ;; This is bogus, as it will not handle all the ways that efs uses cache. - ;; Better to just use the fact that revert-buffer-function is a - ;; buffer-local variable, and reset it to something that knows about - ;; cache. - ;; (dired-uncache - ;; (if (consp dired-directory) (car dired-directory) dired-directory)) - ;; treat top level dir extra (it may contain wildcards) - (let ((dired-after-readin-hook nil) - ;; don't run that hook for each subdir... - (dired-omit-files nil) - (dired-internal-switches oswitches)) - (dired-readin dired-directory (current-buffer) - ;; Don't test for wildcards by checking string= - ;; default-directory and dired-directory - ;; in case default-directory got munged. - (or (consp dired-directory) - (null (file-directory-p dired-directory)))) - ;; The R-switch will clobber sorting of subdirs. - ;; What is the right thing to do here? - (dired-insert-old-subdirs old-subdir-alist)) - (dired-mark-remembered mark-alist) ; mark files that were marked - (if kill-files-p (dired-do-hide dired-kill-marker-char)) - (run-hooks 'dired-after-readin-hook) ; no need to narrow - ;; omit-expunge after the readin hook - (save-excursion - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-omit-expunge)))) - omitted-subdirs)) - ;; hide subdirs that were hidden - (save-excursion - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs)) - ;; Try to get back to where we were - (or (and ofile (dired-goto-file ofile)) - (goto-char opoint)) - (dired-move-to-filename) - (dired-update-mode-line t) - (dired-update-mode-line-modified t))) - -(defun dired-do-redisplay (&optional arg) - "Redisplay all marked (or next ARG) files." - (interactive "P") - ;; message instead of making dired-map-over-marks show-progress is - ;; much faster - (dired-map-over-marks (let ((fname (dired-get-filename))) - (dired-uncache fname nil) - (message "Redisplaying %s..." fname) - (dired-update-file-line fname)) - arg) - (dired-update-mode-line-modified t) - (message "Redisplaying...done")) - -(defun dired-redisplay-subdir (&optional arg) - "Redisplay the current subdirectory. -With a prefix prompts for listing switches." - (interactive "P") - (let ((switches (and arg (dired-make-switches-list - (read-string "Switches for listing: " - (dired-make-switches-string - dired-internal-switches))))) - (dir (dired-current-directory)) - (opoint (point)) - (ofile (dired-get-filename nil t))) - (or switches - (setq switches (nth 3 (assoc dir dired-subdir-alist)))) - (or switches - (setq switches (delq ?R (copy-sequence dired-internal-switches)))) - (message "Redisplaying %s..." dir) - (dired-uncache dir t) - (dired-insert-subdir dir switches) - (dired-update-mode-line-modified t) - (or (and ofile (dired-goto-file ofile)) (goto-char opoint)) - (message "Redisplaying %s... done" dir))) - -(defun dired-update-file-line (file) - ;; Delete the current line, and insert an entry for FILE. - ;; Does not update other dired buffers. Use dired-relist-file for that. - (let* ((start (save-excursion (skip-chars-backward "^\n\r") (point))) - (char (char-after start))) - (dired-save-excursion - ;; don't remember omit marks - (if (memq char (list ?\040 dired-omit-marker-char)) - (setq char nil)) - ;; Delete the current-line. Even though dired-add-entry will not - ;; insert duplicates, the file for the current line may not be the same as - ;; FILE. eg. dired-do-compress - (delete-region (save-excursion (skip-chars-backward "^\n\r") (1- (point))) - (progn (skip-chars-forward "^\n\r") (point))) - ;; dired-add-entry inserts at the end of the previous line. - (forward-char 1) - (dired-add-entry file char t)))) - -;;; Subroutines of dired-revert -;;; Some of these are also used when inserting subdirs. - -;; Don't want to remember omit marks, in case omission regexps -;; were changed, before the dired-revert. If we don't unhide -;; omitted files, we won't see their marks. Therefore we use -;; dired-omit-unhide-region. - -(defun dired-remember-marks (beg end) - ;; Return alist of files and their marks, from BEG to END. - (if selective-display ; must unhide to make this work. - (let (buffer-read-only) - (subst-char-in-region (point-min) (point-max) ?\r ?\n) - (dired-do-hide dired-omit-marker-char))) - (let (fil chr alist) - (save-excursion - (goto-char beg) - (while (re-search-forward dired-re-mark end t) - (if (setq fil (dired-get-filename nil t)) - (setq chr (preceding-char) - alist (cons (cons fil chr) alist))))) - alist)) - -(defun dired-mark-remembered (alist) - ;; Mark all files remembered in ALIST. - (let (elt fil chr) - (while alist - (setq elt (car alist) - alist (cdr alist) - fil (car elt) - chr (cdr elt)) - (if (dired-goto-file fil) - (save-excursion - (beginning-of-line) - (dired-substitute-marker (point) (following-char) chr)))))) - -(defun dired-remember-hidden () - ;; Return a list of all hidden subdirs. - (let ((l dired-subdir-alist) dir result min) - (while l - (setq dir (car (car l)) - min (dired-get-subdir-min (car l)) - l (cdr l)) - (if (and (>= min (point-min)) (<= min (point-max)) - (dired-subdir-hidden-p dir)) - (setq result (cons dir result)))) - result)) - -(defun dired-insert-old-subdirs (old-subdir-alist) - ;; Try to insert all subdirs that were displayed before - (let (elt dir switches) - (while old-subdir-alist - (setq elt (car old-subdir-alist) - old-subdir-alist (cdr old-subdir-alist) - dir (car elt) - switches (or (nth 3 elt) dired-internal-switches)) - (condition-case () - (dired-insert-subdir dir switches) - (error nil))))) - -(defun dired-uncache (file dir-p) - ;; Remove directory DIR from any directory cache. - ;; If DIR-P is non-nil, then FILE is a directory - (let ((handler (find-file-name-handler file 'dired-uncache))) - (if handler - (funcall handler 'dired-uncache file dir-p)))) - - -;;;; ------------------------------------------------------------- -;;;; Inserting subdirectories -;;;; ------------------------------------------------------------- - -(defun dired-maybe-insert-subdir (dirname &optional - switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, just move to it (type \\[dired-do-redisplay] to - refresh), else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (dired-make-switches-list - (read-string "Switches for listing: " - (dired-make-switches-string - dired-internal-switches)))))) - (let ((opoint (point))) - ;; We don't need a marker for opoint as the subdir is always - ;; inserted *after* opoint. - (setq dirname (file-name-as-directory dirname)) - (or (and (not switches) - (dired-goto-subdir dirname)) - (dired-insert-subdir dirname switches no-error-if-not-dir-p)) - ;; Push mark so that it's easy to find back. Do this after the - ;; insert message so that the user sees the `Mark set' message. - (push-mark opoint))) - -(defun dired-insert-subdir (dir-or-list &optional - switches no-error-if-not-dir-p no-posn) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - ;; SWITCHES should be a list. - ;; If NO-POSN is non-nil, doesn't bother position the point at - ;; the first nontrivial file line. This can be used as an efficiency - ;; hack when calling this from a program. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (dired-make-switches-list - (read-string "Switches for listing: " - (dired-make-switches-string - dired-internal-switches)))))) - (let ((dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (or (dired-in-this-tree dirname (expand-file-name default-directory)) - (error "%s: not in this directory tree" dirname)) - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (if switches - (or (dired-compatible-switches-p dired-internal-switches switches) - (error "Cannot have subdirs with %s and %s switches together." - (dired-make-switches-string dired-internal-switches) - (dired-make-switches-string switches))) - (setq switches dired-internal-switches)) - (let ((elt (assoc dirname dired-subdir-alist)) - mark-alist opoint-max buffer-read-only) - (if (memq ?R switches) - ;; avoid duplicated subdirs - (progn - (setq mark-alist (dired-kill-tree dirname t)) - (dired-insert-subdir-newpos dirname)) - (if elt - ;; If subdir is already present, remove it and remember its marks - (setq mark-alist (dired-insert-subdir-del elt)) - ;; else move to new position - (dired-insert-subdir-newpos dirname))) - (setq opoint-max (point-max)) - (condition-case nil - (dired-insert-subdir-doupdate - dirname (dired-insert-subdir-doinsert dir-or-list switches) - switches elt mark-alist) - (quit ; watch out for aborted inserts - (and (= opoint-max (point-max)) - (null elt) - (= (preceding-char) ?\n) - (delete-char -1)) - (signal 'quit nil)))) - (or no-posn (dired-initial-position dirname)))) - -(defun dired-do-insert-subdir () - "Insert all marked subdirectories in situ that are not yet inserted. -Non-directories are silently ignored." - (interactive) - (let ((files (or (dired-get-marked-files) - (error "No files marked.")))) - (while files - (if (file-directory-p (car files)) - (save-excursion (dired-maybe-insert-subdir (car files)))) - (setq files (cdr files))))) - -;;; Utilities for inserting subdirectories - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - (let ((alist dired-subdir-alist) elt dir new-pos) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt)) - (if (dired-tree-lessp dir new-dir) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt) - alist nil))) - (goto-char new-pos)) - (insert "\n") - (point)) - -(defun dired-insert-subdir-del (element) - ;; Erase an already present subdir (given by ELEMENT) from buffer. - ;; Move to that buffer position. Return a mark-alist. - (let ((begin-marker (dired-get-subdir-min element))) - (goto-char begin-marker) - ;; Are at beginning of subdir (and inside it!). Now determine its end: - (goto-char (dired-subdir-max)) - (prog1 - (dired-remember-marks begin-marker (point)) - (delete-region begin-marker (point))))) - -(defun dired-insert-subdir-doinsert (dir-or-list switches) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; Return the boundary of the inserted text (as list of BEG and END). - ;; SWITCHES should be a non-nil list. - (let ((begin (point)) - (dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list)) - end) - (message "Reading directory %s..." dirname) - (if (string-equal dirname (car (car (reverse dired-subdir-alist)))) - ;; top level directory may contain wildcards: - (let ((dired-internal-switches switches)) - (dired-readin-insert dired-directory - (null (file-directory-p dired-directory)))) - (let ((switches (dired-make-switches-string switches)) - (insert-directory-program dired-ls-program)) - (if (consp dir-or-list) - (progn - (insert "list wildcard\n") - (mapcar - (function - (lambda (x) - (insert-directory x switches t))) - (cdr dir-or-list))) - (insert-directory dirname switches nil t)))) - (message "Reading directory %s...done" dirname) - (setq end (point-marker)) - (dired-indent-listing begin end) - (dired-insert-set-properties begin end) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - ;; Need a marker for END as this inserts text. - (goto-char begin) - (dired-insert-headerline dirname) - ;; point is now like in dired-build-subdir-alist - (prog1 - (list begin (marker-position end)) - (set-marker end nil)))) - -(defun dired-insert-subdir-doupdate (dirname beg-end switches elt mark-alist) - ;; Point is at the correct subdir alist position for ELT, - ;; BEG-END is the subdir-region (as list of begin and end). - ;; SWITCHES must be a non-nil list. - (if (memq ?R switches) - ;; This will remove ?R from switches on purpose. - (let ((dired-internal-switches (delq ?R switches))) - (dired-build-subdir-alist)) - (if elt - (progn - (set-marker (dired-get-subdir-min elt) (point-marker)) - (setcar (nthcdr 3 elt) switches) - (if dired-verify-modtimes - (dired-set-file-modtime dirname dired-subdir-alist))) - (dired-alist-add dirname (point-marker) dired-omit-files switches))) - (save-excursion - (let ((begin (nth 0 beg-end)) - (end (nth 1 beg-end))) - (goto-char begin) - (save-restriction - (narrow-to-region begin end) - ;; hook may add or delete lines, but the subdir boundary - ;; marker floats - (run-hooks 'dired-after-readin-hook) - (if mark-alist (dired-mark-remembered mark-alist)) - (dired-do-hide dired-kill-marker-char) - (if (if elt (nth 2 elt) dired-omit-files) - (dired-omit-expunge nil t)))))) - - -;;;; -------------------------------------------------------------- -;;;; Dired motion commands -- moving around in the dired buffer. -;;;; -------------------------------------------------------------- - -(defun dired-next-line (arg) - "Move down lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (condition-case err - (next-line arg) - (error - (if (eobp) - (error "End of buffer") - (error "%s" err)))) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-previous-line (arg) - "Move up lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (previous-line arg) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-scroll-up (arg) - "Dired version of scroll up. -Scroll text of current window upward ARG lines; or near full screen if no ARG. -When calling from a program, supply a number as argument or nil." - (interactive "_P") - (scroll-up arg) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-scroll-down (arg) - "Dired version of scroll-down. -Scroll text of current window down ARG lines; or near full screen if no ARG. -When calling from a program, supply a number as argument or nil." - (interactive "_P") - (scroll-down arg) - (dired-move-to-filename) - (dired-update-mode-line)) - -(defun dired-beginning-of-buffer (arg) - "Dired version of `beginning of buffer'." - (interactive "_P") - (beginning-of-buffer arg) - (dired-update-mode-line)) - -(defun dired-end-of-buffer (arg) - "Dired version of `end-of-buffer'." - (interactive "_P") - (end-of-buffer arg) - (while (not (or (dired-move-to-filename) (dired-get-subdir) (bobp))) - (forward-line -1)) - (dired-update-mode-line t)) - -(defun dired-next-dirline (arg &optional opoint) - "Goto ARG'th next directory file line." - (interactive "_p") - (if dired-re-dir - (progn - (dired-check-ls-l) - (or opoint (setq opoint (point))) - (if (if (> arg 0) - (re-search-forward dired-re-dir nil t arg) - (beginning-of-line) - (re-search-backward dired-re-dir nil t (- arg))) - (progn - (dired-move-to-filename) ; user may type `i' or `f' - (dired-update-mode-line)) - (goto-char opoint) - (error "No more subdirectories"))))) - -(defun dired-prev-dirline (arg) - "Goto ARG'th previous directory file line." - (interactive "_p") - (dired-next-dirline (- arg))) - -(defun dired-next-marked-file (arg &optional wrap opoint) - "Move to the next marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (or opoint (setq opoint (point))) ; return to where interactively started - (if (if (> arg 0) - (re-search-forward dired-re-mark nil t arg) - (beginning-of-line) - (re-search-backward dired-re-mark nil t (- arg))) - (dired-move-to-filename) - (if (null wrap) - (progn - (goto-char opoint) - (error "No next marked file")) - (message "(Wraparound for next marked file)") - (goto-char (if (> arg 0) (point-min) (point-max))) - (dired-next-marked-file arg nil opoint))) - (dired-update-mode-line)) - -(defun dired-prev-marked-file (arg &optional wrap) - "Move to the previous marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (dired-next-marked-file (- arg) wrap) - (dired-update-mode-line)) - -(defun dired-goto-file (file) - "Goto file line of FILE in this dired buffer." - ;; Return value of point on success, else nil. - ;; FILE must be an absolute pathname. - ;; Loses if FILE contains control chars like "\007" for which ls - ;; either inserts "?" or "\\007" into the buffer, so we won't find - ;; it in the buffer. - (interactive - (prog1 ; let push-mark display its message - (list - (let* ((dired-completer-buffer (current-buffer)) - (dired-completer-switches dired-internal-switches) - (stack (reverse - (mapcar (function - (lambda (x) - (dired-abbreviate-file-name (car x)))) - dired-subdir-alist))) - (initial (car stack)) - (dired-goto-file-history (cdr stack)) - dired-completer-cache) - (expand-file-name - (dired-completing-read "Goto file: " - 'dired-goto-file-completer - nil t initial 'dired-goto-file-history)))) - (push-mark))) - (setq file (directory-file-name file)) ; does no harm if no directory - (let (found case-fold-search) - (save-excursion - (if (dired-goto-subdir (or (file-name-directory file) - (error "Need absolute pathname for %s" - file))) - (let* ((base (file-name-nondirectory file)) - ;; filenames are preceded by SPC, this makes - ;; the search faster (e.g. for the filename "-"!). - (search (concat " " (dired-make-filename-string base t))) - (boundary (dired-subdir-max)) - fn) - (while (and (not found) (search-forward search boundary 'move)) - ;; Match could have BASE just as initial substring or - ;; or in permission bits or date or - ;; not be a proper filename at all: - (if (and (setq fn (dired-get-filename 'no-dir t)) - (string-equal fn base)) - ;; Must move to filename since an (actually - ;; correct) match could have been elsewhere on the - ;; line (e.g. "-" would match somewhere in the - ;; permission bits). - (setq found (dired-move-to-filename))))))) - (and found - ;; return value of point (i.e., FOUND): - (prog1 - (goto-char found) - (dired-update-mode-line))))) - -;;; Moving by subdirectories - -(defun dired-up-directory (arg) - "Move to the ARG'th (prefix arg) parent directory of current directory. -Always stays within the current tree dired buffer. Will insert new -subdirectories if necessary." - (interactive "p") - (if (< arg 0) (error "Can't go up a negative number of directories!")) - (or (zerop arg) - (let* ((dir (dired-current-directory)) - (n arg) - (up dir)) - (while (> n 0) - (setq up (file-name-directory (directory-file-name up)) - n (1- n))) - (if (and (< (length up) (length dired-directory)) - (dired-in-this-tree dired-directory up)) - (if (or (memq 'create-top-dir dired-no-confirm) - (y-or-n-p - (format "Insert new top dir %s and rename buffer? " - (dired-abbreviate-file-name up)))) - (let ((newname (let (buff) - (unwind-protect - (buffer-name - (setq buff - (create-file-buffer - (directory-file-name up)))) - (kill-buffer buff)))) - (buffer-read-only nil)) - (push-mark) - (widen) - (goto-char (point-min)) - (insert-before-markers "\n") - (forward-char -1) - (dired-insert-subdir-doupdate - up (dired-insert-subdir-doinsert up dired-internal-switches) - dired-internal-switches nil nil) - (dired-initial-position up) - (rename-buffer newname) - (dired-unadvertise default-directory) - (setq default-directory up - dired-directory up) - (dired-advertise))) - (dired-maybe-insert-subdir up))))) - -(defun dired-down-directory () - "Go down in the dired tree. -Moves to the first subdirectory of the current directory, which exists in -the dired buffer. Does not take a prefix argument." - ;; What would a prefix mean here? - (interactive) - (let ((dir (dired-current-directory)) ; has slash - (rest (reverse dired-subdir-alist)) - pos elt) - (while rest - (setq elt (car rest)) - (if (dired-in-this-tree (directory-file-name (car elt)) dir) - (setq rest nil - pos (dired-goto-subdir (car elt))) - (setq rest (cdr rest)))) - (prog1 - (if pos - (progn - (push-mark) - (goto-char pos)) - (error "At the bottom")) - (dired-update-mode-line t)))) - -(defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) - "Go to next subdirectory, regardless of level." - ;; Use 0 arg to go to this directory's header line. - ;; NO-SKIP prevents moving to end of header line, returning whatever - ;; position was found in dired-subdir-alist. - (interactive "p") - (let ((this-dir (dired-current-directory)) - pos index) - ;; nth with negative arg does not return nil but the first element - (setq index (- (length dired-subdir-alist) - (length (memq (assoc this-dir dired-subdir-alist) - dired-subdir-alist)) - arg)) - (setq pos (if (>= index 0) - (dired-get-subdir-min (nth index dired-subdir-alist)))) - (if pos - (if no-skip - (goto-char pos) - (goto-char pos) - (skip-chars-forward "^\r\n") - (if (= (following-char) ?\r) - (skip-chars-backward "." (- (point) 3))) - (dired-update-mode-line t) - (point)) - (if no-error-if-not-found - nil ; return nil if not found - (error "%s directory" (if (> arg 0) "Last" "First")))))) - -(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) - "Go to previous subdirectory, regardless of level. -When called interactively and not on a subdir line, go to this subdir's line." - (interactive - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - ;; if on subdir start already, don't stay there! - (if (dired-get-subdir) 1 0)))) - (dired-next-subdir (- arg) no-error-if-not-found no-skip)) - -(defun dired-goto-subdir (dir) - "Goto end of header line of DIR in this dired buffer. -Return value of point on success, otherwise return nil. -The next char is either \\n, or \\r if DIR is hidden." - (interactive - (prog1 ; let push-mark display its message - (list - (let* ((table (mapcar - (function - (lambda (x) - (list (dired-abbreviate-file-name - (car x))))) - dired-subdir-alist)) - (stack (reverse (mapcar 'car table))) - (initial (car stack)) - (dired-goto-file-history (cdr stack))) - (expand-file-name - (dired-completing-read "Goto subdirectory " table nil t - initial 'dired-goto-file-history)))) - (push-mark))) - (setq dir (file-name-as-directory dir)) - (let ((elt (assoc dir dired-subdir-alist))) - (and elt - ;; need to make sure that we get where we're going. - ;; beware: narrowing might be in effect - (eq (goto-char (dired-get-subdir-min elt)) (point)) - (progn - ;; dired-subdir-hidden-p and dired-add-entry depend on point being - ;; at either \n or looking-at ...\r after this function succeeds. - (skip-chars-forward "^\r\n") - (if (= (preceding-char) ?.) - (skip-chars-backward "." (- (point) 3))) - (if (interactive-p) (dired-update-mode-line)) - (point))))) - -;;; Internals for motion commands - -(defun dired-update-mode-line (&optional force) - "Updates the mode line in dired according to the position of the point. -Normally this uses a cache of the boundaries of the current subdirectory, -but if the optional argument FORCE is non-nil, then modeline is always -updated and the cache is recomputed." - (if (or force - (>= (point) dired-curr-subdir-max) - (< (point) dired-curr-subdir-min)) - (let ((alist dired-subdir-alist) - min max) - (while (and alist (< (point) - (setq min (dired-get-subdir-min (car alist))))) - (setq alist (cdr alist) - max min)) - (setq dired-curr-subdir-max (or max (point-max-marker)) - dired-curr-subdir-min (or min (point-min-marker)) - dired-subdir-omit (nth 2 (car alist))) - (dired-sort-set-modeline (nth 3 (car alist)))))) - -(defun dired-manual-move-to-filename (&optional raise-error bol eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the UNIX version. - ;; have to be careful that we don't move to omitted files - (let (case-fold-search) - - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (or bol (setq bol (progn (skip-chars-backward "^\r\n") (point)))) - - (if (or (memq ?l dired-internal-switches) - (memq ?g dired-internal-switches)) - (if (and - (> (- eol bol) 17) ; a valid file line must have at least - ; 17 chars. 2 leading, 10 perms, - ; separator, node #, separator, owner, - ; separator - (goto-char (+ bol 17)) - (re-search-forward dired-re-month-and-time eol t)) - (point) - (goto-char bol) - (if raise-error - (error "No file on this line") - nil)) - ;; else ls switches don't contain -l. - ;; Note that even if we make dired-move-to-filename and - ;; dired-move-to-end-of-filename (and thus dired-get-filename) - ;; work, all commands that gleaned information from the permission - ;; bits (like dired-mark-directories) will cease to work properly. - (if (= bol eol) - (if raise-error - (error "No file on this line") - nil) - ;; skip marker, if any - (goto-char bol) - (forward-char)) - ;; If we not going to use the l switch, and use nstd listings, - ;; then we must bomb on files starting with spaces. - (skip-chars-forward " \t") - (point)))) - -(defun dired-manual-move-to-end-of-filename (&optional no-error bol eol) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* - ;; line if at all. So, it should be called only after - ;; (dired-move-to-filename t). - ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). - ;; This is the UNIX version. - (let ((bof (point)) - file-type modes-start case-fold-search) - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) - (and - (null no-error) - selective-display - (eq (char-after (1- bol)) ?\r) - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (if (or (memq ?l dired-internal-switches) - (memq ?g dired-internal-switches)) - (if (save-excursion - (goto-char bol) - (re-search-forward - "[^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ][-+ 0-9+]" - bof t)) - (progn - (setq modes-start (match-beginning 0) - file-type (char-after modes-start)) - ;; Move point to end of name: - (if (eq file-type ?l) ; symlink - (progn - (if (search-forward " -> " eol t) - (goto-char (match-beginning 0)) - (goto-char eol)) - (and dired-ls-F-marks-symlinks - (eq (preceding-char) ?@) ; link really marked? - (memq ?F dired-internal-switches) - (forward-char -1)) - (point)) - ;; else not a symbolic link - (goto-char eol) - ;; ls -lF marks dirs, sockets and executables with exactly - ;; one trailing character. -F may not actually be honored, - ;; e.g. by an FTP ls in efs - (and - (memq ?F dired-internal-switches) - (let ((char (preceding-char))) - (or (and (eq char ?*) (or - (memq - (char-after (+ modes-start 3)) - '(?x ?s ?t)) - (memq - (char-after (+ modes-start 6)) - '(?x ?s ?t)) - (memq - (char-after (+ modes-start 9)) - '(?x ?s ?t)))) - (and (eq char ?=) (eq file-type ?s)))) - (forward-char -1)) - ;; Skip back over /'s unconditionally. It's not a valid - ;; file name character. - (skip-chars-backward "/") - (point))) - (and (null no-error) - (error "No file on this line"))) - - ;; A brief listing - (if (eq (point) eol) - (and (null no-error) - (error "No file on this line")) - (goto-char eol) - (if (and (memq (preceding-char) '(?@ ?* ?=)) - (memq ?F dired-internal-switches)) - ;; A guess, since without a long listing, we can't be sure. - (forward-char -1)) - (skip-chars-backward "/") - (point))))) - -(defun dired-goto-next-nontrivial-file () - ;; Position point on first nontrivial file after point. - ;; Does not move into the next sudir. - ;; If point is on a file line, moves to that file. - ;; This does not move to omitted files. - (skip-chars-backward "^\n\r") - (if (= (preceding-char) ?\r) - (forward-line 1)) - (let ((max (dired-subdir-max)) - file) - (while (and (or (not (setq file (dired-get-filename 'no-dir t))) - (string-match dired-trivial-filenames file)) - (< (point) max)) - (forward-line 1))) - (dired-move-to-filename)) - -(defun dired-goto-next-file () - ;; Doesn't move out of current subdir. Does go to omitted files. - ;; Returns the starting position of the file, or nil if none found. - (let ((max (dired-subdir-max)) - found) - (while (and (null (setq found (dired-move-to-filename))) (< (point) max)) - (skip-chars-forward "^\n\r") - (forward-char 1)) - found)) - -;; fluid vars used by dired-goto-file-completer -(defvar dired-completer-buffer nil) -(defvar dired-completer-switches nil) -(defvar dired-completer-cache nil) - -(defun dired-goto-file-completer (string pred action) - (save-excursion - (set-buffer dired-completer-buffer) - (let* ((saved-md (match-data)) - (file (file-name-nondirectory string)) - (dir (file-name-directory string)) - (xstring (expand-file-name string)) - (xdir (file-name-directory xstring)) - (exact (dired-goto-file xstring))) - (unwind-protect - (if (dired-goto-subdir xdir) - (let ((table (cdr (assoc xdir dired-completer-cache))) - fn result max) - (or table - (progn - (setq table (make-vector 37 0)) - (mapcar (function - (lambda (ent) - (setq ent (directory-file-name - (car ent))) - (if (string-equal - (file-name-directory ent) xdir) - (intern - (concat - (file-name-nondirectory ent) "/") - table)))) - dired-subdir-alist) - (or (looking-at "\\.\\.\\.\n\r") - (progn - (setq max (dired-subdir-max)) - (while (and - (< (point) max) - (not - (setq fn - (dired-get-filename 'no-dir t)))) - (forward-line 1)) - (if fn - (progn - (or (intern-soft (concat fn "/") table) - (intern fn table)) - (forward-line 1) - (while (setq fn - (dired-get-filename 'no-dir t)) - (or (intern-soft (concat fn "/") table) - (intern fn table)) - (forward-line 1)))))) - (setq dired-completer-cache (cons - (cons xdir table) - dired-completer-cache)))) - (cond - ((null action) - (setq result (try-completion file table)) - (if exact - (if (stringp result) - string - t) - (if (stringp result) - (concat dir result) - result))) - ((eq action t) - (setq result (all-completions file table)) - (if exact (cons "." result) result)) - ((eq 'lambda action) - (and (or exact (intern-soft file table))))))) - (store-match-data saved-md))))) - -(defun dired-really-goto-file (file) - ;; Goes to a file, even if it needs to insert it parent directory. - (or (dired-goto-file file) - (progn ; refresh and try again - (dired-insert-subdir (file-name-directory file)) - (dired-goto-file file)))) - -(defun dired-between-files () - ;; Point must be at beginning of line - (save-excursion (not (dired-move-to-filename nil (point))))) - -(defun dired-repeat-over-lines (arg function) - ;; This version skips non-file lines. - ;; Skips file lines hidden with selective display. - ;; BACKWARDS means move backwards after each action. This is not the same - ;; as a negative arg, as that skips the current line. - (beginning-of-line) - (let* ((advance (cond ((> arg 0) 1) ((< arg 0) -1) (t nil))) - (check-fun (if (eq advance 1) 'eobp 'bobp)) - (n (if (< arg 0) (- arg) arg)) - (wall (funcall check-fun)) - (done wall)) - (while (not done) - (if advance - (progn - (while (not (or (save-excursion (dired-move-to-filename)) - (setq wall (funcall check-fun)))) - (forward-line advance)) - (or wall - (progn - (save-excursion (funcall function)) - (forward-line advance) - (while (not (or (save-excursion (dired-move-to-filename)) - (setq wall (funcall check-fun)))) - (forward-line advance)) - (setq done (or (zerop (setq n (1- n))) wall))))) - (if (save-excursion (dired-move-to-filename)) - (save-excursion (funcall function))) - (setq done t)))) - (dired-move-to-filename) - ;; Note that if possible the point has now been moved to the beginning of - ;; the file name. - (dired-update-mode-line)) - - -;;;; ---------------------------------------------------------------- -;;;; Miscellaneous dired commands -;;;; ---------------------------------------------------------------- - -(defun dired-quit () - "Bury the current dired buffer." - (interactive) - (bury-buffer)) - -(defun dired-undo () - "Undo in a dired buffer. -This doesn't recover lost files, it is just normal undo with temporarily -writeable buffer. You can use it to recover marks, killed lines or subdirs." - (interactive) - (let ((lines (count-lines (point-min) (point-max))) - buffer-read-only) - (undo) - ;; reset dired-subdir-alist, if a dir may have been affected - ;; Is there a better way to guess this? - (setq lines (- (count-lines (point-min) (point-max)) lines)) - (if (or (>= lines 2) (<= lines -2)) - (dired-build-subdir-alist))) - (dired-update-mode-line-modified t) - (dired-update-mode-line t)) - - -;;;; -------------------------------------------------------- -;;;; Immediate actions on files: visiting, viewing, etc. -;;;; -------------------------------------------------------- - -(defun dired-find-file () - "In dired, visit the file or directory named on this line." - (interactive) - (let ((find-file-run-dired t)) - (find-file (dired-get-filename)))) - -(defun dired-view-file () - "In dired, examine a file in view mode, returning to dired when done. -When file is a directory, show it in this buffer if it is inserted; -otherwise, display it in another buffer." - (interactive) - (let ((file (dired-get-filename))) - (if (file-directory-p file) - (or (dired-goto-subdir file) - (dired file)) - (view-file file)))) - -(defun dired-find-file-other-window (&optional displayp) - "In dired, visit this file or directory in another window. -With a prefix, the file is displayed, but the window is not selected." - (interactive "P") - (if displayp - (dired-display-file) - (let ((find-file-run-dired t)) - (find-file-other-window (dired-get-filename))))) - -;; Only for Emacs 19 -(defun dired-find-file-other-frame () - "In dired, visit this file or directory in another frame." - (interactive) - (let ((find-file-run-dired t)) - (find-file-other-frame (dired-get-filename)))) - -(defun dired-display-file () - "In dired, displays this file or directory in the other window." - (interactive) - (let ((find-file-run-dired t)) - (display-buffer (find-file-noselect (dired-get-filename))))) - -;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). -(defun dired-do-find-file (&optional arg) - "Visit all marked files at once, and display them simultaneously. -See also function `simultaneous-find-file'. -If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. -If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." - (interactive "P") - (dired-simultaneous-find-file (dired-get-marked-files nil arg))) - -(defun dired-simultaneous-find-file (file-list) - "Visit all files in FILE-LIST and display them simultaneously. - -The current window is split across all files in FILE-LIST, as evenly -as possible. Remaining lines go to the bottommost window. - -The number of files that can be displayed this way is restricted by -the height of the current window and the variable `window-min-height'." - ;; It is usually too clumsy to specify FILE-LIST interactively - ;; unless via dired (dired-do-find-file). - (let ((size (/ (window-height) (length file-list)))) - (or (<= window-min-height size) - (error "Too many files to visit simultaneously")) - (find-file (car file-list)) - (setq file-list (cdr file-list)) - (while file-list - ;; Split off vertically a window of the desired size - ;; The upper window will have SIZE lines. We select the lower - ;; (larger) window because we want to split that again. - (select-window (split-window nil size)) - (let ((find-file-run-dired t)) - (find-file (car file-list))) - (setq file-list (cdr file-list))))) - -(defun dired-create-directory (directory) - "Create a directory called DIRECTORY." - (interactive - (list (read-file-name "Create directory: " - (dired-abbreviate-file-name - (dired-current-directory))))) - (let ((expanded (expand-file-name directory))) - (make-directory expanded) - ;; Because this function is meant to be called interactively, it moves - ;; the point. - (dired-goto-file expanded))) - -(defun dired-recover-file () - "Recovers file from its autosave file. -If the file is an autosave file, then recovers its associated file instead." - (interactive) - (let* ((file (dired-get-filename)) - (name (file-name-nondirectory file)) - (asp (auto-save-file-name-p name)) - (orig (and - asp - (if (fboundp 'auto-save-original-name) - (auto-save-original-name file) - (error - "Need auto-save package to compute original file name.")))) - (buff (if asp - (and orig (get-file-buffer orig)) - (get-file-buffer file)))) - (and - buff - (buffer-modified-p buff) - (or - (yes-or-no-p - (format - "Recover file will erase the modified buffer %s. Do it? " - (buffer-name buff))) - (error "Recover file aborted."))) - (if asp - (if orig - (recover-file orig) - (find-file file)) - (recover-file file)))) - - -;;;; -------------------------------------------------------------------- -;;;; Functions for extracting and manipulating file names -;;;; -------------------------------------------------------------------- - -(defun dired-make-filename-string (filename &optional reverse) - ;; Translates the way that a file name appears in a buffer, to - ;; how it is used in a path name. This is useful for non-unix - ;; support in efs. - filename) - -(defun dired-get-filename (&optional localp no-error-if-not-filep) - "In dired, return name of file mentioned on this line. -Value returned normally includes the directory name. -Optional arg LOCALP with value `no-dir' means don't include directory - name in result. A value of t means use path name relative to - `default-directory', which still may contain slashes if in a subdirectory. -Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on - this line, otherwise an error occurs." - - ;; Compute bol & eol once, rather than twice inside move-to-filename - ;; and move-to-end-of-filename - (let ((eol (save-excursion (skip-chars-forward "^\n\r") (point))) - (bol (save-excursion (skip-chars-backward "^\r\n") (point))) - case-fold-search file p1 p2) - (save-excursion - (and - (setq p1 (dired-move-to-filename (not no-error-if-not-filep) bol eol)) - (setq p2 (if (eq system-type 'windows-nt) ; ignore carriage-return at eol - (1- (dired-move-to-end-of-filename no-error-if-not-filep bol eol)) - (dired-move-to-end-of-filename no-error-if-not-filep bol eol))) - (setq file (buffer-substring p1 p2)) - ;; Check if ls quoted the names, and unquote them. - ;; Using read to unquote is much faster than substituting - ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. - (cond ((memq ?b dired-internal-switches) ; System V ls - ;; This case is about 20% slower than without -b. - (setq file - (read - (concat "\"" - ;; some ls -b don't escape quotes, argh! - ;; This is not needed for GNU ls, though. - (or (dired-string-replace-match - "\\([^\\]\\)\"" file "\\1\\\\\"") - file) - "\"")))) - ;; If you do this, update dired-compatible-switches-p - ;; ((memq ?Q dired-internal-switches) ; GNU ls - ;; (setq file (read file))) - ))) - (and file - (if (eq localp 'no-dir) - (dired-make-filename-string file) - (concat (dired-current-directory localp) - (dired-make-filename-string file)))))) - -(defun dired-make-relative (file &optional dir no-error) - ;; Convert FILE (an *absolute* pathname) to a pathname relative to DIR. - ;; FILE must be absolute, or this function will return nonsense. - ;; If FILE is not in a subdir of DIR, an error is signalled, - ;; unless NO-ERROR is t. Then, ".."'s are inserted to give - ;; a relative representation of FILE wrto DIR - ;; eg. FILE = /vol/tex/bin/foo DIR = /vol/local/bin/ - ;; results in ../../tex/bin/foo - ;; DIR must be expanded. - ;; DIR defaults to default-directory. - ;; DIR must be file-name-as-directory, as with all directory args in - ;; elisp code. - (or dir (setq dir (expand-file-name default-directory))) - (let ((flen (length file)) - (dlen (length dir))) - (if (and (> flen dlen) - (string-equal (substring file 0 dlen) dir)) - (substring file dlen) - ;; Need to insert ..'s - (or no-error (error "%s: not in directory tree growing at %s" file dir)) - (if (string-equal file dir) - "./" - (let ((index 1) - (count 0)) - (while (and (string-match "/" dir index) - (<= (match-end 0) flen) - (string-equal (substring file index (match-end 0)) - (substring dir index (match-end 0)))) - (setq index (match-end 0))) - (setq file (substring file index)) - (if (and (/= flen index) - (not (string-match "/" file)) - (< flen dlen) - (string-equal file (substring dir index flen)) - (= (aref dir flen) ?/)) - (setq file "." - count -1)) - ;; count how many slashes remain in dir. - (while (string-match "/" dir index) - (setq index (match-end 0) - count (1+ count))) - (apply 'concat (nconc (make-list count "../") (list file)))))))) - -;;; Functions for manipulating file names. -;; -;; Used by file tranformers. -;; Define here rather than in dired-shell.el, as it wouldn't be -;; unreasonable to use these elsewhere. - -(defun dired-file-name-base (fn) - "Returns the base name of FN. -This is the file without directory part, and extension. See the variable -`dired-filename-re-ext'." - (setq fn (file-name-nondirectory fn)) - (if (string-match dired-filename-re-ext fn 1) - (substring fn 0 (match-beginning 0)) - fn)) - -(defun dired-file-name-extension (fn) - "Returns the extension for file name FN. -See the variable dired-filename-re-ext'." - (setq fn (file-name-nondirectory fn)) - (if (string-match dired-filename-re-ext fn 1) - (substring fn (match-beginning 0)) - "")) - -(defun dired-file-name-sans-rcs-extension (fn) - "Returns the file name FN without its RCS extension \",v\"." - (setq fn (file-name-nondirectory fn)) - (if (string-match ",v\\'" fn 1) - (substring fn 0 (match-beginning 0)) - fn)) - -(defun dired-file-name-sans-compress-extension (fn) - "Returns the file name FN without the extension from compress or gzip." - (setq fn (file-name-nondirectory fn)) - (if (string-match "\\.\\([zZ]\\|gz\\)\\'" fn 1) - (substring fn (match-beginning 0)) - fn)) - - -;;;; --------------------------------------------------------------------- -;;;; Working with directory trees. -;;;; --------------------------------------------------------------------- -;;; -;;; This where code for the dired-subdir-alist is. - -;;; Utility functions for dired-subdir-alist - -(defun dired-normalize-subdir (dir) - ;; Prepend default-directory to DIR if relative path name. - ;; dired-get-filename must be able to make a valid filename from a - ;; file and its directory DIR. - ;; Fully expand everything. - (file-name-as-directory - (if (file-name-absolute-p dir) - (expand-file-name dir) - (expand-file-name dir (expand-file-name default-directory))))) - -(defun dired-get-subdir () - ;;"Return the subdir name on this line, or nil if not on a headerline." - ;; Look up in the alist whether this is a headerline. - (save-excursion - (let ((cur-dir (dired-current-directory))) - (beginning-of-line) ; alist stores b-o-l positions - (and (zerop (- (point) - (dired-get-subdir-min (assoc cur-dir - dired-subdir-alist)))) - cur-dir)))) - -(defun dired-get-subdir-max (elt) - ;; returns subdir max. - (let ((pos (- (length dired-subdir-alist) - (length (member elt dired-subdir-alist))))) - (if (zerop pos) - (point-max) - (1- (dired-get-subdir-min (nth (1- pos) dired-subdir-alist)))))) - -(defun dired-clear-alist () - ;; Set all markers in dired-subdir-alist to nil. Set the alist to nil too. - (while dired-subdir-alist - (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) - (setq dired-subdir-alist (cdr dired-subdir-alist)))) - -(defun dired-unsubdir (dir) - ;; Remove DIR from the alist - (setq dired-subdir-alist - (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) - -(defun dired-simple-subdir-alist () - ;; Build and return `dired-subdir-alist' assuming just the top level - ;; directory to be inserted. Don't parse the buffer. - (setq dired-subdir-alist - (list (list (expand-file-name default-directory) - (point-min-marker) dired-omit-files - dired-internal-switches nil))) - (if dired-verify-modtimes - (dired-set-file-modtime (expand-file-name default-directory) - dired-subdir-alist))) - -(defun dired-build-subdir-alist () - "Build `dired-subdir-alist' by parsing the buffer and return its new value." - (interactive) - (let ((o-alist dired-subdir-alist) - (count 0) - subdir) - (dired-clear-alist) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward dired-subdir-regexp nil t) - (setq count (1+ count)) - (apply 'dired-alist-add-1 - (setq subdir (buffer-substring (match-beginning 2) - (match-end 2))) - ;; Put subdir boundary between lines. - (set-marker (make-marker) (match-end 1)) - (let ((elt (assoc subdir o-alist))) - (if elt - (list (nth 2 elt) (nth 3 elt)) - (list dired-omit-files dired-internal-switches))))) - (if (interactive-p) - (message "%d director%s." count (if (= 1 count) "y" "ies"))) - ;; We don't need to sort it because it is in buffer order per - ;; constructionem. Return new alist: - ;; pointers for current-subdir may be stale - dired-subdir-alist))) - -(defun dired-alist-add (dir new-marker &optional omit switches) - ;; Add new DIR at NEW-MARKER. Sort alist. - (dired-alist-add-1 dir new-marker omit switches) - (dired-alist-sort)) - -(defun dired-alist-add-1 (dir new-marker &optional omit switches) - ;; Add new DIR at NEW-MARKER. Don't sort. - (let ((dir (dired-normalize-subdir dir))) - (setq dired-subdir-alist - (cons (list dir new-marker omit switches nil) dired-subdir-alist)) - (if dired-verify-modtimes - (dired-set-file-modtime dir dired-subdir-alist)))) - -(defun dired-alist-sort () - ;; Keep the alist sorted on buffer position. - (setq dired-subdir-alist - (sort dired-subdir-alist - (function (lambda (elt1 elt2) - (> (dired-get-subdir-min elt1) - (dired-get-subdir-min elt2))))))) - -;;; Utilities for working with subdirs in the dired buffer - -;; This function is the heart of tree dired. -;; It is called for each retrieved filename. -;; It could stand to be faster, though it's mostly function call -;; overhead. Avoiding to funcall seems to save about 10% in -;; dired-get-filename. Make it a defsubst? -(defun dired-current-directory (&optional localp) - "Return the name of the subdirectory to which this line belongs. -This returns a string with trailing slash, like `default-directory'. -Optional argument means return a file name relative to `default-directory'. -In this it returns \"\" for the top directory." - (let* ((here (point)) - (dir (catch 'done - (mapcar (function - (lambda (x) - (if (<= (dired-get-subdir-min x) here) - (throw 'done (car x))))) - dired-subdir-alist)))) - (if (listp dir) (error "dired-subdir-alist seems to be mangled")) - (if localp - (let ((def-dir (expand-file-name default-directory))) - (if (string-equal dir def-dir) - "" - (dired-make-relative dir def-dir))) - dir))) - -;; Subdirs start at the beginning of their header lines and end just -;; before the beginning of the next header line (or end of buffer). - -(defun dired-subdir-min () - ;; Returns the minimum position of the current subdir - (save-excursion - (if (not (dired-prev-subdir 0 t t)) - (error "Not in a subdir!") - (point)))) - -(defun dired-subdir-max () - ;; Returns the maximum position of the current subdir - (save-excursion - (if (dired-next-subdir 1 t t) - (1- (point)) ; Do not include separating empty line. - (point-max)))) - - -;;;; -------------------------------------------------------- -;;;; Deleting files -;;;; -------------------------------------------------------- - -(defun dired-flag-file-deletion (arg) - "In dired, flag the current line's file for deletion. -With prefix arg, repeat over several lines. - -If on a subdir headerline, mark all its files except `.' and `..'." - (interactive "p") - (dired-mark arg dired-del-marker)) - -(defun dired-flag-file-deletion-backup (arg) - "Flag current file for deletion, and move to previous line. -With a prefix ARG, repeats this ARG times." - (interactive "p") - ;; Use dired-mark-file and not dired-mark, as this function - ;; should do nothing special on subdir headers. - (dired-mark-file (- arg) dired-del-marker)) - -(defun dired-flag-subdir-files () - "Flag all the files in the current subdirectory for deletion." - (interactive) - (dired-mark-subdir-files dired-del-marker)) - -(defun dired-unflag (arg) - "In dired, remove a deletion flag from the current line's file. -Optional prefix ARG says how many lines to unflag." - (interactive "p") - (let (buffer-read-only) - (dired-repeat-over-lines - arg - (function - (lambda () - (if (char-equal (following-char) dired-del-marker) - (progn - (setq dired-del-flags-number (max (1- dired-del-flags-number) 0)) - (dired-substitute-marker (point) dired-del-marker ?\ ))))))) - (dired-update-mode-line-modified)) - -(defun dired-backup-unflag (arg) - "In dired, move up lines and remove deletion flag there. -Optional prefix ARG says how many lines to unflag; default is one line." - (interactive "p") - (dired-unflag (- arg))) - -(defun dired-update-marker-counters (char &optional remove) - (or (memq char '(?\ ?\n ?\r)) - (let ((counter (cond - ((char-equal char dired-del-marker) - 'dired-del-flags-number) - ((char-equal char dired-marker-char) - 'dired-marks-number) - ('dired-other-marks-number)))) - (if remove - (set counter (max (1- (symbol-value counter)) 0)) - (set counter (1+ (symbol-value counter))))))) - -(defun dired-update-mode-line-modified (&optional check) - ;; Updates the value of mode-line-modified in dired. - ;; Currently assumes that it's of the form "-%%-", where % sometimes - ;; gets replaced by %. Should allow some sort of config flag. - ;; SET is t to set to -DD-, nil to set to -%%-, and 'check means - ;; examine the buffer to find out. - (if check - (save-excursion - (let (char) - (goto-char (point-min)) - (setq dired-del-flags-number 0 - dired-marks-number 0 - dired-other-marks-number 0) - (while (not (eobp)) - (setq char (following-char)) - (cond - ((char-equal char dired-del-marker) - (setq dired-del-flags-number (1+ dired-del-flags-number))) - ((char-equal char dired-marker-char) - (setq dired-marks-number (1+ dired-marks-number))) - ((memq char '(?\ ?\n ?\r)) - nil) - ((setq dired-other-marks-number (1+ dired-other-marks-number)))) - (forward-line 1))))) - (setq mode-line-modified - (format dired-mode-line-modified - (if (zerop dired-del-flags-number) - "--" - (format "%d%c" dired-del-flags-number dired-del-marker)) - (if (zerop dired-marks-number) - "--" - (format "%d%c" dired-marks-number dired-marker-char)) - (if (zerop dired-other-marks-number) - "-" - (int-to-string dired-other-marks-number)))) - (set-buffer-modified-p (buffer-modified-p))) - -(defun dired-do-deletions (&optional nomessage) - (dired-expunge-deletions)) - -(defun dired-expunge-deletions () - "In dired, delete the files flagged for deletion." - (interactive) - (let ((files (let ((dired-marker-char dired-del-marker)) - (dired-map-over-marks (cons (dired-get-filename) (point)) - t)))) - (if files - (progn - (dired-internal-do-deletions files nil dired-del-marker) - ;; In case the point gets left somewhere strange -- hope that - ;; this doesn't cause asynch troubles later. - (beginning-of-line) - (dired-goto-next-nontrivial-file) - (dired-update-mode-line-modified t)) ; play safe, it's cheap - (message "(No deletions requested)")))) - -(defun dired-do-delete (&optional arg) - "Delete all marked (or next ARG) files." - ;; This is more consistent with the file marking feature than - ;; dired-expunge-deletions. - (interactive "P") - (dired-internal-do-deletions - ;; this may move point if ARG is an integer - (dired-map-over-marks (cons (dired-get-filename) (point)) - arg) - arg) - (beginning-of-line) - (dired-goto-next-nontrivial-file)) - -(defun dired-internal-do-deletions (l arg &optional marker-char) - ;; L is an alist of files to delete, with their buffer positions. - ;; ARG is the prefix arg. - ;; Filenames are absolute (VMS needs this for logical search paths). - ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. - ;; That way as changes are made in the buffer they do not shift the - ;; lines still to be changed, so the (point) values in L stay valid. - ;; Also, for subdirs in natural order, a subdir's files are deleted - ;; before the subdir itself - the other way around would not work. - (save-excursion - (let ((files (mapcar (function car) l)) - (count (length l)) - (succ 0) - (cdir (dired-current-directory)) - failures) - ;; canonicalize file list for pop up - (setq files (nreverse (mapcar (function - (lambda (fn) - (dired-make-relative fn cdir t))) - files))) - (if (or (memq 'delete dired-no-confirm) - (dired-mark-pop-up - " *Files Flagged for Deletion*" 'delete files - dired-deletion-confirmer - (format "Delete %s " - (dired-mark-prompt arg files marker-char)))) - (save-excursion - ;; files better be in reverse order for this loop! - (while l - (goto-char (cdr (car l))) - (condition-case err - (let ((fn (car (car l)))) - ;; This test is equivalent to - ;; (and (file-directory-p fn) - ;; (not (file-symlink-p fn))) - ;; but more efficient - (if (if (eq t (car (file-attributes fn))) - (if (<= (length (directory-files fn)) 2) - (progn (delete-directory fn) t) - (and (or - (memq 'recursive-delete dired-no-confirm) - (funcall - dired-deletion-confirmer - (format "\ -Recursively delete directory and files within %s? " - (dired-make-relative fn)))) - (progn - (dired-recursive-delete-directory fn) - t))) - (progn (delete-file fn) t)) - (progn - (setq succ (1+ succ)) - (message "%s of %s deletions" succ count) - (dired-clean-up-after-deletion fn)))) - (error;; catch errors from failed deletions - (dired-log (buffer-name (current-buffer)) "%s\n" err) - (setq failures (cons (car (car l)) failures)))) - (setq l (cdr l))))) - (if failures - (dired-log-summary - (buffer-name (current-buffer)) - (format "%d of %d deletion%s failed:" (length failures) count - (dired-plural-s count)) - failures) - (if (zerop succ) - (message "(No deletions performed)") - (message "%d deletion%s done" succ (dired-plural-s succ))))))) - -(defun dired-recursive-delete-directory (fn) - ;; Recursively deletes directory FN, and all of its contents. - (let* ((fn (expand-file-name fn)) - (handler (find-file-name-handler - fn 'dired-recursive-delete-directory))) - (if handler - (funcall handler 'dired-recursive-delete-directory fn) - (progn - (or (file-exists-p fn) - (signal - 'file-error - (list "Removing old file name" "no such directory" fn))) - ;; Which is better, -r or -R? - (call-process "rm" nil nil nil "-r" (directory-file-name fn)) - (and (file-exists-p fn) - (error "Failed to recusively delete %s" fn)))))) - -(defun dired-clean-up-after-deletion (fn) - ;; Offer to kill buffer of deleted file FN. - (let ((buf (get-file-buffer fn))) - (and buf - (or (memq 'kill-file-buffer dired-no-confirm) - (funcall (function yes-or-no-p) - (format "Kill buffer of %s, too? " - (file-name-nondirectory fn)))) - (save-excursion ; you never know where kill-buffer leaves you - (kill-buffer buf))))) - -;;; Cleaning a directory -- flagging backups for deletion - -(defun dired-clean-directory (keep &optional marker msg) - "Flag numerical backups for deletion. -Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. -Positive prefix arg KEEP overrides `dired-kept-versions'; -Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. - -To clear the flags on these files, you can use \\[dired-flag-backup-files] -with a prefix argument." - (interactive "P") - (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) - (let* ((early-retention (if (< keep 0) (- keep) kept-old-versions)) - (late-retention (if (<= keep 0) dired-kept-versions keep)) - (msg (or msg - (format - "Cleaning numerical backups (keeping %d late, %d old)" - late-retention early-retention))) - (trample-marker (or marker dired-del-marker)) - (file-version-assoc-list)) - (message "%s..." msg) - ;; Do this after messaging, as it may take a while. - (setq file-version-assoc-list (dired-collect-file-versions)) - ;; Sort each VERSION-NUMBER-LIST, - ;; and remove the versions to be deleted. - (let ((fval file-version-assoc-list)) - (while fval - (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) - (v-count (length sorted-v-list))) - (if (> v-count (+ early-retention late-retention)) - (rplacd (nthcdr early-retention sorted-v-list) - (nthcdr (- v-count late-retention) - sorted-v-list))) - (rplacd (car fval) - (cdr sorted-v-list))) - (setq fval (cdr fval)))) - ;; Look at each file. If it is a numeric backup file, - ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. - (dired-map-dired-file-lines (function - (lambda (fn) - (dired-trample-file-versions - fn file-version-assoc-list - trample-marker)))) - (message "%s...done" msg))) - -(defun dired-collect-file-versions () - ;; If it looks like a file has versions, return a list of the versions. - ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) - (let (result) - (dired-map-dired-file-lines - (function - (lambda (fn) - (let* ((base-versions - (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn)))) - (if possibilities - (setq result (cons (cons fn - (mapcar 'backup-extract-version - possibilities)) result))))))) - result)) - -(defun dired-trample-file-versions (fn alist marker) - ;; ALIST is an alist of filenames and versions used to determine - ;; if each file should be flagged for deletion. - ;; This version using file-name-sans-versions is probably a lot slower - ;; than Sebastian's original, but it is more easily adaptable to non-unix. - (let ((base (file-name-sans-versions fn)) - base-version-list bv-length) - (and (not (string-equal base fn)) - (setq base-version-list (assoc base alist)) - (setq bv-length (string-match "[0-9]" fn (length base))) - (not (memq (backup-extract-version fn) base-version-list)) - (progn (skip-chars-backward "^\n\r") - (bolp)) ; make sure the preceding char isn't \r. - (dired-substitute-marker (point) (following-char) marker)))) - -(defun dired-map-dired-file-lines (fun) - ;; Perform FUN with point at the end of each non-directory line. - ;; FUN takes one argument, the filename (complete pathname). - (dired-check-ls-l) - (save-excursion - (let (file buffer-read-only) - (goto-char (point-min)) - (while (not (eobp)) - (save-excursion - (and (not (and dired-re-dir (looking-at dired-re-dir))) - (not (memq (following-char) '(?\n ?\n))) - (setq file (dired-get-filename nil t)) ; nil on non-file - (progn (skip-chars-forward "^\n\r") - (funcall fun file)))) - (forward-line 1))))) ; this guarantees that we don't - ; operate on omitted files. - - -;;;; ----------------------------------------------------------- -;;;; Confirmations and prompting the user. -;;;; ----------------------------------------------------------- - -(defun dired-plural-s (count) - (if (= 1 count) "" "s")) - -(defun dired-mark-prompt (arg files &optional marker-char) - ;; Return a string for use in a prompt, either the current file - ;; name, or the marker and a count of marked files. - (let ((count (length files))) - (if (= count 1) - (car files) - ;; more than 1 file: - (if (integerp arg) - (cond ((zerop arg) "[no files]") - ((> arg 0) "[following]") - ((< arg 0) "[preceding]")) - (char-to-string (or marker-char dired-marker-char)))))) - -(defun dired-pop-to-buffer (buf) - ;; Pop up buffer BUF. - ;; Make its window fit its contents. - (let ((window (selected-window)) - target-lines w2) - (cond ;; if split-window-threshold is enabled, use the largest window - ((and (> (window-height (setq w2 (get-largest-window))) - split-height-threshold) - (= (frame-width) (window-width w2))) - (setq window w2)) - ;; if the least-recently-used window is big enough, use it - ((and (> (window-height (setq w2 (get-lru-window))) - (* 2 window-min-height)) - (= (frame-width) (window-width w2))) - (setq window w2))) - (save-excursion - (set-buffer buf) - (goto-char (point-max)) - (skip-chars-backward "\n\r\t ") - (setq target-lines (count-lines (point-min) (point))) - ;; Don't forget to count the last line. - (if (not (bolp)) - (setq target-lines (1+ target-lines)))) - (if (<= (window-height window) (* 2 window-min-height)) - ;; At this point, every window on the frame is too small to split. - (setq w2 (display-buffer buf)) - (setq w2 (split-window - window - (max window-min-height - (- (window-height window) - (1+ (max window-min-height target-lines))))))) - (set-window-buffer w2 buf) - (if (< (1- (window-height w2)) target-lines) - (progn - (select-window w2) - (enlarge-window (- target-lines (1- (window-height w2)))))) - (set-window-start w2 1))) - -(defun dired-mark-pop-up (bufname op-symbol files function &rest args) - ;; Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. - ;; Return FUNCTION's result on ARGS after popping up a window (in a buffer - ;; named BUFNAME, nil gives \" *Marked Files*\") showing the marked - ;; files. Uses function `dired-pop-to-buffer' to do that. - ;; FUNCTION should not manipulate files. - ;; It should only read input (an argument or confirmation). - ;; The window is not shown if there is just one file or - ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. - ;; FILES is the list of marked files. - (if (memq op-symbol dired-no-confirm) - (apply function args) - (or bufname (setq bufname " *Marked Files*")) - (if (<= (length files) 1) - (apply function args) - (save-excursion - (let ((standard-output (set-buffer (get-buffer-create bufname)))) - (erase-buffer) - (dired-format-columns-of-files files) - (dired-remove-text-properties (point-min) (point-max)) - (setq mode-line-format (format " %s [%d files]" - bufname (length files))))) - (save-window-excursion - (dired-pop-to-buffer bufname) - (apply function args))))) - -(defun dired-column-widths (columns list &optional across) - ;; Returns the column widths for breaking LIST into - ;; COLUMNS number of columns. - (cond - ((null list) - nil) - ((= columns 1) - (list (apply 'max (mapcar 'length list)))) - ((let* ((len (length list)) - (col-length (/ len columns)) - (remainder (% len columns)) - (i 0) - (j 0) - (max-width 0) - widths padding) - (if (zerop remainder) - (setq padding 0) - (setq col-length (1+ col-length) - padding (- columns remainder))) - (setq list (nconc (copy-sequence list) (make-list padding nil))) - (setcdr (nthcdr (1- (+ len padding)) list) list) - (while (< i columns) - (while (< j col-length) - (setq max-width (max max-width (length (car list))) - list (if across (nthcdr columns list) (cdr list)) - j (1+ j))) - (setq widths (cons (+ max-width 2) widths) - max-width 0 - j 0 - i (1+ i)) - (if across (setq list (cdr list)))) - (setcar widths (- (car widths) 2)) - (nreverse widths))))) - -(defun dired-calculate-columns (list &optional across) - ;; Returns a list of integers which are the column widths that best pack - ;; LIST, a list of strings, onto the screen. - (and list - (let* ((width (1- (window-width))) - (columns (max 1 (/ width - (+ 2 (apply 'max (mapcar 'length list)))))) - col-list last-col-list) - (while (<= (apply '+ (setq col-list - (dired-column-widths columns list across))) - width) - (setq columns (1+ columns) - last-col-list col-list)) - (or last-col-list col-list)))) - -(defun dired-format-columns-of-files (files &optional across) - ;; Returns the number of lines used. - ;; If ACROSS is non-nil, sorts across rather than down the buffer, like - ;; ls -x - (and files - (let* ((columns (dired-calculate-columns files across)) - (ncols (length columns)) - (ncols1 (1- ncols)) - (nfiles (length files)) - (nrows (+ (/ nfiles ncols) - (if (zerop (% nfiles ncols)) 0 1))) - (space-left (- (window-width) (apply '+ columns) 1)) - (i 0) - (j 0) - file padding stretch float-stretch) - (if (zerop ncols1) - (setq stretch 0 - float-stretch 0) - (setq stretch (/ space-left ncols1) - float-stretch (% space-left ncols1))) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* ncols nrows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j nrows) - (while (< i ncols) - (princ (setq file (car files))) - (setq padding (- (nth i columns) (length file))) - (or (= i ncols1) - (progn - (setq padding (+ padding stretch)) - (if (< i float-stretch) (setq padding (1+ padding))))) - (princ (make-string padding ?\ )) - (setq files (if across (cdr files) (nthcdr nrows files)) - i (1+ i))) - (princ "\n") - (setq i 0 - j (1+ j)) - (or across (setq files (cdr files)))) - nrows))) - -(defun dired-query (qs-var qs-prompt &rest qs-args) - ;; Query user and return nil or t. - ;; Store answer in symbol VAR (which must initially be bound to nil). - ;; Format PROMPT with ARGS. - ;; Binding variable help-form will help the user who types C-h. - (let* ((char (symbol-value qs-var)) - (action (cdr (assoc char dired-query-alist)))) - (cond ((eq 'yes action) - t) ; accept, and don't ask again - ((eq 'no action) - nil) ; skip, and don't ask again - (t;; no lasting effects from last time we asked - ask now - (let ((qprompt (concat qs-prompt - (if help-form - (format " [yn!q or %s] " - (key-description - (char-to-string help-char))) - " [ynq or !] "))) - (dired-in-query t) - elt) - ;; Actually it looks nicer without cursor-in-echo-area - you can - ;; look at the dired buffer instead of at the prompt to decide. - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char))) - (while (not (setq elt (assoc char dired-query-alist))) - (message "Invalid char - type %c for help." help-char) - (ding) - (sit-for 1) - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char)))) - (memq (cdr elt) '(t y yes))))))) - -(defun dired-mark-confirm (op-symbol operation arg) - ;; Request confirmation from the user that the operation described - ;; by OP-SYMBOL is to be performed on the marked files. - ;; Confirmation consists in a y-or-n question with a file list - ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. - ;; OPERATION is a string describing the operation. Used for prompting - ;; the user. - ;; The files used are determined by ARG (like in dired-get-marked-files). - (or (memq op-symbol dired-no-confirm) - (let ((files (dired-get-marked-files t arg))) - (dired-mark-pop-up nil op-symbol files (function y-or-n-p) - (concat operation " " - (dired-mark-prompt arg files) "? "))))) - -(defun dired-mark-read-file-name (prompt dir op-symbol arg files) - (dired-mark-pop-up - nil op-symbol files - (function read-file-name) - (format prompt (dired-mark-prompt arg files)) dir)) - -(defun dired-mark-read-string (prompt initial op-symbol arg files - &optional history-sym) - ;; Reading arguments with history. - ;; Read arguments for a mark command of type OP-SYMBOL, - ;; perhaps popping up the list of marked files. - ;; ARG is the prefix arg and indicates whether the files came from - ;; marks (ARG=nil) or a repeat factor (integerp ARG). - ;; If the current file was used, the list has but one element and ARG - ;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). - ;; PROMPT for a string, with INITIAL input. - (dired-mark-pop-up - nil op-symbol files - (function - (lambda (prompt initial) - (let ((hist (or history-sym - (cdr (assq op-symbol dired-op-history-alist)) - 'dired-history))) - (dired-read-with-history prompt initial hist)))) - (format prompt (dired-mark-prompt arg files)) initial)) - - -;;;; ---------------------------------------------------------- -;;;; Marking files. -;;;; ---------------------------------------------------------- - -(defun dired-mark (arg &optional char) - "Mark the current (or next ARG) files. -If on a subdir headerline, mark all its files except `.' and `..'. - -Use \\[dired-unmark-all-files] to remove all marks, -and \\[dired-unmark] to remove the mark of the current file." - (interactive "p") - (if (dired-get-subdir) - (dired-mark-subdir-files char) - (dired-mark-file arg char))) - -(defun dired-mark-file (arg &optional char) - "Mark ARG files starting from the current file line. -Optional CHAR indicates a marker character to use." - (let (buffer-read-only) - (if (memq (or char dired-marker-char) '(?\ ?\n ?\r)) - (error "Invalid marker character %c" dired-marker-char)) - (or char (setq char dired-marker-char)) - (dired-repeat-over-lines - arg - (function - (lambda () - (dired-update-marker-counters (following-char) t) - (dired-substitute-marker (point) (following-char) char) - (dired-update-marker-counters char)))) - (dired-update-mode-line-modified))) - -(defun dired-mark-subdir-files (&optional char) - "Mark all files except `.' and `..'." - (interactive) - (save-excursion - (dired-mark-files-in-region (dired-subdir-min) (dired-subdir-max) char))) - -(defun dired-unmark (arg) - "Unmark the current (or next ARG) files. -If looking at a subdir, unmark all its files except `.' and `..'." - (interactive "p") - (let (buffer-read-only) - (dired-repeat-over-lines - arg - (function - (lambda () - (let ((char (following-char))) - (or (memq char '(?\ ?\n ?\r)) - (progn - (cond - ((char-equal char dired-marker-char) - (setq dired-marks-number (max (1- dired-marks-number) 0))) - ((char-equal char dired-del-marker) - (setq dired-del-flags-number - (max (1- dired-del-flags-number) 0))) - ((setq dired-other-marks-number - (max (1- dired-other-marks-number) 0)))) - (dired-substitute-marker (point) char ?\ ))))))) - (dired-update-mode-line-modified))) - -(defun dired-mark-prefix (&optional arg) - "Mark the next ARG files with the next character typed. -If ARG is negative, marks the previous files." - (interactive "p") - (if (sit-for echo-keystrokes) - (cond - ((or (= arg 1) (zerop arg)) - (message "Mark with character?")) - ((< arg 0) - (message "Mark %d file%s moving backwards?" - (- arg) (dired-plural-s (- arg)))) - ((> arg 1) - (message "Mark %d following files with character?" arg)))) - (dired-mark arg (read-char))) - -(defun dired-change-marks (old new) - "Change all OLD marks to NEW marks. -OLD and NEW are both characters used to mark files. -With a prefix, prompts for a mark to toggle. In other words, all unmarked -files receive that mark, and all files currently marked with that mark become -unmarked." - ;; When used in a lisp program, setting NEW to nil means toggle the mark OLD. - (interactive - (let* ((cursor-in-echo-area t) - (old nil) - (new nil) - (markers (dired-mark-list)) - (default (cond ((null markers) - (error "No markers in buffer")) - ((= (length markers) 1) - (setq old (car markers))) - ((memq dired-marker-char markers) - dired-marker-char) - ;; picks the last one in the buffer. reasonable? - ((car markers))))) - (or old (setq old - (progn - (if current-prefix-arg - (message "Toggle mark (default %c): " default) - (message "Change old mark (default %c): " default)) - (read-char)))) - (if (memq old '(?\ ?\n ?\r)) (setq old default)) - (or current-prefix-arg - (setq new (progn - (message - "Change %c marks to new mark (RET means abort): " old) - (read-char)))) - (list old new))) - (let ((old-count (cond - ((char-equal old dired-marker-char) - 'dired-marks-number) - ((char-equal old dired-del-marker) - 'dired-del-flags-number) - ('dired-other-marks-number)))) - (if new - (or (memq new '(?\ ?\n ?\r)) - ;; \n and \r aren't valid marker chars. Assume that if the - ;; user hits return, he meant to abort the command. - (let ((string (format "\n%c" old)) - (new-count (cond - ((char-equal new dired-marker-char) - 'dired-marks-number) - ((char-equal new dired-del-marker) - 'dired-del-flags-number) - ('dired-other-marks-number))) - (buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (while (search-forward string nil t) - (if (char-equal (preceding-char) old) - (progn - (dired-substitute-marker (1- (point)) old new) - (set new-count (1+ (symbol-value new-count))) - (set old-count (max (1- (symbol-value old-count)) 0)))) - )))) - (save-excursion - (let ((ucount 0) - (mcount 0) - (buffer-read-only nil)) - (goto-char (point-min)) - (while (not (eobp)) - (or (dired-between-files) - (looking-at dired-re-dot) - (cond - ((= (following-char) ?\ ) - (setq mcount (1+ mcount)) - (set old-count (1+ (symbol-value old-count))) - (dired-substitute-marker (point) ?\ old)) - ((= (following-char) old) - (setq ucount (1+ ucount)) - (set old-count (max (1- (symbol-value old-count)) 0)) - (dired-substitute-marker (point) old ?\ )))) - (forward-line 1)) - (message "Unmarked %d file%s; marked %d file%s with %c." - ucount (dired-plural-s ucount) mcount - (dired-plural-s mcount) old))))) - (dired-update-mode-line-modified)) - -(defun dired-unmark-all-files (flag &optional arg) - "Remove a specific mark or any mark from every file. -With prefix arg, query for each marked file. -Type \\[help-command] at that time for help. -With a zero prefix, only counts the number of marks." - (interactive - (let* ((cursor-in-echo-area t) - executing-kbd-macro) ; for XEmacs - (list (and (not (eq current-prefix-arg 0)) - (progn (message "Remove marks (RET means all): ") (read-char))) - current-prefix-arg))) - (save-excursion - (let* ((help-form "\ -Type SPC or `y' to unflag one file, DEL or `n' to skip to next, -`!' to unflag all remaining files with no more questions.") - (allp (memq flag '(?\n ?\r))) - (count-p (eq arg 0)) - (count (if (or allp count-p) - (mapcar - (function - (lambda (elt) - (cons elt 0))) - (nreverse (dired-mark-list))) - 0)) - (msg "") - (no-query (or (not arg) count-p)) - buffer-read-only case-fold-search query) - (goto-char (point-min)) - (if (or allp count-p) - (while (re-search-forward dired-re-mark nil t) - (if (or no-query - (dired-query 'query "Unmark file `%s'? " - (dired-get-filename t))) - (let ((ent (assq (preceding-char) count))) - (if ent (setcdr ent (1+ (cdr ent)))) - (or count-p (dired-substitute-marker - (- (point) 1) (preceding-char) ?\ )))) - (forward-line 1)) - (while (search-forward (format "\n%c" flag) nil t) - (if (or no-query - (dired-query 'query "Unmark file `%s'? " - (dired-get-filename t))) - (progn - (dired-substitute-marker (match-beginning 0) flag ?\ ) - (setq count (1+ count)))))) - (if (or allp count-p) - (mapcar - (function - (lambda (elt) - (or (zerop (cdr elt)) - (setq msg (format "%s%s%d %c%s" - msg - (if (zerop (length msg)) - " " - ", ") - (cdr elt) - (car elt) - (if (= 1 (cdr elt)) "" "'s")))))) - count) - (or (zerop count) - (setq msg (format " %d %c%s" - count flag (if (= 1 count) "" "'s"))))) - (if (zerop (length msg)) - (setq msg " none") - (or count-p (dired-update-mode-line-modified t))) - (message "%s:%s" (if count-p "Number of marks" "Marks removed") msg)))) - -(defun dired-get-marked-files (&optional localp arg) - "Return the marked files' names as list of strings. -The list is in the same order as the buffer, that is, the car is the - first marked file. -Values returned are normally absolute pathnames. -Optional arg LOCALP as in `dired-get-filename'. -Optional second argument ARG forces to use other files. If ARG is an - integer, use the next ARG files. If ARG is otherwise non-nil, use - current file. Usually ARG comes from the current prefix arg." - (save-excursion - (nreverse (dired-map-over-marks (dired-get-filename localp) arg)))) - -;;; Utility functions for marking files - -(defun dired-mark-files-in-region (start end &optional char) - (let (buffer-read-only) - (if (> start end) - (error "start > end")) - (goto-char start) ; assumed at beginning of line - (or char (setq char dired-marker-char)) - (while (< (point) end) - ;; Skip subdir line and following garbage like the `total' line: - (while (and (< (point) end) (dired-between-files)) - (forward-line 1)) - (if (and (/= (following-char) char) - (not (looking-at dired-re-dot)) - (save-excursion - (dired-move-to-filename nil (point)))) - (progn - (dired-update-marker-counters (following-char) t) - (dired-substitute-marker (point) (following-char) char) - (dired-update-marker-counters char))) - (forward-line 1))) - (dired-update-mode-line-modified)) - -(defun dired-mark-list () - ;; Returns a list of all marks currently used in the buffer. - (let ((result nil) - char) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (and (not (memq (setq char (following-char)) '(?\ ?\n ?\r))) - (not (memq char result)) - (setq result (cons char result))) - (forward-line 1))) - result)) - -;;; Dynamic markers - -(defun dired-set-current-marker-string () - "Computes and returns `dired-marker-string'." - (prog1 - (setq dired-marker-string - (if dired-marker-stack - (let* ((n (+ (length dired-marker-stack) 5)) - (str (make-string n ?\ )) - (list dired-marker-stack) - (pointer dired-marker-stack-pointer)) - (setq n (1- n)) - (aset str n ?\]) - (setq n (1- n)) - (while list - (aset str n (car list)) - (if (zerop pointer) - (progn - (setq n (1- n)) - (aset str n dired-marker-stack-cursor))) - (setq n (1- n) - pointer (1- pointer) - list (cdr list))) - (aset str n dired-default-marker) - (if (zerop pointer) - (aset str 2 dired-marker-stack-cursor)) - (aset str 1 ?\[) - str) - "")) - (set-buffer-modified-p (buffer-modified-p)))) - -(defun dired-set-marker-char (c) - "Set the marker character to something else. -Use \\[dired-restore-marker-char] to restore the previous value." - (interactive "cNew marker character: ") - (and (memq c '(?\ ?\n ?\r)) (error "invalid marker char %c" c)) - (setq dired-marker-stack (cons c dired-marker-stack) - dired-marker-stack-pointer 0 - dired-marker-char c) - (dired-update-mode-line-modified t) - (dired-set-current-marker-string)) - -(defun dired-restore-marker-char () - "Restore the marker character to its previous value. -Uses `dired-default-marker' if the marker stack is empty." - (interactive) - (setq dired-marker-stack (cdr dired-marker-stack) - dired-marker-char (car dired-marker-stack) - dired-marker-stack-pointer (min dired-marker-stack-pointer - (length dired-marker-stack))) - (or dired-marker-char - (setq dired-marker-char dired-default-marker)) - (dired-set-current-marker-string) - (dired-update-mode-line-modified t) - (or dired-marker-stack (message "Marker is %c" dired-marker-char))) - -(defun dired-marker-stack-left (n) - "Moves the marker stack cursor to the left." - (interactive "p") - (let ((len (1+ (length dired-marker-stack)))) - (or dired-marker-stack (error "Dired marker stack is empty.")) - (setq dired-marker-stack-pointer - (% (+ dired-marker-stack-pointer n) len)) - (if (< dired-marker-stack-pointer 0) - (setq dired-marker-stack-pointer (+ dired-marker-stack-pointer - len))) - (dired-set-current-marker-string) - (setq dired-marker-char - (if (= dired-marker-stack-pointer (1- len)) - dired-default-marker - (nth dired-marker-stack-pointer dired-marker-stack)))) - (dired-update-mode-line-modified t)) - -(defun dired-marker-stack-right (n) - "Moves the marker stack cursor to the right." - (interactive "p") - (dired-marker-stack-left (- n))) - -;;; Commands to mark or flag files based on their characteristics or names. - -(defun dired-mark-symlinks (&optional unflag-p) - "Mark all symbolic links. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-sym) "symbolic link")) - (dired-update-mode-line-modified t)) - -(defun dired-mark-directories (&optional unflag-p) - "Mark all directory file lines except `.' and `..'. -With prefix argument, unflag all those files." - (interactive "P") - (if dired-re-dir - (progn - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (and (looking-at dired-re-dir) - (not (looking-at dired-re-dot))) - "directory file")))) - (dired-update-mode-line-modified t)) - -(defun dired-mark-executables (&optional unflag-p) - "Mark all executable files. -With prefix argument, unflag all those files." - (interactive "P") - (if dired-re-exe - (progn - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-exe) "executable file")))) - (dired-update-mode-line-modified t)) - -(defun dired-flag-backup-files (&optional unflag-p) - "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unflag these files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - (and (not (and dired-re-dir (looking-at dired-re-dir))) - (let ((fn (dired-get-filename t t))) - (if fn (backup-file-name-p fn)))) - "backup file")) - (dired-update-mode-line-modified t)) - -(defun dired-flag-auto-save-files (&optional unflag-p) - "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unflag those files instead." - (interactive "P") - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - ;; It is less than general to check for ~ here, - ;; but it's the only way this runs fast enough. - (and (save-excursion (end-of-line) - (eq (preceding-char) ?#)) - (not (and dired-re-dir (looking-at dired-re-dir))) - (let ((fn (dired-get-filename t t))) - (if fn (auto-save-file-name-p - (file-name-nondirectory fn))))) - "auto save file")) - (dired-update-mode-line-modified t)) - -(defun dired-mark-rcs-files (&optional unflag-p) - "Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - ;; Returns failures, or nil on success. - ;; Finding those with locks would require to peek into the ,v file, - ;; depends slightly on the RCS version used and should be done - ;; together with the Emacs RCS interface. - ;; Unfortunately, there is no definitive RCS interface yet. - (interactive "P") - (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - rcs-files wf failures count total) - (mapcar ; loop over subdirs - (function - (lambda (dir) - (or (equal (file-name-nondirectory (directory-file-name dir)) - "RCS") - ;; skip inserted RCS subdirs - (setq rcs-files - (append (directory-files dir t ",v\\'") ; *,v and RCS/*,v - (let ((rcs-dir (expand-file-name "RCS" dir))) - (if (file-directory-p rcs-dir) - (mapcar ; working files from ./RCS are in ./ - (function - (lambda (x) - (expand-file-name x dir))) - (directory-files - (file-name-as-directory rcs-dir) - nil ",v\\'")))) - rcs-files))))) - (mapcar (function car) dired-subdir-alist)) - (setq total (length rcs-files)) - (while rcs-files - (setq wf (substring (car rcs-files) 0 -2) - rcs-files (cdr rcs-files)) - (save-excursion (if (dired-goto-file wf) - (dired-mark 1) ; giving a prefix avoids checking - ; for subdir line. - (setq failures (cons wf failures))))) - (dired-update-mode-line-modified t) - (if (null failures) - (message "%d RCS file%s %smarked." - total (dired-plural-s total) (if unflag-p "un" "")) - (setq count (length failures)) - (dired-log-summary (buffer-name (current-buffer)) - "RCS working file not found %s" failures) - (message "%d RCS file%s: %d %smarked - %d not found %s." - total (dired-plural-s total) (- total count) - (if unflag-p "un" "") count failures)) - failures)) - - -;;;; ------------------------------------------------------------ -;;;; Logging failures -;;;; ------------------------------------------------------------ - -(defun dired-why () - "Pop up a buffer with error log output from Dired. -A group of errors from a single command ends with a formfeed. -Thus, use \\[backward-page] to find the beginning of a group of errors." - (interactive) - (if (get-buffer dired-log-buffer) - (let ((owindow (selected-window)) - (window (display-buffer (get-buffer dired-log-buffer)))) - (unwind-protect - (progn - (select-window window) - (goto-char (point-max)) - (recenter -1)) - (select-window owindow))))) - -(defun dired-log (buffer-name log &rest args) - ;; Log a message or the contents of a buffer. - ;; BUFFER-NAME is the name of the dired buffer to which the message applies. - ;; If LOG is a string and there are more args, it is formatted with - ;; those ARGS. Usually the LOG string ends with a \n. - ;; End each bunch of errors with (dired-log t): this inserts - ;; current time and buffer, and a \f (formfeed). - (or (stringp buffer-name) (setq buffer-name (buffer-name buffer-name))) - (let ((obuf (current-buffer))) - (unwind-protect ; want to move point - (progn - (set-buffer (get-buffer-create dired-log-buffer)) - (goto-char (point-max)) - (let (buffer-read-only) - (cond ((stringp log) - (insert (if args - (apply (function format) log args) - log))) - ((bufferp log) - (insert-buffer log)) - ((eq t log) - (insert "\n\t" (current-time-string) - "\tBuffer `" buffer-name "'\n\f\n"))))) - (set-buffer obuf)))) - -(defun dired-log-summary (buffer-name string failures) - (message (if failures "%s--type y for details %s" - "%s--type y for details") - string failures) - ;; Log a summary describing a bunch of errors. - (dired-log buffer-name (concat "\n" string)) - (if failures (dired-log buffer-name "\n%s" failures)) - (dired-log buffer-name t)) - - -;;;; ------------------------------------------------------- -;;;; Sort mode of dired buffers. -;;;; ------------------------------------------------------- - -(defun dired-sort-type (list) - ;; Returns the sort type of LIST, as a symbol. - (let* ((list (reverse list)) - (alist (sort - (mapcar (function - (lambda (x) - (cons (length (memq (car x) list)) (cdr x)))) - dired-sort-type-alist) - (function - (lambda (x y) - (> (car x) (car y)))))) - (winner (car alist))) - (if (zerop (car winner)) - 'name - (cdr winner)))) - -(defun dired-sort-set-modeline (&optional switches) - ;; Set modeline display according to dired-internal-switches. - ;; Modeline display of "by name" or "by date" guarantees the user a - ;; match with the corresponding regexps. Non-matching switches are - ;; shown literally. - (or switches (setq switches dired-internal-switches)) - (setq dired-sort-mode - (if dired-show-ls-switches - (concat " " (dired-make-switches-string - (or switches dired-internal-switches))) - (concat " by " (and (memq ?r switches) "rev-") - (symbol-name (dired-sort-type switches))))) - ;; update mode line - (set-buffer-modified-p (buffer-modified-p))) - -(defun dired-sort-toggle-or-edit (&optional arg) - "Toggle between sort by date/name for the current subdirectory. - -With a 0 prefix argument, simply reports on the current switches. - -With a prefix 1 allows the ls switches for the current subdirectory to be -edited. - -With a prefix 2 allows the default ls switches for newly inserted -subdirectories to be edited. - -With a prefix \\[universal-argument] allows you to sort the entire -buffer by either name or date. - -With a prefix \\[universal-argument] \\[universal-argument] allows the default switches -for the entire buffer to be edited, and then reverts the buffer so that all -subdirectories are sorted according to these switches. - -Note that although dired allows different ls switches to be used for -different subdirectories, certain combinations of ls switches are incompatible. -If incompatible switches are detected, dired will offer to revert the buffer -to force the ls switches for all subdirectories to a single value. If you -refuse to revert the buffer, any change of ls switches will be aborted." - (interactive "P") - (cond - ((eq arg 0) - ;; Report on switches - (message "Switches for current subdir: %s. Default for buffer: %s." - (dired-make-switches-string - (nth 3 (assoc (dired-current-directory) dired-subdir-alist))) - (dired-make-switches-string dired-internal-switches))) - ((null arg) - ;; Toggle between sort by date/name. - (let* ((dir (dired-current-directory)) - (curr (nth 3 (assoc dir dired-subdir-alist)))) - (dired-sort-other - (if (eq (dired-sort-type curr) 'name) - (cons ?t curr) - (mapcar (function - (lambda (x) - (setq curr - (delq (car x) curr)))) - dired-sort-type-alist) - curr) - nil dir))) - ((eq arg 1) - ;; Edit switches for current subdir. - (let* ((dir (dired-current-directory)) - (switch-string - (read-string - "New ls switches for current subdir (must contain -l): " - (dired-make-switches-string - (nth 3 (assoc dir dired-subdir-alist))))) - (switches (dired-make-switches-list switch-string))) - (if (dired-compatible-switches-p switches dired-internal-switches) - (dired-sort-other switches nil dir) - (if (or - (memq 'sort-revert dired-no-confirm) - (y-or-n-p - (format - "Switches %s incompatible with default %s. Revert buffer? " - switch-string - (dired-make-switches-string dired-internal-switches)))) - (dired-sort-other switches nil nil) - (error "Switches unchanged. Remain as %s." switch-string))))) - ((eq arg 2) - ;; Set new defaults for subdirs inserted in the future. - (let* ((switch-string - (read-string - "Default ls switches for new subdirs (must contain -l): " - (dired-make-switches-string dired-internal-switches))) - (switches (dired-make-switches-list switch-string)) - (alist dired-subdir-alist) - x bad-switches) - (while alist - (setq x (nth 3 (car alist)) - alist (cdr alist)) - (or (dired-compatible-switches-p x switches) - (member x bad-switches) - (setq bad-switches (cons x bad-switches)))) - (if bad-switches - (if (or (memq 'sort-revert dired-no-confirm) - (y-or-n-p - (format - "Switches %s incompatible with %s. Revert buffer? " - switch-string (mapconcat 'dired-make-switches-string - bad-switches ", ")))) - (dired-sort-other switches nil nil) - (error "Default switches unchanged. Remain as %s." - (dired-make-switches-string dired-internal-switches))) - (dired-sort-other switches t nil)))) - ((or (equal arg '(4)) (eq arg 'date) (eq arg 'name)) - ;; Toggle the entire buffer name/data. - (let ((cursor-in-echo-area t) - (switches (copy-sequence dired-internal-switches)) - (type (and (symbolp arg) arg)) - char) - (while (null type) - (message "Sort entire buffer according to (n)ame or (d)ate? ") - (setq char (read-char) - type (cond - ((char-equal char ?d) 'date) - ((char-equal char ?n) 'name) - (t (message "Type one of n or d.") (sit-for 1) nil)))) - (mapcar (function - (lambda (x) - (setq switches - (delq (car x) switches)))) - dired-sort-type-alist) - (dired-sort-other - (if (eq type 'date) (cons ?t switches) switches) nil nil))) - ((equal arg '(16)) - ;; Edit the switches for the entire buffer. - (dired-sort-other - (dired-make-switches-list - (read-string - "Change ls switches for entire buffer to (must contain -l): " - (dired-make-switches-string dired-internal-switches))) - nil nil)) - (t - ;; No idea what's going on. - (error - "Invalid prefix. See %s dired-sort-toggle-or-edit." - (substitute-command-keys - (if (featurep 'ehelp) - "\\[electric-describe-function]" - "\\[describe-function]")))))) - -(defun dired-sort-other (switches &optional no-revert subdir) - ;; Specify new ls SWITCHES for current dired buffer. - ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. - ;; If subdir is non-nil, only changes the switches for the - ;; sudirectory. - (if subdir - (let ((elt (assoc subdir dired-subdir-alist))) - (if elt (setcar (nthcdr 3 elt) switches))) - (setq dired-internal-switches switches)) - (or no-revert - (cond - - (subdir - (let ((ofile (dired-get-filename nil t)) - (opoint (point))) - (message "Relisting %s..." subdir) - (dired-insert-subdir subdir switches) - (message "Relisting %s... done" subdir) - (or (and ofile (dired-goto-file ofile)) (goto-char opoint)))) - - ((memq ?R switches) - ;; We are replacing a buffer with a giant recursive listing. - (let ((opoint (point)) - (ofile (dired-get-filename nil t)) - (hidden-subdirs (dired-remember-hidden)) - (mark-alist (dired-remember-marks (point-min) (point-max))) - (kill-files-p (save-excursion - (goto-char (point)) - (search-forward - (concat (char-to-string ?\r) - (regexp-quote - (char-to-string - dired-kill-marker-char))) - nil t))) - (omit-files (nth 2 (nth (1- (length dired-subdir-alist)) - dired-subdir-alist))) - buffer-read-only) - (dired-readin dired-directory (current-buffer) - (or (consp dired-directory) - (null (file-directory-p dired-directory)))) - (dired-mark-remembered mark-alist) ; mark files that were marked - (if kill-files-p (dired-do-hide dired-kill-marker-char)) - (if omit-files - (dired-omit-expunge nil t)) - ;; hide subdirs that were hidden - (save-excursion - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs)) - ;; Try to get back to where we were - (or (and ofile (dired-goto-file ofile)) - (goto-char opoint)) - (dired-move-to-filename))) - - (t - ;; Clear all switches in the subdir alist - (setq dired-subdir-alist - (mapcar (function - (lambda (x) - (setcar (nthcdr 3 x) nil) - x)) - dired-subdir-alist)) - (revert-buffer nil t)))) - (dired-update-mode-line t)) - -(defun dired-compatible-switches-p (list1 list2) - ;; Returns t if list1 and list2 are allowed as switches in the same - ;; dired buffer. - (and (eq (null (or (memq ?l list1) (memq ?o list1) (memq ?g list1))) - (null (or (memq ?l list2) (memq ?o list2) (memq ?g list2)))) - (eq (null (memq ?F list1)) (null (memq ?F list2))) - (eq (null (memq ?p list1)) (null (memq ?p list2))) - (eq (null (memq ?b list1)) (null (memq ?b list2))))) - -(defun dired-check-ls-l (&optional switches) - ;; Check for long-style listings - (let ((switches (or switches dired-internal-switches))) - (or (memq ?l switches) (memq ?o switches) (memq ?g switches) - (error "Dired needs -l, -o, or -g in ls switches")))) - - -;;;; -------------------------------------------------------------- -;;;; Creating new files. -;;;; -------------------------------------------------------------- -;;; -;;; The dired-create-files paradigm is used for copying, renaming, -;;; compressing, and making hard and soft links. - -(defun dired-file-marker (file) - ;; Return FILE's marker, or nil if unmarked. - (save-excursion - (and (dired-goto-file file) - (progn - (skip-chars-backward "^\n\r") - (and (not (= ?\040 (following-char))) - (following-char)))))) - -;; The basic function for half a dozen variations on cp/mv/ln/ln -s. -(defun dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char query - implicit-to) - ;; Create a new file for each from a list of existing files. The user - ;; is queried, dired buffers are updated, and at the end a success or - ;; failure message is displayed - - ;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists - ;; It is called for each file and must create newfile, the entry of - ;; which will be added. The user will be queried if the file already - ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a - ;; rename), it is FILE-CREATOR's responsibility to update dired - ;; buffers. FILE-CREATOR must abort by signalling a file-error if it - ;; could not create newfile. The error is caught and logged. - - ;; OPERATION (a capitalized string, e.g. `Copy') describes the - ;; operation performed. It is used for error logging. - - ;; FN-LIST is the list of files to copy (full absolute pathnames). - - ;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to - ;; skip. If it skips files, it is supposed to tell why (using dired-log). - - ;; Optional MARKER-CHAR is a character with which to mark every - ;; newfile's entry, or t to use the current marker character if the - ;; oldfile was marked. - - ;; QUERY is a function to use to prompt the user about creating a file. - ;; It accepts two args, the from and to files, - ;; and must return nil or t. If QUERY is nil, then no user - ;; confirmation will be requested. - - ;; If IMPLICIT-TO is non-nil, then the file constructor does not take - ;; a to-file arg. e.g. compress. - - (let ((success-count 0) - (total (length fn-list)) - failures skipped overwrite-query) - ;; Fluid vars used for storing responses of previous queries must be - ;; initialized. - (dired-save-excursion - (setq dired-overwrite-backup-query nil - dired-file-creator-query nil) - (mapcar - (function - (lambda (from) - (let ((to (funcall name-constructor from))) - (if to - (if (equal to from) - (progn - (dired-log (buffer-name (current-buffer)) - "Cannot %s to same file: %s\n" - (downcase operation) from) - (setq skipped (cons (dired-make-relative from) skipped))) - (if (or (null query) - (funcall query from to)) - (let* ((overwrite (let (jka-compr-enabled) - ;; Don't let jka-compr fool us. - (file-exists-p to))) - ;; for dired-handle-overwrite - (dired-overwrite-confirmed - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite %s?" to)))) - ;; must determine if FROM is marked before - ;; file-creator gets a chance to delete it - ;; (in case of a move). - (actual-marker-char - (cond ((integerp marker-char) marker-char) - (marker-char (dired-file-marker from)) - (t nil)))) - (if (and overwrite (null dired-overwrite-confirmed)) - (setq skipped (cons (dired-make-relative from) - skipped)) - (condition-case err - (let ((dired-unhandle-add-files - (cons to dired-unhandle-add-files))) - (if implicit-to - (funcall file-creator from - dired-overwrite-confirmed) - (funcall file-creator from to - dired-overwrite-confirmed)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" - operation success-count total) - (dired-add-file to actual-marker-char)) - (file-error ; FILE-CREATOR aborted - (progn - (setq failures (cons (dired-make-relative from) - failures)) - (dired-log (buffer-name (current-buffer)) - "%s `%s' to `%s' failed:\n%s\n" - operation from to err)))))) - (setq skipped (cons (dired-make-relative from) skipped)))) - (setq skipped (cons (dired-make-relative from) skipped)))))) - fn-list) - (cond - (failures - (dired-log-summary - (buffer-name (current-buffer)) - (format "%s failed for %d of %d file%s" - operation (length failures) total - (dired-plural-s total)) failures)) - (skipped - (dired-log-summary - (buffer-name (current-buffer)) - (format "%s: %d of %d file%s skipped" - operation (length skipped) total - (dired-plural-s total)) skipped)) - (t - (message "%s: %s file%s." - operation success-count (dired-plural-s success-count))))))) - -(defun dired-do-create-files (op-symbol file-creator operation arg - &optional marker-char - prompter how-to) - ;; Create a new file for each marked file. - ;; Prompts user for target, which is a directory in which to create - ;; the new files. Target may be a plain file if only one marked - ;; file exists. - ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' - ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-get-marked-files. - ;; PROMPTER is a function of one-arg, the list of files, to return a prompt - ;; to use for dired-read-file-name. If it is nil, then a default prompt - ;; will be used. - ;; Optional arg MARKER-CHAR as in dired-create-files. - ;; Optional arg HOW-TO determines how to treat target: - ;; If HOW-TO is not given (or nil), and target is a directory, the - ;; file(s) are created inside the target directory. If target - ;; is not a directory, there must be exactly one marked file, - ;; else error. - ;; If HOW-TO is t, then target is not modified. There must be - ;; exactly one marked file, else error. - ;; Else HOW-TO is assumed to be a function of one argument, target, - ;; that looks at target and returns a value for the into-dir - ;; variable. The function dired-into-dir-with-symlinks is provided - ;; for the case (common when creating symlinks) that symbolic - ;; links to directories are not to be considered as directories - ;; (as file-directory-p would if HOW-TO had been nil). - - (let* ((fn-list (dired-get-marked-files nil arg)) - (fn-count (length fn-list)) - (cdir (dired-current-directory)) - (target (expand-file-name - (dired-mark-read-file-name - (if prompter - (funcall prompter fn-list) - (concat operation " %s to: ")) - (dired-dwim-target-directory) - op-symbol arg (mapcar (function - (lambda (fn) - (dired-make-relative fn cdir t))) - fn-list)))) - (into-dir (cond ((null how-to) (file-directory-p target)) - ((eq how-to t) nil) - (t (funcall how-to target))))) - (if (and (> fn-count 1) - (not into-dir)) - (error "Marked %s: target must be a directory: %s" operation target)) - ;; rename-file bombs when moving directories unless we do this: - (or into-dir (setq target (directory-file-name target))) - (dired-create-files - file-creator operation fn-list - (if into-dir ; target is a directory - (list 'lambda '(from) - (list 'expand-file-name '(file-name-nondirectory from) target)) - (list 'lambda '(from) target)) - marker-char))) - -(defun dired-into-dir-with-symlinks (target) - (and (file-directory-p target) - (not (file-symlink-p target)))) -;; This may not always be what you want, especially if target is your -;; home directory and it happens to be a symbolic link, as is often the -;; case with NFS and automounters. Or if you want to make symlinks -;; into directories that themselves are only symlinks, also quite -;; common. -;; So we don't use this function as value for HOW-TO in -;; dired-do-symlink, which has the minor disadvantage of -;; making links *into* a symlinked-dir, when you really wanted to -;; *overwrite* that symlink. In that (rare, I guess) case, you'll -;; just have to remove that symlink by hand before making your marked -;; symlinks. - -(defun dired-handle-overwrite (to) - ;; Save old version of a to be overwritten file TO. - ;; `dired-overwrite-confirmed' and `dired-overwrite-backup-query' - ;; are fluid vars from dired-create-files. - (if (and dired-backup-if-overwrite - dired-overwrite-confirmed - (or (eq 'always dired-backup-if-overwrite) - (dired-query 'dired-overwrite-backup-query - (format "Make backup for existing file `%s'? " to)))) - (let ((backup (car (find-backup-file-name to)))) - (rename-file to backup 0)))) ; confirm overwrite of old backup - -(defun dired-dwim-target-directory () - ;; Try to guess which target directory the user may want. - ;; If there is a dired buffer displayed in the next window, use - ;; its current subdir, else use current subdir of this dired buffer. - ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode - (let* ((this-dir (and (eq major-mode 'dired-mode) - (dired-current-directory))) - (dwimmed - (if dired-dwim-target - (let* ((other-buf (window-buffer (next-window))) - (other-dir (save-excursion - (set-buffer other-buf) - (and (eq major-mode 'dired-mode) - (dired-current-directory))))) - (or other-dir this-dir)) - this-dir))) - (and dwimmed (dired-abbreviate-file-name dwimmed)))) - -(defun dired-get-target-directory () - "Writes a copy of the current subdirectory into an active minibuffer." - (interactive) - (let ((mb (dired-get-active-minibuffer-window))) - (if mb - (let ((dir (dired-current-directory))) - (select-window mb) - (set-buffer (window-buffer mb)) - (erase-buffer) - (insert dir)) - (error "No active minibuffer")))) - -;;; Copying files - -(defun dired-do-copy (&optional arg) - "Copy all marked (or next ARG) files, or copy the current file. -When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and the files are copied into that directory, retaining the same file names. - -A zero prefix argument copies nothing. But it toggles the -variable `dired-copy-preserve-time' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'copy (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg dired-keep-marker-copy) - (setq dired-copy-preserve-time (not dired-copy-preserve-time)) - (if dired-copy-preserve-time - (message "Copy will preserve time.") - (message "Copied files will get current date.")))) - -(defun dired-copy-file (from to ok-flag) - (dired-handle-overwrite to) - (copy-file from to ok-flag dired-copy-preserve-time)) - -;;; Renaming/moving files - -(defun dired-do-rename (&optional arg) - "Rename current file or all marked (or next ARG) files. -When renaming just the current file, you specify the new name. -When renaming multiple or marked files, you specify a directory. - -A zero ARG moves no files but toggles `dired-dwim-target' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'move (function dired-rename-file) - "Move" arg dired-keep-marker-rename - (function - (lambda (list) - (if (= (length list) 1) - "Rename %s to: " - "Move %s to: ")))) - (setq dired-dwim-target (not dired-dwim-target)) - (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) - -(defun dired-rename-file (from to ok-flag) - (dired-handle-overwrite to) - (let ((insert (assoc (file-name-as-directory from) dired-subdir-alist))) - (rename-file from to ok-flag) ; error is caught in -create-files - ;; Silently rename the visited file of any buffer visiting this file. - (dired-rename-update-buffers from to insert))) - -(defun dired-rename-update-buffers (from to &optional insert) - (if (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) ; kills write-file-hooks - (set-buffer-modified-p modflag))) - ;; It's a directory. More work to do. - (let ((blist (buffer-list)) - (from-dir (file-name-as-directory from)) - (to-dir (file-name-as-directory to))) - (save-excursion - (while blist - (set-buffer (car blist)) - (setq blist (cdr blist)) - (cond - (buffer-file-name - (if (dired-in-this-tree buffer-file-name from-dir) - (let ((modflag (buffer-modified-p))) - (unwind-protect - (set-visited-file-name - (concat to-dir (substring buffer-file-name - (length from-dir)))) - (set-buffer-modified-p modflag))))) - (dired-directory - (if (string-equal from-dir (expand-file-name default-directory)) - ;; If top level directory was renamed, lots of things - ;; have to be updated. - (progn - (dired-unadvertise from-dir) - (setq default-directory to-dir - dired-directory - ;; Need to beware of wildcards. - (expand-file-name - (file-name-nondirectory dired-directory) - to-dir)) - (let ((new-name (file-name-nondirectory - (directory-file-name dired-directory)))) - ;; Try to rename buffer, but just leave old name if new - ;; name would already exist (don't try appending "<%d>") - ;; Why? --sandy 19-8-94 - (or (get-buffer new-name) - (rename-buffer new-name))) - (dired-advertise)) - (and insert - (assoc (file-name-directory (directory-file-name to)) - dired-subdir-alist) - (dired-insert-subdir to)))))))))) - -;;; Making symbolic links - -(defun dired-do-symlink (&optional arg) - "Make symbolic links to current file or all marked (or next ARG) files. -When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and new symbolic links are made in that directory -with the same names that the files currently have." - (interactive "P") - (dired-do-create-files 'symlink (function make-symbolic-link) - "SymLink" arg dired-keep-marker-symlink)) - -;; Relative symlinks: -;; make-symbolic no longer expands targets (as of at least 18.57), -;; so the code to call ln has been removed. - -(defun dired-do-relsymlink (&optional arg) - "Symlink all marked (or next ARG) files into a directory, -or make a symbolic link to the current file. -This creates relative symbolic links like - - foo -> ../bar/foo - -not absolute ones like - - foo -> /ugly/path/that/may/change/any/day/bar/foo" - (interactive "P") - (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) - "RelSymLink" arg dired-keep-marker-symlink)) - -(defun dired-make-relative-symlink (target linkname - &optional ok-if-already-exists) - "Make a relative symbolic link pointing to TARGET with name LINKNAME. -Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS -The link is relative (if possible), for example - - \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" - -results in - - \"../../tex/bin/foo\" \"/vol/local/bin/foo\"" - (interactive - (let ((target (read-string "Make relative symbolic link to file: "))) - (list - target - (read-file-name (format "Make relsymlink to file %s: " target)) - 0))) - (let* ((target (expand-file-name target)) - (linkname (expand-file-name linkname)) - (handler (or (find-file-name-handler - linkname 'dired-make-relative-symlink) - (find-file-name-handler - target 'dired-make-relative-symlink)))) - (if handler - (funcall handler 'dired-make-relative-symlink target linkname - ok-if-already-exists) - (setq target (directory-file-name target) - linkname (directory-file-name linkname)) - (make-symbolic-link - (dired-make-relative target (file-name-directory linkname) t) - linkname ok-if-already-exists)))) - -;;; Hard links -- adding names to files - -(defun dired-do-hardlink (&optional arg) - "Add names (hard links) current file or all marked (or next ARG) files. -When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and new hard links are made in that directory -with the same names that the files currently have." - (interactive "P") - (dired-do-create-files 'hardlink (function add-name-to-file) - "HardLink" arg dired-keep-marker-hardlink)) - - -;;;; --------------------------------------------------------------- -;;;; Running process on marked files -;;;; --------------------------------------------------------------- -;;; -;;; Commands for shell processes are in dired-shell.el. - -;;; Internal functions for running subprocesses, -;;; checking and logging of their errors. - -(defun dired-call-process (program discard &rest arguments) - ;; Run PROGRAM with output to current buffer unless DISCARD is t. - ;; Remaining arguments are strings passed as command arguments to PROGRAM. - ;; Returns program's exit status, as an integer. - ;; This is a separate function so that efs can redefine it. - (let ((return - (apply 'call-process program nil (not discard) nil arguments))) - (if (and (not (equal shell-file-name program)) - (integerp return)) - return - ;; Fudge return code by looking for errors in current buffer. - (if (zerop (buffer-size)) 0 1)))) - -(defun dired-check-process (msg program &rest arguments) - ;; Display MSG while running PROGRAM, and check for output. - ;; Remaining arguments are strings passed as command arguments to PROGRAM. - ;; On error, insert output in a log buffer and return the - ;; offending ARGUMENTS or PROGRAM. - ;; Caller can cons up a list of failed args. - ;; Else returns nil for success. - (let ((err-buffer (get-buffer-create " *dired-check-process output*")) - (dir default-directory)) - (message "%s..." msg) - (save-excursion - ;; Get a clean buffer for error output: - (set-buffer err-buffer) - (erase-buffer) - (setq default-directory dir) ; caller's default-directory - (if (not - (eq 0 (apply (function dired-call-process) program nil arguments))) - (progn - (dired-log (buffer-name (current-buffer)) - (concat program " " (prin1-to-string arguments) "\n")) - (dired-log (buffer-name (current-buffer)) err-buffer) - (or arguments program t)) - (kill-buffer err-buffer) - (message "%s...done" msg) - nil)))) - -;;; Changing file attributes - -(defun dired-do-chxxx (attribute-name program op-symbol arg) - ;; Change file attributes (mode, group, owner) of marked files and - ;; refresh their file lines. - ;; ATTRIBUTE-NAME is a string describing the attribute to the user. - ;; PROGRAM is the program used to change the attribute. - ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). - ;; ARG describes which files to use, like in dired-get-marked-files. - (let* ((files (dired-get-marked-files t arg)) - (new-attribute - (dired-mark-read-string - (concat "Change " attribute-name " of %s to: ") - nil op-symbol arg files)) - (operation (concat program " " new-attribute)) - (failures - (dired-bunch-files 10000 (function dired-check-process) - (list operation program new-attribute) - files))) - (dired-do-redisplay arg);; moves point if ARG is an integer - (if failures - (dired-log-summary (buffer-name (current-buffer)) - (format "%s: error" operation) nil)))) - -(defun dired-do-chmod (&optional arg) - "Change the mode of the marked (or next ARG) files. -This calls chmod, thus symbolic modes like `g+w' are allowed." - (interactive "P") - (dired-do-chxxx "Mode" "chmod" 'chmod arg)) - -(defun dired-do-chgrp (&optional arg) - "Change the group of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) - -(defun dired-do-chown (&optional arg) - "Change the owner of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) - -;;; Utilities for running processes on marked files. - -;; Process all the files in FILES in batches of a convenient size, -;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...). -;; Batches are chosen to need less than MAX chars for the file names, -;; allowing 3 extra characters of separator per file name. -(defun dired-bunch-files (max function args files) - (let (pending - (pending-length 0) - failures) - ;; Accumulate files as long as they fit in MAX chars, - ;; then process the ones accumulated so far. - (while files - (let* ((thisfile (car files)) - (thislength (+ (length thisfile) 3)) - (rest (cdr files))) - ;; If we have at least 1 pending file - ;; and this file won't fit in the length limit, process now. - (if (and pending (> (+ thislength pending-length) max)) - (setq failures - (nconc (apply function (append args pending)) - failures) - pending nil - pending-length 0)) - ;; Do (setq pending (cons thisfile pending)) - ;; but reuse the cons that was in `files'. - (setcdr files pending) - (setq pending files) - (setq pending-length (+ thislength pending-length)) - (setq files rest))) - (nconc (apply function (append args pending)) - failures))) - - -;;;; --------------------------------------------------------------- -;;;; Calculating data or properties for marked files. -;;;; --------------------------------------------------------------- - -(defun dired-do-total-size (&optional arg) - "Show total size of all marked (or next ARG) files." - (interactive "P") - (let* ((result (dired-map-over-marks (dired-get-file-size) arg)) - (total (apply (function +) result)) - (num (length result))) - (message "%d bytes (%d kB) in %s file%s" - total (/ total 1024) num (dired-plural-s num)) - total)) - -(defun dired-get-file-size () - ;; Returns the file size in bytes of the current file, as an integer. - ;; Assumes that it is on a valid file line. It's the caller's responsibility - ;; to ensure this. Assumes that match 0 for dired-re-month-and-time is - ;; at the end of the file size. - (dired-move-to-filename t) - ;; dired-move-to-filename must leave match-beginning 0 at the start of - ;; the date. - (goto-char (match-beginning 0)) - (skip-chars-backward " ") - (string-to-int (buffer-substring (point) - (progn (skip-chars-backward "0-9") - (point))))) - -(defun dired-copy-filenames-as-kill (&optional arg) - "Copy names of marked (or next ARG) files into the kill ring. -The names are separated by a space, and may be copied into other buffers -with \\[yank]. The list of names is also stored in the variable -`dired-marked-files' for possible manipulation in the *scratch* buffer. - -With a 0 prefix argument, use the pathname relative to the top-level dired -directory for each marked file. - -With a prefix \\[universal-argument], use the complete pathname of each -marked file. - -With a prefix \\[universal-argument] \\[universal-argument], copy the complete -file line. In this case, the lines are separated by newlines. - -If on a subdirectory headerline and no prefix argument given, use the -subdirectory name instead." - (interactive "P") - (let (res) - (cond - ((and (null arg) (setq res (dired-get-subdir))) - (kill-new res) - (message "Copied %s into kill ring." res)) - ((equal arg '(16)) - (setq dired-marked-files - (dired-map-over-marks - (concat " " ; Don't copy the mark. - (buffer-substring - (progn (beginning-of-line) (1+ (point))) - (progn (skip-chars-forward "^\n\r") (point)))) - nil)) - (let ((len (length dired-marked-files))) - (kill-new (concat - (mapconcat 'identity dired-marked-files "\n") - "\n")) - (message "Copied %d file line%s into kill ring." - len (dired-plural-s len)))) - (t - (setq dired-marked-files - (cond - ((null arg) - (dired-get-marked-files 'no-dir)) - ((eq arg 0) - (dired-get-marked-files t)) - ((integerp arg) - (dired-get-marked-files 'no-dir arg)) - ((equal arg '(4)) - (dired-get-marked-files)) - (t (error "Invalid prefix %s" arg)))) - (let ((len (length dired-marked-files))) - (kill-new (mapconcat 'identity dired-marked-files " ")) - (message "Copied %d file name%s into kill ring." - len (dired-plural-s len))))))) - - -;;;; ----------------------------------------------------------- -;;;; Killing subdirectories -;;;; ----------------------------------------------------------- -;;; -;;; These commands actually remove text from the dired buffer. - -(defun dired-kill-subdir (&optional remember-marks tree) - "Remove all lines of current subdirectory. -Lower levels are unaffected. If given a prefix when called interactively, -kills the entire directory tree below the current subdirectory." - ;; With optional REMEMBER-MARKS, return a mark-alist. - (interactive (list nil current-prefix-arg)) - (let ((cur-dir (dired-current-directory))) - (if (string-equal cur-dir (expand-file-name default-directory)) - (error "Attempt to kill top level directory")) - (if tree - (dired-kill-tree cur-dir remember-marks) - (let ((beg (dired-subdir-min)) - (end (dired-subdir-max)) - buffer-read-only) - (prog1 - (if remember-marks (dired-remember-marks beg end)) - (goto-char beg) - (or (bobp) (forward-char -1)) ; gobble separator - (delete-region (point) end) - (dired-unsubdir cur-dir) - (dired-update-mode-line) - (dired-update-mode-line-modified t)))))) - -(defun dired-kill-tree (dirname &optional remember-marks) - "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. -With optional arg REMEMBER-MARKS, return an alist of marked files." - (interactive "DKill tree below directory: ") - (let ((s-alist dired-subdir-alist) dir m-alist) - (while s-alist - (setq dir (car (car s-alist)) - s-alist (cdr s-alist)) - (if (and (not (string-equal dir dirname)) - (dired-in-this-tree dir dirname) - (dired-goto-subdir dir)) - (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) - (dired-update-mode-line) - (dired-update-mode-line-modified t) - m-alist)) - - -;;;; ------------------------------------------------------------ -;;;; Killing file lines -;;;; ------------------------------------------------------------ -;;; -;;; Uses selective diplay, rather than removing lines from the buffer. - -(defun dired-do-kill-file-lines (&optional arg) - "Kill all marked file lines, or those indicated by the prefix argument. -Killing file lines means hiding them with selective display. Giving -a zero prefix redisplays all killed file lines." - (interactive "P") - (or selective-display - (error "selective-display must be t for file line killing to work!")) - (if (eq arg 0) - (dired-do-unhide dired-kill-marker-char - "Successfully resuscitated %d file line%s." - dired-keep-marker-kill) - (let ((files - (length - (dired-map-over-marks - (progn - (beginning-of-line) - (subst-char-in-region (1- (point)) (point) ?\n ?\r) - (dired-substitute-marker (point) (following-char) - dired-kill-marker-char) - (dired-update-marker-counters dired-marker-char t) - t) - arg)))) - ;; Beware of extreme apparent save-excursion lossage here. - (let ((opoint (point))) - (skip-chars-backward "^\n\r") - (if (= (preceding-char) ?\n) - (goto-char opoint) - (setq opoint (- opoint (point))) - (beginning-of-line) - (skip-chars-forward "^\n\r" (+ (point) opoint)))) - (dired-update-mode-line-modified) - (message "Killed %d file line%s." files (dired-plural-s files))))) - - -;;;; ---------------------------------------------------------------- -;;;; Omitting files. -;;;; ---------------------------------------------------------------- - -;; Marked files are never omitted. -;; Adapted from code submitted by: -;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 -;; Changed to work with selective display by Sandy Rutherford, 13/12/92. -;; For historical reasons, we still use the term expunge, although nothing -;; is expunged from the buffer. - -(defun dired-omit-toggle (&optional arg) - "Toggle between displaying and omitting files matching -`dired-omit-regexps' in the current subdirectory. -With a positive prefix, omits files in the entire tree dired buffer. -With a negative prefix, forces all files in the tree dired buffer to be -displayed." - (interactive "P") - (if arg - (let ((arg (prefix-numeric-value arg))) - (if (>= arg 0) - (dired-omit-expunge nil t) - (dired-do-unhide dired-omit-marker-char "") - (mapcar - (function - (lambda (elt) - (setcar (nthcdr 2 elt) nil))) - dired-subdir-alist))) - (if (dired-current-subdir-omitted-p) - (save-restriction - (narrow-to-region (dired-subdir-min) (dired-subdir-max)) - (dired-do-unhide dired-omit-marker-char "") - (setcar (nthcdr 2 (assoc - (dired-current-directory) dired-subdir-alist)) - nil) - (setq dired-subdir-omit nil)) - (dired-omit-expunge) - (setq dired-subdir-omit t))) - (dired-update-mode-line t)) - -(defun dired-current-subdir-omitted-p () - ;; Returns t if the current subdirectory is omited. - (nth 2 (assoc (dired-current-directory) dired-subdir-alist))) - -(defun dired-remember-omitted () - ;; Returns a list of omitted subdirs. - (let ((alist dired-subdir-alist) - result elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (if (nth 2 elt) - (setq result (cons (car elt) result)))) - result)) - -(defun dired-omit-expunge (&optional regexp full-buffer) - ;; Hides all unmarked files matching REGEXP. - ;; If REGEXP is nil or not specified, uses `dired-omit-regexps', - ;; and also omits filenames ending in `dired-omit-extensions'. - ;; If REGEXP is the empty string, this function is a no-op. - (let ((omit-re (or regexp (dired-omit-regexp))) - (alist dired-subdir-alist) - elt min) - (if (null omit-re) - 0 - (if full-buffer - (prog1 - (dired-omit-region (point-min) (point-max) omit-re) - ;; Set omit property in dired-subdir-alist - (while alist - (setq elt (car alist) - min (dired-get-subdir-min elt) - alist (cdr alist)) - (if (and (<= (point-min) min) (>= (point-max) min)) - (setcar (nthcdr 2 elt) t)))) - (prog1 - (dired-omit-region (dired-subdir-min) (dired-subdir-max) omit-re) - (setcar - (nthcdr 2 (assoc (dired-current-directory) - dired-subdir-alist)) - t)))))) - -(defun dired-omit-region (start end regexp) - ;; Omits files matching regexp in region. Returns count. - (save-restriction - (narrow-to-region start end) - (let ((hidden-subdirs (dired-remember-hidden)) - buffer-read-only count) - (or selective-display - (error "selective-display must be t for file omission to work!")) - (dired-omit-unhide-region start end) - (let ((dired-marker-char dired-omit-marker-char) - ;; since all subdirs are now unhidden, this fakes - ;; dired-move-to-end-of-filename into working faster - (selective-display nil)) - (or dired-omit-silent - dired-in-query (message "Omitting...")) - (if (dired-mark-unmarked-files regexp nil nil 'no-dir) - (setq count (dired-do-hide - dired-marker-char - (and (memq dired-omit-silent '(nil 0)) - (not dired-in-query) - "Omitted %d line%s."))) - (or dired-omit-silent dired-in-query - (message "(Nothing to omit)")))) - (save-excursion ;hide subdirs that were hidden - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs)) - count))) - -(defun dired-omit-unhide-region (beg end) - ;; Unhides hidden, but not marked files in the region. - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (and (char-equal (following-char) ?\ ) - (subst-char-in-region (1- (point)) (point) ?\r ?\n)))))) - -(defun dired-do-unhide (char &optional fmt marker) - ;; Unhides files marked with CHAR. Optional FMT is a message - ;; to be displayed. Note that after unhiding, we will need to re-hide - ;; files belonging to hidden subdirs. - (save-excursion - (goto-char (point-min)) - (let ((count 0) - (string (concat "\r" (char-to-string char))) - (hidden-subdirs (dired-remember-hidden)) - (new (if marker (concat "\n" (char-to-string marker)) "\n ")) - buffer-read-only) - (while (search-forward string nil t) - (replace-match new) - (setq count (1+ count))) - (or (equal "" fmt) - (message (or fmt "Unhid %d line%s.") count (dired-plural-s count))) - (goto-char (point-min)) - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1 t)))) - hidden-subdirs) - (if marker (dired-update-mode-line-modified t)) - count))) - -(defun dired-do-hide (char &optional fmt) - ;; Hides files marked with CHAR. Otional FMT is a message - ;; to be displayed. FMT is a format string taking args the number - ;; of hidden file lines, and dired-plural-s. - (save-excursion - (goto-char (point-min)) - (let ((count 0) - (string (concat "\n" (char-to-string char))) - buffer-read-only) - (while (search-forward string nil t) - (subst-char-in-region (match-beginning 0) - (1+ (match-beginning 0)) ?\n ?\r t) - (setq count (1+ count))) - (if fmt - (message fmt count (dired-plural-s count))) - count))) - -(defun dired-omit-regexp () - (let (rgxp) - (if dired-omit-extensions - (setq rgxp (concat - ".\\(" - (mapconcat 'regexp-quote dired-omit-extensions "\\|") - "\\)\\'"))) - (if dired-omit-regexps - (setq rgxp - (concat - rgxp - (and rgxp "\\|") - (mapconcat 'identity dired-omit-regexps "\\|")))) - rgxp)) - -(defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) - ;; Marks unmarked files matching REGEXP, displaying MSG. - ;; REGEXP is matched against the complete pathname, unless localp is - ;; specified. - ;; Does not re-mark files which already have a mark. - ;; Returns t if any work was done, nil otherwise. - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - fn) - (dired-mark-if - (and - ;; not already marked - (eq (following-char) ?\ ) - ;; uninteresting - (setq fn (dired-get-filename localp t)) - (string-match regexp fn)) - msg))) - -(defun dired-add-omit-regexp (rgxp &optional how) - "Adds a new regular expression to the list of omit regular expresions. -With a non-zero numeric prefix argument, deletes a regular expresion from -the list. - -With a prefix argument \\[universal-argument], adds a new extension to -the list of file name extensions omitted. -With a prefix argument \\[universal-argument] \\[universal-argument], deletes -a file name extension from the list. - -With a prefix 0, reports on the current omit regular expressions and -extensions." - (interactive - (list - (cond - ((null current-prefix-arg) - (read-string "New omit regular expression: ")) - ((equal '(4) current-prefix-arg) - (read-string "New omit extension (\".\" is not implicit): ")) - ((equal '(16) current-prefix-arg) - (completing-read - "Remove from omit extensions (type SPACE for options): " - (mapcar 'list dired-omit-extensions) nil t)) - ((eq 0 current-prefix-arg) - nil) - (t - (completing-read - "Remove from omit regexps (type SPACE for options): " - (mapcar 'list dired-omit-regexps) nil t))) - current-prefix-arg)) - (let (remove) - (cond - ((null how) - (if (member rgxp dired-omit-regexps) - (progn - (describe-variable 'dired-omit-regexps) - (error "%s is already included in the list." rgxp)) - (setq dired-omit-regexps (cons rgxp dired-omit-regexps)))) - ((equal how '(4)) - (if (member rgxp dired-omit-extensions) - (progn - (describe-variable 'dired-omit-extensions) - (error "%s is already included in list." rgxp)) - (setq dired-omit-extensions (cons rgxp dired-omit-extensions)))) - ((equal how '(16)) - (let ((tail (member rgxp dired-omit-extensions))) - (if tail - (setq dired-omit-extensions - (delq (car tail) dired-omit-extensions) - remove t) - (setq remove 'ignore)))) - ((eq 0 how) - (setq remove 'ignore) - (if (featurep 'ehelp) - (with-electric-help - (function - (lambda () - (princ "Omit extensions (dired-omit-extensions <V>):\n") - (dired-format-columns-of-files dired-omit-extensions) - (princ "\n") - (princ "Omit regular expressions (dired-omit-regexps <V>):\n") - (dired-format-columns-of-files dired-omit-regexps) - nil))) - (with-output-to-temp-buffer "*Help*" - (princ "Omit extensions (dired-omit-extensions <V>):\n") - (dired-format-columns-of-files dired-omit-extensions) - (princ "\n") - (princ "Omit regular expressions (dired-omit-regexps <V>):\n") - (dired-format-columns-of-files dired-omit-regexps) - (print-help-return-message)))) - (t - (let ((tail (member rgxp dired-omit-regexps))) - (if tail - (setq dired-omit-regexps (delq (car tail) dired-omit-regexps) - remove t) - (setq remove 'ignore))))) - (or (eq remove 'ignore) - (save-excursion - (mapcar - (function - (lambda (dir) - (if (dired-goto-subdir dir) - (progn - (if remove - (save-restriction - (narrow-to-region - (dired-subdir-min) (dired-subdir-max)) - (dired-do-unhide dired-omit-marker-char ""))) - (dired-omit-expunge))))) - (dired-remember-omitted)))))) - - - -;;;; ---------------------------------------------------------------- -;;;; Directory hiding. -;;;; ---------------------------------------------------------------- -;;; -;;; To indicate a hidden subdir, we actually insert "..." in the buffer. -;;; Aside from giving the look of ellipses (even though -;;; selective-display-ellipses is nil), it allows us to tell the difference -;;; between a dir with a single omitted file, and a hidden subdir with one -;;; file. - -(defun dired-subdir-hidden-p (dir) - (save-excursion - (and selective-display - (dired-goto-subdir dir) - (looking-at "\\.\\.\\.\r")))) - -(defun dired-unhide-subdir () - (let (buffer-read-only) - (goto-char (dired-subdir-min)) - (skip-chars-forward "^\n\r") - (skip-chars-backward "." (- (point) 3)) - (if (looking-at "\\.\\.\\.\r") (delete-char 4)) - (dired-omit-unhide-region (point) (dired-subdir-max)))) - -(defun dired-hide-check () - (or selective-display - (error "selective-display must be t for subdir hiding to work!"))) - -(defun dired-hide-subdir (arg &optional really) - "Hide or unhide the current subdirectory and move to next directory. -Optional prefix arg is a repeat factor. -Use \\[dired-hide-all] to (un)hide all directories. -With the optional argument REALLY, we always hide -the subdir, regardless of dired-subdir-hidden-p." - ;; The arg REALLY is needed because when we unhide - ;; omitted files in a hidden subdir, we want to - ;; re-hide the subdir, regardless of whether dired - ;; thinks it's already hidden. - (interactive "p") - (dired-hide-check) - (dired-save-excursion - (while (>= (setq arg (1- arg)) 0) - (let* ((cur-dir (dired-current-directory)) - (hidden-p (and (null really) - (dired-subdir-hidden-p cur-dir))) - (elt (assoc cur-dir dired-subdir-alist)) - (end-pos (1- (dired-get-subdir-max elt))) - buffer-read-only) - ;; keep header line visible, hide rest - (goto-char (dired-get-subdir-min elt)) - (skip-chars-forward "^\n\r") - (skip-chars-backward "." (- (point) 3)) - (if hidden-p - (progn - (if (looking-at "\\.\\.\\.\r") - (progn - (delete-char 3) - (setq end-pos (- end-pos 3)))) - (dired-omit-unhide-region (point) end-pos)) - (if (looking-at "\\.\\.\\.\r") - (goto-char (match-end 0)) - (insert "...") - (setq end-pos (+ end-pos 3))) - (subst-char-in-region (point) end-pos ?\n ?\r))) - (dired-next-subdir 1 t)))) - -(defun dired-hide-all (arg) - "Hide all subdirectories, leaving only their header lines. -If there is already something hidden, make everything visible again. -Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." - (interactive "P") - (dired-hide-check) - (let (buffer-read-only) - (dired-save-excursion - (if (let ((alist dired-subdir-alist) - (hidden nil)) - (while (and alist (null hidden)) - (setq hidden (dired-subdir-hidden-p (car (car alist))) - alist (cdr alist))) - hidden) - ;; unhide - (let ((alist dired-subdir-alist)) - (while alist - (goto-char (dired-get-subdir-min (car alist))) - (skip-chars-forward "^\n\r") - (delete-region (point) (progn (skip-chars-backward ".") (point))) - (setq alist (cdr alist))) - (dired-omit-unhide-region (point-min) (point-max))) - ;; hide - (let ((alist dired-subdir-alist)) - (while alist - (dired-goto-subdir (car (car alist))) - (dired-hide-subdir 1 t) - (setq alist (cdr alist)))))))) - - -;;;; ----------------------------------------------------------------- -;;;; Automatic dired buffer maintenance. -;;;; ----------------------------------------------------------------- -;;; -;;; Keeping Dired buffers in sync with the filesystem and with each -;;; other. -;;; When used with efs on remote directories, buffer maintainence is -;;; done asynch. - -(defun dired-buffers-for-dir (dir-or-list &optional check-wildcard) -;; Return a list of buffers that dired DIR-OR-LIST -;; (top level or in-situ subdir). -;; The list is in reverse order of buffer creation, most recent last. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. If DIR-OR-LIST is a wildcard or list, returns any -;; dired buffers for which DIR-OR-LIST is equal to `dired-directory'. -;; If check-wildcard is non-nil, only returns buffers which contain dir-or-list -;; exactly, including the wildcard part. - (let ((alist dired-buffers) - (as-dir (and (stringp dir-or-list) - (file-name-as-directory dir-or-list))) - result buff elt) - (while alist - (setq buff (cdr (setq elt (car alist))) - alist (cdr alist)) - ;; dired-in-this-tree is not fast. It doesn't pay to use this to check - ;; whether the buffer is a good candidate. - (if (buffer-name buff) - (save-excursion - (set-buffer buff) - (if (or (equal dir-or-list dired-directory) ; the wildcard case. - (and as-dir - (not (and check-wildcard - (string-equal - as-dir - (expand-file-name default-directory)))) - (assoc as-dir dired-subdir-alist))) - (setq result (cons buff result)))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers)))) - (or dired-buffers (dired-remove-from-file-name-handler-alist)) - result)) - -(defun dired-advertise () - ;; Advertise in variable `dired-buffers' that we dired `default-directory'. - ;; With wildcards we actually advertise too much. - ;; Also makes sure that we are installed in the file-name-handler-alist - (prog1 - (let ((ddir (expand-file-name default-directory))) - (if (memq (current-buffer) (dired-buffers-for-dir ddir)) - t ; we have already advertised ourselves - (setq dired-buffers - (cons (cons ddir (current-buffer)) - dired-buffers)))) - ;; Do this last, otherwise the call to dired-buffers-for-dir will - ;; remove dired-handler-fn from the file-name-handler-alist. - ;; Strictly speaking, we only need to do this in th else branch of - ;; the if statement. We do it unconditionally as a sanity check. - (dired-check-file-name-handler-alist))) - -(defun dired-unadvertise (dir) - ;; Remove DIR from the buffer alist in variable dired-buffers. - ;; This has the effect of removing any buffer whose main directory is DIR. - ;; It does not affect buffers in which DIR is a subdir. - ;; Removing is also done as a side-effect in dired-buffer-for-dir. - (setq dired-buffers - (delq (assoc dir dired-buffers) dired-buffers)) - ;; If there are no more dired buffers, we are no longer needed in the - ;; file-name-handler-alist. - (or dired-buffers (dired-remove-from-file-name-handler-alist))) - -(defun dired-unadvertise-current-buffer () - ;; Remove all references to the current buffer in dired-buffers. - (setq dired-buffers - (delq nil - (mapcar - (function - (lambda (x) - (and (not (eq (current-buffer) (cdr x))) x))) - dired-buffers))) - ;; If there are no more dired buffers, we are no longer needed in the - ;; file-name-handler-alist. - (or dired-buffers (dired-remove-from-file-name-handler-alist))) - -(defun dired-fun-in-all-buffers (directory fun &rest args) - ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. - ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). - (let* ((buf-list (dired-buffers-for-dir directory)) - (obuf (current-buffer)) - (owin (selected-window)) - (win owin) - buf windows success-list) - (if buf-list - (unwind-protect - (progn - (while (not (eq (setq win (next-window win)) owin)) - (and (memq (setq buf (window-buffer win)) buf-list) - (progn - (set-buffer buf) - (= (point) (window-point win))) - (setq windows (cons win windows)))) - (while buf-list - (setq buf (car buf-list) - buf-list (cdr buf-list)) - (set-buffer buf) - (if (apply fun args) - (setq success-list (cons (buffer-name buf) success-list)))) - ;; dired-save-excursion prevents lossage of save-excursion - ;; for point. However, if dired buffers are displayed in - ;; other windows, the setting of window-point loses, and - ;; drags the point with it. This should fix this. - (while windows - (condition-case nil - (progn - (set-buffer (window-buffer (setq win (car windows)))) - (set-window-point win (point))) - (error nil)) - (setq windows (cdr windows)))) - (set-buffer obuf))) - success-list)) - -(defun dired-find-file-place (subdir file) - ;; Finds a position to insert in SUBDIR FILE. If it can't find SUBDIR, - ;; returns nil. - (let ((sort (dired-sort-type dired-internal-switches)) - (rev (memq ?r (nth 3 (assoc subdir dired-subdir-alist))))) - (cond - ((eq sort 'name) - (if (dired-goto-subdir subdir) - (let ((max (dired-subdir-max)) - start end found) - (if (dired-goto-next-file) - (progn - (skip-chars-forward "^\n\r") - (setq start (point)) - (goto-char (setq end max)) - (forward-char -1) - (skip-chars-backward "^\n\r") - ;; This loop must find a file. At the very least, it will - ;; find the one found previously. - (while (not found) - (if (save-excursion (dired-move-to-filename nil (point))) - (setq found t) - (setq end (point)) - (forward-char -1) - (skip-chars-backward "^\n\r"))) - (if rev - (while (< start end) - (goto-char (/ (+ start end) 2)) - (if (dired-file-name-lessp - (or (dired-get-filename 'no-dir t) - (error - "Error in dired-find-file-place")) - file) - (setq end (progn - (skip-chars-backward "^\n\r") - (point))) - (setq start (progn - (skip-chars-forward "^\n\r") - (forward-char 1) - (skip-chars-forward "^\n\r") - (point))))) - (while (< start end) - (goto-char (/ (+ start end) 2)) - (if (dired-file-name-lessp - file - (or (dired-get-filename 'no-dir t) - (error - "Error in dired-find-file-place"))) - (setq end (progn - (skip-chars-backward "^\n\r") - (point))) - (setq start (progn - (skip-chars-forward "^\n\r") - (forward-char 1) - (skip-chars-forward "^\n\r") - (point)))))) - (goto-char end)) - (goto-char max)) - t))) - ((eq sort 'date) - (if (dired-goto-subdir subdir) - (if rev - (goto-char (dired-subdir-max)) - (dired-goto-next-file) - t))) - ;; Put in support for other sorting types. - (t - (if (string-equal (dired-current-directory) subdir) - (progn - ;; We are already where we should be, except when - ;; point is before the subdir line or its total line. - (or (save-excursion (beginning-of-line) (dired-move-to-filename)) - (dired-goto-next-nontrivial-file)) ; in the header somewhere - t) ; return t, for found. - (if (dired-goto-subdir subdir) - (progn - (dired-goto-next-nontrivial-file) - t))))))) - -(defun dired-add-entry (filename &optional marker-char inplace) - ;; Add a new entry for FILENAME, optionally marking it - ;; with MARKER-CHAR (a character, else dired-marker-char is used). - ;; Hidden subdirs are exposed if a file is added there. - ;; - ;; This function now adds the new entry at the END of the previous line, - ;; not the beginning of the current line. - ;; Logically, we now think of the `newline' associated - ;; with a fileline, as the one at the beginning of the line, not the end. - ;; This makes it easier to keep track of omitted files. - ;; - ;; Uses dired-save-excursion, so that it doesn't move the - ;; point around. Especially important when it runs asynch. - ;; - ;; If there is already an entry, delete the existing one before adding a - ;; new one. In this case, doesn't remember its mark. Use - ;; dired-update-file-line for that. - ;; - ;; If INPLACE eq 'relist, then the new entry is put in the - ;; same place as the old, if there was an old entry. - ;; If INPLACE is t, then the file entry is put on the line - ;; currently containing the point. Otherwise, dired-find-file-place - ;; attempts to determine where to put the file. - - (setq filename (directory-file-name filename)) - (dired-save-excursion - (let ((oentry (save-excursion (dired-goto-file filename))) - (directory (file-name-directory filename)) - (file-nodir (file-name-nondirectory filename)) - buffer-read-only) - (if oentry - ;; Remove old entry - (let ((opoint (point))) - (goto-char oentry) - (delete-region (save-excursion - (skip-chars-backward "^\r\n") - (dired-update-marker-counters (following-char) t) - (1- (point))) - (progn - (skip-chars-forward "^\r\n") - (point))) - ;; Move to right place to replace deleted line. - (cond ((eq inplace 'relist) (forward-char 1)) - ((eq inplace t) (goto-char opoint))) - (dired-update-mode-line-modified))) - (if (or (eq inplace t) - (and oentry (eq inplace 'relist)) - ;; Tries to move the point to the right place. - ;; Returns t on success. - (dired-find-file-place directory file-nodir)) - (let ((switches (dired-make-switches-string - (cons ?d dired-internal-switches))) - b-of-l) - ;; Bind marker-char now, in case we are working asynch and - ;; dired-marker-char changes in the meantime. - (if (and marker-char (not (integerp marker-char))) - (setq marker-char dired-marker-char)) - ;; since we insert at the end of a line, - ;; backup to the end of the previous line. - (skip-chars-backward "^\n\r") - (forward-char -1) - (setq b-of-l (point)) - (if (and (featurep 'efs-dired) efs-dired-host-type) - ;; insert asynch - ;; we call the efs version explicitly here, - ;; rather than let the handler-alist work for us - ;; because we want to pass extra args. - ;; Is there a cleaner way to do this? - (efs-insert-directory filename ; don't expand `.' ! - switches nil nil - t ; nowait - marker-char) - (let ((insert-directory-program dired-ls-program)) - (insert-directory filename switches nil nil)) - (dired-after-add-entry b-of-l marker-char)) - (if dired-verify-modtimes - (dired-set-file-modtime directory dired-subdir-alist)) - t))))) ; return t on success, else nil. - -(defun dired-after-add-entry (start marker-char) - ;; Does the cleanup of a dired entry after listing it. - ;; START is the start of the new listing-line. - ;; This is a separate function for the sake of efs. - (save-excursion - (goto-char start) - ;; we make sure that the new line is bracketted by new-lines - ;; so the user doesn't need to use voodoo in the - ;; after-readin-hook. - (insert ?\n) - (dired-add-entry-do-indentation marker-char) - (let* ((beg (dired-manual-move-to-filename t)) - ;; error for strange output - (end (dired-manual-move-to-end-of-filename)) - (filename (buffer-substring beg end))) - ;; We want to have the non-directory part only. - (delete-region beg end) - ;; Any markers pointing to the beginning of the filename, will - ;; still point there after this insertion. Should keep - ;; save-excursion from losing. - (setq beg (point)) - (insert (file-name-nondirectory filename)) - (dired-insert-set-properties beg (point)) - (dired-move-to-filename)) - ;; The subdir-alist is not affected so we can run it right now. - (let ((omit (dired-current-subdir-omitted-p)) - (hide (dired-subdir-hidden-p (dired-current-directory)))) - (if (or dired-after-readin-hook omit hide) - (save-excursion - (save-restriction - ;; Use start so that we get the new-line at - ;; the beginning of the line in case we want - ;; to hide the file. Don't need to test (bobp) - ;; here, since we never add a file at - ;; the beginning of the buffer. - (narrow-to-region start - (save-excursion (forward-line 1) (point))) - (run-hooks 'dired-after-readin-hook) - (if omit - (let ((dired-omit-silent (or dired-omit-silent 0))) - (dired-omit-region (point-min) (point-max) - (dired-omit-regexp)))) - (if hide - (subst-char-in-region (point-min) (1- (point-max)) - ?\n ?\r)))))) - ;; clobber the extra newline at the end of the line - (end-of-line) - (delete-char 1))) - -;; This is a separate function for the sake of nested dired format. -(defun dired-add-entry-do-indentation (marker-char) - ;; two spaces or a marker plus a space: - (insert (if marker-char - (let ((char (if (integerp marker-char) - marker-char - dired-marker-char))) - (dired-update-marker-counters char) - (dired-update-mode-line-modified) - char) - ?\040) - ?\040)) - -(defun dired-remove-file (file) - (let ((alist dired-buffers) - buff) - (save-excursion - (while alist - (setq buff (cdr (car alist))) - (if (buffer-name buff) - (progn - (set-buffer buff) - (dired-remove-entry file)) - (setq dired-buffers (delq (car alist) dired-buffers))) - (setq alist (cdr alist)))) - (or dired-buffers (dired-remove-from-file-name-handler-alist)))) - -(defun dired-remove-entry (file) - (let ((ddir (expand-file-name default-directory)) - (dirname (file-name-as-directory file))) - (if (dired-in-this-tree ddir dirname) - (if (or (memq 'kill-dired-buffer dired-no-confirm) - (y-or-n-p (format "Kill dired buffer %s for %s, too? " - (buffer-name) dired-directory))) - (kill-buffer (current-buffer))) - (if (dired-in-this-tree file ddir) - (let ((alist dired-subdir-alist)) - (while alist - (if (dired-in-this-tree (car (car alist)) dirname) - (save-excursion - (goto-char (dired-get-subdir-min (car alist))) - (dired-kill-subdir))) - (setq alist (cdr alist))) - (dired-save-excursion - (and (dired-goto-file file) - (let (buffer-read-only) - (delete-region - (progn (skip-chars-backward "^\n\r") - (or (memq (following-char) '(\n \r ?\ )) - (progn - (dired-update-marker-counters - (following-char) t) - (dired-update-mode-line-modified))) - (1- (point))) - (progn (skip-chars-forward "^\n\r") (point))) - (if dired-verify-modtimes - (dired-set-file-modtime - (file-name-directory (directory-file-name file)) - dired-subdir-alist)))))))))) - -(defun dired-add-file (filename &optional marker-char) - (dired-fun-in-all-buffers - (file-name-directory filename) - (function dired-add-entry) filename marker-char)) - -(defun dired-relist-file (file) - (dired-uncache file nil) - (dired-fun-in-all-buffers (file-name-directory file) - (function dired-relist-entry) file)) - -(defun dired-relist-entry (file) - ;; Relist the line for FILE, or just add it if it did not exist. - ;; FILE must be an absolute pathname. - (let* ((file (directory-file-name file)) - (directory (file-name-directory file)) - (dd (expand-file-name default-directory))) - (if (assoc directory dired-subdir-alist) - (if (or - ;; Not a wildcard - (equal dd dired-directory) - ;; Not top-level - (not (string-equal directory dd)) - (and (string-equal directory - (if (consp dired-directory) - (file-name-as-directory - (car dired-directory)) - (file-name-directory dired-directory))) - (dired-file-in-wildcard-p dired-directory file))) - (let ((marker (save-excursion - (and (dired-goto-file file) - (dired-file-marker file))))) - ;; recompute omission - (if (eq marker dired-omit-marker-char) - (setq marker nil)) - (dired-add-entry file marker 'relist)) - ;; At least tell dired that we considered updating the buffer. - (if dired-verify-modtimes - (dired-set-file-modtime directory dired-subdir-alist)))))) - -(defun dired-file-in-wildcard-p (wildcard file) - ;; Return t if a file is part of the listing for wildcard. - ;; File should be the non-directory part only. - ;; This version is slow, but meticulously correct. Is it worth it? - (if (consp wildcard) - (let ((files (cdr wildcard)) - (dir (car wildcard)) - yep) - (while (and files (not yep)) - (setq yep (string-equal file (expand-file-name (car files) dir)) - files (cdr files))) - yep) - (let ((err-buff - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create " *dired-check-process output*"))) - (dir default-directory) - (process-connection-type nil)) - (save-excursion - (set-buffer err-buff) - (erase-buffer) - (setq default-directory dir) - (call-process shell-file-name nil t nil "-c" - (concat dired-ls-program " -d " wildcard " | " - "egrep '(^|/)" file "$'")) - (/= (buffer-size) 0))))) - -;; The difference between dired-add-file and dired-relist-file is that -;; the former creates the entry with a specific marker. The later preserves -;; existing markers on a per buffer basis. This is not the same as -;; giving dired-create-files a marker of t, which uses a marker in a specific -;; buffer to determine the marker for file line creation in all buffers. - - -;;;; ---------------------------------------------------------------- -;;;; Applying Lisp functions to marked files. -;;;; ---------------------------------------------------------------- - -;;; Running tags commands on marked files. -;; -;; Written 8/30/93 by Roland McGrath <roland@gnu.ai.mit.edu>. -;; Requires tags.el as distributed with GNU Emacs 19.23, or later. - -(defun dired-do-tags-search (regexp) - "Search through all marked files for a match for REGEXP. -Stops when a match is found. -To continue searching for next match, use command \\[tags-loop-continue]." - (interactive "sSearch marked files (regexp): ") - (tags-search regexp '(dired-get-marked-files))) - -(defun dired-do-tags-query-replace (from to &optional delimited) - "Query-replace-regexp FROM with TO through all marked files. -Third arg DELIMITED (prefix arg) means replace only word-delimited matches. -If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace -with the command \\[tags-loop-continue]." - (interactive - "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") - (tags-query-replace from to delimited '(dired-get-marked-files))) - -;;; byte compiling - -(defun dired-byte-compile () - ;; Return nil for success, offending file name else. - (let* ((filename (dired-get-filename)) - buffer-read-only failure) - (condition-case err - (save-excursion (byte-compile-file filename)) - (error - (setq failure err))) - ;; We should not need to update any file lines, as this will have - ;; already been done by after-write-region-hook. - (and failure - (progn - (dired-log (buffer-name (current-buffer)) - "Byte compile error for %s:\n%s\n" filename failure) - (dired-make-relative filename))))) - -(defun dired-do-byte-compile (&optional arg) - "Byte compile marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-map-over-marks-check (function dired-byte-compile) arg - 'byte-compile "byte-compile" t)) - -;;; loading - -(defun dired-load () - ;; Return nil for success, offending file name else. - (let ((file (dired-get-filename)) failure) - (condition-case err - (load file nil nil t) - (error (setq failure err))) - (if (not failure) - nil - (dired-log (buffer-name (current-buffer)) - "Load error for %s:\n%s\n" file failure) - (dired-make-relative file)))) - -(defun dired-do-load (&optional arg) - "Load the marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-map-over-marks-check (function dired-load) arg 'load "load" t)) - - -;;;; ---------------------------------------------------------------- -;;;; File Name Handler Alist -;;;; ---------------------------------------------------------------- -;;; -;;; Make sure that I/O functions maintain dired buffers. - -(defun dired-remove-from-file-name-handler-alist () - ;; Remove dired from the file-name-handler-alist - (setq file-name-handler-alist - (delq nil - (mapcar - (function - (lambda (x) - (and (not (eq (cdr x) 'dired-handler-fn)) - x))) - file-name-handler-alist)))) - -(defun dired-check-file-name-handler-alist () - ;; Verify that dired is installed as the first item in the alist - (and dired-refresh-automatically - (or (eq (cdr (car file-name-handler-alist)) 'dired-handler-fn) - (setq file-name-handler-alist - (cons - '("." . dired-handler-fn) - (dired-remove-from-file-name-handler-alist)))))) - -(defun dired-handler-fn (op &rest args) - ;; Function to update dired buffers after I/O. - (prog1 - (let ((inhibit-file-name-handlers - (cons 'dired-handler-fn - (and (eq inhibit-file-name-operation op) - inhibit-file-name-handlers))) - (inhibit-file-name-operation op)) - (apply op args)) - (let ((dired-omit-silent t) - (hf (get op 'dired))) - (and hf (funcall hf args))))) - -(defun dired-handler-fn-1 (args) - (let ((to (expand-file-name (nth 1 args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-2 (args) - (let ((from (expand-file-name (car args))) - (to (expand-file-name (nth 1 args)))) - ;; Don't remove the original entry if making backups. - ;; Otherwise we lose marks. I'm not completely happy with the - ;; logic here. - (or (and - (eq (nth 2 args) t) ; backups always have OK-IF-OVERWRITE t - (string-equal (car (find-backup-file-name from)) to)) - (dired-remove-file from)) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-3 (args) - (let ((to (expand-file-name (nth 2 args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-4 (args) - (dired-remove-file (expand-file-name (car args)))) - -(defun dired-handler-fn-5 (args) - (let ((to (expand-file-name (car args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)))) - -(defun dired-handler-fn-6 (args) - (let ((to (expand-file-name (nth 1 args))) - (old (expand-file-name (car args)))) - (or (member to dired-unhandle-add-files) - (dired-relist-file to)) - (dired-relist-file old))) - -(put 'copy-file 'dired 'dired-handler-fn-1) -(put 'dired-make-relative-symlink 'dired 'dired-handler-fn-1) -(put 'make-symbolic-link 'dired 'dired-handler-fn-1) -(put 'add-name-to-file 'dired 'dired-handler-fn-6) -(put 'rename-file 'dired 'dired-handler-fn-2) -(put 'write-region 'dired 'dired-handler-fn-3) -(put 'delete-file 'dired 'dired-handler-fn-4) -(put 'delete-directory 'dired 'dired-handler-fn-4) -(put 'dired-recursive-delete-directory 'dired 'dired-handler-fn-4) -(put 'make-directory-internal 'dired 'dired-handler-fn-5) -(put 'set-file-modes 'dired 'dired-handler-fn-5) - -;;;; ------------------------------------------------------------ -;;;; Autoload land. -;;;; ------------------------------------------------------------ - -;;; Reading mail (dired-xy) - -(autoload 'dired-read-mail "dired-xy" - "Reads the current file as a mail folder." t) -(autoload 'dired-vm "dired-xy" "Run VM on this file." t) -(autoload 'dired-rmail "dired-xy" "Run RMAIL on this file." t) - -;;; Virtual dired (dired-vir) - -(autoload 'dired-virtual "dired-vir" - "Put this buffer into virtual dired mode." t) - -;;; Grep (dired-grep) - -(autoload 'dired-do-grep "dired-grep" "Grep marked files for a pattern." t) - -;;; Doing diffs (dired-diff) - -(autoload 'dired-diff "dired-diff" - "Compare file at point with FILE using `diff'." t) -(autoload 'dired-backup-diff "dired-diff" - "Diff this file with its backup file or vice versa." t) -(autoload 'dired-emerge "dired-diff" - "Merge file at point with FILE using `emerge'." t) -(autoload 'dired-emerge-with-ancestor "dired-diff" - "Merge file at point with FILE, using a common ANCESTOR file." t) -(autoload 'dired-ediff "dired-diff" "Ediff file at point with FILE." t) -(autoload 'dired-epatch "dired-diff" "Patch file at point using `epatch'." t) - -;;; Shell commands (dired-shell) - -(autoload 'dired-do-print "dired-shell" "Print the marked (next ARG) files." t) -(autoload 'dired-run-shell-command "dired-shell" nil) -(autoload 'dired-do-shell-command "dired-shell" - "Run a shell command on the marked (or next ARG) files." t) -(autoload 'dired-do-background-shell-command "dired-shell" - "Run a background shell command on marked (or next ARG) files." t) - -;;; Commands using regular expressions (dired-rgxp) - -(autoload 'dired-mark-files-regexp "dired-rgxp" - "Mark all files whose names match REGEXP." t) -(autoload 'dired-flag-files-regexp "dired-rgxp" - "Flag for deletion all files whose names match REGEXP." t) -(autoload 'dired-mark-extension "dired-rgxp" - "Mark all files whose names have a given extension." t) -(autoload 'dired-flag-extension "dired-rgxp" - "Flag for deletion all files whose names have a given extension." t) -(autoload 'dired-cleanup "dired-rgxp" - "Flag for deletion dispensable files files created by PROGRAM." t) -(autoload 'dired-do-rename-regexp "dired-rgxp" - "Rename marked files whose names match a given regexp." t) -(autoload 'dired-do-copy-regexp "dired-rgxp" - "Copy marked files whose names match a given regexp." t) -(autoload 'dired-do-hardlink-regexp "dired-rgxp" - "Hardlink all marked files whose names match a regexp." t) -(autoload 'dired-do-symlink "dired-rgxp" - "Make a symbolic link to all files whose names match a regexp." t) -(autoload - 'dired-do-relsymlink-regexp "dired-rgxp" - "Make a relative symbolic link to all files whose names match a regexp." t) -(autoload 'dired-upcase "dired-rgxp" - "Rename all marked (or next ARG) files to upper case." t) -(autoload 'dired-downcase "dired-rgxp" - "Rename all marked (or next ARG) files to lower case." t) - -;;; Marking files from other buffers (dired-mob) - -(autoload 'dired-mark-files-from-other-dired-buffer "dired-mob" - "Mark files which are marked in another dired buffer." t) -(autoload 'dired-mark-files-compilation-buffer "dired-mob" - "Mark the files mentioned in the compilation buffer." t) - -;;; uuencoding (dired-uu) - -(autoload 'dired-do-uucode "dired-uu" "Uuencode or uudecode marked files." t) - -;;; Compressing (dired-cmpr) - -(autoload 'dired-do-compress "dired-cmpr" - "Compress or uncompress marked files." t) -(autoload 'dired-compress-subdir-files "dired-cmpr" - "Compress uncompressed files in the current subdirectory." t) - - -;;; Marking files according to sexps - -(autoload 'dired-mark-sexp "dired-sex" - "Mark files according to an sexpression." t) - -;;; Help! - -(autoload 'dired-summary "dired-help" - "Display summary of basic dired commands in the minibuffer." t) -(autoload 'dired-describe-mode "dired-help" - "Detailed description of dired mode. -With a prefix, runs the info documentation browser for dired." t) -(autoload 'dired-apropos "dired-help" - "Do command apropos help for dired commands. -With prefix does apropos help for dired variables." t) -(autoload 'dired-report-bug "dired-help" "Report a bug for dired." t) - -;;;; -------------------------------------------------------------- -;;;; Multi-flavour Emacs support -;;;; -------------------------------------------------------------- - -(let ((lucid-p (string-match "XEmacs" emacs-version)) - ver) - (or (string-match "^\\([0-9]+\\)\\." emacs-version) - (error "Weird emacs version %s" emacs-version)) - (setq ver (string-to-int (substring emacs-version (match-beginning 1) - (match-end 1)))) - - ;; Reading with history. - (if (>= ver 19) - - (defun dired-read-with-history (prompt initial history) - (read-from-minibuffer prompt initial nil nil history)) - - (defun dired-read-with-history (prompt initial history) - (let ((minibuffer-history-symbol history)) ; for gmhist - (read-string prompt initial)))) - - ;; Completing read with history. - (if (>= ver 19) - - (fset 'dired-completing-read 'completing-read) - - (defun dired-completing-read (prompt table &optional predicate - require-match initial-input history) - (let ((minibuffer-history-symbol history)) ; for gmhist - (completing-read prompt table predicate require-match - initial-input)))) - - ;; Abbreviating file names. - (if lucid-p - (fset 'dired-abbreviate-file-name - ;; Lemacs has this extra hack-homedir arg - (function - (lambda (fn) - (abbreviate-file-name fn t)))) - (fset 'dired-abbreviate-file-name 'abbreviate-file-name)) - - ;; Deleting directories - ;; Check for pre 19.8 versions of lucid emacs. - (if lucid-p - (or (fboundp 'delete-directory) - (fset 'delete-directory 'remove-directory))) - - ;; Minibuffers - (if (= ver 18) - - (defun dired-get-active-minibuffer-window () - (and (> (minibuffer-depth) 0) - (minibuffer-window))) - - (defun dired-get-active-minibuffer-window () - (let ((frames (frame-list)) - win found) - (while frames - (if (and (setq win (minibuffer-window (car frames))) - (minibuffer-window-active-p win)) - (setq found win - frames nil) - (setq frames (cdr frames)))) - found))) - - ;; Text properties and menus. - - (cond - (lucid-p - (require 'dired-xemacs)) - ((>= ver 19) - (require 'dired-fsf)) - (t - ;; text property stuff doesn't work in V18 - (fset 'dired-insert-set-properties 'ignore) - (fset 'dired-remove-text-properties 'ignore) - (fset 'dired-set-text-properties 'ignore) - (fset 'dired-move-to-filename 'dired-manual-move-to-filename) - (fset 'dired-move-to-end-of-filename - 'dired-manual-move-to-end-of-filename)))) - -;;; MULE - -(if (or (boundp 'MULE) (featurep 'mule)) (load "dired-mule")) - - -;; Run load hook for user customization. -(run-hooks 'dired-load-hook) - -;;; end of dired.el
--- a/lisp/efs/efs-auto.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-auto.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.8 $ -;; RCS: -;; Description: Simple way of autoloading efs -;; Author: Andy Norman, Dawn -;; Created: Thu Sep 24 09:50:08 1992 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Provides a way of autoloading efs. To use this, just put -;;; (require 'efs-auto) in your .emacs file. -;;; -;;; The Bad News: -;;; -;;; 1. Calls to load and require will not trigger efs to autoload. -;;; If you are want to put remote directories in your load path, -;;; you should require efs. -;;; 2. Because efs does not overload expand-file-name until it is loaded, -;;; "smart" expansion of file names on remote apollos running domain -;;; will not work yet. This means that accessing a file on a remote -;;; apollo may not correctly cause efs to autoload. This will depend -;;; the details of your command sequence. - -(provide 'efs-auto) -(require 'efs-ovwrt) -(require 'efs-fnh) - -(defconst efs-auto-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.8 $" 11 -2))) - -;;; Interactive functions that should be accessible from here. - -(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) -(autoload - 'efs-set-passwd "efs-netrc" - "For a given HOST and USER, set or change the associated PASSWORD." t) -(autoload 'efs-nslookup-host "efs" - "Attempt to resolve a hostname using nslookup if possible." t) -(autoload 'efs-display-ftp-activity "efs" - "Displays the number of active background ftp sessions in the modeline. -Uses the variable `efs-mode-line-format' to determine how this will be -displayed." t) -(autoload 'efs-ftp-path "efs-cu" - "Parse PATH according to efs-path-regexp. -Returns a list (HOST USER PATH), or nil if PATH does not match the format.") - -;;; end of efs-auto.el
--- a/lisp/efs/efs-cms-knet.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,245 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cms-knet.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: CMS support for efs using KNET/VM server -;; Authors: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Joerg-Martin Schwarz <schwarz@hal1.physik.uni-dortmund.de> -;; Created: Wed Mar 23 14:39:00 1994 by schwarz on hal1 from efs-cms.el -;; Modified: Sun Nov 27 11:45:58 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-cms-knet) -(require 'efs) - -(defconst efs-cms-knet-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; CMS support for KNET-VM server -;;;; ------------------------------------------------------------ - -;;; efs has full support, including tree dired support, for hosts running -;;; CMS. It should be able to automatically recognize any CMS machine. -;;; We would be grateful if you would report any failures to automatically -;;; recognize a CMS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; KNET/VM Support (J. M. Schwarz, Mar 12, 1994): -;;; This code has been developed and tested with -;;; "KNET/VM FTP server Release 3.2.0" by Spartacus. -;;; -;;; This server uses not only a different listing format than the one used in -;;; efs-cms.el, but also handles minidisks differently. -;;; The cd command for changing minidisk is not supported, -;;; instead a full filename syntax "FILENAME.FILETYPE.FM" is used, where -;;; FM is the filemode. To access a file "PROFILE EXEC A0", efs uses a -;;; syntax "/cms-hostname:/A:/PROFILE.EXEC" (Note the ':') -;;; -;;; In this directory notation, "/A0:" is actually a subset of the "/A:" -;;; directory. - -(efs-defun efs-send-pwd cms-knet (host user &optional xpwd) - ;; cms-knet has no concept of current directory. - ;; Is it safe to always assume this is the user's home? - (cons "A" "")) - -(efs-defun efs-fix-path cms-knet (path &optional reverse) - ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert - ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, - ;; so we fudge things by sending cd's. - (if reverse - ;; Since we only convert output from a pwd in this direction, - ;; this should never be applied, as PWD doesn't work for this server. - (concat "/" path "/") - (efs-save-match-data - (if (string-match "^/[A-Z]/\\([-A-Z0-9$_+@:]+\\.[-A-Z0-9$_+@:]+\\)$" - path) - (concat - (substring path (match-beginning 1) (match-end 1)) - "." - ;; minidisk - (substring path 1 2)) - (error "Invalid CMS-KNET filename"))))) - -(efs-defun efs-fix-dir-path cms-knet (dir-path) - ;; Convert path from UNIX-ish to CMS-KNET ready for a DIRectory listing. - (cond - ((string-equal "/" dir-path) - "*.*.*") - ((string-match - "^/[A-Z]/\\([-A-Z0-9$._+@:]+\\.[-A-Z0-9$._+@:]+\\)?$" - dir-path) - (concat - (if (match-beginning 1) - (substring dir-path (match-beginning 1) (match-end 1)) - "*") - "." - (substring dir-path 1 2))) - (t (error "Invalid CMS-KNET pathname")))) - -(defconst efs-cms-knet-file-name-regexp - (concat - "^ *\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +" - "\\([A-Z]\\)[0-9] +[VF] +[0-9]+ ")) - -(efs-defun efs-parse-listing cms-knet - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a CMS directory listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory as a full efs-path - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (efs-save-match-data - (if (string-equal dir "/") - (let ((case-fold (memq 'cms-knet efs-case-insensitive-host-types)) - tbl-alist md md-tbl) - (while (re-search-forward efs-cms-knet-file-name-regexp nil t) - (setq md (buffer-substring (match-beginning 3) (match-end 3)) - md-tbl (or (cdr (assoc md tbl-alist)) - (let ((new-tbl (efs-make-hashtable))) - (setq tbl-alist - (cons (cons md new-tbl) - tbl-alist)) - new-tbl))) - (efs-put-hash-entry md '(t) tbl) - (efs-put-hash-entry (concat - (buffer-substring (match-beginning 1) - (match-end 1)) - "." - (buffer-substring (match-beginning 2) - (match-end 2))) - '(nil) md-tbl) - (forward-line 1)) - (while tbl-alist - (setq md (car (car tbl-alist)) - md-tbl (cdr (car tbl-alist))) - (efs-put-hash-entry "." '(t) md-tbl) - (efs-put-hash-entry ".." '(t) md-tbl) - (efs-put-hash-entry (concat path md "/") md-tbl - efs-files-hashtable case-fold) - (setq tbl-alist (cdr tbl-alist)))) - (while (re-search-forward efs-cms-knet-file-name-regexp nil t) - (efs-put-hash-entry - (concat (buffer-substring (match-beginning 1) - (match-end 1)) - "." - (buffer-substring (match-beginning 2) - (match-end 2))) - '(nil) tbl) - (forward-line 1))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-allow-child-lookup cms-knet (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; CMS file system is flat. Only minidisks are "subdirs". - (string-equal "/" dir)) - -;;; Tree dired support: - -(defconst efs-dired-cms-re-exe - "^. +[-A-Z0-9$_+@:]+ +\\(EXEC\\|MODULE\\) " - "Regular expression to use to search for CMS executables.") - -(or (assq 'cms efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'cms-knet efs-dired-cms-re-exe) - efs-dired-re-exe-alist))) - -(efs-defun efs-dired-insert-headerline cms-knet (dir) - ;; CMS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename cms-knet - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; This is the CMS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-cms-knet-file-name-regexp eol t) - (goto-char (match-beginning 1)) - (if raise-error - (error "No file on this line.") - (goto-char bol))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename cms-knet - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the CMS version. - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (looking-at "[-A-Z0-9$_+@:]+ +[-A-Z0-9$_+@:]+ +[A-Z][0-9] ") - (goto-char (- (match-end 0) 2)) ; return point - (if no-error - nil - (error "No file on this line.")))) - -(efs-defun efs-dired-get-filename cms-knet - (&optional localp no-error-if-not-filep) - (let ((name (efs-real-dired-get-filename 'no-dir no-error-if-not-filep))) - (and name - (if (string-match - "^\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +\\([A-Z]\\)$" - name) - (let* ((dir (dired-current-directory)) - (rdir (nth 2 (efs-ftp-path dir)))) - (setq name (concat (substring name (match-beginning 1) - (match-end 1)) - "." - (substring name (match-beginning 2) - (match-end 2)))) - (if (string-equal rdir "/") - (setq name (concat (substring name (match-beginning 3) - (match-end 3)) "/" name))) - (if (eq localp 'no-dir) - name - (concat (if localp - (dired-current-directory localp) - dir) - name))) - (error "Strange CMS-KNET file name %s" name))))) - -;;; end of efs-cms-knet.el
--- a/lisp/efs/efs-cms.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,462 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cms.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.9 $ -;; RCS: -;; Description: CMS support for efs -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Fri Oct 23 08:52:00 1992 -;; Modified: Sun Nov 27 11:46:51 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-cms) -(require 'efs) - -(defconst efs-cms-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.9 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; CMS support -;;;; ------------------------------------------------------------ - -;;; efs has full support, including tree dired support, for hosts running -;;; CMS. It should be able to automatically recognize any CMS machine. -;;; We would be grateful if you would report any failures to automatically -;;; recognize a CMS host as a bug. -;;; -;;; This should also work with CMS machines running SFS (Shared File System). -;;; -;;; Filename syntax: -;;; -;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are -;;; treated as UNIX directories. For example to access the file READ.ME in -;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter -;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME -;;; If *.301 is the default minidisk for this account, you could access -;;; FOO.BAR on this minidisk as -;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR -;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be -;;; up to 8 characters. Again, beware that CMS filenames are always upper -;;; case, and hence must be entered as such. -;;; -;;; Tips: -;;; 1. CMS machines, with the exception of anonymous accounts, nearly always -;;; need an account password. To have efs send an account password, -;;; you can either include it in your .netrc file, or use -;;; efs-set-account. -;;; 2. efs-set-account can be used to set account passwords for specific -;;; minidisks. This is usually used to optain write access to the minidisk. -;;; As well you can put tokens of the form -;;; minidisk <minidisk name> <password> in your .netrc file. There can be -;;; as many minidisk tokens as you like, however they should follow all -;;; other tokens for a given machine entry. Of course, ordinary ftp -;;; will not understand these entries in your .netrc file. -;;; - - -;;; Since CMS doesn't have any full pathname syntax, we have to fudge -;;; things with cd's. We actually send too many cd's, but is dangerous -;;; to try to remember the current minidisk, because if the connection -;;; is closed and needs to be reopened, we will find ourselves back in -;;; the default minidisk. This is fairly likely since CMS ftp servers -;;; usually close the connection after 5 minutes of inactivity. - -;;; Have I got the filename character set right? - -;;; The following three functions are entry points to this file. -;;; They have been added to the appropriate alists in efs.el - -(efs-defun efs-fix-path cms (path &optional reverse) - ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert - ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, - ;; so we fudge things by sending cd's. - (efs-save-match-data - (if reverse - (if (string-match ":" path) - ;; It's SFS - (let* ((start (match-end 0)) - (return (concat "/" (substring path 0 start)))) - (while (string-match "\\." path start) - (setq return (concat return "/" - (substring path start - (match-beginning 0))) - start (match-end 0))) - (concat return "/" (substring path start))) - ;; Since we only convert output from a pwd in this direction, - ;; we'll assume that it's a minidisk, and make it into a - ;; directory file name. Note that the expand-dir-hashtable - ;; stores directories without the trailing /. - (if (char-equal (string-to-char path) ?/) - path - (concat "/" path))) - (if (let ((case-fold-search t)) - (string-match - (concat - "^/\\([-A-Z0-9$*._+:]+\\)/" - ;; In case there is a SFS - "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" - "\\([-A-Z0-9$._+]+\\)$") - path)) - (let ((minidisk (substring path 1 (match-end 1))) - (sfs (and (match-beginning 2) - (substring path (match-beginning 3) - (match-end 3)))) - (file (substring path (match-beginning 5) (match-end 5))) - account) - (and sfs (match-beginning 4) - (setq sfs (concat sfs "." (substring path (match-beginning 4) - (1- (match-end 4)))))) - (unwind-protect - (progn - (or sfs - (setq account - (efs-get-account host user minidisk))) - (efs-raw-send-cd host user (if sfs - (concat minidisk sfs ".") - minidisk)) - (if account - (efs-cms-send-minidisk-acct - host user minidisk account))) - (if account (fillarray account 0))) - file) - (error "Invalid CMS filename"))))) - -(efs-defun efs-fix-dir-path cms (dir-path) - ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. - (efs-save-match-data - (cond - ((string-equal "/" dir-path) - (error "Cannot get listing for CMS \"/\" directory.")) - ((let ((case-fold-search t)) - (string-match - (concat "^/\\([-A-Z0-9$*._+:]+\\)/" - "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" - "\\([-A-Z0-9$*_.+]+\\)?$") dir-path)) - (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1))) - (sfs (and (match-beginning 2) - (concat - (substring dir-path (match-beginning 3) - (match-end 3))))) - (file (if (match-beginning 5) - (substring dir-path (match-beginning 5) (match-end 5)) - "*")) - account) - (and sfs (match-beginning 4) - (setq sfs (concat sfs "." (substring dir-path - (match-beginning 4) - (1- (match-end 4)))))) - (unwind-protect - (progn - (or sfs - (setq account (efs-get-account host user minidisk))) - (efs-raw-send-cd host user (if sfs - (concat minidisk sfs ".") - minidisk)) - (if account - (efs-cms-send-minidisk-acct host user minidisk account))) - (if account (fillarray account 0))) - file)) - (t (error "Invalid CMS pathname"))))) - -(defconst efs-cms-file-line-regexp - (concat - "\\([-A-Z0-9$_+]+\\) +" - "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)")) - -(efs-defun efs-parse-listing cms - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a CMS directory listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory as a full efs-path - (let ((tbl (efs-make-hashtable)) - fn dir-p) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward efs-cms-file-line-regexp nil t) - (if (match-beginning 3) - (setq fn (concat (buffer-substring - (match-beginning 1) (match-end 1)) - "." - (buffer-substring - (match-beginning 4) (match-end 4))) - dir-p nil) - (setq fn (buffer-substring (match-beginning 1) (match-end 1)) - dir-p t)) - (efs-put-hash-entry fn (list dir-p) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(defun efs-cms-send-minidisk-acct (host user minidisk account - &optional noretry) - "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given, -the account password is for that minidisk. If PROC is given, send to that -process, rathr than use HOST and USER to look up the process." - (efs-save-match-data - (let ((result (efs-raw-send-cmd - (efs-get-process host user) - (concat "quote acct " account)))) - (cond - ((eq (car result) 'failed) - (setq account nil) - (unwind-protect - (progn - (setq - account - (read-passwd - (format - "Invalid acct. password for %s on %s@%s. Try again: " - minidisk user host))) - (if (string-equal "" account) - (setq account nil))) - ;; This guarantees that an interrupt will clear the account - ;; password. - (efs-set-account host user minidisk account)) - (if account ; give the user another chance - (efs-cms-send-minidisk-acct host user minidisk account))) - ((eq (car result) 'fatal) - (if noretry - ;; give up - (efs-error host user - (concat "ACCOUNT password failed: " (nth 1 result))) - ;; try once more - (efs-cms-send-minidisk-acct host user minidisk account t)))) - ;; return result - result))) - -(efs-defun efs-write-recover cms - (line cont-lines host user cmd msg pre-cont cont nowait noretry) - ;; If a write fails because of insufficient privileges, give the user a - ;; chance to send an account password. - (let ((cmd0 (car cmd)) - (cmd1 (nth 1 cmd)) - (cmd2 (nth 2 cmd))) - (efs-save-match-data - (if (and (or (memq cmd0 '(append put rename)) - (and (eq cmd0 'quote) (eq cmd1 'stor))) - (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2)) - (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1))) - account retry) - (unwind-protect - (progn - (setq account - (read-passwd - (format "Account password for minidisk %s on %s@%s: " - minidisk user host))) - (if (string-equal account "") - (setq account nil))) - (efs-set-account host user minidisk account)) - (if account - (progn - (efs-cms-send-minidisk-acct host user minidisk account) - (setq retry - (efs-send-cmd host user cmd msg pre-cont cont - nowait noretry)) - (and (null (or cont nowait)) retry)) - (if cont - (progn - (efs-call-cont cont 'failed line cont-lines) - nil) - (and (null nowait) (list 'failed line cont-lines))))) - (if cont - (progn - (efs-call-cont cont 'failed line cont-lines) - nil) - (and (null nowait) (list 'failed line cont-lines))))))) - -(efs-defun efs-allow-child-lookup cms (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; CMS file system is flat. Only minidisks are "subdirs". - (or (string-equal "/" dir) - (efs-save-match-data - (string-match "^/[^/:]+:/$" dir)))) - -;;; Sorting listings - -(defconst efs-cms-date-and-time-regexp - (concat - " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +" - "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) ")) - -(efs-defun efs-t-converter cms (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-cms-date-and-time-regexp nil t) - (let (list-start list bol nbol) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq bol (point)) - (re-search-forward efs-cms-date-and-time-regexp - (setq nbol (save-excursion - (forward-line 1) (point))) - t)) - (setq list - (cons - (cons - (list (string-to-int (buffer-substring - (match-beginning 3) - (match-end 3))) ; year - (string-to-int (buffer-substring - (match-beginning 1) - (match-end 1))) ; month - (string-to-int (buffer-substring - (match-beginning 2) - (match-end 2))) ; day - (string-to-int (buffer-substring - (match-beginning 4) - (match-end 4))) ; hour - (string-to-int (buffer-substring - (match-beginning 5) - (match-end 5))) ; minutes - (string-to-int (buffer-substring - (match-beginning 6) - (match-end 6)))) ; seconds - (buffer-substring bol nbol)) - list)) - (goto-char nbol)) - (if list - (progn - (setq list - (mapcar 'cdr - (sort list 'efs-cms-t-converter-sort-pred))) - (if reverse (setq list (nreverse list))) - (delete-region list-start (point)) - (apply 'insert list))) - t))))) - -(defun efs-cms-t-converter-sort-pred (elt1 elt2) - (let* ((data1 (car elt1)) - (data2 (car elt2)) - (year1 (car data1)) - (year2 (car data2)) - (month1 (nth 1 data1)) - (month2 (nth 1 data2)) - (day1 (nth 2 data1)) - (day2 (nth 2 data2)) - (hour1 (nth 3 data1)) - (hour2 (nth 3 data2)) - (minute1 (nth 4 data1)) - (minute2 (nth 4 data2)) - (second1 (nth 5 data1)) - (second2 (nth 5 data2))) - (or (> year1 year2) - (and (= year1 year2) - (or (> month1 month2) - (and (= month1 month2) - (or (> day1 day2) - (and (= day1 day2) - (or (> hour1 hour2) - (and (= hour1 hour2) - (or (> minute1 minute2) - (and (= minute1 minute2) - (or (> (nth 5 data1) - (nth 5 data2))) - )))))))))))) - - -;;; Tree dired support: - -(defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ") - -(or (assq 'cms efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'cms efs-dired-cms-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ") - -(or (assq 'cms efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'cms efs-dired-cms-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline cms (dir) - ;; CMS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename cms - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; This is the CMS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-cms-file-line-regexp eol t) - (goto-char (match-beginning 0)) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename cms - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the CMS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9$_+") - (or (looking-at " +DIR ") - (progn - (skip-chars-forward " ") - (skip-chars-forward "-A-Z0-9$_+"))) - (if (or (= opoint (point)) (/= (following-char) ?\ )) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-make-filename-string cms (filename &optional reverse) - (if reverse - (if (string-match "\\." filename) - ;; Can't count on the number of blanks between the base and the - ;; extension, so ignore the extension. - (substring filename 0 (match-beginning 0)) - filename) - (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename) - (concat (substring filename 0 (match-end 1)) - "." - (substring filename (match-beginning 2) (match-end 2))) - filename))) - -;;; end of efs-cms.el
--- a/lisp/efs/efs-coke.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,176 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-coke.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Coke Machine support for efs -;; Author: Sandy Rutherford <sandy@imb550.sissa.it> -;; Created: Fri Oct 14 23:55:04 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 12:16:47 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-coke) -(require 'efs) - -(defconst efs-coke-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; Coke Machine support -;;;; ------------------------------------------------------------ -;;; -;;; Works for the MIT vending machine FTP server. -;;; Hopefully, a vending machine RFC is on its way, so we won't -;;; need to support a wide variation of vending machine protocols. - -(efs-defun efs-send-pwd coke (host user &optional xpwd) - ;; Directories on vending machines? - "/") - -(efs-defun efs-fix-path coke (path &optional reverse) - (if (= ?/ (aref path 0)) - (if reverse path (substring path 1)) - (if reverse (concat "/" path) path))) - -(efs-defun efs-fix-dir-path coke (dir-path) - ;; Make a beverage path for a dir listing. - (if (or (string-equal dir-path "/") (string-equal dir-path "/.")) - "*" - dir-path)) - -(efs-defun efs-parse-listing coke - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in coke machine - ;; ftp dir format. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a remote full path - ;; PATH = directory as an efs full path - ;; SWITCHES are never used here, but they - ;; must be specified in the argument list for compatibility - ;; with the unix version of this function. - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward "^\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\)" - nil t) - (efs-put-hash-entry (buffer-substring (match-beginning 2) - (match-end 2)) - (list nil) tbl) - (forward-line 1))) - ;; Don't need to bother with .. - (efs-put-hash-entry "." '(t) tbl) - tbl)) - -(efs-defun efs-allow-child-lookup coke (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Coke machine file system is flat. Hopefully not the coke. - (and (string-equal "/" dir) (string-equal "." file))) - -(defun efs-coke-insert-beverage-contents (buffer file line) - ;; Inserts the contents of a beverage (determined by the FTP server - ;; response LINE) into BUFFER, and then drinks it. - ;; FILE is the name of the file. - (efs-save-buffer-excursion - (set-buffer buffer) - (if (zerop (buffer-size)) - (progn - (insert "\n\n\n\n " (substring line 4) "\n") - (set-buffer-modified-p nil) - (set-process-sentinel - (start-process "efs-coke-gulp-buffer" (current-buffer) "sleep" "3") - (function - (lambda (proc str) - (efs-save-buffer-excursion - (let ((buff (process-buffer proc))) - (and buff (get-buffer buff) - (progn - (set-buffer buff) - (erase-buffer) - (insert "\n\n\n\n GULP!!!\n") - (sit-for 1) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))))))))) - (if (featurep 'dired) - (dired-fun-in-all-buffers - (file-name-directory file) 'dired-revert))) - (message "You haven't finished your last drink in buffer %s!" - (current-buffer)) - (ding) - (sit-for 1)))) - -;;; Dired support - -(efs-defun efs-dired-manual-move-to-filename coke - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the COKE version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (looking-at "\\(. \\)?\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\): ") - (goto-char (match-beginning 3)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename coke - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the COKE version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (search-forward ": " eol t) - (goto-char (- (match-end 0) 2)) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline coke (dir) - (let* ((parsed (efs-ftp-path dir)) - (host (car parsed)) - (user (nth 1 parsed)) - (accounting - (efs-send-cmd - host user '(quote pwd) - (format "Getting accounting data for %s@%s user host" user host)))) - (insert " " user "@" host "\n " - (if (car accounting) - "Account status unavailable" - (substring (nth 1 accounting) 4))) - (delete-region (point) (progn (skip-chars-backward ":.,;") (point))) - (insert ":\n \n"))) - -;;; end of efs-coke.el
--- a/lisp/efs/efs-cp-p.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cp-p.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Support for preserving file modtimes with copies. i.e. cp -p -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Fri Feb 18 03:28:22 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 12:17:33 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-cp-p) -(require 'efs) - -;;;; Internal Variables - -(defconst efs-cp-p-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defvar efs-local-timezone nil) -;; cache. - -;;; Utility functions - -(efs-define-fun efs-gmt-time () - ;; Get the time as the number of seconds elapsed since midnight, - ;; Jan 1, 1970, GMT. Emacs 18 doesn't have `current-time' function. - (let ((time (current-time))) - (list (car time) (nth 1 time)))) - -(defun efs-local-time () - (let ((str (current-time-string))) - (efs-seconds-elapsed - (string-to-int (substring str -4)) - (cdr (assoc (substring str 4 7) efs-month-alist)) - (string-to-int (substring str 8 10)) - (string-to-int (substring str 11 13)) - (string-to-int (substring str 14 16)) - 0))) ; don't care about seconds - -(defun efs-local-timezone () - ;; Returns the local timezone as an integer. Right two digits the minutes, - ;; others the hours. - (or efs-local-timezone - (setq efs-local-timezone - (let* ((local (efs-local-time)) - (gmt (efs-gmt-time)) - (sign 1) - (diff (efs-time-minus local gmt)) - hours minutes) - ;; 2^16 is 36 hours. - (if (zerop (car diff)) - (setq diff (nth 1 diff)) - (error "Weird timezone!")) - (setq diff (/ (- (nth 1 local) (nth 1 gmt)) 60)) - (setq hours (/ diff 60)) - (setq minutes (% diff 60)) - (if (< diff 0) - (setq sign -1 - hours (- hours) - minutes (- minutes))) - ;; Round minutes - (setq minutes (* 10 (/ (+ minutes 5) 10))) - (if (= minutes 60) - (setq hours (1+ hours) - minutes 0)) - (* sign (+ (* hours 100) minutes)))))) - -(defun efs-last-day-of-month (month year) - ;; The last day in MONTH during YEAR. - ;; Taken from calendar.el. Thanks. - (if (and - (or - (and (= (% year 4) 0) - (/= (% year 100) 0)) ; leap-year-p - (= (% year 400) 0)) - (= month 2)) - 29 - (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - -(defun efs-make-date-local (year month day hour minutes seconds) - ;; Takes a GMT date (list of integers), and returns the local time. - (let* ((lzone (efs-local-timezone)) - (lminutes (% lzone 100)) - (lhour (/ lzone 100))) - (setq minutes (+ minutes lminutes)) - (cond ((> minutes 60) - (setq minutes (- minutes 60) - hour (1+ hour))) - ((< minutes 0) - (setq minutes (+ minutes 60) - hour (1- hour)))) - (setq hour (+ lhour hour)) - (if (or (< hour 0) (> hour 23)) - (progn - (cond ((< hour 0) - (setq hour (+ hour 24) - day (1- day))) - ((> hour 23) - (setq hour (- hour 24) - day (1+ day)))) - (if (or (zerop day) (> day - (efs-last-day-of-month month year))) - (cond ((zerop day) - (setq month (1- month)) - (if (zerop month) - (setq year (1- year) - month 12)) - (setq day (efs-last-day-of-month month year))) - ((> day (efs-last-day-of-month month year)) - (setq month (1+ month) - day 1) - (if (= month 13) - (setq year (1+ year) - month 1))))))) - (list year month day hour minutes seconds))) - -;;;; Entry function - -(defun efs-set-mdtm-of (filename newname &optional cont) - ;; NEWNAME must be local - ;; Always works NOWAIT = 0 - (let* ((parsed (efs-ftp-path filename)) - (host (car parsed)) - (user (nth 1 parsed)) - (file (nth 2 parsed))) - (if (efs-get-host-property host 'mdtm-failed) - (and cont (efs-call-cont cont 'failed "" "") nil) - (efs-send-cmd - host user - (list 'quote 'mdtm file) - nil nil - (efs-cont (result line cont-lines) (host newname cont) - (if (or result - (not (string-match efs-mdtm-msgs line))) - (efs-set-host-property host 'mdtm-failed t) - (let ((time (apply 'efs-make-date-local - (mapcar 'string-to-int - (list - (substring line 4 8) - (substring line 8 10) - (substring line 10 12) - (substring line 12 14) - (substring line 14 16) - (substring line 16 18)))))) - (if time - (call-process "touch" nil 0 nil "-t" - (format "%04d%02d%02d%02d%02d.%02d" - (car time) (nth 1 time) - (nth 2 time) (nth 3 time) - (nth 4 time) (nth 5 time)) - newname)))) - (if cont (efs-call-cont cont result line cont-lines))) - 0)))) - -;;; end of efs-cp-p.el
--- a/lisp/efs/efs-cu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,637 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-cu.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.12 $ -;; RCS: -;; Description: Common utilities needed by efs files. -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Fri Jan 28 19:55:45 1994 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;;; Provisions and autoloads. - -(provide 'efs-cu) -(require 'backquote) -(autoload 'efs-get-process "efs") -(autoload 'efs-parse-netrc "efs-netrc") - -;;;; ------------------------------------------------------------ -;;;; Use configuration variables. -;;;; ------------------------------------------------------------ - -(defvar efs-default-user "anonymous" - "*User name to use when none is specied in a pathname. - -If a string, than this string is used as the default user name. -If nil, then the name under which the user is logged in is used. -If t, then the user is prompted for a name. -If an association list of the form - - '((REGEXP1 . USERNAME1) (REGEXP2 . USERNAME2) ...) - -then the host name is tested against each of the regular expressions -REGEXP in turn, and the default user name is the corresponding value -of USERNAME. USERNAME may be either a string, nil, or t, and these -values are interpreted as above. If there are no matches, then the -user's curent login name is used.") - -(defvar efs-default-password nil - "*Password to use when the user is the same as efs-default-user.") - -(defvar efs-default-account nil - "*Account password to use when the user is efs-default-user.") - -;;;; ------------------------------------------------------------- -;;;; Internal variables. -;;;; ------------------------------------------------------------- - -(defconst efs-cu-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.12 $" 11 -2))) - -(defconst efs-case-insensitive-host-types - '(vms cms mts ti-twenex ti-explorer dos mvs tops-20 mpe ka9q dos-distinct - os2 hell guardian ms-unix netware cms-knet nos-ve) - "List of host types for which case is insignificant in file names.") - -;;; Remote path name syntax - -;; All of the following variables must be set consistently. -;; As well the below two functions depend on the grouping constructs -;; in efs-path-regexp. So know what you're doing if you change them. - -(defvar efs-path-regexp "^/\\([^@:/]*@\\)?\\([^@:/]*\\):.*" - "Regexp of a fully expanded remote path.") - -(defvar efs-path-format-string "/%s@%s:%s" - "Format of a fully expanded remote path. Passed to format with -additional arguments user, host, and remote path.") - -(defvar efs-path-format-without-user "/%s:%s" - "Format of a remote path, but not specifying a user.") - -(defvar efs-path-user-at-host-format - (substring efs-path-format-string 1 7) - "Format to return `user@host:' strings for completion in root directory.") - -(defvar efs-path-host-format - (substring efs-path-user-at-host-format 3) - "Format to return `host:' strings for completion in root directory.") - -;;;###autoload -(defvar efs-path-root-regexp "^/[^/:]+:" - "Regexp to match the `/user@host:' root of an efs full path.") - -(defvar efs-path-root-short-circuit-regexp "//[^/:]+:") -;; Regexp to match an efs user@host root, which short-circuits -;; the part of the path to the left of this pattern. - -;;;; ----------------------------------------------------------- -;;;; Variables for multiple host type support -;;;; ----------------------------------------------------------- - -(defvar efs-vms-host-regexp nil - "Regexp to match the names of hosts running VMS.") -(defvar efs-cms-host-regexp nil - "Regexp to match the names of hosts running CMS.") -(defvar efs-mts-host-regexp nil - "Regexp to match the names of hosts running MTS.") -(defvar efs-ti-explorer-host-regexp nil - "Regexp to match the names of hosts running TI-EXPLORER. -These are lisp machines.") -(defvar efs-ti-twenex-host-regexp nil - "Regexp to match the names of hosts running TI-TWENEX. -These are lisp machines, and this should not be confused with DEC's TOPS-20.") -(defvar efs-sysV-unix-host-regexp nil - "Regexp to match the names of sysV unix hosts. -These are defined to be unix hosts which mark symlinks -with a @ in an ls -lF listing.") -(defvar efs-bsd-unix-host-regexp nil - "Regexp to match the names of bsd unix hosts. -These are defined to be unix hosts which do not mark symlinks -with a @ in an ls -lF listing.") -(defvar efs-next-unix-host-regexp nil - "Regexp to match names of NeXT unix hosts. -These are defined to be unix hosts which put a @ after the -destination of a symlink when doing ls -lF listing.") -(defvar efs-unix-host-regexp nil - "Regexp to match names of unix hosts. -I you know which type of unix, it is much better to set that regexp instead.") -(defvar efs-dumb-unix-host-regexp nil - "Regexp to match names of unix hosts which do not take ls switches. -For these hosts we use the \"dir\" command.") -(defvar efs-super-dumb-unix-host-regexp nil - "Regexp to match names of unix hosts with FTP servers that cannot do a PWD. -It is also assumed that these hosts do not accept ls switches, whether -or not this is actually true.") -(defvar efs-dos-host-regexp nil - "Regexp to match names of hosts running DOS.") -;; In principal there is apollo unix support -- at least efs -;; should do the right thing. However, apollo ftp servers can be -;; very flakey, especially about accessing files by fullpaths. -;; Good luck. -(defvar efs-apollo-unix-host-regexp nil - "Regexp to match names of apollo unix hosts running Apollo's Domain. -For these hosts we don't short-circuit //'s immediately following -\"/user@host:\"") -(defvar efs-mvs-host-regexp nil - "Regexp to match names of hosts running MVS.") -(defvar efs-tops-20-host-regexp nil - "Regexp to match names of hosts runninf TOPS-20.") -(defvar efs-mpe-host-regexp nil - "Regexp to match hosts running the MPE operating system.") -(defvar efs-ka9q-host-regexp nil - "Regexp to match hosts using the ka9q ftp server. -These may actually be running one of DOS, LINUX, or unix.") -(defvar efs-dos-distinct-host-regexp nil - "Regexp to match DOS hosts using the Distinct FTP server. -These are not treated as DOS hosts with a special listing format, because -the Distinct FTP server uses unix-style path syntax.") -(defvar efs-os2-host-regexp nil - "Regexp to match names of hosts running OS/2.") -(defvar efs-vos-host-regexp nil - "Regexp to match hosts running the VOS operating system.") -(defvar efs-hell-host-regexp nil - "Regexp to match hosts using the hellsoft ftp server. -These map be either DOS PC's or Macs.") -;; The way that we implement the hellsoft support, it probably won't -;; work with Macs. This could probably be fixed, if enough people scream. -(defvar efs-guardian-host-regexp nil - "Regexp to match hosts running Tandem's guardian operating system.") -;; Note that ms-unix is really an FTP server running under DOS. -;; It's not a type of unix. -(defvar efs-ms-unix-host-regexp nil - "Regexp to match hosts using the Microsoft FTP server in unix mode.") -(defvar efs-plan9-host-regexp nil - "Regexp to match hosts running ATT's Plan 9 operating system.") -(defvar efs-cms-knet-host-regexp nil - "Regexp to match hosts running the CMS KNET FTP server.") -(defvar efs-nos-ve-host-regexp nil - "Regexp to match hosts running NOS/VE.") -(defvar efs-netware-host-regexp nil - "Regexp to match hosts running Novell Netware.") -(defvar efs-dumb-apollo-unix-regexp nil - "Regexp to match dumb hosts running Apollo's Domain. -These are hosts which do not accept switches to ls over FTP.") - -;;; Further host types: -;; -;; unknown: This encompasses ka9q, dos-distinct, unix, sysV-unix, bsd-unix, -;; next-unix, and dumb-unix. - -(defconst efs-host-type-alist - ;; When efs-add-host is called interactively, it will only allow - ;; host types from this list. - '((dumb-unix . efs-dumb-unix-host-regexp) - (super-dumb-unix . efs-super-dumb-unix-host-regexp) - (next-unix . efs-next-unix-host-regexp) - (sysV-unix . efs-sysV-unix-host-regexp) - (bsd-unix . efs-bsd-unix-host-regexp) - (apollo-unix . efs-apollo-unix-host-regexp) - (unix . efs-unix-host-regexp) - (vms . efs-vms-host-regexp) - (mts . efs-mts-host-regexp) - (cms . efs-cms-host-regexp) - (ti-explorer . efs-ti-explorer-host-regexp) - (ti-twenex . efs-ti-twenex-host-regexp) - (dos . efs-dos-host-regexp) - (mvs . efs-mvs-host-regexp) - (tops-20 . efs-tops-20-host-regexp) - (mpe . efs-mpe-host-regexp) - (ka9q . efs-ka9q-host-regexp) - (dos-distinct . efs-dos-distinct-host-regexp) - (os2 . efs-os2-host-regexp) - (vos . efs-vos-host-regexp) - (hell . efs-hell-host-regexp) - (guardian . efs-guardian-host-regexp) - (ms-unix . efs-ms-unix-host-regexp) - (plan9 . efs-plan9-host-regexp) - (cms-net . efs-cms-knet-host-regexp) - (nos-ve . efs-nos-ve-host-regexp) - (netware . efs-netware-host-regexp) - (dumb-apollo-unix . efs-dumb-apollo-unix-regexp))) - -;; host type cache -(defconst efs-host-cache nil) -(defconst efs-host-type-cache nil) - -;; cache for efs-ftp-path. -(defconst efs-ftp-path-arg "") -(defconst efs-ftp-path-res nil) - -;;;; ------------------------------------------------------------- -;;;; General macros. -;;;; ------------------------------------------------------------- - -(defmacro efs-save-match-data (&rest body) - "Execute the BODY forms, restoring the global value of the match data. -Before executing BODY, case-fold-search is locally bound to nil." - ;; Because Emacs is buggy about let-binding buffer-local variables, - ;; we have to do this in a slightly convoluted way. - (let ((match-data-temp (make-symbol "match-data")) - (buff-temp (make-symbol "buff")) - (cfs-temp (make-symbol "cfs"))) - (list - 'let (list (list match-data-temp '(match-data)) - (list buff-temp '(current-buffer)) - (list cfs-temp 'case-fold-search)) - (list 'unwind-protect - (cons 'progn - (cons - '(setq case-fold-search nil) - body)) - (list 'condition-case nil - (list 'save-excursion - (list 'set-buffer buff-temp) - (list 'setq 'case-fold-search cfs-temp)) - '(error nil)) - (list 'store-match-data match-data-temp))))) - -(put 'efs-save-match-data 'lisp-indent-hook 0) -(put 'efs-save-match-data 'edebug-form-spec '(&rest form)) - -(defmacro efs-define-fun (fun args &rest body) - "Like defun, but only defines a function if it has no previous definition." - ;; There are easier ways to do this. This approach is used so that the - ;; byte compiler won't complain about possibly undefined functions. - (` - (progn - (put (quote (, fun)) 'efs-define-fun - (and (fboundp (quote (, fun))) - (symbol-function (quote (, fun))))) - (defun (, fun) (, args) (,@ body)) - (if (and (get (quote (, fun)) 'efs-define-fun) - (not (eq (car-safe (get (quote (, fun)) 'efs-define-fun)) - (quote autoload)))) - (fset (quote (, fun)) (get (quote (, fun)) 'efs-define-fun))) - (put (quote (, fun)) 'efs-define-fun nil) - (quote (, fun))))) - -(put 'efs-define-fun 'lisp-indent-hook 'defun) - -(defmacro efs-quote-dollars (string) - ;; Quote `$' as `$$' in STRING to get it past `substitute-in-file-name.' - (` - (let ((string (, string)) - (pos 0)) - (while (setq pos (string-match "\\$" string pos)) - (setq string (concat (substring string 0 pos) - "$";; precede by escape character (also a $) - (substring string pos)) - ;; add 2 instead 1 since another $ was inserted - pos (+ 2 pos))) - string))) - -(defmacro efs-cont (implicit-args explicit-args &rest body) - "Defines an efs continuation function. -The IMPLICIT-ARGS are bound when the continuation function is called. -The EXPLICIT-ARGS are bound when the continuation function is set." - (let ((fun (list 'function - (cons 'lambda - (cons - (append implicit-args explicit-args) - body))))) - (if explicit-args - (cons 'list (cons fun explicit-args)) - fun))) - -(put 'efs-cont 'lisp-indent-hook 2) - -;;;; ------------------------------------------------------------ -;;;; Utility functions -;;;; ------------------------------------------------------------ - -(efs-define-fun efs-repaint-minibuffer () - ;; Set minibuf_message = 0, so that the contents of the minibuffer will show. - ;; This is the Emacs V19 version of this function. For Emacs 18, it will - ;; be redefined in a grotty way to accomplish the same thing. - (message nil)) - -(defun efs-get-user (host) - "Given a HOST, return the default USER." - (efs-parse-netrc) - ;; We cannot check for users case-insensitively on those systems - ;; which are treat usernames case-insens., because we need to log in - ;; first, before we know what type of system. - (let ((user (efs-get-host-property host 'user))) - (if (stringp user) - user - (prog1 - (setq user - (cond ((stringp efs-default-user) - ;; We have a default name. Use it. - efs-default-user) - ((consp efs-default-user) - ;; Walk the list looking for a host-specific value. - (efs-save-match-data - (let ((alist efs-default-user) - (case-fold-search t) - result) - (while alist - (if (string-match (car (car alist)) host) - (setq result (cdr (car alist)) - alist nil) - (setq alist (cdr alist)))) - (cond - ((stringp result) - result) - (result - (let ((enable-recursive-minibuffers t)) - (read-string (format "User for %s: " host) - (user-login-name)))) - (t - (user-login-name)))))) - (efs-default-user - ;; Ask the user. - (let ((enable-recursive-minibuffers t)) - (read-string (format "User for %s: " host) - (user-login-name)))) - ;; Default to the user's login name. - (t - (user-login-name)))) - (efs-set-user host user))))) - -;;;###autoload -(defun efs-ftp-path (path) - "Parse PATH according to efs-path-regexp. -Returns a list (HOST USER PATH), or nil if PATH does not match the format." - (or (string-equal path efs-ftp-path-arg) - (setq efs-ftp-path-res - (efs-save-match-data - (and (string-match efs-path-regexp path) - (let ((host (substring path (match-beginning 2) - (match-end 2))) - (user (and (match-beginning 1) - (substring path (match-beginning 1) - (1- (match-end 1))))) - (rpath (substring path (1+ (match-end 2))))) - (list (if (string-equal host "") - (setq host (system-name)) - host) - (or user (efs-get-user host)) - rpath)))) - ;; Set this last, in case efs-get-user calls this - ;; function, which would modify an earlier setting. - efs-ftp-path-arg path)) - efs-ftp-path-res) - -(defun efs-chase-symlinks (file) - ;; If FILE is a symlink, chase it until we get to a real file. - ;; Unlike file truename, this function does not chase symlinks at - ;; every level, only the bottom level. Therefore, it is not useful for - ;; obtaining the truename of a file. It is useful for getting at file - ;; attributes, with a lot less overhead than file truename. - (let ((target (file-symlink-p file))) - (if target - (efs-chase-symlinks - (expand-file-name target (file-name-directory file))) - file))) - -;; If efs-host-type is called with the optional user -;; argument, it will attempt to guess the host type by connecting -;; as user, if necessary. - -(defun efs-host-type (host &optional user) - "Return a symbol which represents the type of the HOST given. -If the optional argument USER is given, attempts to guess the -host-type by logging in as USER." - - (and host - (let ((host (downcase host)) - type) - (cond - - ((and efs-host-cache - (string-equal host efs-host-cache) - efs-host-type-cache)) - - ((setq type - (efs-get-host-property host 'host-type)) - (setq efs-host-cache host - efs-host-type-cache type)) - - ;; Trigger an ftp connection, in case we need to - ;; guess at the host type. - ((and user (efs-get-process host user) - (if (string-equal host efs-host-cache) - ;; logging in may update the cache - efs-host-type-cache - (and (setq type (efs-get-host-property host 'host-type)) - (setq efs-host-cache host - efs-host-type-cache type))))) - - ;; Try the regexps. - ((setq type - (let ((alist efs-host-type-alist) - regexp type-pair) - (catch 'match - (efs-save-match-data - (let ((case-fold-search t)) - (while alist - (progn - (and (setq type-pair (car alist) - regexp (eval (cdr type-pair))) - (string-match regexp host) - (throw 'match (car type-pair))) - (setq alist (cdr alist))))) - nil)))) - (setq efs-host-cache host - efs-host-type-cache type)) - ;; Return 'unknown, but _don't_ cache it. - (t 'unknown))))) - -;;;; ------------------------------------------------------------- -;;;; Functions and macros for hashtables. -;;;; ------------------------------------------------------------- - -(defun efs-make-hashtable (&optional size) - "Make an obarray suitable for use as a hashtable. -SIZE, if supplied, should be a prime number." - (make-vector (or size 31) 0)) - -(defun efs-map-hashtable (fun tbl &optional property) - "Call FUNCTION on each key and value in HASHTABLE. -If PROPERTY is non-nil, it is the property to be used as the second -argument to FUNCTION. The default property is 'val" - (let ((prop (or property 'val))) - (mapatoms - (function - (lambda (sym) - (funcall fun (symbol-name sym) (get sym prop)))) - tbl))) - -(defmacro efs-make-hash-key (key) - "Convert KEY into a suitable key for a hashtable. This returns a string." - (` (let ((key (, key))) ; eval exactly once, in case evalling key moves the - ; point. - (if (stringp key) key (prin1-to-string key))))) - -;;; Note, if you store entries in a hashtable case-sensitively, and then -;;; retrieve them with IGNORE-CASE=t, it is possible that there may be -;;; be more than one entry that could be retrieved. It is more or less random -;;; which one you'll get. The onus is on the programmer to be consistent. -;;; Suggestions to make this faster are gratefully accepted! - -(defmacro efs-case-fold-intern-soft (name tbl) - "Returns a symbol with case-insensitive name NAME in the obarray TBL. -Case is considered insignificant in NAME. Note, if there is more than -one possible match, it is hard to predicate which one you'll get." - (` - (let* ((completion-ignore-case t) - (name (, name)) - (tbl (, tbl)) - (len (length (, name))) - (newname (try-completion name tbl - (function - (lambda (sym) - (= (length (symbol-name sym)) len)))))) - (and newname - (if (eq newname t) - (intern name tbl) - (intern newname tbl)))))) - -(defmacro efs-hash-entry-exists-p (key tbl &optional ignore-case) - "Return whether there is an association for KEY in TABLE. -If optional IGNORE-CASE is non-nil, then ignore-case in the test." - (` (let ((key (efs-make-hash-key (, key)))) - (if (, ignore-case) - (efs-case-fold-intern-soft key (, tbl)) - (intern-soft key (, tbl)))))) - -(defmacro efs-get-hash-entry (key tbl &optional ignore-case) - "Return the value associated with KEY in HASHTABLE. -If the optional argument IGNORE-CASE is given, then case in the key is -considered irrelevant." - (` (let* ((key (efs-make-hash-key (, key))) - (sym (if (, ignore-case) - (efs-case-fold-intern-soft key (, tbl)) - (intern-soft key (, tbl))))) - (and sym (get sym 'val))))) - -(defmacro efs-put-hash-entry (key val tbl &optional ignore-case) - "Record an association between KEY and VALUE in HASHTABLE. -If the optional IGNORE-CASE argument is given, then check for an entry -which is the same modulo case, and update it instead of adding a new entry." - (` (let* ((key (efs-make-hash-key (, key))) - (sym (if (, ignore-case) - (or (efs-case-fold-intern-soft key (, tbl)) - (intern key (, tbl))) - (intern key (, tbl))))) - (put sym 'val (, val))))) - -(defun efs-del-hash-entry (key tbl &optional ignore-case) - "Copy all symbols except KEY in HASHTABLE and return modified hashtable. -If the optional argument CASE-FOLD is non-nil, then fold KEY to lower case." - (let* ((len (length tbl)) - (new-tbl (efs-make-hashtable len)) - (i (1- len)) - (key (efs-make-hash-key key))) - (if ignore-case (setq key (downcase key))) - (efs-map-hashtable - (if ignore-case - (function - (lambda (k v) - (or (string-equal (downcase k) key) - ;; Don't need to specify ignore-case here, because - ;; we have already weeded out possible case-fold matches. - (efs-put-hash-entry k v new-tbl)))) - (function - (lambda (k v) - (or (string-equal k key) - (efs-put-hash-entry k v new-tbl))))) - tbl) - (while (>= i 0) - (aset tbl i (aref new-tbl i)) - (setq i (1- i))) - ;; Return the result. - tbl)) - -(defun efs-hash-table-keys (tbl &optional nosort) - "Return a sorted of all the keys in the hashtable TBL, as strings. -This list is sorted, unless the optional argument NOSORT is non-nil." - (let ((result (all-completions "" tbl))) - (if nosort - result - (sort result (function string-lessp))))) - -;;; hashtable variables - -(defconst efs-host-hashtable (efs-make-hashtable) - "Hash table holding data on hosts.") - -(defconst efs-host-user-hashtable (efs-make-hashtable) - "Hash table for holding data on host user pairs.") - -(defconst efs-minidisk-hashtable (efs-make-hashtable) - "Mapping between a host, user, minidisk triplet and a account password.") - -;;;; ------------------------------------------------------------ -;;;; Host / User mapping -;;;; ------------------------------------------------------------ - -(defun efs-set-host-property (host property value) - ;; For HOST, sets PROPERTY to VALUE. - (put (intern (downcase host) efs-host-hashtable) property value)) - -(defun efs-get-host-property (host property) - ;; For HOST, gets PROPERTY. - (get (intern (downcase host) efs-host-hashtable) property)) - -(defun efs-set-host-user-property (host user property value) - ;; For HOST and USER, sets PROPERTY to VALUE. - (let* ((key (concat (downcase host) "/" user)) - (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) - (efs-case-fold-intern-soft key efs-host-user-hashtable)))) - (or sym (setq sym (intern key efs-host-user-hashtable))) - (put sym property value))) - -(defun efs-get-host-user-property (host user property) - ;; For HOST and USER, gets PROPERTY. - (let* ((key (concat (downcase host) "/" user)) - (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) - (efs-case-fold-intern-soft key efs-host-user-hashtable)))) - (or sym (setq sym (intern key efs-host-user-hashtable))) - (get sym property))) - -(defun efs-set-user (host user) - "For a given HOST, set or change the default USER." - (interactive "sHost: \nsUser: ") - (efs-set-host-property host 'user user)) - -;;;; ------------------------------------------------------------ -;;;; Encryption -;;;; ------------------------------------------------------------ - -(defconst efs-passwd-seed nil) -;; seed used to encrypt the password cache. - -(defun efs-get-passwd-seed () - ;; Returns a random number to use for encrypting passwords. - (or efs-passwd-seed - (setq efs-passwd-seed (+ 1 (random 255))))) - -(defun efs-code-string (string) - ;; Encode a string, using `efs-passwd-seed'. This is nil-potent, - ;; meaning applying it twice decodes. - (if (and (fboundp 'int-to-char) (fboundp 'char-to-int)) - (mapconcat - (function - (lambda (c) - (char-to-string - (int-to-char (logxor (efs-get-passwd-seed) (char-to-int c)))))) - string "") - (mapconcat - (function - (lambda (c) - (char-to-string (logxor (efs-get-passwd-seed) c)))) - string ""))) - -;;; end of efs-cu.el
--- a/lisp/efs/efs-defun.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-defun.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: efs-defun allows for OS-dependent coding of functions -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Thu Oct 22 17:58:14 1992 -;; Modified: Sun Nov 27 12:18:35 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; efs-defun allows object-oriented emacs lisp definitions. -;;; In efs, this feature is used to support multiple host types. -;;; -;;; The first arg after the function name is a key which determines -;;; which version of the function is being defined. Normally, when the function -;;; is called this key is given as the first argument to the function. -;;; -;;; For example: -;;; -;;; (efs-defun foobar vms (x y) -;;; (message "hello vms world") -;;; (+ x y)) -;;; => foobar -;;; -;;; (foobar 'vms 1 2) -;;; => 3 - -;;; The key nil plays a special role: -;;; -;;; First, it defines a default action. If there is no function -;;; definition associated with a given OS-key, then the function -;;; definition associated with nil is used. If further there is no -;;; function definition associated with nil, then an error is -;;; signaled. -;;; -;;; Second, the documentation string for the function is the one given -;;; with the nil definition. You can supply doc-strings with other -;;; definitions of the function, but they are not accessible with -;;; 'describe-function. In fact, when the function is either loaded or -;;; byte-compiled, they are just thrown away. - -;;; There is another way to define the default action of an efs-function. -;;; This is with the use flag. If you give as the key (&use foobar), -;;; then when the function is called the variable foobar will be used to -;;; determine which OS version of the function to use. As well as -;;; allowing you to define the doc string, if the use flag is used, -;;; then you can specify an interactive specification with the function. -;;; Although a function is only interactive, if the default definition -;;; has an interactive spec, it is still necessary to give interactive -;;; specs for the other definitions of the function as well. It is possible -;;; for these interactive specs to differ. -;;; -;;; For example: -;;; -;;; (efs-defun fizzle (&use foobar) -;;; "Fizzle's doc string." -;;; (interactive) -;;; (message "fizz wizz")) -;;; -;;; (efs-defun fizzle vms -;;; (interactive) -;;; (message "VMS is fizzled.")) -;;; -;;; (setq foobar 'unix) -;;; => unix -;;; -;;; (fizzle) -;;; => "fizz wizz" -;;; -;;; (setq foobar 'vms) -;;; => vms -;;; -;;; (fizzle) -;;; => "VMS is fizzled." -;;; -;;; M-x f i z z l e <return> -;;; => "VMS is fizzled." -;;; -;;; Actually, when you use the &use spec, whatever follows it is simply -;;; evaluated at call time. - -;;; Note that when the function is defined, the key is implicitly -;;; quoted, whereas when the function is called, the key is -;;; evaluated. If this seems strange, think about how efs-defuns -;;; are used in practice. - -;;; There are no restrictions on the order in which the different OS-type -;;; definitions are done. - -;;; There are no restrictions on the keys that can be used, nor on the -;;; symbols that can be used as arguments to an efs-defun. We go -;;; to some lengths to avoid potential conflicts. In particular, when -;;; the OS-keys are looked up in the symbol's property list, we -;;; actually look for a symbol with the same name in the special -;;; obarray, efs-key-obarray. This avoids possible conflicts with -;;; other entries in the property list, that are usually accessed with -;;; symbols in the standard obarray. - -;;; The V19 byte-compiler will byte-compile efs-defun's. -;;; The standard emacs V18 compiler will not, however they will still -;;; work, just not at byte-compiled speed. - -;;; efs-autoload works much like the standard autoload, except it -;;; defines the efs function cell for a given host type as an autoload. -;;; The from-kbd arg only makes sense if the default action of the autoload -;;; has been defined with a &use. - -;;; To do: -;;; -;;; 1. Set an edebug-form-hook for efs-defun - -;;; Known Bugs: -;;; -;;; 1. efs-autoload will correctly NOT overload an existing function -;;; definition with an autoload definition. However, it will also -;;; not overload a previous autoload with a new one. It should. An -;;; overload can be forced for the KEY def of function FUN by doing -;;; (put 'FUN (intern "KEY" efs-key-obarray) nil) first. -;;; - -;;; Provisions and requirements - -(provide 'efs-defun) -(require 'backquote) - -;;; Variables - -(defconst efs-defun-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defconst efs-key-obarray (make-vector 7 0)) - -;; Unfortunately, we need to track this in bytecomp.el. -;; It's not much to keep track of, although. -(defconst efs-defun-bytecomp-buffer "*Compile-Log*") - -(defvar efs-key nil - "Inside an efs function, this is set to the key that was used to -call the function. You can test this inside the default definition, to -determine which key was actually used.") -(defvar efs-args nil - "Inside an efs function, this is set to a list of the calling args -of the function.") - -;;; Utility Functions - -;;; These functions are called when the macros efs-defun and efs-autoload -;;; are expanded. Their purpose is to help in producing the expanded code. - -(defun efs-defun-arg-count (list) - ;; Takes a list of arguments, and returns a list of three - ;; integers giving the number of normal args, the number - ;; of &optional args, and the number of &rest args (this should - ;; only be 0 or 1, but we don't check this). - (let ((o-leng (length (memq '&optional list))) - (r-leng (length (memq '&rest list))) - (leng (length list))) - (list (- leng (max o-leng r-leng)) - (max 0 (- o-leng r-leng 1)) - (max 0 (1- r-leng))))) - -;; For each efs-function the property efs-function-arg-structure -;; is either a list of three integers to indicate the number of normal, -;; optional, and rest args, or it can be the symbol 'autoload to indicate -;; that all definitions of the function are autoloads, and we have no -;; idea of its arg structure. - -(defun efs-defun-arg-check (fun key list) - ;; Checks that the LIST of args is consistent for the KEY def - ;; of function FUN. - (let ((prop (get fun 'efs-function-arg-structure)) - count) - (if (eq list 'autoload) - (or prop (put fun 'efs-function-arg-structure 'autoload)) - (setq count (efs-defun-arg-count list)) - (if (and prop (not (eq prop 'autoload)) (not (equal prop count))) - (let ((warning - (format - "args. for the %s def. of %s don't agree with previous defs." - key fun))) - (message (concat "Warning: " warning)) - ;; We are compiling, I suppose... - (if (get-buffer efs-defun-bytecomp-buffer) - (save-excursion - (set-buffer efs-defun-bytecomp-buffer) - (goto-char (point-max)) - (insert "efs warning:\n " warning "\n"))))) - (put fun 'efs-function-arg-structure count)))) - -(defun efs-def-generic (fun use doc-string interactive-p) - ;; Generates a generic function def using USE. - ;; If use is nil, the first arg of the function - ;; is the key. - (let ((def-args '(&rest efs-args)) - result) - (or use - (setq def-args (cons 'efs-key def-args))) - (setq result - (` (or (get (quote (, fun)) - (, (if use - (list 'intern - (list 'symbol-name use) - 'efs-key-obarray) - '(intern - (symbol-name efs-key) - efs-key-obarray)))) - (get (quote (, fun)) - (intern "nil" efs-key-obarray))))) - ;; Make the gen fun interactive, if nec. - (setq result - (if interactive-p - (` ((interactive) - (if (interactive-p) - (let ((prefix-arg current-prefix-arg)) - (call-interactively - (, result))) - (, (cons 'apply (list result 'efs-args)))))) - (list (cons 'apply (list result 'efs-args))))) - (if doc-string (setq result (cons doc-string result))) - (cons 'defun (cons fun (cons def-args result))))) - -(defun efs-def-autoload (fun key file from-kbd) - ;; Returns the autoload lambda for FUN and FILE. - ;; I really should have some notion of efs-autoload - ;; objects, and not just plain lambda's. - (let ((result - (if from-kbd - (` - (lambda (&rest args) - (interactive) - (let ((qkey (intern (symbol-name (quote (, key))) - efs-key-obarray)) - (tmp1 (intern "tmp1" efs-key-obarray)) - (tmp2 (intern "tmp2" efs-key-obarray))) - ;; Need to store the a-f-function, to see if it has been - ;; re-defined by the load. This is avoid to an infinite loop. - (set tmp1 (get (quote (, fun)) qkey)) - ;; Need to store the prefix arg in case it's interactive. - ;; These values are stored in variables interned in the - ;; efs-key-obarray, because who knows what loading a - ;; file might do. - (set tmp2 current-prefix-arg) - (load (, file)) - ;; check for re-def - (if (equal (symbol-value tmp1) - (get (quote (, fun)) qkey)) - (error "%s definition of %s is not defined by loading %s" - qkey (quote (, fun)) (, file))) - ;; call function - (if (interactive-p) - (let ((prefix-arg (symbol-value tmp2))) - (call-interactively - (get (quote (, fun)) qkey))) - (apply (get (quote (, fun)) qkey) args))))) - (` (lambda (&rest args) - (let ((qkey (intern (symbol-name (quote (, key))) - efs-key-obarray)) - (tmp1 (intern "tmp1" efs-key-obarray))) - ;; Need to store the a-f-function, to see if it has been - ;; re-defined by the load. This is avoid to an infinite loop. - (set tmp1 (get (quote (, fun)) qkey)) - (load (, file)) - ;; check for re-def - (if (equal (symbol-value tmp1) - (get (quote (, fun)) qkey)) - (error "%s definition of %s is not defined by loading %s" - qkey (quote (, fun)) (, file))) - ;; call function - (apply (get (quote (, fun)) qkey) args))))))) - (list 'put (list 'quote fun) - (list 'intern - (list 'symbol-name (list 'quote key)) - 'efs-key-obarray) - (list 'function result)))) - -;;; User level macros -- efs-defun and efs-autoload. - -(defmacro efs-defun (funame key args &rest body) - (let* ((use (and (eq (car-safe key) '&use) - (nth 1 key))) - (key (and (null use) key)) - result doc-string interactive-p) - ;; check args - (efs-defun-arg-check funame key args) - ;; extract doc-string - (if (stringp (car body)) - (setq doc-string (car body) - body (cdr body))) - ;; If the default fun is interactive, and it's a use construct, - ;; then we allow the gen fun to be interactive. - (if use - (setq interactive-p (eq (car-safe (car-safe body)) 'interactive))) - (setq result - (` ((put (quote (, funame)) - (intern (symbol-name (quote (, key))) - efs-key-obarray) - (function - (, (cons 'lambda - (cons args body))))) - (quote (, funame))))) - ;; if the key is null, make a generic def - (if (null key) - (setq result - (cons (efs-def-generic - funame use doc-string interactive-p) - result))) - ;; return - (cons 'progn result))) - -;;; For lisp-mode - -(put 'efs-defun 'lisp-indent-hook 'defun) - -;; efs-autoload -;; Allows efs function cells to be defined as autoloads. -;; If efs-autoload inserted autoload objects in the property list, -;; and the funcall mechanism in efs-defun checked for such -;; auto-load objects, we could reduce the size of the code -;; resulting from expanding efs-autoload. However, the expansion -;; of efs-defun would be larger. What is the best thing to do? - -(defmacro efs-autoload (fun key file &optional docstring from-kbd) - (let* ((use (and (eq (car-safe key) '&use) - (nth 1 key))) - (key (and (null use) key))) - (efs-defun-arg-check (eval fun) key 'autoload) - ;; has the function been previously defined? - (` - (if (null (get (, fun) - (intern (symbol-name (quote (, key))) - efs-key-obarray))) - (, - (if (null key) - (list 'progn - ;; need to eval fun, since autoload wants an explicit - ;; quote built into the fun arg. - (efs-def-generic - (eval fun) use docstring from-kbd ) - (efs-def-autoload (eval fun) key file from-kbd) - (list 'quote - (list - 'efs-autoload - key file docstring from-kbd))) - (list 'progn - (efs-def-autoload (eval fun) key file from-kbd) - (list 'quote - (list - 'efs-autoload - key file docstring from-kbd))))))))) - -(defun efs-fset (sym key fun) - ;; Like fset but sets KEY's definition of SYM. - (put sym (intern (symbol-name key) efs-key-obarray) fun)) - -(defun efs-fboundp (key fun) - ;; Like fboundp, but checks for KEY's def. - (null (null (get fun (intern (symbol-name key) efs-key-obarray))))) - -;; If we are going to use autoload objects, the following two functions -;; will be useful. -;; -;; (defun efs-defun-do-autoload (fun file key interactive-p args) -;; ;; Loads FILE and runs the KEY def of FUN. -;; (let (fun file key interactive-p args) -;; (load file)) -;; (let ((new-def (get fun key))) -;; (if (eq (car-safe new-def) 'autoload) -;; (error "%s definition of %s is not defined by loading %s" -;; key fun file) -;; (if interactive-p -;; (let ((prefix-arg current-predix-arg)) -;; (call-interactively fun)) -;; (apply new-def args))))) -;; -;; (defun efs-defun-autoload (fun key file doc-string from-kbd) -;; ;; Sets the KEY def of FUN to an autoload object. -;; (let* ((key (intern (symbol-name key) efs-key-obarray)) -;; (def (get fun key))) -;; (if (or (null def) -;; (eq (car-safe def) 'autoload)) -;; (put fun key (list 'autoload file doc-string from-kbd))))) - -;;; end of efs-defun.el
--- a/lisp/efs/efs-dired-mule.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dired.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Makes efs-dired.el work with MULE. -;; Author: Ishikawa Ichiro <ichiro@ccsr.u-tokyo.ac.jp> -;; Created: Sat Aug 20 05:25:55 1994 -;; Modified: Sun Nov 27 12:19:17 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst efs-dired-mule-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;; Keep the byte-compiler happy -(defvar efs-version-host-types) -(defvar efs-dired-host-type) - -(defun efs-dired-find-file (&optional coding-system) - "Documented as original" - (interactive "ZCoding-system: ") - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (find-file file coding-system))) - -(defun efs-dired-find-file-other-window (&optional display coding-system) - "Documented as original" - (interactive "P\nZCoding-system: ") - (if display - (dired-display-file coding-system) - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (find-file-other-window file coding-system)))) - - -(defun efs-dired-display-file (&optional coding-system) - "Documented as original" - (interactive "ZCoding-system: ") - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (display-buffer (find-file-noselect file coding-system)))) - -;;; end of efs-dired-mule.el
--- a/lisp/efs/efs-dired.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1635 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dired.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.32 $ -;; RCS: -;; Description: Extends much of Dired to work under efs. -;; Authors: Sebastian Kremer <sk@thp.uni-koeln.de>, -;; Andy Norman <ange@hplb.hpl.hp.com>, -;; Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Throughout the ages. -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Provisions and requirements - -(provide 'efs-dired) -(require 'efs) -(require 'dired) -(autoload 'dired-shell-call-process "dired-shell") - -(defconst efs-dired-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.32 $" 11 -2))) - -;;;; ---------------------------------------------------------------- -;;;; User Configuration Variables -;;;; ---------------------------------------------------------------- - -(defvar efs-dired-verify-modtime-host-regexp nil - "Regular expression determining on which hosts dired modtimes are checked.") - -(defvar efs-dired-verify-anonymous-modtime nil - "If non-nil, dired modtimes are checked for anonymous logins.") - -;;; Internal Variables - -(make-variable-buffer-local 'dired-ls-F-marks-symlinks) - -;;;; ----------------------------------------------------------- -;;;; Inserting Directories into Buffers -;;;; ----------------------------------------------------------- - -;; The main command for inserting a directory listing in a buffer. -;; In Emacs 19 this is in files.el, and not specifically connected to -;; dired. Since our version of it uses some dired functions, it is -;; included here, but there is an autoload for it in efs.el. - -(defun efs-insert-directory (file switches &optional wildcard full-directory-p - nowait marker-char) - ;; Inserts a remote directory. Can do this asynch. - (let* ((parsed (efs-ftp-path file)) - (mk (point-marker)) - (host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (host-type (efs-host-type host)) - (dumb (memq host-type efs-dumb-host-types)) - (subdir (and (null (or full-directory-p wildcard)) - (condition-case nil - (dired-current-directory) - (error nil)))) - (case-fold-search nil) ; for testing switches - (parse (and full-directory-p (not wildcard) - (or dumb (efs-parsable-switches-p switches)))) - ;; In case dired-omit-silent isn't defined. - (dired-omit-silent (and (boundp 'dired-omit-silent) - dired-omit-silent))) - - ;; Insert the listing. If it's not a wild-card, and not a full-dir, - ;; then we are updating a dired-line. Do this asynch. - ;; This way of doing the listing makes sure that the dired - ;; buffer is still around after the listing is obtained. - - (efs-ls - file switches t (if parse 'parse t) nil - ;; asynch, if we're inserting in a subdir. Do it nowait = 0, so - ;; updating the file line gets a high priority?? - ;; Insert subdir listings NOWAIT = 0 also so 1-line - ;; updates don't toggle the mode line. - (if (and subdir nowait) 0 nowait) - (efs-cont (listing) (host user file path wildcard - nowait marker-char - mk subdir parse switches dired-omit-silent) - ;; We pass the value of dired-omit-silent from the caller to the cont. - (let ((host-type (efs-host-type host)) - (listing-type (efs-listing-type host user))) - (if (marker-buffer mk) - (efs-save-buffer-excursion - (set-buffer (marker-buffer mk)) - ;; parsing a listing, sometimes updates info - (if (and parse (eq major-mode 'dired-mode)) - (progn - (setq efs-dired-host-type host-type - efs-dired-listing-type listing-type - efs-dired-listing-type-string - (and efs-show-host-type-in-dired - (concat " " - (symbol-name - efs-dired-listing-type)))) - (if (memq host-type '(bsd-unix next-unix)) - (setq dired-ls-F-marks-symlinks nil) - (if (memq host-type '(sysV-unix apollo-unix)) - (setq dired-ls-F-marks-symlinks t))))) - (if subdir - ;; a 1-line re-list - (save-excursion - (efs-update-file-info - host-type file efs-data-buffer-name) - (goto-char mk) - (let ((new-subdir (condition-case nil - (dired-current-directory) - (error nil))) - buffer-read-only) - (if (and new-subdir - (string-equal subdir new-subdir)) - (progn - ;; Is there an existing entry? - (if (dired-goto-file file) - (progn - (delete-region - (save-excursion - (skip-chars-backward "^\n\r") - (1- (point))) - (progn - (skip-chars-forward "^\n\r") - (point))) - (goto-char mk))) - (insert listing) - (save-restriction - (narrow-to-region mk (point)) - (efs-dired-fixup-listing - listing-type file path switches wildcard) - (efs-dired-ls-trim - listing-type) - ;; save-excursion loses if fixup had to - ;; remove and re-add the region. Say for - ;; sorting. - (goto-char (point-max))) - (if (and nowait (eq major-mode 'dired-mode)) - (dired-after-add-entry - (marker-position mk) - marker-char)))))) - (goto-char mk) - (let (buffer-read-only) - (insert listing) - (save-restriction - (narrow-to-region mk (point)) - (efs-dired-fixup-listing - listing-type file path switches wildcard) - (goto-char (point-max)))))))))) - ;; Return 0 if synch, nil if asynch - (if nowait nil 0))) - -;;; Functions for cleaning listings. - -(efs-defun efs-dired-ls-trim nil () - ;; Trims dir listings, so that the listing of a single file is one line. - nil) - -(efs-defun efs-dired-fixup-listing nil (file path &optional switches wildcard) - ;; FILE is in efs syntax. - ;; PATH is just the remote path. - ;; Some ftpd's put the whole directory name in front of each filename. - ;; Seems to depend in a strange way on server-client interaction. - ;; Walk down the listing generated and remove this stuff. - ;; SWITCHES is a string. - (if (memq efs-key efs-unix-host-types) - (let ((continue t) - spot bol) - (goto-char (point-min)) - (while (and (not (eobp)) continue) - (and (setq bol (point) - spot (dired-manual-move-to-filename nil bol)) - (setq continue (= (following-char) ?/)) - (dired-manual-move-to-end-of-filename t bol) - (progn - (skip-chars-backward "^/") - (delete-region spot (point)))) - (forward-line 1)) - (efs-save-match-data - (if (and switches (string-match "R" switches) - (not (string-match "d" switches))) - (let ((subdir-regexp "^\\(/[^ \n\r]+\\):[\n\r]") - name) - (goto-char (point-min)) - (while (re-search-forward subdir-regexp nil t) - (goto-char (match-beginning 0)) - ;; There may be /./ type nonsense. - ;; expand-file-name will handle it. - (setq name (expand-file-name - (buffer-substring (point) (match-end 0)))) - (delete-region (point) (match-end 0)) - (insert (efs-replace-path-component file name))))))))) - - -;;;; ------------------------------------------------------------ -;;;; Tree Dired support -;;;; ------------------------------------------------------------ - -;;; efs-dired keymap - -(defvar efs-dired-map nil - "Keymap for efs commands in dired buffers.") - -(if efs-dired-map - () - (setq efs-dired-map (make-sparse-keymap)) - (define-key efs-dired-map "c" 'efs-dired-close-ftp-process) - (define-key efs-dired-map "k" 'efs-dired-kill-ftp-process) - (define-key efs-dired-map "o" 'efs-dired-display-ftp-process-buffer) - (define-key efs-dired-map "p" 'efs-dired-ping-connection)) - -(fset 'efs-dired-prefix efs-dired-map) - -;;; Functions for dealing with the FTP process - -(defun efs-dired-close-ftp-process () - "Close the FTP process for the current dired buffer. -Closing causes the connection to be dropped, but efs will retain its -cached data for the connection. This will make it more efficient to -reopen the connection." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-close-ftp-process (current-buffer)) - (let ((parsed (efs-ftp-path default-directory))) - (message "Closed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) - -(defun efs-dired-kill-ftp-process () - "Kills the FTP process for the current dired buffer. -Killing causes the connection to be closed, the process buffer to be killed, -and most of efs's cached data to be wiped." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-kill-ftp-process (current-buffer)) - (let ((parsed (efs-ftp-path default-directory))) - (message "Killed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) - -(defun efs-dired-display-ftp-process-buffer () - "Displays in another window the FTP process buffer for a dired buffer." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-display-ftp-process-buffer (current-buffer))) - -(defun efs-dired-ping-connection () - "Pings FTP connection associated with current dired buffer." - (interactive) - (or efs-dired-host-type - (error "Dired buffer is not for a remote directory.")) - (efs-ping-ftp-connection (current-buffer))) - - -;;; Reading in dired buffers. - -(defun efs-dired-revert (&optional arg noconfirm) - (let ((efs-ls-uncache t)) - (dired-revert arg noconfirm))) - -(defun efs-dired-default-dir-function () - (let* ((cd (dired-current-directory)) - (parsed (efs-ftp-path cd))) - (if parsed - (efs-save-match-data - (let ((tail directory-abbrev-alist)) - (while tail - (if (string-match (car (car tail)) cd) - (setq cd (concat (cdr (car tail)) - (substring cd (match-end 0))) - parsed nil)) - (setq tail (cdr tail))) - (apply 'efs-unexpand-parsed-filename - (or parsed (efs-ftp-path cd))))) - cd))) - -(defun efs-dired-before-readin () - ;; Put in the dired-before-readin-hook. - (let ((parsed (efs-ftp-path default-directory))) - (if parsed - (let ((host (car parsed)) - (user (nth 1 parsed))) - (setq efs-dired-listing-type (efs-listing-type host user) - efs-dired-host-type (efs-host-type host) - efs-dired-listing-type-string - (and efs-show-host-type-in-dired - (concat " " (symbol-name efs-dired-listing-type)))) - (set (make-local-variable 'revert-buffer-function) - (function efs-dired-revert)) - (set (make-local-variable 'default-directory-function) - (function efs-dired-default-dir-function)) - (set (make-local-variable 'dired-verify-modtimes) - (null (null (and - efs-dired-verify-modtime-host-regexp - (efs-save-match-data - (let ((case-fold-search t)) - (string-match - efs-dired-verify-modtime-host-regexp host)) - (or efs-dired-verify-anonymous-modtime - (not (efs-anonymous-p user)))))))) - ;; The hellsoft ftp server mixes up cases. - ;; However, we may not be able to catch this until - ;; after the first directory is listed. - (if (and - (eq efs-dired-host-type 'hell) - (not (string-equal default-directory - (setq default-directory - (downcase default-directory))))) - (or (string-equal (buffer-name) (downcase (buffer-name))) - (rename-buffer (generate-new-buffer-name - (directory-file-name default-directory))))) - ;; Setup the executable and directory regexps - (let ((eentry (assq efs-dired-listing-type - efs-dired-re-exe-alist)) - (dentry (assq efs-dired-listing-type - efs-dired-re-dir-alist))) - (if eentry - (set (make-local-variable 'dired-re-exe) (cdr eentry))) - (if dentry - (set (make-local-variable 'dired-re-dir) (cdr dentry)))) - ;; No switches are sent to dumb hosts, so don't confuse dired. - ;; I hope that dired doesn't get excited if it doesn't see the l - ;; switch. If it does, then maybe fake things by setting this to - ;; "-Al". - (if (eq efs-dired-listing-type 'vms) - (setq dired-internal-switches - (delq ?F dired-internal-switches)) - (if (memq efs-dired-host-type efs-dumb-host-types) - (setq dired-internal-switches '(?l ?A) - ;; Don't lie on the mode line - dired-sort-mode ""))) - ;; If the remote file system is version-based, don't set - ;; dired-kept-versions to 0. It will flag the most recent - ;; copy of the file for deletion -- this isn't really a backup. - (if (memq efs-dired-host-type efs-version-host-types) - (set (make-local-variable 'dired-kept-versions) - (max 1 dired-kept-versions))))))) - -(efs-defun efs-dired-insert-headerline (&use efs-dired-listing-type) (dir) - "Documented as original." - (efs-real-dired-insert-headerline dir)) - -(defun efs-dired-uncache (file dir-p) - ;; Remove FILE from cache. - (if dir-p - (efs-del-from-ls-cache file nil t) - (efs-del-from-ls-cache file t nil))) - -;;; Checking modtimes of directories. -;; -;; This only runs if efs-dired-verify-anonymous-modtime and -;; efs-verify-modtime-host-regexp turn it on. Few (any?) FTP servers -;; support getting MDTM for directories. As usual, we cache whether -;; this works, and don't keep senselessly trying it if it doesn't. - -(defun efs-dired-file-modtime (file) - ;; Returns the modtime. - (let* ((parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (rpath (nth 2 parsed))) - (and (null (efs-get-host-property host 'dir-mdtm-failed)) - (let ((result (efs-send-cmd host user (list 'quote 'mdtm rpath) - (and (eq efs-verbose t) - "Getting modtime"))) - mp) - (if (and (null (car result)) - (setq mp (efs-parse-mdtime (nth 1 result)))) - (let ((ent (efs-get-file-entry file))) - (if ent - (setcdr ent (list (nth 1 ent) (nth 2 ent) - (nth 3 ent) (nth 4 ent) mp))) - parsed) - (efs-set-host-property host 'dir-mdtm-failed t) - nil))))) - -(defun efs-dired-set-file-modtime (file alist) - ;; This works asynch. - (let* ((parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed))) - (if (efs-get-host-property host 'dir-mdtm-failed) - (let ((elt (assoc file alist))) - (if elt (setcar (nthcdr 4 elt) nil))) - (efs-send-cmd - host user (list 'quote 'mdtm path) nil nil - (efs-cont (result line cont-lines) (file alist host) - (let ((elt (assoc file alist)) - modtime) - (if (and (null result) (setq modtime (efs-parse-mdtime line))) - (if elt (setcar (nthcdr 4 elt) modtime)) - (if elt (setcar (nthcdr 4 elt) nil)) - (efs-set-host-property host 'dir-mdtm-failed t)))) - 0) ; Always do this NOWAIT = 0 - nil))) ; return NIL - -;;; Asynch insertion of subdirs. Used when renaming subdirs. - -(defun efs-dired-insert-subdir (dirname &optional noerror nowait) - (let ((buff (current-buffer)) - (switches (delq ?R (copy-sequence dired-internal-switches)))) - (efs-ls - dirname (dired-make-switches-string switches) - t nil noerror nowait - (efs-cont (listing) (dirname buff switches) - (if (and listing (get-buffer buff)) - (save-excursion - (set-buffer buff) - (save-excursion - (let ((elt (assoc dirname dired-subdir-alist)) - mark-list) - (if elt - (setq mark-list (dired-insert-subdir-del elt)) - (dired-insert-subdir-newpos dirname)) - (dired-insert-subdir-doupdate - dirname - (efs-dired-insert-subdir-do-insert dirname listing) - switches elt mark-list))))))))) - -(defun efs-dired-insert-subdir-do-insert (dirname listing) - (let ((begin (point)) - indent-tabs-mode end) - (insert listing) - (setq end (point-marker)) - (indent-rigidly begin end 2) - (goto-char begin) - (dired-insert-headerline dirname) - ;; If the listing has null lines `quote' them so that "\n\n" delimits - ;; subdirs. This is OK, because we aren't inserting -R listings. - (save-excursion - (while (search-forward "\n\n" end t) - (forward-char -1) - (insert " "))) - ;; point is now like in dired-build-subdir-alist - (prog1 - (list begin (marker-position end)) - (set-marker end nil)))) - -;;; Moving around in dired buffers. - -(efs-defun efs-dired-manual-move-to-filename (&use efs-dired-listing-type) - (&optional raise-error bol eol) - "Documented as original." - (efs-real-dired-manual-move-to-filename raise-error bol eol)) - -(efs-defun efs-dired-manual-move-to-end-of-filename - (&use efs-dired-listing-type) (&optional no-error bol eol) - "Documented as original." - (efs-real-dired-manual-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-make-filename-string (&use efs-dired-listing-type) - (filename &optional reverse) - "Documented as original." - ;; This translates file names from the way that they are displayed - ;; in listings to the way that the user gives them in the minibuffer. - ;; For example, in CMS this should take "FOO BAR" to "FOO.BAR". - filename) - -(defun efs-dired-find-file () - "Documented as original." - (interactive) - (find-file - (if (memq efs-dired-host-type efs-version-host-types) - (efs-internal-file-name-sans-versions - efs-dired-host-type (dired-get-filename) t) - (dired-get-filename)))) - -(defun efs-dired-find-file-other-window (&optional display) - "Documented as original." - (interactive "P") - (if display - (dired-display-file) - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (find-file-other-window file)))) - -(defun efs-dired-display-file () - "Documented as original." - (interactive) - (let ((file (dired-get-filename))) - (if (memq efs-dired-host-type efs-version-host-types) - (setq file (efs-internal-file-name-sans-versions - efs-dired-host-type file t))) - (display-buffer (find-file-noselect file)))) - -(defun efs-dired-find-file-other-frame () - "Documented as original." - (interactive) - (find-file-other-frame - (if (memq efs-dired-host-type efs-version-host-types) - (efs-internal-file-name-sans-versions - efs-dired-host-type (dired-get-filename) t) - (dired-get-filename)))) - -;;; Creating and deleting new directories. - -(defun efs-dired-recursive-delete-directory (fn) - ;; Does recursive deletion of remote directories for dired. - (or (file-exists-p fn) - (signal 'file-error - (list "Removing old file name" "no such directory" fn))) - (efs-dired-internal-recursive-delete-directory fn)) - -(defun efs-dired-internal-recursive-delete-directory (fn) - (if (eq (car (file-attributes fn)) t) - (let ((files (efs-directory-files fn))) - (if files - (mapcar (function - (lambda (ent) - (or (string-equal "." ent) - (string-equal ".." ent) - (efs-dired-internal-recursive-delete-directory - (expand-file-name ent fn))))) - files)) - (efs-delete-directory fn)) - (condition-case err - (efs-delete-file fn) - (ftp-error (if (and (nth 2 err) (stringp (nth 2 err)) - (efs-save-match-data - (string-match "^FTP Error: \"550 " (nth 2 err)))) - (message "File %s already deleted." fn) - (signal (car err) (cdr err))))))) - -;;; File backups and versions. - -(efs-defun efs-dired-flag-backup-files - (&use efs-dired-host-type) (&optional unflag-p) - "Documented as original." - (interactive "P") - (efs-real-dired-flag-backup-files unflag-p)) - -(efs-defun efs-dired-collect-file-versions (&use efs-dired-host-type) () - ;; If it looks like a file has versions, return a list of the versions. - ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) - (efs-real-dired-collect-file-versions)) - -;;; Sorting dired buffers - -(defun efs-dired-file-name-lessp (name1 name2) - (if (and efs-dired-host-type - (memq efs-dired-host-type efs-case-insensitive-host-types)) - (string< (downcase name1) (downcase name2)) - (string< name1 name2))) - -;;; Support for async file creators. - -(defun efs-dired-copy-file (from to ok-flag &optional cont nowait) - ;; Version of dired-copy-file for remote files. - ;; Assumes that filenames are already expanded. - (dired-handle-overwrite to) - (efs-copy-file-internal from (efs-ftp-path from) to (efs-ftp-path to) - ok-flag dired-copy-preserve-time 0 cont nowait)) - -(defun efs-dired-rename-file (from to ok-flag &optional cont nowait - insert-subdir) - ;; Version of dired-rename-file for remote files. - (dired-handle-overwrite to) - (efs-rename-file-internal - from to ok-flag nil - (efs-cont (result line cont-lines) (from to cont insert-subdir) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Dired Renaming" - (format "FTP Error: \"%s\"" line) - from to))) - (dired-remove-file from) - ;; Silently rename the visited file of any buffer visiting this file. - ;; We do not maintain inserted subdirs for remote - (efs-dired-rename-update-buffers from to insert-subdir) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait)) - -(defun efs-dired-rename-update-buffers (from to &optional insert-subdir) - (if (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) ; kills write-file-hooks - (set-buffer-modified-p modflag))) - ;; It's a directory. More work to do. - (let ((blist (buffer-list)) - (from-dir (file-name-as-directory from)) - (to-dir (file-name-as-directory to))) - (save-excursion - (while blist - (set-buffer (car blist)) - (setq blist (cdr blist)) - (cond - (buffer-file-name - (if (dired-in-this-tree buffer-file-name from-dir) - (let ((modflag (buffer-modified-p))) - (unwind-protect - (set-visited-file-name - (concat to-dir (substring buffer-file-name - (length from-dir)))) - (set-buffer-modified-p modflag))))) - (dired-directory - (if (string-equal from-dir (expand-file-name default-directory)) - ;; If top level directory was renamed, lots of things - ;; have to be updated. - (progn - (dired-unadvertise from-dir) - (setq default-directory to-dir - dired-directory - ;; Need to beware of wildcards. - (expand-file-name - (file-name-nondirectory dired-directory) - to-dir)) - (let ((new-name (file-name-nondirectory - (directory-file-name dired-directory)))) - ;; Try to rename buffer, but just leave old name if new - ;; name would already exist (don't try appending "<%d>") - ;; Why? --sandy 19-8-94 - (or (get-buffer new-name) - (rename-buffer new-name))) - (dired-advertise)) - (and insert-subdir - (assoc (file-name-directory (directory-file-name to)) - dired-subdir-alist) - (if (efs-ftp-path to) - (efs-dired-insert-subdir to t 1) - (dired-insert-subdir to))))))))))) - -(defun efs-dired-make-relative-symlink (from to ok-flag &optional cont nowait) - ;; efs version of dired-make-relative-symlink - ;; Called as a file-name-handler when dired-make-relative-symlink is - ;; called interactively. - ;; efs-dired-create-files calls it directly to supply CONT - ;; and NOWAIT args. - (setq from (directory-file-name from) - to (directory-file-name to)) - (efs-make-symbolic-link-internal - (dired-make-relative from (file-name-directory to) t) - to ok-flag cont nowait)) - -(defun efs-dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char query - implicit-to) - "Documented as original." - (if (catch 'found - (let ((list fn-list) - val) - (while list - (if (setq val (efs-ftp-path (car list))) - (throw 'found val) - (if (setq val (funcall name-constructor (car list))) - (throw 'found (efs-ftp-path val)) - (setq list (cdr list))))))) - (progn - (cond ((eq file-creator 'dired-copy-file) - (setq file-creator 'efs-dired-copy-file)) - ((eq file-creator 'dired-rename-file) - (setq file-creator 'efs-dired-rename-file)) - ((eq file-creator 'make-symbolic-link) - (setq file-creator 'efs-make-symbolic-link-internal)) - ((eq file-creator 'add-name-to-file) - (setq file-creator 'efs-add-name-to-file-internal)) - ((eq file-creator 'dired-make-relative-symlink) - (setq file-creator 'efs-dired-make-relative-symlink)) - ((eq file-creator 'dired-compress-file) - (setq file-creator 'efs-dired-compress-file)) - ((error "Unable to perform operation %s on remote hosts." - file-creator))) - ;; use the process-filter driven routine rather than the iterative one. - (efs-dcf-1 file-creator operation fn-list name-constructor - (if (eq marker-char t) - (mapcar 'dired-file-marker fn-list) - marker-char) - query (buffer-name (current-buffer)) - nil ;overwrite-query - nil ;dired-overwrite-backup-query - nil ;dired-file-creator-query - nil ;failures - nil ;skipped - 0 ;success-count - (length fn-list) ;total - implicit-to - (and (eq file-creator 'efs-dired-rename-file) - (delq nil - (mapcar - (function - (lambda (x) - (and (assoc (file-name-as-directory x) - dired-subdir-alist) - x))) - fn-list))))) - ;; normal case... use the interative routine... much cheaper. - (efs-real-dired-create-files file-creator operation fn-list - name-constructor marker-char query - implicit-to))) - -(defun efs-dcf-1 (file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - overwrite-backup-query file-creator-query - failures skipped success-count total - implicit-to insertions) - (if (null fn-list) - (efs-dcf-3 failures operation total skipped - success-count buffer-name) - (let* ((from (car fn-list)) - ;; For dired-handle-overwrite and the file-creator-query, - ;; need to set these 2 fluid vars according to the cont data. - (dired-overwrite-backup-query overwrite-backup-query) - (dired-file-creator-query file-creator-query) - (to (funcall name-constructor from)) - (marker-char (if (consp markers) - (prog1 (car markers) - (setq markers (cdr markers))) - markers)) - (fn-list (cdr fn-list))) - (if to - (if (equal to from) - (progn - (dired-log buffer-name "Cannot %s to same file: %s\n" - (downcase operation) from) - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - dired-overwrite-backup-query - dired-file-creator-query failures - (cons (dired-make-relative from nil t) skipped) - success-count total implicit-to insertions)) - (if (or (null query) - (funcall query from to)) - (let* ((overwrite (let (jka-compr-enabled) - ;; Don't let jka-compr fool us. - (file-exists-p to))) - (overwrite-confirmed ; for dired-handle-overwrite - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite `%s'?" to))))) - (condition-case err - (let ((dired-unhandle-add-files - (cons to dired-unhandle-add-files))) - (if implicit-to - (funcall file-creator from overwrite-confirmed - (list (function efs-dcf-2) - file-creator operation fn-list - name-constructor markers - query marker-char - buffer-name to from overwrite - overwrite-confirmed overwrite-query - dired-overwrite-backup-query - dired-file-creator-query - failures skipped success-count - total implicit-to insertions) - t) - (apply file-creator from to overwrite-confirmed - (list (function efs-dcf-2) - file-creator operation fn-list - name-constructor markers - query marker-char - buffer-name to from overwrite - overwrite-confirmed overwrite-query - dired-overwrite-backup-query - dired-file-creator-query - failures skipped success-count total - implicit-to insertions) - (if insertions - (list t insertions) - '(t))))) - (error ; FILE-CREATOR aborted - (efs-dcf-2 'failed ;result - (format "%s" err) ;line - "" file-creator operation fn-list - name-constructor markers query marker-char - buffer-name to from overwrite - overwrite-confirmed overwrite-query - dired-overwrite-backup-query - dired-file-creator-query failures skipped - success-count total implicit-to insertions)))) - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - dired-overwrite-backup-query dired-file-creator-query - failures - (cons (dired-make-relative from nil t) skipped) - success-count total implicit-to insertions))) - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query - dired-overwrite-backup-query dired-file-creator-query - failures (cons (dired-make-relative from nil t) skipped) - success-count total implicit-to insertions))))) - -(defun efs-dcf-2 (result line cont-lines file-creator operation fn-list - name-constructor markers query marker-char - buffer-name to from overwrite overwrite-confirmed - overwrite-query overwrite-backup-query - file-creator-query failures skipped success-count - total implicit-to insertions) - (if result - (progn - (setq failures (cons (dired-make-relative from nil t) failures)) - (dired-log buffer-name "%s `%s' to `%s' failed:\n%s\n" - operation from to line)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (let ((efs-ls-uncache t)) - (dired-add-file to marker-char))) - ;; iterate again - (efs-dcf-1 file-creator operation fn-list name-constructor - markers query buffer-name overwrite-query overwrite-backup-query - file-creator-query failures skipped success-count total - implicit-to insertions)) - -(defun efs-dcf-3 (failures operation total skipped success-count buffer-name) - (cond - (failures - (dired-log-summary buffer-name (format "%s failed for %d of %d file%s" - operation (length failures) total - (dired-plural-s total)) failures)) - (skipped - (dired-log-summary buffer-name (format "%s: %d of %d file%s skipped" - operation (length skipped) total - (dired-plural-s total)) skipped)) - (t - (message "%s: %s file%s." - operation success-count - (dired-plural-s success-count))))) - -;;; Running remote shell commands - -;;; This support isn't very good. efs is really about a virtual file system, -;;; and not remote processes. What is really required is low-level -;;; support for start-process & call-process on remote hosts. This shouldn't -;;; be part of efs, although. - -(defun efs-dired-shell-unhandle-file-name (filename) - ;; Puts remote file names into a form where they can be passed to remsh. - (nth 2 (efs-ftp-path filename))) - -(defun efs-dired-shell-call-process (command dir &optional in-background) - ;; Runs shell process on remote hosts. - (let* ((parsed (efs-ftp-path dir)) - (host (car parsed)) - (user (nth 1 parsed)) - (rdir (nth 2 parsed)) - (file-name-handler-alist nil)) - (or (string-equal (efs-internal-directory-file-name dir) - (efs-expand-tilde "~" (efs-host-type host) host user)) - (string-match "^cd " command) - (setq command (concat "cd " rdir "; " command))) - (setq command - (format "%s %s%s \"%s\"" ; remsh -l USER does not work well - ; on a hp-ux machine I tried - efs-remote-shell-file-name host - (if efs-remote-shell-takes-user - (concat " -l " user) - "") - command)) - (message "Doing shell command on %s..." host) - (dired-shell-call-process - command (file-name-directory efs-tmp-name-template) in-background))) - -;;; Dired commands for running local processes on remote files. -;; -;; Lots of things in this section need to be re-thunk. - -(defun efs-dired-call-process (program discard &rest arguments) - "Documented as original." - ;; PROGRAM is always one of those below in the cond in dired.el. - ;; The ARGUMENTS are (nearly) always files. - (if (efs-ftp-path default-directory) - ;; Can't use efs-dired-host-type here because the current - ;; buffer is *dired-check-process output* - (condition-case oops - (cond - ((string-equal "efs-call-compress" program) - (apply 'efs-call-compress arguments)) - ((string-equal "chmod" program) - (efs-call-chmod arguments)) - (t (error "Unknown remote command: %s" program))) - (ftp-error (dired-log (buffer-name (current-buffer)) - (format "%s: %s, %s\n" - (nth 1 oops) - (nth 2 oops) - (nth 3 oops)))) - (error (dired-log (buffer-name (current-buffer)) - (format "%s\n" (nth 1 oops))))) - (apply 'call-process program nil (not discard) nil arguments))) - -(defun efs-dired-make-compressed-filename (name &optional method) - ;; Version of dired-make-compressed-filename for efs. - ;; If NAME is in the syntax of a compressed file (according to - ;; dired-compression-method-alist), return the data (a list) from this - ;; alist on how to uncompress it. Otherwise, return a string, the - ;; uncompressed form of this file name. This is computed using the optional - ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of - ;; dired-compression-method is used. - (let* ((host-type (efs-host-type (car (efs-ftp-path name)))) - (ef-alist (if (memq host-type efs-single-extension-host-types) - (mapcar - (function - (lambda (elt) - (list (car elt) - (mapconcat - (function - (lambda (char) - (if (= char ?.) - "-" - (char-to-string char)))) - (nth 1 elt) "") - (nth 2 elt) - (nth 3 elt)))) - dired-compression-method-alist) - dired-compression-method-alist)) - (alist ef-alist) - (len (length name)) - ext ext-len result) - (if (memq host-type efs-version-host-types) - (setq name (efs-internal-file-name-sans-versions host-type name))) - (if (memq host-type efs-case-insensitive-host-types) - (let ((name (downcase name))) - (while alist - (if (and (> len - (setq ext-len (length (setq ext (nth 1 (car alist)))))) - (string-equal (downcase ext) - (substring name (- ext-len)))) - (setq result (car alist) - alist nil) - (setq alist (cdr alist))))) - (while alist - (if (and (> len - (setq ext-len (length (setq ext (nth 1 (car alist)))))) - (string-equal ext (substring name (- ext-len)))) - (setq result (car alist) - alist nil) - (setq alist (cdr alist))))) - (or result - (concat name - (nth 1 (or (assq (or method dired-compression-method) - ef-alist) - (error "Unknown compression method: %s" - (or method dired-compression-method)))))))) - -(defun efs-dired-compress-file (file ok-flag &optional cont nowait) - ;; Version of dired-compress-file for remote files. - (let* ((compressed-fn (efs-dired-make-compressed-filename file)) - (host (car (efs-ftp-path file))) - (host-type (efs-host-type host))) - (cond ((file-symlink-p file) - (if cont - (efs-call-cont - cont 'failed - (format "Cannot compress %s, a symbolic link." file) "") - (signal 'file-error (list "Compress error:" file - "a symbolic link")))) - ((listp compressed-fn) - (let ((newname (substring (if (memq host-type - efs-version-host-types) - (efs-internal-file-name-sans-versions - host-type file) - file) - 0 (- (length (nth 1 compressed-fn))))) - (program (nth 3 compressed-fn))) - (if (and (memq host-type efs-unix-host-types) - (null (efs-get-host-property host 'exec-failed)) - (null (eq (efs-get-host-property - host - (intern - (concat - "exec-" - (efs-compress-progname (car program))))) - 'failed))) - (efs-call-remote-compress - program file newname t ok-flag - (efs-cont (result line cont-lines) (program file newname - cont nowait) - (if result - (if (eq result 'unsupported) - (efs-call-compress program file newname - t t cont nowait) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Uncompressing file" - (format "FTP Error: \"%s\" " line) - file)))) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait) - (efs-call-compress - program file newname t ok-flag cont nowait) - newname))) - ((stringp compressed-fn) - (let ((program (nth 2 (assq dired-compression-method - dired-compression-method-alist)))) - (if (and (memq host-type efs-unix-host-types) - (null (efs-get-host-property host 'exec-failed)) - (null (eq (efs-get-host-property - host - (intern - (concat - "exec-" - (efs-compress-progname (car program))))) - 'failed))) - (efs-call-remote-compress - program file compressed-fn nil ok-flag - (efs-cont (result line cont-lines) (program file - compressed-fn - cont nowait) - (if result - (if (eq result 'unsupported) - (efs-call-compress program file compressed-fn nil - t cont nowait) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Compressing file" - (format "FTP Error: \"%s\" " line) - file)))) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait) - (efs-call-compress - program file compressed-fn nil ok-flag cont nowait))) - compressed-fn) - (t (error "Strange error in efs-dired-compress-file."))))) - -(defun efs-dired-print-file (command file) - ;; Version of dired-print-file for remote files. - (let ((command (dired-trans-command command (list file) ""))) - ;; Only replace the first occurence of the file name? - (if (string-match (concat "[ ><|]\\(" (regexp-quote - (dired-shell-quote file)) - "\\)\\($\\|[ |><&]\\)") - command) - (setq command (concat (substring command 0 (match-beginning 1)) - "%s" - (substring command (match-end 1)))) - (error "efs-print-command: strange error")) - (efs-call-lpr file command))) - -;;;;---------------------------------------------------------------- -;;;; Support for `processes' run on remote files. -;;;; Usually (but not necessarily) these are only called from dired. -;;;;---------------------------------------------------------------- - -(defun efs-compress-progname (program) - ;; Returns a canonicalized i.e. without the "un", version of a compress - ;; program name. - (efs-save-match-data - (if (string-equal program "gunzip") - "gzip" - (if (string-match "^un" program) - (substring program (match-end 0)) - program)))) - -(defun efs-call-remote-compress (program filename newname &optional uncompress - ok-if-already-exists cont nowait) - ;; Run a remote compress process using SITE EXEC. - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname - (if uncompress - "uncompress to it" - "compress to it") - (numberp ok-if-already-exists))) - (let* ((filename (expand-file-name filename)) - (parsed (efs-ftp-path filename)) - (host (car parsed)) - (user (nth 1 parsed)) - (rpath (nth 2 parsed))) - (if (efs-get-host-property host 'exec-failed) - (if cont - (efs-call-cont cont 'unsupported "SITE EXEC not supported" "") - (signal 'ftp-error (list "Unable to SITE EXEC" host))) - (let* ((progname (efs-compress-progname (car program))) - (propsym (intern (concat "exec-" progname))) - (prop (efs-get-host-property host propsym))) - (cond - ((eq prop 'failed) - (if cont - (efs-call-cont cont 'unsupported - (concat progname " not in FTP exec path") "") - (signal 'ftp-error - (list (concat progname " not in FTP exec path") host)))) - ((eq prop 'worked) - (efs-send-cmd - host user - (list 'quote 'site 'exec - (concat (mapconcat 'identity program " ") " " rpath)) - (concat (if uncompress "Uncompressing " "Compressing ") filename) - nil - (efs-cont (result line cont-lines) (host user filename cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (concat "FTP exec Error: " line))) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user (concat "FTP Error: " err)))) - ;; This function only gets called for unix hosts, so - ;; we'll use the default version of efs-delete-file-entry - ;; and save a host-type lookup. - (efs-delete-file-entry nil filename) - (dired-remove-file filename) - (if cont (efs-call-cont cont nil line cont-lines)))))) - nowait)) - (t ; (null prop) - (efs-send-cmd - host user - (list 'quote 'site 'exec (concat progname " " "-V")) - (format "Checking for %s executable" progname) - nil - (efs-cont (result line cont-lines) (propsym host program filename - newname uncompress - cont nowait) - (efs-save-match-data - (if (string-match "\n200-" cont-lines) - (efs-set-host-property host propsym 'worked) - (efs-set-host-property host propsym 'failed))) - (efs-call-remote-compress program filename newname uncompress - t ; already tested for overwrite - cont nowait)) - nowait))))))) - -(defun efs-call-compress (program filename newname &optional uncompress - ok-if-already-exists cont nowait) - "Perform a compress command on a remote file. -PROGRAM is a list of the compression program and args. Works by taking a -copy of the file, compressing it and copying the file back. Returns 0 on -success, 1 or 2 on failure. If UNCOMPRESS is non-nil, does this instead." - (let* ((filename (expand-file-name filename)) - (newname (expand-file-name newname)) - (parsed (efs-ftp-path filename)) - (tmp1 (car (efs-make-tmp-name nil (car parsed)))) - (tmp2 (car (efs-make-tmp-name nil (car parsed)))) - (program (mapconcat 'identity program " "))) - (efs-copy-file-internal - filename parsed tmp1 nil - t nil 2 - (efs-cont (result line cont-lines) (filename newname tmp1 tmp2 program - uncompress ok-if-already-exists - cont nowait) - (if result - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\" " line) filename)) - (let ((err-buff (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create - (generate-new-buffer-name - (format - " efs-call-compress %s" filename)))))) - (save-excursion - (set-buffer err-buff) - (set (make-local-variable 'efs-call-compress-filename) filename) - (set (make-local-variable 'efs-call-compress-newname) newname) - (set (make-local-variable 'efs-call-compress-tmp1) tmp1) - (set (make-local-variable 'efs-call-compress-tmp2) tmp2) - (set (make-local-variable 'efs-call-compress-cont) cont) - (set (make-local-variable 'efs-call-compress-nowait) nowait) - (set (make-local-variable 'efs-call-compress-ok) - ok-if-already-exists) - (set (make-local-variable 'efs-call-compress-uncompress) - uncompress) - (set (make-local-variable 'efs-call-compress-abbr) - (efs-relativize-filename filename)) - (if efs-verbose - (efs-message - (format "%s %s..." - (if uncompress "Uncompressing" "Compressing") - (symbol-value (make-local-variable - 'efs-call-compress-abbr))))) - (set-process-sentinel - (start-process (format "efs-call-compress %s" filename) - err-buff shell-file-name - "-c" (format "%s %s < %s > %s" - program - ;; Hope -c makes the compress - ;; program write to std out. - "-c" - tmp1 tmp2)) - (function - (lambda (proc str) - (let ((buff (get-buffer (process-buffer proc)))) - (if buff - (save-excursion - (set-buffer buff) - (if (/= (buffer-size) 0) - (if cont - (efs-call-cont - (symbol-value - (make-local-variable - 'efs-call-compress-cont)) - 'failed - (concat - "failed to compress " - (symbol-value (make-local-variable - 'efs-call-compress-filename)) - ", " - (buffer-substring - (point-min) - (progn (goto-char (point-min)) - (end-of-line) (point)))))) - (efs-del-tmp-name (symbol-value - (make-local-variable - 'efs-call-compress-tmp1))) - (let ((tmp2 (symbol-value - (make-local-variable - 'efs-call-compress-tmp2))) - (newname (symbol-value - (make-local-variable - 'efs-call-compress-newname))) - (filename (symbol-value - (make-local-variable - 'efs-call-compress-filename))) - (cont (symbol-value - (make-local-variable - 'efs-call-compress-cont))) - (nowait (symbol-value - (make-local-variable - 'efs-call-compress-nowait))) - (ok (symbol-value - (make-local-variable - 'efs-call-compress-ok))) - (uncompress - (symbol-value - (make-local-variable - 'efs-call-compress-uncompress)))) - (if efs-verbose - (efs-message - (format "%s %s...done" - (if uncompress - "Uncompressing" - "Compressing") - (symbol-value - (make-local-variable - 'efs-call-compress-abbr))))) - (kill-buffer (current-buffer)) - (efs-copy-file-internal - tmp2 nil newname (efs-ftp-path newname) - ok nil 1 - (efs-cont (result line cont-lines) (cont - tmp2 - filename) - (efs-del-tmp-name tmp2) - (or result - (let (efs-verbose) - (efs-delete-file filename) - (dired-remove-file filename))) - (if cont - (efs-call-cont cont result line - cont-lines))) - nowait (if uncompress nil 'image))))) - (error "Strange error: %s" proc)))))))))) - nowait (if uncompress 'image nil)))) - -(defun efs-update-mode-string (perms modes) - ;; For PERMS of the form `u+w', and MODES a unix 9-character mode string, - ;; computes the new mode string. - ;; Doesn't call efs-save-match-data. The calling function should. - (or (string-match "^[augo]+\\([+-]\\)[rwxst]+$" perms) - (error "efs-update-mode-string: invalid perms %s" perms)) - (let* ((who (substring perms 0 (match-beginning 1))) - (add (= (aref perms (match-beginning 1)) ?+)) - (what (substring perms (match-end 1))) - (newmodes (copy-sequence modes)) - (read (string-match "r" what)) - (write (string-match "w" what)) - (execute (string-match "x" what)) - (sticky (string-match "t" what)) - (suid (string-match "s" what))) - (if (string-match "a" who) - (if add - (progn - (if read - (progn - (aset newmodes 0 ?r) - (aset newmodes 3 ?r) - (aset newmodes 6 ?r))) - (if write - (progn - (aset newmodes 1 ?w) - (aset newmodes 4 ?w) - (aset newmodes 7 ?w))) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?s))) - (setq curr (aref newmodes 5)) - (if (= curr ?-) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?s))) - (setq curr (aref newmodes 8)) - (if (= curr ?-) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?t))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?S) - (if (= curr ?x) - (aset newmodes 2 ?s))) - (setq curr (aref newmodes 5)) - (if (= curr ?-) - (aset newmodes 5 ?S) - (if (= curr ?x) - (aset newmodes 5 ?s))))) - (if sticky - (let ((curr (aref newmodes 8))) - (if (= curr ?-) - (aset newmodes 8 ?T) - (if (= curr ?x) - (aset newmodes 8 ?t)))))) - (if read - (progn - (aset newmodes 0 ?-) - (aset newmodes 3 ?-) - (aset newmodes 6 ?-))) - (if write - (progn - (aset newmodes 1 ?-) - (aset newmodes 4 ?-) - (aset newmodes 7 ?-))) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?x) - (aset newmodes 2 ?-) - (if (= curr ?s) - (aset newmodes 2 ?S))) - (setq curr (aref newmodes 5)) - (if (= curr ?x) - (aset newmodes 5 ?-) - (if (= curr ?s) - (aset newmodes 5 ?S))) - (setq curr (aref newmodes 8)) - (if (= curr ?x) - (aset newmodes 8 ?-) - (if (= curr ?t) - (aset newmodes 8 ?T))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?s) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?-))) - (setq curr (aref newmodes 5)) - (if (= curr ?s) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?-))))) - (if sticky - (let ((curr (aref newmodes 8))) - (if (= curr ?t) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?-)))))) - (if (string-match "u" who) - (if add - (progn - (if read - (aset newmodes 0 ?r)) - (if write - (aset newmodes 1 ?w)) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?s))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?-) - (aset newmodes 2 ?S) - (if (= curr ?x) - (aset newmodes 2 ?s)))))) - (if read - (aset newmodes 0 ?-)) - (if write - (aset newmodes 1 ?-)) - (if execute - (let ((curr (aref newmodes 2))) - (if (= curr ?x) - (aset newmodes 2 ?-) - (if (= curr ?s) - (aset newmodes 2 ?S))))) - (if suid - (let ((curr (aref newmodes 2))) - (if (= curr ?s) - (aset newmodes 2 ?x) - (if (= curr ?S) - (aset newmodes 2 ?-))))))) - (if (string-match "g" who) - (if add - (progn - (if read - (aset newmodes 3 ?r)) - (if write - (aset newmodes 4 ?w)) - (if execute - (let ((curr (aref newmodes 5))) - (if (= curr ?-) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?s))))) - (if suid - (let ((curr (aref newmodes 5))) - (if (= curr ?-) - (aset newmodes 5 ?S) - (if (= curr ?x) - (aset newmodes 5 ?s)))))) - (if read - (aset newmodes 3 ?-)) - (if write - (aset newmodes 4 ?-)) - (if execute - (let ((curr (aref newmodes 5))) - (if (= curr ?x) - (aset newmodes 5 ?-) - (if (= curr ?s) - (aset newmodes 5 ?S))))) - (if suid - (let ((curr (aref newmodes 5))) - (if (= curr ?s) - (aset newmodes 5 ?x) - (if (= curr ?S) - (aset newmodes 5 ?-))))))) - (if (string-match "o" who) - (if add - (progn - (if read - (aset newmodes 6 ?r)) - (if write - (aset newmodes 7 ?w)) - (if execute - (let ((curr (aref newmodes 8))) - (if (= curr ?-) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?t))))) - (if sticky - (let ((curr (aref newmodes 8))) - (if (= curr ?-) - (aset newmodes 8 ?T) - (if (= curr ?x) - (aset newmodes 5 ?t)))))) - (if read - (aset newmodes 6 ?-)) - (if write - (aset newmodes 7 ?-)) - (if execute - (let ((curr (aref newmodes 8))) - (if (= curr ?x) - (aset newmodes 8 ?-) - (if (= curr ?t) - (aset newmodes 8 ?T))))) - (if suid - (let ((curr (aref newmodes 8))) - (if (= curr ?t) - (aset newmodes 8 ?x) - (if (= curr ?T) - (aset newmodes 8 ?-)))))))) - newmodes)) - -(defun efs-compute-chmod-arg (perms file) - ;; Computes the octal number, represented as a string, required to - ;; modify the permissions PERMS of FILE. - (efs-save-match-data - (cond - ((string-match "^[0-7][0-7]?[0-7]?[0-7]?$" perms) - perms) - ((string-match "^[augo]+[-+][rwxst]+$" perms) - (let ((curr-mode (nth 3 (efs-get-file-entry file)))) - (or (and curr-mode - (stringp curr-mode) - (= (length curr-mode) 10)) - (progn - ;; Current buffer is process error buffer - (insert "Require an octal integer to modify modes for " - file ".\n") - (error "Require an octal integer to modify modes for %s." file))) - (format "%o" - (efs-parse-mode-string - (efs-update-mode-string perms - (substring curr-mode 1)))))) - (t - (insert "Don't know how to set modes " perms " for " file ".\n") - (error "Don't know how to set modes %s" perms))))) - -(defun efs-call-chmod (args) - ;; Sends an FTP CHMOD command. - (if (< (length args) 2) - (error "efs-call-chmod: missing mode and/or filename: %s" args)) - (let ((mode (car args)) - bombed) - (mapcar - (function - (lambda (file) - (setq file (expand-file-name file)) - (let ((parsed (efs-ftp-path file))) - (if parsed - (condition-case nil - (let* ((mode (efs-compute-chmod-arg mode file)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (efs-quote-string - (efs-host-type host user) (nth 2 parsed))) - (abbr (efs-relativize-filename file)) - (result (efs-send-cmd host user - (list 'quote 'site 'chmod - mode path) - (format "doing chmod %s" - abbr)))) - - (if (car result) - (efs-dired-shell-call-process - (concat "chmod " mode " " (file-name-nondirectory file)) - (file-name-directory file))) - - (efs-del-from-ls-cache file t)) - (error (setq bombed t))))))) - (cdr args)) - (if bombed 1 0))) ; return code - -(defun efs-call-lpr (file command-format) - "Print remote file FILE. SWITCHES are passed to the print program." - ;; Works asynch. - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file)) - (abbr (efs-relativize-filename file)) - (temp (car (efs-make-tmp-name nil (car parsed))))) - (efs-copy-file-internal - file parsed temp nil t nil 2 - (efs-cont (result line cont-lines) (command-format file abbr temp) - (if result - (signal 'ftp-error (list "Opening input file" - (format "FTP Error: \"%s\" " line) - file)) - (message "Spooling %s..." abbr) - (set-process-sentinel - (start-process (format "*print %s /// %s*" abbr temp) - (generate-new-buffer-name " *print temp*") - "sh" "-c" (format command-format temp)) - (function - (lambda (proc status) - (let ((buff (process-buffer proc)) - (name (process-name proc))) - (if (and buff (get-buffer buff)) - (unwind-protect - (save-excursion - (set-buffer buff) - (if (> (buffer-size) 0) - (let ((log-buff (get-buffer-create - "*Shell Command Output*"))) - (set-buffer log-buff) - (goto-char (point-max)) - (or (bobp) - (insert "\n")) - (insert-buffer-substring buff) - (goto-char (point-max)) - (display-buffer log-buff)))) - (condition-case nil (kill-buffer buff) (error nil)) - (efs-save-match-data - (if (string-match "^\\*print \\(.*\\) /// \\(.*\\)\\*$" - name) - (let ((abbr (substring name (match-beginning 1) - (match-end 1))) - (temp (substring name (match-beginning 2) - (match-end 2)))) - (or (= (match-beginning 2) (match-end 2)) - (efs-del-tmp-name temp)) - (message "Spooling %s...done" abbr)))))))))))) - t))) - -;;;; -------------------------------------------------------------- -;;;; Attaching onto dired. -;;;; -------------------------------------------------------------- - -;;; Look out for MULE -(if (or (boundp 'MULE) (featurep 'mule)) (load "efs-dired-mule")) - -;;; Magic file name hooks for dired. - -(put 'dired-print-file 'efs 'efs-dired-print-file) -(put 'dired-make-compressed-filename 'efs 'efs-dired-make-compressed-filename) -(put 'dired-compress-file 'efs 'efs-dired-compress-file) -(put 'dired-recursive-delete-directory 'efs - 'efs-dired-recursive-delete-directory) -(put 'dired-uncache 'efs 'efs-dired-uncache) -(put 'dired-shell-call-process 'efs 'efs-dired-shell-call-process) -(put 'dired-shell-unhandle-file-name 'efs 'efs-dired-shell-unhandle-file-name) -(put 'dired-file-modtime 'efs 'efs-dired-file-modtime) -(put 'dired-set-file-modtime 'efs 'efs-dired-set-file-modtime) - -;;; Overwriting functions - -(efs-overwrite-fn "efs" 'dired-call-process) -(efs-overwrite-fn "efs" 'dired-insert-headerline) -(efs-overwrite-fn "efs" 'dired-manual-move-to-filename) -(efs-overwrite-fn "efs" 'dired-manual-move-to-end-of-filename) -(efs-overwrite-fn "efs" 'dired-make-filename-string) -(efs-overwrite-fn "efs" 'dired-flag-backup-files) -(efs-overwrite-fn "efs" 'dired-create-files) -(efs-overwrite-fn "efs" 'dired-find-file) -(efs-overwrite-fn "efs" 'dired-find-file-other-window) -(efs-overwrite-fn "efs" 'dired-find-file-other-frame) -(efs-overwrite-fn "efs" 'dired-collect-file-versions) -(efs-overwrite-fn "efs" 'dired-file-name-lessp) - -;;; Hooks - -(add-hook 'dired-before-readin-hook 'efs-dired-before-readin) - -;;; Handle dired-grep.el too. - -(if (featurep 'dired-grep) - (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file - 'efs-diff/grep-del-temp-file) - (add-hook 'dired-grep-load-hook - (function - (lambda () - (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file - 'efs-diff/grep-del-temp-file))))) - -;;; end of efs-dired.el
--- a/lisp/efs/efs-dl.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,145 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dl.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.3 $ -;; RCS: -;; Description: Unix descriptive listing support for efs -;; Author: Sandy Rutherford <sandy@tsmi19.sissa.it> -;; Created: Wed Jan 13 19:19:20 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:29:41 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-unix:dl) -(require 'efs) - -(defconst efs-dl-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.3 $" 11 -2))) - -;;;----------------------------------------------------------------- -;;; Unix descriptive listing (dl) support for efs -;;;----------------------------------------------------------------- - -;; this is also defined in efs.el, because it used to recognize -;; a dl listing. We re-define it here just to keep the dl stuff self-contained. - -(defconst efs-unix:dl-listing-regexp - "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") - -;; entry point - -(efs-defun efs-parse-listing unix:dl - (host user dir path &optional switches) - ;; Parse the current buffer, which is assumed to be a unix descriptive - ;; listing, and return a hashtable. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - ;; Is it really a listing? - (efs-save-match-data - (if (re-search-forward efs-unix:dl-listing-regexp nil t) - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (while (not (eobp)) - (efs-put-hash-entry - (buffer-substring (point) - (progn - (skip-chars-forward "^ /\n") - (point))) - (list (eq (following-char) ?/)) - tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -;;; Support for tree dired. - -(defconst efs-dired-dl-re-dir - "^. [^ /]+/[ \n]" - "Regular expression to use to search for dl directories.") - -(or (assq 'unix:dl efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'unix:dl efs-dired-dl-re-dir) - efs-dired-re-dir-alist))) - - -(efs-defun efs-dired-manual-move-to-filename unix:dl - (&optional raise-error bol eol) - ;; In dired, move to the first character of the filename on this line. - ;; This is the Unix dl version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (and - (> (- eol bol) 3) - (progn - (forward-char 2) - (skip-chars-forward " \t") - (looking-at "[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) "))) - (point) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename unix:dl - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Unix dl version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "^ /\r\n\t") - (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?/)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline unix:dl (dir) - ;; Unix dl has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-fixup-listing unix:dl (file path &optional - switches wildcard) - ;; Deal with continuation lines. - (efs-save-match-data - (goto-char (point-min)) - (while (re-search-forward "\n +" nil t) - (delete-region (match-beginning 0) (match-end 0)) - (insert " ")))) - -;;; end of efs-dl.el
--- a/lisp/efs/efs-dos-distinct.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dos-distinct.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Distinct's DOS FTP server support for efs -;; Author: Sandy Rutherford <sandy@tsmi19.sissa.it> -;; Created: Fri Jan 15 22:20:32 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:30:04 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Thanks to Rodd Zurcher <rbz@hook.corp.mot.com> for beta testing. - -(provide 'efs-dos-distinct) -(require 'efs) - -(defconst efs-dos-distinct-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ----------------------------------------------------------------- -;;;; Distinct's DOS FTP server support for efs -;;;; ----------------------------------------------------------------- - -;;; This is not included in efs-dos.el with the support for the -;;; other dos ftp servers, because the Distinct server uses unix syntax -;;; for path names. - -;; This is defined in efs.el, but we put it here too. - -(defconst efs-dos-distinct-date-and-time-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " - "[ 12][0-9]:[0-5][0-9] ")) - -;;; entry point - -(efs-defun efs-parse-listing dos-distinct - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a listing from - ;; Distinct's DOS FTP server. Both empty dirs, and ls errors return - ;; empty buffers. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a full remote path - ;; PATH = directory in full efs-path syntax - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-dos-distinct-date-and-time-regexp nil t) - (let ((tbl (efs-make-hashtable)) - dir-p) - (beginning-of-line) - (while (progn - (setq dir-p (eq (following-char) ?d)) ; we're bolp - (re-search-forward - efs-dos-distinct-date-and-time-regexp nil t)) - (efs-put-hash-entry (buffer-substring (point) - (progn (end-of-line) - (point))) - (list dir-p) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(efs-defun efs-allow-child-lookup dos-distinct (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Subdirs in DOS can't have an extension. - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-dos-distinct-re-exe - "^[^\n]+\\.exe$") - -(or (assq 'dos-distinct efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos-distinct efs-dired-dos-distinct-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos-distinct-re-dir - "^. [ \t]*d") - -(or (assq 'dos-distinct efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos-distinct efs-dired-dos-distinct-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos-distinct (dir) - ;; The Distinct DOS server has no total line, so we insert a - ;; blank line for aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos-distinct - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This version is for Distinct's DOS FTP server. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-dos-distinct-date-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos-distinct - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the version for Distinct's DOS FTP server. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; it's hidden or omitted - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_+=a-z0-9.$") - (if (or (= opoint (point)) (not (memq (following-char) '(\n \r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-dos-distinct.el
--- a/lisp/efs/efs-dump.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-dump.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Install a bare-bones EFS hook into file-name-handler-alist -;; for dumping -;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de> -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-dump) - -(defconst efs-dump-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;###autoload -(or (assoc efs-path-root-regexp file-name-handler-alist) - (setq file-name-handler-alist - (cons - (cons efs-path-root-regexp 'remote-path-file-handler-function) - file-name-handler-alist))) - -;;;###autoload -(defun remote-path-file-handler-function (operation &rest args) - "Function to call special file handlers for remote files." - (if allow-remote-paths - (apply 'efs-file-handler-function operation args) - (let ((inhibit-file-name-handlers - (cons 'remote-path-file-handler-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args)))) - -;;; end of efs-dump.el
--- a/lisp/efs/efs-fnh.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-fnh.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.3 $ -;; RCS: -;; Description: Look for the emacs version, and install into -;; the file-name-handler-alist -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Although used by efs, these utilities could be of general use to other -;;; packages too. Keeping them separate from the main efs program -;;; makes it easier for other programs to require them. - -(provide 'efs-fnh) - -(defconst efs-fnh-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.3 $" 11 -2))) - -;;;###autoload -(defvar allow-remote-paths t - "*Set this to nil if you don't want remote paths to access -remote files.") - -;;;; ---------------------------------------------------------------- -;;;; Loading emacs version files -;;;; ---------------------------------------------------------------- - -(defun efs-handle-emacs-version () - ;; Load appropriate files for the current emacs version - (let ((ehev-match-data (match-data))) - (unwind-protect - (let ((lucidp (string-match "Lucid" emacs-version)) - ver subver) - (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) - (error "efs does not work with emacs version %s" emacs-version)) - (setq ver (string-to-int (substring emacs-version - (match-beginning 1) - (match-end 1))) - subver (string-to-int (substring emacs-version - (match-beginning 2) - (match-end 2)))) - (cond - - ;; Lucid XEmacs (emacs-version looks like \"19.xx XEmacs Lucid\") - (lucidp - (cond - ((and (= ver 19) (>= subver 11) (< subver 15)) - (require 'efs-l19\.11)) - ((and (= ver 19) (>= subver 15)) - (require 'efs-x19\.15)) - ((= ver 20) - (require 'efs-x19\.15)) - (t - (error - "efs does not work with emacs version %s" emacs-version)))) - - ;; Original GNU Emacs from FSF - (t - (cond - ((and (= ver 19) (<= subver 22)) - (require 'efs-19)) - ((and (= ver 19) (>= subver 23)) - (require 'efs-19\.23)) - - ;; GNU Emacs 18- - ((<= ver 18) - (require 'efs-18)) ; this file will (require 'emacs-19) - - (t - (error - "efs does not work with emacs version %s" emacs-version)))))) - - (store-match-data ehev-match-data)))) - -;;;; -------------------------------------------------------------- -;;;; Stuff for file name handlers. -;;;; -------------------------------------------------------------- - -;;; Need to do this now, to make sure that the file-name-handler-alist is -;;; defined for Emacs 18. - -(efs-handle-emacs-version) - -;; Also defined in efs-cu.el -(defvar efs-path-root-regexp "^/[^/:]+:" - "Regexp to match the `/user@host:' root of an efs full path.") - -(defun efs-file-name-handler-alist-sans-fn (fn) - ;; Returns a version of file-name-handler-alist without efs. - (delq nil (mapcar - (function - (lambda (x) - (and (not (eq (cdr x) fn)) x))) - file-name-handler-alist))) - -(defun efs-root-handler-function (operation &rest args) - "Function to handle completion in the root directory." - (let ((handler (and (if (boundp 'allow-remote-paths) - allow-remote-paths - t) - (get operation 'efs-root)))) - (if handler - (apply handler args) - (let ((inhibit-file-name-handlers - (cons 'efs-root-handler-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args))))) - -(put 'file-name-completion 'efs-root 'efs-root-file-name-completion) -(put 'file-name-all-completions 'efs-root 'efs-root-file-name-all-completions) -(autoload 'efs-root-file-name-all-completions "efs-netrc") -(autoload 'efs-root-file-name-completion "efs-netrc") - -(autoload 'efs-file-handler-function "efs" - "Function to use efs to handle remote files.") - -;; Install into the file-name-handler-alist. -;; If we are already there, remove the old entry, and re-install. -;; Remove the ange-ftp entry too. - -(setq file-name-handler-alist - (let (dired-entry alist) - (setq alist - (nconc - (list - (cons efs-path-root-regexp 'efs-file-handler-function) - '("^/$" . efs-root-handler-function)) - (delq nil - (mapcar - (function - (lambda (x) - (if (eq (cdr x) 'dired-handler-fn) - (progn - (setq dired-entry x) - nil) - (and (not - (memq (cdr x) - '(remote-path-file-handler-function - efs-file-handler-function - efs-root-handler-function - ange-ftp-hook-function - ange-ftp-completion-hook-function))) - x)))) - file-name-handler-alist)))) - ;; Make sure that dired is in first. - (if dired-entry (cons dired-entry alist) alist))) - -;;; end of efs-fnh.el
--- a/lisp/efs/efs-guardian.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,241 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-guardian.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.7 $ -;; RCS: -;; Description: Guardian support for efs -;; Author: Sandy Rutherford <sandy@math.ubc.ca> -;; Created: Sat Jul 10 12:26:12 1993 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Acknowledgements: -;;; Adrian Philips and David Karr for answering questions -;;; and debugging. Thanks. - -(defconst efs-guardian-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.7 $" 11 -2))) - -(provide 'efs-guardian) -(require 'efs) - -;;;; ------------------------------------------------------------ -;;;; Support for Tandem's GUARDIAN operating system. -;;;; ------------------------------------------------------------ - -;;; Supposed to work for (Version 2.7 TANDEM 01SEP92). - -;;; File name syntax: -;;; -;;; File names are of the form volume.subvolume.file where -;;; volume is $[alphanumeric characters]{1 to 7} -;;; subvolume is <alpha character>[<alphanumeric character>]{0 to 7} -;;; and file is the same as subvolume. - -(defconst efs-guardian-date-regexp - (concat - " [ 1-3][0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|" - "Sep\\|Oct\\|Nov\\|Dec\\)-[0-9][0-9] ")) - -;;; entry points -- 2 of 'em. - -(efs-defun efs-fix-path guardian (path &optional reverse) - ;; Convert PATH from unix-ish to guardian. - ;; If REVERSE is non-nil do just that. - (efs-save-match-data - (let ((case-fold-search t)) - (if reverse - (if (string-match - (concat - "^\\(\\\\[A-Z0-9]+\\.\\)?" - "\\(\\$[A-Z0-9]+\\)\\.\\([A-Z0-9]+\\)\\(\\.[A-Z0-9]+\\)?$") - path) - (concat - "/" - (substring path (match-beginning 2) (match-end 2)) - "/" - (substring path (match-beginning 3) (match-end 3)) - "/" - (and (match-beginning 4) - (substring path (1+ (match-beginning 4))))) - (error "path %s is invalid for the GUARDIAN operating system" - path)) - (if (string-match - "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" path) - (apply 'concat - (substring path 1 (match-end 1)) - "." - (substring path (match-beginning 2) (match-end 2)) - (and (match-beginning 3) - (/= (- (match-end 3) (match-beginning 3)) 1) - (list "." - (substring path (1+ (match-beginning 3)))))) - (error "path %s is invalid for the guardian operating system" - path)))))) - -(efs-defun efs-fix-dir-path guardian (dir-path) - ;; Convert DIR-PATH from unix-ish to guardian fir a DIR listing. - (efs-save-match-data - (let ((case-fold-search t)) - (cond - ((string-equal "/" dir-path) - (error "Can't grok guardian disk volumes.")) - ((string-match "^/\\$[A-Z0-9]+/?$" dir-path) - (error "Can't grok guardian subvolumes.")) - ((string-match "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" - dir-path) - (apply 'concat - (substring dir-path 1 (match-end 1)) - "." - (substring dir-path (match-beginning 2) (match-end 2)) - (and (match-beginning 3) - (/= (- (match-end 3) (match-beginning 3)) 1) - (list "." - (substring dir-path (1+ (match-beginning 3))))))) - (t - (error "path %s is invalid for the guardian operating system")))))) - -(efs-defun efs-parse-listing guardian - (host user dir path &optional switches) - ;; Parses a GUARDIAN DIRectory listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a remote full path - ;; PATH = directory as an efs full path - ;; SWITCHES are never used here, but they - ;; must be specified in the argument list for compatibility - ;; with the unix version of this function. - (efs-save-match-data - (goto-char (point-min)) - (if (re-search-forward efs-guardian-date-regexp nil t) - (let ((tbl (efs-make-hashtable)) - file size) - (while - (progn - (beginning-of-line) - (setq file (buffer-substring (point) - (progn - (skip-chars-forward "A-Z0-9") - (point)))) - (skip-chars-forward " ") - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq size (string-to-int (buffer-substring - (point) - (progn - (skip-chars-forward "0-9"))))) - (efs-put-hash-entry file (list nil size) tbl) - (forward-line 1) - (re-search-forward efs-guardian-date-regexp nil t))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(efs-defun efs-allow-child-lookup guardian (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - (efs-save-match-data - (let ((case-fold-search t)) - (string-match "^/\\$[A-Z0-9]+/$" dir)))) - -(efs-defun efs-internal-file-directory-p guardian (file) - ;; Directories pop into existence simply by putting files in them. - (efs-save-match-data - (let ((case-fold-search t)) - (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) - t - (efs-internal-file-directory-p nil file))))) - -(efs-defun efs-internal-file-exists-p guardian (file) - ;; Directories pop into existence simply by putting files in them. - (efs-save-match-data - (let ((case-fold-search t)) - (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) - t - (efs-internal-file-exists-p nil file))))) - -;;; Tree Dired support - -(defconst efs-dired-guardian-re-exe nil) - -(or (assq 'guardian efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'guardian efs-dired-guardian-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-guardian-re-dir nil) - -(or (assq 'guardian efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'guardian efs-dired-guardian-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename guardian - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the guardian version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (save-excursion (re-search-forward efs-guardian-date-regexp eol t)) - (progn - (if (looking-at ". [^ ]") - (forward-char 2)) - (point)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename guardian - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the guardian version. - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (if (and - (>= (following-char) ?A) - (<= (following-char) ?Z) - (progn - (skip-chars-forward "A-Z0-9") - (= (following-char) ?\ ))) - (point) - (and (null no-error) - (error "No file on this line")))) - -(efs-defun efs-dired-ls-trim guardian () - (goto-char (point-min)) - (let (case-fold-search) - (if (re-search-forward efs-guardian-date-regexp nil t) - (progn - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max)))))) - -;;; end of efs-guardian.el
--- a/lisp/efs/efs-gwp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-gwp.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Support for efs to use an interactive gateway. -;; Author: Andy Norman, Dawn -;; Created: Thu Mar 18 13:03:14 1993 -;; Modified: Sun Nov 27 18:31:50 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-gwp) -(require 'efs) - -;;;; ------------------------------------------------------------ -;;;; Interactive gateway program support. -;;;; ------------------------------------------------------------ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; User Variables and Documentation - -(defvar efs-gwp-setup-term-command - (if (eq system-type 'hpux) - "stty -onlcr -echo\n" - "stty -echo nl\n") - "Command to do terminal setup on the gateway machine. -They must stop the terminal echoing each command and strip out trailing -^M characters. This string must end in \\n. If you need to send multiple -commands, include them all in this string, separated by \\n. -See the documentation in efs.el for some example commands.") - -;; About efs-gwp-term-setup-command: -;; -;; It is important to get efs-gwp-setup-term-command right. -;; Here are some examples. Please tell us about which commands -;; to use on other platforms, so that we can include it in the -;; documentation. -;; -;; -;; HP-UX: -;; -;; "stty -onlcr -echo\n" -;; -;; SunOS: -;; -;; "stty -echo nl\n" -;; -;; VMS: (this should work) -;; -;; "set terminal/noecho\n" -;; - - -(defvar efs-gwp-prompt-pattern "^[^#$%>;]*[#$%>;] *" - "*Regexp used to detect that the gateway login sequence has completed. -It will be assumed that the shell is ready to receive input. Make this -regexp as strict as possible; it shouldn't match *anything* at all except -the shell's initial prompt. The above string will fail under most SUN-3's -since it matches the login banner.") - -;; About efs-gwp-prompt-pattern: -;; -;; It is very important that this not match anything in the machine's -;; login banner. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Internal Variables - -(defconst efs-gwp-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defvar efs-gwp-running t) -(defvar efs-gwp-status nil) -(defvar efs-gwp-string "") - -;;; Entry point (defined as an autoload in efs.el) - -(defun efs-gwp-start (host user name) - "Login to the gateway machine and fire up an ftp process." - (message "Connecting to gateway %s..." efs-gateway-host) - (let ((proc (apply 'start-process name (efs-ftp-process-buffer host user) - (nth 1 efs-gateway-type) - (append (nth 2 efs-gateway-type) - (list efs-gateway-host)))) - (ftp (concat (nth 3 efs-gateway-type) " " - (mapconcat (function identity) (nth 4 efs-gateway-type) - " ") "\n"))) - (process-kill-without-query proc) - (set-process-sentinel proc (function efs-gwp-sentinel)) - (set-process-filter proc (function efs-gwp-filter)) - (set-marker (process-mark proc) (point)) - (setq efs-gwp-running t - efs-gwp-status nil - efs-gwp-string "") - (while efs-gwp-running ;perform login sequence - (accept-process-output proc)) - (if (not efs-gwp-status) - (efs-error host user "unable to login to gateway")) - (message "Connecting to gateway %s...done" efs-gateway-host) - (setq efs-gwp-running t - efs-gwp-status nil - efs-gwp-string "") - (process-send-string proc efs-gwp-setup-term-command) - (while efs-gwp-running ;zap ^M's and double echoing. - (accept-process-output proc)) - (if (not efs-gwp-status) - (efs-error host user "unable to set terminal modes on gateway")) - (setq efs-gwp-running t - efs-gwp-status nil - efs-gwp-string "") - (message "Opening FTP connection to %s..." host) - (process-send-string proc ftp) - proc)) - -;;; Process filter/sentinel - -(defun efs-gwp-sentinel (proc str) - (setq efs-gwp-running nil)) - -(defun efs-gwp-filter (proc str) - (efs-save-match-data - ;; Don't be sensitive to login vn LOGIN. - (let ((case-fold-search t)) - (efs-process-log-string proc str) - (setq efs-gwp-string (concat efs-gwp-string str)) - (cond ((string-match "\\(login\\|username\\): *$" efs-gwp-string) - (process-send-string proc - (concat - (let ((efs-default-user t)) - (efs-get-user efs-gateway-host)) - "\n"))) - ((string-match "password: *$" efs-gwp-string) - (process-send-string proc - (concat - (efs-get-passwd efs-gateway-host - (efs-get-user - efs-gateway-host)) - "\n"))) - ((string-match efs-gateway-fatal-msgs - efs-gwp-string) - (delete-process proc) - (setq efs-gwp-running nil)) - ((string-match efs-gwp-prompt-pattern - efs-gwp-string) - (setq efs-gwp-running nil - efs-gwp-status t)))))) - -;;; end of efs-gwp.el
--- a/lisp/efs/efs-hell.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-hell.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Hellsoft FTP server support for efs -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Tue May 25 02:31:37 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:32:27 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-hell) -(require 'efs) - -(defconst efs-hell-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; -------------------------------------------------------------- -;;;; Hellsoft FTP server support for efs -;;;; -------------------------------------------------------------- - -;;; The hellsoft FTP server runs on DOS PC's and Macs. The hellsoft -;;; support here probably won't work for Macs. If enough people need it -;;; the Mac support _might_ be fixed. - -;;; Works for "novell FTP Server for NW 3.11 (v1.8), (c) by HellSoft." - -;; Hellsoft uses unix path syntax. However, we shouldn't append a "." -;; to directories, because if foobar is a plain file, then -;; dir foobar/ will not give a listing (which is correct), but -;; dir foobar/. will give a one-line listing (which is a little strange). - -(efs-defun efs-fix-dir-path hell (dir-path) - dir-path) - -;; Hellsoft returns PWD output in upper case, whereas dir listings are -;; in lower case. To avoid confusion, downcase pwd output. - -(efs-defun efs-send-pwd hell (host user &optional xpwd) - ;; Returns ( DIR . LINE ), where DIR is either the current directory, or - ;; nil if this couldn't be found. LINE is the line of output from the - ;; FTP server. Since the hellsoft server returns pwd output in uppercase, we - ;; downcase it. - (let ((result (efs-send-pwd 'unix host user xpwd))) - (if (car result) - (setcar result (downcase (car result)))) - result)) - -(defconst efs-hell-date-and-time-regexp - (concat - " \\([0-9]+\\) \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [0-3][0-9] " - "\\([012][0-9]:[0-5][0-9]\\| [12][019][0-9][0-9]\\) ")) -;; The end of this regexp corresponds to the start of a filename. - -(defmacro efs-hell-parse-file-line () - ;; Returns ( FILENAME DIR-P SIZE ) from the current line - ;; of a hellsoft listing. Assumes that the point is at the beginning - ;; of the line. - (` (let ((eol (save-excursion (end-of-line) (point))) - (dir-p (= (following-char) ?d))) - (if (re-search-forward efs-hell-date-and-time-regexp eol t) - (list (buffer-substring (point) (progn (end-of-line) (point))) - dir-p - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))))))) - -(efs-defun efs-parse-listing hell - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a listing from - ;; a Hellsoft FTP server. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a full remote path - ;; PATH = directory in full efs-path syntax - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-hell-date-and-time-regexp nil t) - (let ((tbl (efs-make-hashtable)) - file-info) - (beginning-of-line) - (while (setq file-info (efs-hell-parse-file-line)) - (efs-put-hash-entry (car file-info) (cdr file-info) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl) - (if (not (string-match (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name dir)) "\\.")) - ;; It's an empty dir - (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - - -(efs-defun efs-allow-child-lookup hell (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Subdirs in DOS can't have an extension. - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-hell-re-exe - "^[^\n]+\\.exe$") - -(or (assq 'hell efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'hell efs-dired-hell-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-hell-re-dir - "^. [ \t]*d") - -(or (assq 'hell efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'hell efs-dired-hell-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename hell - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line, where - ;; line can be delimited by either \r or \n. - ;; Returns (point) or nil if raise-error is nil and there is no - ;; filename on this line. In the later case, leaves the point at the - ;; beginning of the line. - ;; This version is for the Hellsoft FTP server. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-hell-date-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename hell - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the Hellsoft FTP server version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_+=a-zA-Z0-9.$~") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline hell (dir) - ;; Insert a blank line for aesthetics - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -;;; end of efs-hell.el
--- a/lisp/efs/efs-ka9q.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ka9q.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: KA9Q support for efs -;; Author: Sandy Rutherford <sandy@tsmi19.sissa.it> -;; Created: Mon Dec 21 10:34:43 1992 by sandy on ibm550 -;; Modified: Sun Nov 27 18:32:56 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Thanks go to Joe Reinhardt for beta testing. - -(provide 'efs-ka9q) -(require 'efs) - -(defconst efs-ka9q-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;;;----------------------------------------------------------------- -;;; KA9Q support for efs -;;;----------------------------------------------------------------- -;;; -;;; KA9Q is not really an OS, but an ftp server that runs on PC's. -;;; It runs under DOS and unix. Seems to have been adopted by LINUX. - -;; KA9Q uses unix syntax for paths, so don't need to bother with pathname -;; converters. It always gives a listing, even if a file or dir doesn't -;; exist. Therefore, we shall assume that empty dir = nonexistent dir. sigh... - -(defconst efs-ka9q-date-regexp - " +[.,0-9]* [ 0-2][0-9]:[0-9][0-9] +[0-9]+/[0-9]+/[0-9]+") - ;; (match-beginning 0) should be the last char of the filename. - -(defun efs-ka9q-bogus-listing (dir path) - ;; Check to see if a 1-line ka9q listing is bogus, and the directory - ;; is really just a file. - (and - (not (string-equal "/" dir)) - (goto-char (point-min)) - (looking-at (regexp-quote - (concat (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name dir)) - " "))) - (forward-line 1) - (looking-at "1 file\\. ") - (string-match "^No files\\. " - ;; ls switches don't matter - (efs-ls (concat path "*") "-al" t t)))) - -(efs-defun efs-parse-listing ka9q - (host user dir path &optional switches) - ;; Parse the current listing which is assumed to be a ka9q listing. - ;; Format is based on version 890421.1a.linux.7 (whatever that means). - ;; Note that ka9q uses two files per line. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs-path syntax - (let ((tbl (efs-make-hashtable)) - dir-p file) - (efs-save-match-data - (if (and - (progn - (goto-char (point-max)) - (forward-line -1) - ;; Although "No files." may refer to an empty - ;; directory, it may also be a non-existent - ;; dir. Returning nil should force a listing - ;; of the parent, which will sort things out. - (looking-at "[0-9]+ files?\\. ")) - ;; Check for a bogus listing. - (not (efs-ka9q-bogus-listing dir path))) - (progn - (goto-char (point-min)) - (while (re-search-forward efs-ka9q-date-regexp nil t) - (goto-char (match-beginning 0)) - (if (setq dir-p (eq (preceding-char) ?/)) - (forward-char -1)) - (setq file (buffer-substring (point) - (progn (skip-chars-backward "^ \n") - (point)))) - (efs-put-hash-entry file (list dir-p) tbl) - (goto-char (match-end 0))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - -;;; Tree Dired - -(defconst efs-dired-ka9q-re-exe - "^. [^ \n\r./]+\\.exe ") - -(or (assq 'ka9q efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'ka9q efs-dired-ka9q-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-ka9q-re-dir - "^. [^ \n\r/]+/ ") - -(or (assq 'ka9q efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'ka9q efs-dired-ka9q-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-fixup-listing ka9q (file path &optional switches wildcard) - ;; ka9q puts two files per line. Need to put in one file per line format - ;; for dired. - (let ((regexp (concat efs-ka9q-date-regexp " "))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (delete-char -3) - (insert-char ?\n 1)) - ;; is there a blank line left? - (if (looking-at "[ \t]*\n") - (delete-region (match-beginning 0) (match-end 0))))) - -(efs-defun efs-dired-ls-trim ka9q () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (forward-line 1) - (if (looking-at "\\([0-9]+\\|No\\) files?\\. ") - (delete-region (point) (point-max))))) - -(efs-defun efs-dired-insert-headerline ka9q (dir) - ;; Insert a headerline - (insert-char ?\n 1) - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename ka9q - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This is the KA9Q version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-ka9q-date-regexp eol t) - (progn - (goto-char (match-beginning 0)) - (skip-chars-backward "^ " bol) - (point)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ka9q - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the KA9Q version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "^ \n\r/") - (if (or (= opoint (point)) (not (memq (following-char) '(?/ ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-ka9q.el
--- a/lisp/efs/efs-kerberos.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,136 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-kerberos.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.0 $ -;; RCS: -;; Description: Support for Kerberos gateways. -;; Author: Sandy Rutherford <sandy@gandalf.sissa.it> -;; Created: Thu Nov 24 21:19:25 1994 by sandy on gandalf -;; Modified: -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Support for the Kerberos gateway authentication system from MIT's -;;; Project Athena. - -(provide 'efs-kerberos) -(require 'efs) - -(defconst efs-kerberos-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.0 $" 11 -2))) - -;;; Internal Variables - -(defvar efs-kerberos-passwd-sent nil) -;; Set to t after the passwd has been sent. -(defvar efs-kerberos-output "") -;; Holds the output lines from the kinit process. -(defvar efs-kerberos-buffer-name "*efs kerberos*") -;; Buffer where kinit output is logged. -(defvar efs-kerberos-passwd-prompt-regexp "^Password: *$") -;; Regular expression to match prompt used by the kinit program. -(defvar efs-kerberos-failed-msgs "[^ ]+") -;; Regular expression to match output for an invalid kinit ticket password. -;; Is this too general? -(defvar efs-kerberos-passwd-failed nil) -;; Whether the kinit command worked. -(defvar efs-kerberos-passwd-retry nil) - -;;; Code - -(defun efs-kerberos-process-filter (proc str) - ;; Process filter for the kinit process. - (setq efs-kerberos-output (concat efs-kerberos-output str)) - (let ((buff (get-buffer (process-buffer proc)))) - (if buff - (efs-save-buffer-excursion - (set-buffer buff) - (efs-save-match-data - (goto-char (point-max)) - (while (string-match "\n" efs-kerberos-output) - (let ((line (substring efs-kerberos-output 0 - (match-beginning 0)))) - (insert line "\n") - (and efs-kerberos-passwd-sent - (string-match efs-kerberos-failed-msgs line) - (setq efs-kerberos-passwd-failed t))) - (setq efs-kerberos-output (substring efs-kerberos-output - (match-end 0)))) - (and (null efs-kerberos-passwd-sent) - (string-match efs-kerberos-passwd-prompt-regexp - efs-kerberos-output) - (memq (process-status proc) '(run open)) - (let ((passwd (or - (efs-lookup-passwd efs-gateway-host "kerberos") - (read-passwd - (if efs-kerberos-passwd-retry - "Password failed. Try again: " - (format "Kerberos password for %s: " - efs-gateway-host)))))) - (unwind-protect - (progn - (insert efs-kerberos-output) - (setq efs-kerberos-output "") - (process-send-string proc passwd) - (insert "Turtle Power!\n")) - (fillarray passwd 0))))))))) - -(defun efs-kerberos-get-ticket () - ;; Gets a kerbos ticket. The password is actually sent by the process - ;; filter. - (let ((mess (format "Getting kerberos ticket for %s..." efs-gateway-host))) - (message mess) - (setq efs-kerberos-passwd-failed nil - efs-kerberos-passwd-sent nil - efs-kerberos-output "") - (condition-case nil (delete-process "*efs kerberos*") (eror nil)) - (let* ((program (or (nth 3 efs-gateway-type) "kinit")) - (args (nth 4 efs-gateway-type)) - (proc (apply 'start-process - "*efs kerberos*" efs-kerberos-buffer-name - program args))) - (set-process-filter proc (function efs-kerberos-process-filter)) - ;; Should check for a pty, but efs-pty-check will potentially eat - ;; important output. Need to wait until Emacs 19.29 to do this properly. - (while (memq (process-status proc) '(run open)) - (accept-process-output proc)) - (if efs-kerberos-passwd-failed - (let ((efs-kerberos-passwd-failed t)) - (efs-kerberos-get-ticket)))) - (message "%sdone" mess))) - -(defun efs-kerberos-login (host user proc) - ;; Open a connection using process PROC to HOST adn USER, using a - ;; kerberos gateway. Returns the process object of the connection. - ;; This may not be PROC, if a ticket collection was necessary. - (let ((to host) - result port cmd) - (if (string-match "#" host) - (setq to (substring host 0 (match-beginning 0)) - port (substring host (match-end 0)))) - (and efs-nslookup-on-connect - (string-match "[^0-9.]" to) - (setq to (efs-nslookup-host to))) - (setq cmd (concat "open " to)) - (if port (setq cmd (concat cmd " " port))) - (setq result (efs-raw-send-cmd proc cmd)) - (while (and (car result) - (string-match "\\bcannot authenticate to server\\b" - (nth 1 result))) - (let ((name (process-name proc))) - (condition-case nil (delete-process proc) (error nil)) - (efs-kerberos-get-ticket) - (setq proc (efs-start-process host user name) - result (efs-raw-send-cmd proc cmd)))) - (if (car result) - (progn - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "OPEN request failed: " - (nth 1 result))))) - proc)) - -;;; End of efs-kerberos.el
--- a/lisp/efs/efs-mpe.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,678 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-mpe.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.8 $ -;; RCS: -;; Description: MPE (HP3000) support for efs. -;; Author: (Corny de Souza) cdesouza@hpbbn.bbn.hp.com -;; Created: Fri Jan 15 12:58:29 1993 -;; Modified: Sun Nov 27 18:36:13 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Credits -;; -;; Sandy Rutherford for his help and advice. - -;;; Usage -;; -;; For a general description of remote file access see efs.el. -;; -;; MPE Specifics -;; -;; *) To make things easier (for me) MPE has been UNIXified so think UNIX -;; and you stand a good chance of understanding everything. -;; -;; *) Filename syntax is as follows -;; -;; /session,user.account,group@system:/account/group/file;buildparms -;; -;; the "session," and ",group" in the logon sequence are optional. -;; -;; e.g. /CDSUSER.OSCAR@SYSTEM41:/OSCAR/CDSSRC/TST0000S -;; will get the file TST0000S.CDSSRC.OSCAR -;; -;; The ";buildparms" is also optional. It should be used when creating -;; files whos characteristics differ from the default system buildparms, -;; described in the file FTPDOC.ARPA.SYS (at least it is on my system). -;; Also see variable efs-mpe-default-buildparms. -;; -;; e.g. REC=-256,,V,ASCII -;; -;; *) Password syntax is as follows -;; -;; userpass,accountpass,grouppass -;; -;; Leading commas cannot be omitted, trailing commas can. -;; e.g. USERPASS,ACCTPASS (no group password) -;; ,ACCTPASS (only account password) -;; USERPASS,,GRPPASS (no account password) -;; -;; *) Do not use account name completion on large systems. See the variable -;; efs-mpe-account-completion-confirm -;; -;; *) Do not use group name completion on large accounts. See the variable -;; efs-mpe-group-completion-confirm -;; -;; *) The buffers FILE and FILE;BUILDPARMS both point to the same physical -;; disc file. -;; -;; *) When using filename completion you will usually be given the option -;; between FILE and FILE;BUILDPARMS. Just ignore the FILE;BUILDPARMS -;; bit. -;; -;; *) WARNING ********* Two buffer for the same file ************ WARNING -;; If you land up with two buffers FILE and FILE;BUILDPARMS for the same -;; file kill the FILE;BUILDPARMS one. If however this is newwer than -;; the FILE buffer (and you cannot live with a buffer called -;; FILE;BUILDPARMS) save it kill both buffers and get the FILE buffer again. -;; -;; *) When creating new files only create FILES. It is possible to create -;; files as GROUPs and ACCOUNTs but don't! -;; -;;; To Do -;; -;; A lot of things are likely to change with MPE 4.5 and POSIX so I do not want -;; to invest too much time in this now. I would rather wait until I can see -;; what comes with POSIX. -;; -;; Feel free to send bugs, suggestions for enhancements and enhancements -;; to me cdesouza@hpbbn.bbn.hp.com. If I have TIME I will try to deal with -;; them. Also I'm not a lisp programmer so keep it simple or put in plenty -;; of comments. -;; -;; -;; *) Improve on the dired GROUP and ACCOUNT listings. -;; -;; *) Add ".." to dired FILE and GROUP listings. -;; -;; *) Support POSIX (need POSIX machine first though). -;; -;; *) Test ACCOUNT name completion and listings properly. I have the problem -;; that the only systems available to me are large ( i.e. start a listf -;; @.@.@,2 today and come back tomorrow), which makes -;; it pretty hard for me to test. -;; - -;;; Code - -(provide 'efs-mpe) -(require 'efs) - -;;; User Variables - -(defvar efs-mpe-account-completion-confirm t - "*Set to non-nil will cause a prompt to be issued before attempting ACCOUNT -name completion. For ACCOUNT name completion a LISTF @.@.@,2 is required. -This can take a very long time on large systems") - -(defvar efs-mpe-group-completion-confirm t - "*Set to non-nil will cause a prompt to be issued before attempting GROUP -name completion. For GROUP name completion a LISTF @.@.ACCOUNT,2 is required. -This can take a very long time on large accounts") - -(defvar efs-mpe-default-buildparms "" - "*If set to non empty string used to override the system default buildparms.") - -;;; Internal Variables - -(defconst efs-mpe-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.8 $" 11 -2))) - -;;; Support for build parameters - -(defun efs-mpe-get-buildparms (path) - ;; Gets the mpe buildparms for PATH. PATH should be in efs syntax. - (let ((files (efs-get-files-hashtable-entry (file-name-directory - (directory-file-name path))))) - (if files - (let* ((file (efs-get-file-part path)) - (completion-ignore-case - (memq 'mpe efs-case-insensitive-host-types)) - (bpversions (all-completions (concat file ";") files))) - (cond - ((null bpversions) - efs-mpe-default-buildparms) - ((= (length bpversions) 1) - (substring (car bpversions) (length file))) - (t - (error - "efs-mpe: %s seems to have more than one set of buildparams." - path)))) - ;; return the default - efs-mpe-default-buildparms))) - -(defun efs-mpe-fix-buildparms (buildparms host user path) - "Try to assign buildparms for the file being PUT" - (or - ;; Buildparms specified with file use them. - buildparms - (efs-mpe-get-buildparms (format efs-path-format-string user host path)))) - -;;; entry points - -(efs-defun efs-fix-path mpe (path &optional reverse) - ;; Convert PATH from UNIX-ish to MPE. If REVERSE given then convert from - ;; MPE to UNIX-ish. N.B. Path does not contain HOST or USER part so the - ;; dynamic variables HOST and USER are used. - ;; Also uses the dynamic variable CMD0. - (efs-save-match-data - (if reverse - ;; This is never used as we only convert PWD (see below) output in - ;; this direction. However I will leave this here should it be - ;; required in the future. - (if (let ((case-fold-search t)) - (string-match - (concat "^\\([A-Z][A-Z0-9]*\\)" ; file - "\\(.[A-Z][A-Z0-9]*\\)" ; group - "\\(.[A-Z][A-Z0-9]*\\)$") ; account - path)) - (let (file group account) - (setq file (substring path 0 (match-end 1))) - (if (match-beginning 2) - (setq group (substring - path (1+ (match-beginning 2)) (match-end 2)))) - (if (match-beginning 3) - (setq account (substring - path (1+ (match-beginning 3)) - (match-end 3)))) - (concat (and account (concat "/" account "/")) - (and group (concat group "/")) - file)) - ;; handle PWD output - (if (let ((case-fold-search t)) - (string-match - (concat - "\\([A-Z][A-Z0-9]*\\)?" ; sessionname - ",[A-Z][A-Z0-9]*\.\\([A-Z][A-Z0-9]*\\)," ; username.account - "\\([A-Z][A-Z0-9]*\\)$") ; group - path)) - (concat "/" - (substring path (match-beginning 2) (match-end 2)) - "/" - (substring path (match-beginning 3) (match-end 3)) - "/") - (error "Invalid MPE (MPE->UNIX) filename: %s" path))) - (if (let ((case-fold-search t)) - (string-match - (concat - "^\\(/[A-Z][A-Z0-9]*/\\)" ; account - "\\([A-Z][A-Z0-9]*/\\)" ; group - "\\([A-Z][A-Z0-9]*\\)" ; file - "\\(;.*\\)?$") ; buildparms - path)) - (let ((for-put (and (boundp 'cmd0) (eq cmd0 'put))) - file group account buildparms) - (setq account (substring - path (1+ (match-beginning 1)) (1- (match-end 1)))) - (setq group (substring - path (match-beginning 2) (1- (match-end 2)))) - (setq file (substring path (match-beginning 3) (match-end 3))) - (if for-put - (setq buildparms - (efs-mpe-fix-buildparms - (and (match-beginning 4) - (substring path - (match-beginning 4) (match-end 4))) - host user path))) - (concat file - (and group (concat "." group )) - (and account (concat "." account )) - (and for-put buildparms))) - (error "Invalid MPE (UNIX->MPE) filename: *%s*" path))))) - -(efs-defun efs-fix-dir-path mpe (dir-path) - ;; Convert path from UNIX-ish to MPE ready for a DIRectory listing. MPE does - ;; not have directories as such. It does have GROUPS and ACCOUNTS, but the - ;; DIR command does not let you list just ACCOUNTs on the system or just - ;; GROUPs in the ACCOUNT - no you always get everything downwards - ;; i.e. ACCOUNTs + GROUPs + FILEs or GROUPs + FILEs or just FILEs - ;; depending on the level. - (efs-save-match-data - (message "Fixing listing %s ..." dir-path) - (cond - ;; Everything !?! might take a while. - ((string-equal dir-path "/") - (if efs-mpe-account-completion-confirm - (if (y-or-n-p "Continue with ACCOUNT name completion? ") - "@.@.@" - (error "Quit ACCOUNT name completion")) - "@.@.@")) - ;; specification starts with account - ((let ((case-fold-search t)) - (string-match - (concat - "^\\(/[A-Z][A-Z0-9]*/\\)" ; account - "\\([A-Z][A-Z0-9]*/\\)?" ; group - "\\([A-Z][A-Z0-9]*\\)?" ; file - "\\(;.*\\)?/?$") ; buildparms - dir-path)) - (let (file group account) - (setq account (substring dir-path - (1+ (match-beginning 1)) (1- (match-end 1)))) - (if (match-beginning 2) - (setq group (substring dir-path - (match-beginning 2) (1- (match-end 2)))) - (if efs-mpe-group-completion-confirm - (if (y-or-n-p "Continue with GROUP name completion? ") - (setq group "@") - (error "Quit GROUP name completion")) - (setq group "@"))) - (if (match-beginning 3) - ;;(setq file (substring dir-path - ;; (match-beginning 3) (1- (match-end 3)))) - ;; set the filename to something silly so that the DIR will fail - ;; and so force a DIR for the group instead. Either I've - ;; misunderstood something or you have to do it like this. - (setq file "~!#&*") - (setq file "@")) - (concat file "." group "." account))) - (t - (error "Invalid MPE (LISTF) filename: %s" dir-path))))) - -(defconst efs-mpe-acct-grp-line-regexp - "ACCOUNT= +\\([A-Z][A-Z0-9]*\\) +GROUP= +\\([A-Z][A-Z0-9]*\\)") -(defconst efs-mpe-file-line-regexp - (concat - "\\*? +\\([A-Z0-9]*\\) +\\([0-9]+\\)" - "\\([BW]\\) +\\([FV]\\)\\([AB]\\)\\([MCO]?\\) +\\([0-9]+\\)")) - -(efs-defun efs-parse-listing mpe - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in - ;; mpe ftp dir format. - ;; HOST is the name of the remote host. - ;; USER is the user name. - ;; DIR is the directory as a full remote path - ;; PATH is the directory in full efs-syntax - ;; SWITCHES are the switches passed to ls (not relevant for mpe) - (goto-char (point-min)) - (efs-save-match-data - ;;Make sure this is a valid listing - (if (re-search-forward "ACCOUNT= +[A-Z]+ +GROUP=" nil t) - (let (acct-tbl grp-tbl file-tbl - account group file - acct-cur grp-cur) - (goto-char (point-min)) - ;; Look for something that could be a filename. - (while (re-search-forward "^[A-Z][A-Z0-9]*" nil t) - (goto-char (match-beginning 0)) - ;; Check to see if looking at an ACCOUNT= GROUP= line. Could - ;; be a continuation (cont). line or a change in account or group - (if (looking-at efs-mpe-acct-grp-line-regexp) - (progn - (setq account (buffer-substring (match-beginning 1) - (match-end 1))) - (setq group (buffer-substring (match-beginning 2) - (match-end 2))) - ;;Check for change of account - (if (not (string-equal acct-cur account)) - (progn - ;;Create table for account names and fill with - ;; "." entry. - (if (not acct-tbl) - (progn - (setq acct-tbl (efs-make-hashtable)) - (efs-put-hash-entry "." '(t) acct-tbl))) - (efs-put-hash-entry account '(t) acct-tbl) - ;;Store the current group table - (if grp-tbl - (progn - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/")) - grp-tbl ) - (setq grp-tbl nil))))) - ;;Check for change in group. Change in account is automatic - ;;change in group. - (if (or (not (string-equal acct-cur account)) - (not (string-equal grp-cur group))) - (progn - ;;Create table for group names and fill with - ;; "." and ".." entries. - (if (not grp-tbl) - (progn - (setq grp-tbl (efs-make-hashtable)) - (efs-put-hash-entry "." '(t) grp-tbl) - (efs-put-hash-entry ".." '(t) grp-tbl))) - (efs-put-hash-entry group '(t) grp-tbl) - ;;Store current file table - (if file-tbl - (progn - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/" grp-cur "/")) - file-tbl) - (setq file-tbl nil))))) - ;;Set new grp-cur and acct-cur incase one or both chnaged. - (setq grp-cur group acct-cur account) - ) - ;;Looking at either a file name, or the line - ;;"FILENAME CODE --....--LOGICAL.." - ;;Save the possible filename. - (setq file (buffer-substring (point) - (progn - (skip-chars-forward "A-Z0-9") - (point)))) - ;;Make sure its a file name. - ;;"\\*?" is for files in access. - ;; File codes can be numeric as well! CdS - (if (looking-at efs-mpe-file-line-regexp) - ;;Hack out the buildparms - (let* ((code (and - (/= (match-beginning 1) (match-end 1)) - (concat ";CODE=" - (buffer-substring - (match-beginning 1) (match-end 1))))) - (length (buffer-substring (match-beginning 2) - (match-end 2))) - (eof (buffer-substring (match-beginning 7) - (match-end 7))) - (bytes (* (string-to-int eof) - (string-to-int length))) - (word-byte (buffer-substring (match-beginning 3) - (match-end 3))) - (fix-var (buffer-substring (match-beginning 4) - (match-end 4))) - (ascii-binary (buffer-substring (match-beginning 5) - (match-end 5))) - (cir-msg (and (match-beginning 6) - (buffer-substring (match-beginning 6) - (match-end 6)))) - (rec ";REC=")) - (if (string-equal word-byte "B") - (setq rec (concat rec "-")) - (setq bytes (* 2 bytes))) - (setq rec (concat rec length ",," fix-var ",")) - (if (string-equal ascii-binary "A") - (setq rec (concat rec "ASCII")) - (setq rec (concat rec "BINARY"))) - (cond ((string-equal cir-msg "M") - (setq cir-msg ";MSG")) - ((string-equal cir-msg "O") - (setq cir-msg ";CIR")) - (t - (setq cir-msg nil))) - (if (not file-tbl) - (progn - (setq file-tbl (efs-make-hashtable)) - (efs-put-hash-entry "." '(t) file-tbl) - (efs-put-hash-entry ".." '(t) file-tbl))) - (message "Adding... %s" file) - (efs-put-hash-entry file (list nil bytes) file-tbl) - (efs-put-hash-entry (concat file rec code cir-msg) - (list nil bytes) file-tbl))) - ) ;if looking-at - (forward-line 1) - );while - ;;Check at what level the listing was done and return the - ;;corresponding table. System = acct-tbl, Account = grp-tbl, - ;;Group = file-tbl. - (if (let ((case-fold-search t)) - (string-match - "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" - dir)) - ;;group level listing, just return table of files - (if (or (match-beginning 3) (match-beginning 4)) - file-tbl - ;;account level listing, return table of groups but do not - ;;forget to store current table of files. - (if (match-beginning 2) - (progn - (if file-tbl - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/" grp-cur "/")) - file-tbl)) - grp-tbl) - ;;System level listing, return table of accounts but do not - ;;forget to store current table of groups and files - (if (match-beginning 1) - (progn - (if file-tbl - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/" grp-cur "/")) - file-tbl)) - (if grp-tbl - (efs-set-files - (efs-replace-path-component - path - (concat "/" acct-cur "/")) - grp-tbl)) - acct-tbl) - (error "Parse listing 0 path %s" path)))) - (error "Parse listing 1 path %s" path)))))) - - -(efs-defun efs-really-file-p mpe (file ent) - ;; Doesn't treat the buildparm entry as a real file entry. - (efs-save-match-data - (not (string-match ";" file)))) - -(efs-defun efs-delete-file-entry mpe (path &optional dir-p) - ;; Deletes FILE and FILE;BUILDPARMS from file hashtable. - (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-files-hashtable-entry - (file-name-directory path))) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (let ((file (efs-get-file-part path)) - (files (efs-get-files-hashtable-entry - (file-name-directory path)))) - (if files - (efs-save-match-data - (if (string-match ";" file) - (let ((root (substring file (match-beginning 0)))) - ;; delete ROOT from hashtable - (efs-del-hash-entry root files ignore-case) - ;; delete ROOT;BUILDPARAMS from hashtable - (efs-del-hash-entry file files ignore-case)) - ;; we've specified only a root. - (let* ((root (concat file ";")) - (completion-ignore-case ignore-case) - (extensions (all-completions root files))) - ;; Get rid of FILE. - (efs-del-hash-entry file files ignore-case) - ;; Get rid of all BUILDPARAMS versions - (while extensions - ;; all-completions will return names with the right case. - ;; Don't need to ignore-case now. - (efs-del-hash-entry (car extensions) files) - (setq extensions (cdr extensions))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry mpe (path dir-p size owner - &optional modes nlinks mdtm) - ;; Deletes FILE (if present) and FILE;BUILDPARMS (if present) from hashtable - ;; then adds FILE and FILE;BUILDPARMS (if specified) to hashtable. - (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-files-hashtable-entry - (file-name-directory path)))) - (if files - (efs-put-hash-entry (efs-get-file-part path) ent files - ignore-case))) - - (let ((files (efs-get-files-hashtable-entry - (file-name-directory path)))) - (efs-save-match-data - (if files - (let* ((file (efs-get-file-part path)) - (root (substring file 0 (string-match ";" file)))) - (if (equal root file) - (setq file (concat file (efs-mpe-get-buildparms path)))) - ;; In case there is another entry with different buildparams, - ;; wipe it. - (efs-delete-file-entry 'mpe path nil) - (efs-put-hash-entry root ent files ignore-case) - (efs-put-hash-entry file ent files ignore-case)))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-allow-child-lookup mpe (host user dir file) - ;; Returns non-NIL if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. Note that DIR is in directory syntax i.e. /foo/bar/, not - ;; /foo/bar. - - ;; Subdirs in MPE are accounts or groups. - (string-match "^/\\([^/]+/\\)?$" dir)) - -(efs-defun efs-file-type mpe (path) - ;; Returns whether to treat an efs file as a text file or not. - (let ((buildparams (efs-mpe-get-buildparms path))) - (efs-save-match-data - (let ((case-fold-search t)) - (cond - ((string-match "BINARY" buildparams) - '8-binary) - (t - 'text)))))) - -;;; Tree dired support: - -(efs-defun efs-dired-manual-move-to-filename mpe - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the MPE version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - ;; The "\\|ACCOUNT=\\|GROUP=" bit is to take care of the hacked account and - ;; group dired listings. - (if (looking-at - ". [A-Z][A-Z0-9]*\\*? +\\([A-Z]* +[0-9]+\\|ACCOUNT=\\|GROUP=\\)") - (progn - (forward-char 2) - (point)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mpe - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the MPE version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "A-Z0-9") - (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?*)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-ls-trim mpe () - ;; trim single file listings 1-line. - ;; This uses an evil dynamical binding of file. - (if (and (boundp 'file) (stringp file)) - (let ((f (file-name-nondirectory file))) - (or (zerop (length f)) - (progn - (goto-char (point-min)) - (if (search-forward (concat "\n" (upcase file) " ") nil t) - (progn - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))))))))) - -(efs-defun efs-dired-fixup-listing mpe (file path &optional switches wildcard) - ;; File (group) listings stay pretty much as they are group (account) and - ;; account (system) listings get realy hacked. - (efs-save-match-data - (goto-char (point-max)) - (string-match - "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" - path) - ;; group or file level listing. - (if (or (match-beginning 3) (match-beginning 4)) - ;; Hack out the continuation lines. - (while - (re-search-backward - "\n\nACCOUNT=.+GROUP=.+(CONT\\.)\n\n.*\n.*\n" nil t) - (replace-match "" nil nil)) - ;;account level listing, hack out everything apart from group names - (if (match-beginning 2) - (let ((group nil) - (grp-cur nil)) - (while - (re-search-backward - "GROUP= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" - nil t) - (setq group - (buffer-substring (match-beginning 1) (match-end 1))) - ;;Continuation header or new group - (if (string-equal grp-cur group) - (replace-match "" nil nil) - (replace-match (format "\n\n%-10sGROUP=" group) nil nil)) - (forward-line -1) - (setq grp-cur group) - (narrow-to-region (point-min) (point))) - (widen) - (goto-char (point-max)) - (insert "\n\n")) - ;;System level listing, hack out everything apart from account names - (if (match-beginning 1) - (let (account acct-cur) - (while - (re-search-backward - "^ACCOUNT= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" - nil t) - (setq account - (buffer-substring (match-beginning 1) (match-end 1))) - ;;Continuation header or new account - (if (string-equal acct-cur account) - (replace-match "" nil nil) - (replace-match (format "%-10sACCOUNT=" account) nil nil)) - (forward-line -1) - (setq acct-cur account) - (narrow-to-region (point-min) (point))) - (widen) - (goto-char (point-max)) - (insert "\n\n"))))))) - -;;; end of efs-mpe.el
--- a/lisp/efs/efs-ms-unix.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ms-unix.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: efs support for the Microsoft PC FTP server in unix mode. -;; Author: Sandy Rutherford <sandy@tsmi19.sissa.it> -;; Created: Thu Aug 19 08:31:15 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:37:00 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-ms-unix) -(require 'efs) - -(defconst efs-ms-unix-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(defvar efs-ms-unix-month-and-time-regexp - (concat - " \\([0-9]+\\) +" ; file size - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 0-3][0-9]" - " +\\([ 012][0-9]:[0-6][0-9]\\|[12][90][0-9][0-9]\\) +")) - -;;; entry points - -(efs-defun efs-fix-path ms-unix (path &optional reverse) - ;; Convert PATH from UNIX-ish to MS-UNIX. - (if reverse - (concat "/" path) - (substring path 1))) - -(efs-defun efs-fix-dir-path ms-unix (dirpath) - ;; Convert a path from UNIX-ish to MS-UNIX for a dir listing - (if (string-equal dirpath "/") - (error "Cannot grok disk names.") - (setq dirpath (substring dirpath 1)) - (efs-save-match-data - (if (string-match "/$" dirpath) - (concat dirpath "*") - dirpath)))) - -(defmacro efs-ms-unix-parse-file-line () - ;; Extract the filename, size, and permission string from the current - ;; line of a dired-like listing. Assumes that the point is at - ;; the beginning of the line, leaves it just before the size entry. - ;; Returns a list (name size perm-string nlinks owner). - ;; If there is no file on the line, returns nil. - (` (let ((eol (save-excursion (end-of-line) (point))) - name size modes nlinks owner) - (skip-chars-forward " 0-9" eol) - (and - (looking-at efs-modes-links-owner-regexp) - (setq modes (buffer-substring (match-beginning 1) - (match-end 1)) - nlinks (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))) - owner (buffer-substring (match-beginning 3) (match-end 3))) - (re-search-forward efs-ms-unix-month-and-time-regexp eol t) - (setq name (buffer-substring (point) eol) - size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (list name size modes nlinks owner))))) - -(efs-defun efs-parse-listing ms-unix (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be output from - ;; the Microsoft FTP server in unix mode. - ;; Return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-ms-unix-month-and-time-regexp nil t) - (let ((tbl (efs-make-hashtable)) - size modes nlinks dir-p owner file) - (beginning-of-line) - (while (setq file (efs-ms-unix-parse-file-line)) - (setq size (nth 1 file) - modes (nth 2 file) - nlinks (nth 3 file) - owner (nth 4 file) - file (car file) - dir-p (= (string-to-char modes) ?d)) - (if (and dir-p - (string-match "/$" file)) - (setq file (substring file 0 -1))) - (efs-put-hash-entry file (list dir-p size owner modes nlinks) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -;;; Tree Dired - -;; ms-unix does not have a total line - -(efs-defun efs-dired-insert-headerline ms-unix (dir) - ;; MTS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename ms-unix - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This version is for ms-unix. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-ms-unix-month-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ms-unix - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the ms-unix version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) - (if (eolp) - (progn - (goto-char opoint) - (if no-error - nil - (error "No file on this line"))) - (end-of-line) - (if (char-equal (preceding-char) ?/) - (forward-char -1)) - (point)))) - -;;; end of efs-ms-unix.el
--- a/lisp/efs/efs-mts.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,239 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-mts.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: MTS support for efs -;; Author: Sandy Rutherford <sandy@itp.ethz.ch> -;; Created: Fri Oct 23 08:51:29 1992 -;; Modified: Sun Nov 27 18:37:18 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-mts) -(require 'efs) - -(defconst efs-mts-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; MTS support -;;;; ------------------------------------------------------------ - -;;; efs has full support, including tree dired support, for hosts running -;;; the Michigan terminal system. It should be able to automatically -;;; recognize any MTS machine. We would be grateful if you -;;; would report any failures to automatically recognize a MTS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; MTS filenames are entered in a UNIX-y way. For example, if your account -;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be -;;; entered as -;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE -;;; In other words, MTS accounts are treated as UNIX directories. Of course, -;;; to access a file in another account, you must have access permission for -;;; it. If FILE were in your own account, then you could enter it in a -;;; relative path fashion as -;;; /YYYY@mtsg.ubc.ca:FILE -;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the -;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you -;;; like.) MTS filenames are always in upper case, and hence be sure to enter -;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX -;;; is. - - -(defconst efs-mts-date-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 123]?[0-9] ")) - -;;; The following two functions are entry points to this file. -;;; They are put into the appropriate alists in efs.el - -(efs-defun efs-fix-path mts (path &optional reverse) - ;; Convert PATH from UNIX-ish to MTS. - ;; If REVERSE given then convert from MTS to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path) - (let (acct file) - (if (match-beginning 1) - (setq acct (substring path 0 (match-end 1)))) - (if (match-beginning 2) - (setq file (substring path - (match-beginning 2) (match-end 2)))) - (concat (and acct (concat "/" acct "/")) - file)) - (error "path %s didn't match" path)) - (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path) - (concat (substring path 1 (match-end 1)) - (substring path (match-beginning 2) (match-end 2))) - ;; Let's hope that mts will recognize it anyway. - path)))) - -(efs-defun efs-fix-dir-path mts (dir-path) -;; Convert path from UNIX-ish to MTS ready for a DIRectory listing. -;; Remember that there are no directories in MTS. - (if (string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.") - (let ((dir-path (efs-fix-path 'mts dir-path))) - (cond - ((string-equal dir-path "") - "?") - ((efs-save-match-data (string-match ":$" dir-path)) - (concat dir-path "?")) - (dir-path))))) ; It's just a single file. - - -(efs-defun efs-parse-listing mts - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in - ;; mts ftp dir format. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory as a remote full path - ;; PATH = directory as an efs full path - ;; SWITCHES are never used here, but they - ;; must be specified in the argument list for compatibility - ;; with the unix version of this function. - (let ((tbl (efs-make-hashtable)) - perms) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward efs-mts-date-regexp nil t) - (beginning-of-line) - (if (looking-at "[rwed]+") - (setq perms (buffer-substring (match-beginning 0) (match-end 0))) - (setq perms nil)) - (end-of-line) - (skip-chars-backward " ") - (let ((end (point))) - (skip-chars-backward "-A-Z0-9_.!") - (efs-put-hash-entry (buffer-substring (point) end) - (list nil nil nil perms) tbl)) - (forward-line 1))) - ;; Don't need to bother with .. - (efs-put-hash-entry "." '(t) tbl) - tbl)) - -(efs-defun efs-allow-child-lookup mts (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; MTS file system is flat. Only "accounts" are subdirs. - (string-equal "/" dir)) - -(efs-defun efs-internal-file-writable-p mts (user owner modes) - (if (stringp modes) - (efs-save-match-data - (null (null (string-match "w" modes)))) - t)) ; guess - -(efs-defun efs-internal-file-readable-p mts (user owner modes) - (if (stringp modes) - (efs-save-match-data - (null (null (string-match "r" modes)))) - t)) ; guess - -;;; Tree dired support: - -;; There aren't too many systems left that use MTS. This dired support will -;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems -;; implement ftp in the same way. If not, it might be necessary to make the -;; following more flexible. - -(defconst efs-dired-mts-re-exe nil) - -(or (assq 'mts efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'mts efs-dired-mts-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-mts-re-dir nil) - -(or (assq 'mts efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'mts efs-dired-mts-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename mts - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the MTS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-mts-date-regexp eol t) - (progn - (skip-chars-forward " ") ; Eat blanks after date - (skip-chars-forward "0-9:") ; Eat time or year - (skip-chars-forward " ") ; one space before filename - (point)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mts - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the MTS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9._!") - (if (or (= opoint (point)) (not (memq (following-char) '(?\r ?\n)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-fixup-listing mts (file path &optional switches wildcard) - ;; If you're not listing your own account, MTS puts the - ;; account name in front of each filename. Scrape them off. - ;; PATH will have unix /'s on it. - ;; file-name-directory is in case of wildcards - (let ((len (length path))) - (if (> len 2) - (progn - (if (= (aref path (1- len)) ?/) - (setq path (substring path -2)) - (setq path (substring path -1))) - (goto-char (point-min)) - (while (search-forward path nil t) - (delete-region (match-beginning 0) (match-end 0))))))) - -(efs-defun efs-dired-insert-headerline mts (dir) - ;; MTS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -;;; end of efs-mts.el
--- a/lisp/efs/efs-mvs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,361 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-mvs.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.4 $ -;; RCS: -;; Description: MVS support for efs -;; Author: Sandy Rutherford <sandy@math.ubc.ca, sandy@itp.ethz.ch> -;; Created: Sat Nov 14 02:04:54 1992 -;; Modified: Sun Nov 27 18:37:54 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; -------------------------------------------------------- -;;; MVS support -;;; -------------------------------------------------------- - -(provide 'efs-mvs) -(require 'efs) - -(defconst efs-mvs-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.4 $" 11 -2))) - -;; What's the MVS character set for valid partitioned data sets? -;; I'll guess [-A-Z0-9_$+] - -;; The top level directory in MVS contains partitioned data sets. -;; We will view these as directories. The data sets within each -;; partitioned data set will be viewed as files. -;; -;; In MVS an entry for a "sub-dir" may have the same name as a plain -;; file. This is impossible in unix, so we retain the "dots" at the -;; end of subdir names, to distinuguish. -;; i.e. FOO.BAR --> /FOO./BAR - -(efs-defun efs-send-pwd mvs (host user &optional xpwd) - ;; Broken quoting for PWD output on some MVS servers. - (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) - (line (nth 1 result)) - dir) - (and (car result) - (efs-save-match-data - (and (string-match " \"'?\\([0-9A-Z]+\\)'?\"" line) - (setq dir (substring line (match-beginning 1) - (match-end 1)))))) - (cons dir line))) - -(efs-defun efs-fix-path mvs (path &optional reverse) - ;; Convert PATH from UNIX-ish to MVS. - (efs-save-match-data - (if reverse - (let ((start 0) - (res "/")) - ;; MVS has only files, some of which are partitioned - ;; into smaller files (partitioned data sets). We will - ;; assume that path starts with a partitioned dataset. - (while (string-match "\\." path) - ;; grab the dot too, because in mvs prefixes and plain - ;; files can have the same name. - (setq res (concat res (substring path start (match-end 0)) "/") - start (match-end 0))) - (concat res (substring path start))) - (let ((start 1) - res) - (while (string-match "/" path start) - (setq res (concat res (substring path start (match-beginning 0))) - start (match-end 0))) - (concat res (substring path start)))))) - -(efs-defun efs-fix-dir-path mvs (dir-path) - ;; Convert path from UNIX-ish to MVS for a DIR listing. - (cond - ((string-equal "/" dir-path) - " ") - (t (concat (efs-fix-path 'mvs dir-path) "*")))) - -(efs-defun efs-allow-child-lookup mvs (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; MVS file system is flat. Only partitioned data sets are "subdirs". - (efs-save-match-data - (string-match "\\.$" file))) - -(efs-defun efs-parse-listing mvs (host user dir path &optional switches) - ;; Guesses the type of mvs listings. - (efs-save-match-data - (goto-char (point-min)) - (cond - ((looking-at "Volume ") - (efs-add-listing-type 'mvs:tcp host user) - (efs-parse-listing 'mvs:tcp host user dir path switches)) - - ((looking-at "[-A-Z0-9_$.+]+ ") - (efs-add-listing-type 'mvs:nih host user) - (efs-parse-listing 'mvs:nih host user dir path switches)) - - (t - ;; Since MVS works on a template system, return an empty hashtable. - (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - -(efs-defun efs-ls-dumb-check mvs (line host file path lsargs msg noparse - noerror nowait cont) - ;; Because of the template structure of the MVS file system, empty - ;; directories are the same as non-existent. It's better for us to treat - ;; them as empty. - (and (string-match "^550 " line) - (let ((parse (or (null noparse) (eq noparse 'parse) - (efs-parsable-switches-p lsargs t)))) - (efs-add-to-ls-cache file lsargs "\n" parse) - (if parse - (efs-set-files file (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - (if nowait - (progn - (if cont - (efs-call-cont cont "\n")) - t) - (if cont - (efs-call-cont cont "\n")) - "\n")))) - -;;;; ---------------------------------------------------- -;;;; Support for the NIH FTP server. -;;;; ---------------------------------------------------- - -(efs-defun efs-parse-listing mvs:nih - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an MVS listing - ;; Based on the listing format of the NIH server. Hope that this format - ;; is widespread. If a directory doesn't exist, get a 426 ftp error. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs-syntax - (let ((tbl (efs-make-hashtable)) - (top-p (string-equal "/" dir)) - ;; assume that everything top-level is a partitioned data set - ) - (goto-char (point-min)) - (efs-save-match-data - (while (re-search-forward "^[-A-Z0-9_$.+]+" nil t) - (efs-put-hash-entry - (concat (buffer-substring (match-beginning 0) (match-end 0)) - (and top-p ".")) - (list top-p) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (or top-p (efs-put-hash-entry ".." '(t) tbl))) - tbl)) - -;;; Tree dired support - -(defconst efs-dired-mvs-re-exe - "^. [-A-Z0-9_$+]+\\.EXE " - "Regular expression to use to search for MVS executables.") - -(or (assq 'mvs:nih efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'mvs:nih efs-dired-mvs-re-exe) - efs-dired-re-exe-alist))) - -(efs-defun efs-dired-insert-headerline mvs:nih (dir) - ;; MVS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename mvs:nih - (&optional raise-error bol eol) - ;; In dired, move to the first char of the filename on this line. - ;; This is the MVS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - ;; MVS listings are pretty loose. Tough to tell when we've got a file line. - (if (and - (> (- eol bol) 2) - (progn - (forward-char 2) - (skip-chars-forward " \t") - (looking-at "[-A-Z0-9$_.+]+[ \n\r]"))) - (point) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mvs:nih - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the MVS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9$_.+" eol) - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-get-filename mvs:nih - (&optional localp no-error-if-not-filep) - (let ((name (efs-real-dired-get-filename localp no-error-if-not-filep)) - (parsed (efs-ftp-path (dired-current-directory)))) - (if (and name (string-equal "/" (nth 2 parsed))) - (concat name ".") - name))) - -(efs-defun efs-dired-fixup-listing mvs:nih - (file path &optional switches wildcard) - ;; MVS listings have trailing spaces to 80 columns. - ;; Can lead to a mess after indentation. - (goto-char (point-min)) - (while (re-search-forward " +$" nil t) - (replace-match ""))) - -;;;; ------------------------------------------------------- -;;;; Support for the TCPFTP MVS server -;;;; ------------------------------------------------------- -;;; -;;; For TCPFTP IBM MVS V2R2.1 Does it really work? - -(efs-defun efs-parse-listing mvs:tcp - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an MVS listing - ;; Based on the listing format of the NIH server. Hope that this format - ;; is widespread. If a directory doesn't exist, get a 426 ftp error. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs-syntax - (efs-save-match-data - (goto-char (point-min)) - (and (looking-at "Volume ") - (let ((top-tbl (efs-make-hashtable)) - (case-fold (memq 'mvs efs-case-insensitive-host-types)) - tbl-list file dn fn tbl dir-p) - (forward-line 1) - (while (not (eobp)) - (end-of-line) - (setq file (buffer-substring (point) - (progn (skip-chars-backward "^ ") - (point))) - dn path - dir-p (string-match "\\." file)) - (efs-put-hash-entry file '(nil) top-tbl) - (if dir-p - (progn - (setq dir-p (1+ dir-p) - fn (substring file 0 dir-p)) - (efs-put-hash-entry fn '(t) top-tbl) - (while dir-p - (setq dn (efs-internal-file-name-as-directory nil - (concat dn fn)) - file (substring file dir-p) - tbl (cdr (assoc dn tbl-list))) - (or tbl (setq tbl (efs-make-hashtable) - tbl-list (cons (cons dn tbl) tbl-list))) - (efs-put-hash-entry file '(nil) tbl) - (setq dir-p (string-match "\\." file)) - (if dir-p - (progn - (setq dir-p (1+ dir-p) - fn (substring file 0 dir-p)) - (efs-put-hash-entry fn '(t) tbl)))))) - (forward-line 1)) - (while tbl-list - (efs-put-hash-entry (car (car tbl-list)) (cdr (car tbl-list)) - efs-files-hashtable case-fold) - (setq tbl-list (cdr tbl-list))) - top-tbl)))) - -;;; Tree Dired - -(efs-defun efs-dired-manual-move-to-filename mvs:tcp - (&optional raise-error bol eol) - ;; In dired, move to the first char of the filename on this line. - ;; This is the MVS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (and (re-search-forward " [0-9][0-9]/[0-9][0-9]/[0-9][0-9] " eol t) - (progn - (goto-char eol) - (skip-chars-backward "-A-Z0-9$_.") - (char-equal (preceding-char) ?\ )) - (/= eol (point))) - (point) - (goto-char bol) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename mvs:tcp - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the MVS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-A-Z0-9$_.+" eol) - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-mvs.el
--- a/lisp/efs/efs-netrc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-netrc.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: Parses ~/.netrc file, and does completion in /. -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Fri Jan 28 19:32:47 1994 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;;; ------------------------------------------------------------ -;;;; Provisions and requirements. -;;;; ------------------------------------------------------------ - -(provide 'efs-netrc) -(require 'efs-cu) -(require 'efs-ovwrt) -(require 'passwd) -(require 'efs-fnh) - -;;;; ------------------------------------------------------------ -;;;; Internal Variables -;;;; ------------------------------------------------------------ - -(defconst efs-netrc-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;; Make the byte compiler happy. -(defvar dired-directory) - -;;;; ------------------------------------------------------------ -;;;; Use configuration variables. -;;;; ------------------------------------------------------------ - -(defvar efs-netrc-filename "~/.netrc" - "*File in .netrc format to search for passwords. -If you encrypt this file, name it something other than ~/.netrc. Otherwise, -ordinary FTP will bomb. - -If you have any cryption package running off of find-file-hooks -(such as crypt.el or crypt++.el), efs will use it to decrypt this file. -Encrypting this file is a good idea!") - -(defvar efs-disable-netrc-security-check nil - "*If non-nil avoid checking permissions for `efs-netrc-filename'.") - -;;;; ------------------------------------------------------------ -;;;; Host / User / Account mapping support. -;;;; ------------------------------------------------------------ - -;;;###autoload -(defun efs-set-passwd (host user passwd) - "For a given HOST and USER, set or change the associated PASSWORD." - (interactive (list (read-string "Host: ") - (read-string "User: ") - (read-passwd "Password: "))) - (efs-set-host-user-property host user 'passwd - (and passwd (efs-code-string passwd)))) - -(defun efs-set-account (host user minidisk account) - "Given HOST, USER, and MINIDISK, set or change the ACCOUNT password. -The minidisk is only relevant for CMS. If minidisk is irrelevant, -give the null string for it. In lisp programs, give the minidisk as nil." - (interactive (efs-save-match-data - (let* ((path (or buffer-file-name - (and (eq major-mode 'dired-mode) - dired-directory))) - (parsed (and path (efs-ftp-path path))) - (default-host (car parsed)) - (default-user (nth 1 parsed)) - (default-minidisk - (and parsed - (eq (efs-host-type default-host) 'cms) - (string-match "^/[^/]+/" (nth 2 parsed)) - (substring (nth 2 parsed) 1 - (1- (match-end 0))))) - (host (read-string "Host: " default-host)) - (user (read-string "User: " default-user)) - (minidisk - (read-string - "Minidisk (enter null string if inapplicable): " - default-minidisk)) - (account (read-passwd "Account password: "))) - (if (string-match "^ *$" minidisk) - (setq minidisk nil)) - (list host user minidisk account)))) - (and account (setq account (efs-code-string account))) - (if minidisk - (efs-put-hash-entry (concat (downcase host) "/" user "/" minidisk) - account efs-minidisk-hashtable) - (efs-set-host-user-property host user 'account account))) - -;;;; ------------------------------------------------------------ -;;;; Parsing the ~/.netrc. -;;;; ------------------------------------------------------------ - -(defconst efs-netrc-modtime nil) -;; Last modified time of the netrc file from file-attributes. - -(defun efs-netrc-next-token () - ;; Gets the next token plus it's value. - ;; Returns \(token value-1 value-2 ...\) - (skip-chars-forward " \t\n") - (while (char-equal (following-char) ?#) - (forward-line 1) - (skip-chars-forward " \t\n")) - (let ((tok (and (not (eobp)) - (downcase (buffer-substring - (point) - (progn - (skip-chars-forward "^ \n\t") - (point))))))) - (cond - ((null tok) nil) - ((string-equal tok "default") - (list tok)) - ((member tok (list "machine" "login" "password" "account")) - (list tok (efs-netrc-read-token-value))) - ((string-equal tok "minidisk") - (list tok (efs-netrc-read-token-value) - (efs-netrc-read-token-value))) - ((string-equal tok "include") - (let ((start (- (point) 7)) - (path (expand-file-name (efs-netrc-read-token-value)))) - (delete-region start (point)) - (save-excursion (insert (efs-netrc-get-include path)))) - (efs-netrc-next-token)) - ;; Deal with tokens that we skip - ((string-equal tok "macdef") - (efs-save-match-data - (search-forward "\n\n" nil 'move)) - (if (eobp) - nil - (efs-netrc-next-token))) - (t (error "efs netrc file error: Invalid token %s." tok))))) - -(defun efs-netrc-read-token-value () - ;; Read the following word as a token value. - (skip-chars-forward " \t\n") - (while (char-equal (following-char) ?#) - (forward-line 1) - (skip-chars-forward " \t\n")) - (if (eq (following-char) ?\") ;quoted token value - (prog2 - (forward-char 1) - (buffer-substring (point) - (progn (skip-chars-forward "^\"") (point))) - (forward-char 1)) - (buffer-substring (point) - (progn (skip-chars-forward "^ \n\t") (point))))) - -(defun efs-netrc-get-include (path) - ;; Returns the text of an include file. - (let ((buff (create-file-buffer path))) - (unwind-protect - (save-excursion - (set-buffer buff) - (setq buffer-file-name path - default-directory (file-name-directory path)) - (insert-file-contents path) - (normal-mode t) - (mapcar 'funcall find-file-hooks) - (setq buffer-file-name nil) - (buffer-string)) - (condition-case nil - ;; go through this rigamoroll, because who knows - ;; where an interrupt in find-file-hooks leaves us. - (save-excursion - (set-buffer buff) - (set-buffer-modified-p nil) - (passwd-kill-buffer buff)) - (error nil))))) - -(defun efs-parse-netrc-group (&optional machine) - ;; Extract the values for the tokens "machine", "login", "password", - ;; "account" and "minidisk" in the current buffer. If successful, - ;; record the information found. - (let (data login) - ;; Get a machine token. - (if (or machine (setq data (efs-netrc-next-token))) - (progn - (cond - (machine) ; noop - ((string-equal (car data) "machine") - (setq machine (nth 1 data))) - ((string-equal (car data) "default") - (setq machine 'default)) - (error - "efs netrc file error: %s" - "Token group must start with machine or default.")) - ;; Next look for a login token. - (setq data (efs-netrc-next-token)) - (cond - ((null data) - ;; This just interns in the hashtable for completion to - ;; work. The username gets set later by efs-get-user. - (if (stringp machine) (efs-set-user machine nil)) - nil) - ((string-equal (car data) "machine") - (if (stringp machine) (efs-set-user machine nil)) - (nth 1 data)) - ((string-equal (car data) "default") - 'default) - ((not (string-equal (car data) "login")) - (error "efs netrc file error: Expected login token for %s." - (if (eq machine 'default) - "default" - (format "machine %s" machine)))) - (t - (setq login (nth 1 data)) - (if (eq machine 'default) - (setq efs-default-user login) - (efs-set-user machine login) - ;; Since an explicit login entry is given, intern an entry - ;; in the efs-host-user-hashtable for completion purposes. - (efs-set-host-user-property machine login nil nil)) - (while (and (setq data (efs-netrc-next-token)) - (not (or (string-equal (car data) "machine") - (string-equal (car data) "default")))) - (cond - ((string-equal (car data) "password") - (if (eq machine 'default) - (setq efs-default-password (nth 1 data)) - (efs-set-passwd machine login (nth 1 data)))) - ((string-equal (car data) "account") - (if (eq machine 'default) - (setq efs-default-account (nth 1 data)) - (efs-set-account machine login nil (nth 1 data)))) - ((string-equal (car data) "minidisk") - (if (eq machine 'default) - (error "efs netrc file error: %s." - "Minidisk token is not allowed for default entry.") - (apply 'efs-set-account machine login (cdr data)))) - ((string-equal (car data) "login") - (error "efs netrc file error: Second login token for %s." - (if (eq machine 'default) - "default" - (format "machine %s" machine)))))) - (and data (if (string-equal (car data) "machine") - (nth 1 data) - 'default)))))))) - -(defun efs-parse-netrc () - "Parse the users ~/.netrc file, or file specified `by efs-netrc-filename'. -If the file exists and has the correct permissions then extract the -\`machine\', \`login\', \`password\', \`account\', and \`minidisk\' -information from within." - (interactive) - (and efs-netrc-filename - (let* ((file (expand-file-name efs-netrc-filename)) - ;; Set to nil to avoid an infinite recursion if the - ;; .netrc file is remote. - (efs-netrc-filename nil) - (file (efs-chase-symlinks file)) - (attr (file-attributes file)) - netrc-buffer next) - (if (or (interactive-p) ; If interactive, really do something. - (and attr ; file exists. - ;; file changed - (not (equal (nth 5 attr) efs-netrc-modtime)))) - (efs-save-match-data - (or efs-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr))) - (efs-netrc-scream-and-yell file attr)) - (unwind-protect - (save-excursion - ;; we are cheating a bit here. I'm trying to do the - ;; equivalent of find-file on the .netrc file, but - ;; then nuke it afterwards. - ;; with the bit of logic below we should be able to have - ;; encrypted .netrc files. - (set-buffer (setq netrc-buffer - (generate-new-buffer "*ftp-.netrc*"))) - (insert-file-contents file) - (setq buffer-file-name file) - (setq default-directory (file-name-directory file)) - (normal-mode t) - (mapcar 'funcall find-file-hooks) - (setq buffer-file-name nil) - (goto-char (point-min)) - (while (and (not (eobp)) - (setq next (efs-parse-netrc-group next))))) - (condition-case nil - ;; go through this rigamoroll, because we knows - ;; where an interrupt in find-file-hooks leaves us. - (save-excursion - (set-buffer netrc-buffer) - (set-buffer-modified-p nil) - (passwd-kill-buffer netrc-buffer)) - (error nil))) - (setq efs-netrc-modtime (nth 5 attr))))))) - -(defun efs-netrc-scream-and-yell (file attr) - ;; Complain about badly protected netrc files. - (let* ((bad-own (/= (nth 2 attr) (user-uid))) - (modes (nth 8 attr)) - (bad-protect (not (string-match ".r..------" modes)))) - (if (or bad-own bad-protect) - (save-window-excursion - (with-output-to-temp-buffer "*Help*" - (if bad-own - (princ - (format - "Beware that your .netrc file %s is not owned by you.\n" - file))) - (if bad-protect - (progn - (if bad-own - (princ "\nAlso,") - (princ "Beware that")) - (princ - " your .netrc file ") - (or bad-own (princ (concat file " "))) - (princ - (format - "has permissions\n %s.\n" modes)))) - (princ - "\nIf this is intentional, then setting \ -efs-disable-netrc-security-check -to t will inhibit this warning in the future.\n")) - (select-window (get-buffer-window "*Help*")) - (enlarge-window (- (count-lines (point-min) (point-max)) - (window-height) -1)) - (if (and bad-protect - (y-or-n-p (format "Set permissions on %s to 600? " file))) - (set-file-modes file 384)))))) - -;;;; ---------------------------------------------------------------- -;;;; Completion in the root directory. -;;;; ---------------------------------------------------------------- - -(defun efs-generate-root-prefixes () - "Return a list of prefixes of the form \"user@host:\". -Used when completion is done in the root directory." - (efs-parse-netrc) - (efs-save-match-data - (let (res) - (efs-map-hashtable - (function - (lambda (key value) - (if (string-match "^[^/]+\\(/\\).+$" key) - ;; efs-passwd-hashtable may have entries of the type - ;; "machine/" to indicate a password assigned to the default - ;; user for "machine". Don't use these entries for completion. - (let ((host (substring key 0 (match-beginning 1))) - (user (substring key (match-end 1)))) - (setq res (cons (list (format - efs-path-user-at-host-format - user host)) - res)))))) - efs-host-user-hashtable) - (efs-map-hashtable - (function (lambda (host user) - (setq res (cons (list (format efs-path-host-format - host)) - res)))) - efs-host-hashtable) - (if (and (null res) - (string-match "^1[0-8]\\.\\|^[0-9]\\." emacs-version)) - (list nil) - res)))) - -;;;###autoload -(defun efs-root-file-name-all-completions (file dir) - ;; Generates all completions in the root directory. - (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn - 'efs-root-handler-function))) - (nconc (all-completions file (efs-generate-root-prefixes)) - (file-name-all-completions file dir)))) - - -;;;###autoload -(defun efs-root-file-name-completion (file dir) - ;; Calculates completions in the root directory to include remote hosts. - (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn - 'efs-root-handler-function))) - (try-completion - file - (nconc (efs-generate-root-prefixes) - (mapcar 'list (file-name-all-completions file "/")))))) - - -;;; end of efs-netrc.el
--- a/lisp/efs/efs-netware.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-netware.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.5 $ -;; RCS: -;; Description: efs support for the Novell Netware FTP server -;; Author: Sandy Rutherford <sandy@math.ubc.ca> -;; Created: Fri Oct 15 00:30:50 1993 by sandy on gauss.math.ubc.ca -;; Modified: Tue Nov 22 00:11:46 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Works for (at least) Novell NetWare v3.11. This is a DOS FTP server, -;;; however, it returns a unix-ish path format. - -(provide 'efs-netware) -(require 'efs) - -(defconst efs-netware-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.5 $" 11 -2))) - -;;; Basic efs support - -(defconst efs-netware-date-regexp - (concat - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" - "Dec\\) [ 0-3][0-9] \\([0-9][0-9] \\)?[0-2][0-9]:[0-6][0-9] +")) - -(efs-defun efs-fix-path netware (path &optional reverse) - ;; Convert PATH from UNIX-ish to netware. - (efs-save-match-data - (if reverse - (cond ((string-match "^[^/][^:]*:" path) - (concat "/" path)) - ((string-match "^/" path) - path) - ((error "%s not a valid netware path." path))) - (if (string-match ":" path) - (substring path 1) - path)))) - -(efs-defun efs-fix-dir-path netware (dir-path) - ;; Convert DIR-PATH from UN*X-ish to Netware for a DIR listing. - (efs-fix-dir-path nil (efs-fix-path 'netware dir-path))) - -(defun efs-netware-bogus-listing-p (dir path) - (save-excursion - (and - (not (eobp)) - (save-excursion (forward-line 1) (eobp)) - (not (string-equal dir "/")) - (re-search-forward efs-netware-date-regexp nil t) - (search-forward "/.\n")))) - -(efs-defun efs-parse-listing netware (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a listing from - ;; a Novell Netware FTP server (runs under DOS). - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-netware-date-regexp nil t) - (progn - (beginning-of-line) - (and (not (efs-netware-bogus-listing-p dir path)) - (let ((tbl (efs-make-hashtable)) - dir-p file size) - (while (let ((eol (save-excursion (end-of-line) (point)))) - (setq dir-p (= (following-char) ?d)) - (re-search-forward efs-netware-date-regexp eol t)) - (setq file (buffer-substring (point) - (progn (end-of-line) (point))) - size (progn - (goto-char (match-beginning 0)) - (skip-chars-backward " ") - (buffer-substring (point) - (progn - (skip-chars-backward "0-9") - (point))))) - (if (string-equal size "") - (setq size nil) - (setq size (string-to-int size))) - (efs-put-hash-entry file (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))))) - -;;; Sorting dir listings. - -(efs-fset 'efs-t-converter 'netware 'efs-unix-t-converter) - -;;; Dired support - -(defconst efs-dired-netware-re-exe "\\.\\(exe\\|EXE\\)$") -(or (assq 'netware efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'netware efs-dired-netware-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-netware-re-dir "^.[ \t]+d ") -(or (assq 'netware efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'netware efs-dired-netware-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename netware - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This is the Netware version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - ;; move over marker - (if (re-search-forward efs-netware-date-regexp eol t) - (goto-char (match-end 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename netware - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the Netware version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "^A-Z\n\r") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-insert-headerline netware (dir) - ;; Insert a blank line for aesthetics. - (insert " \n") - (forward-char -2) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-fixup-listing netware - (file path &optional switches wildcard) - ;; listings come out in random order - (let (case-fold-search) - (if (or (null switches) - ;; In case efs is handling the switches itself. - (not (string-match "t" switches))) - (progn - (goto-char (point-max)) - (if (re-search-backward efs-netware-date-regexp nil t) - (save-restriction - (forward-line 1) - (narrow-to-region (point-min) (point)) - (forward-line -1) - ;; Count how many fields - (let ((fields 0)) - (skip-chars-forward " \t") - (while (not (eolp)) - (skip-chars-forward "^ \t\n") - (skip-chars-forward " \t") - (setq fields (1+ fields))) - (sort-fields fields (point-min) (point-max))))))))) - -;;; end of efs-netware.el
--- a/lisp/efs/efs-nos-ve.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,209 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-nos-ve.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: efs support for NOS/VE -;; Authors: Sandy Rutherford <sandy@ibm550.sissa,it> -;; Created: Fri Aug 19 04:57:09 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 18:39:43 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-nos-ve) -(require 'efs) - -;;; Works for NOS/VE from CDC. NOS/VE runs on Cybers. - -;;; Thank you to Jost Krieger <Jost.Krieger@rz.ruhr-uni-bochum.de> for -;;; providing imformation and testing. - -(defconst efs-nos-ve-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;;;;--------------------------------------------------------------- -;;;; NOS/VE support for efs -;;;;--------------------------------------------------------------- - -;;; A legal NOS/VE filename is of the form -;;; <family>.<dirname>.<dirname>.<direname>.....<filename> -;;; where <family> always starts with the char : and is followed by -;;; alphanumeric characters. Each <dirname> or <filename> can be up to 31 -;;; characters. File names are case insensistive. -;;; eg. :FOO.DIR_1.DIR_2.BAR -;;; -;;; The character set consists of (single case) alphabet, the numerals, -;;; and the characters "@$_#". (Not the quotes ...) The characters -;;; "[\]{|}" will also occur in a misguided attempt at -;;; internationalization. A filename may not start with a numeral. - - -;;; entry points - -(efs-defun efs-fix-path nos-ve (path &optional reverse) - ;; Convert path from UNIX to NOS/VE. - ;; If REVERSE is non-nil, goes in the opposite direction. - (if reverse - (let* ((res (concat "." path)) - (len (length res)) - (n 0)) - (while (< n len) - (and (= (aref res n) ?.) (aset res n ?/)) - (setq n (1+ n))) - res) - (let* ((res (substring (efs-internal-directory-file-name path) 1)) - (len (length res)) - (n 0)) - (while (< n len) - (and (= (aref res n) ?/) (aset res n ?.)) - (setq n (1+ n))) - res))) - -(efs-defun efs-fix-dir-path nos-ve (dir-path) - ;; Converts DIR-PATH to NOS/VE format for a directory listing. - (efs-fix-path 'nos-ve dir-path)) - -;;; parser - -(defconst efs-nos-ve-file-line-regexp - (concat - " \\([>0-9,]+\\) bytes \\(in [0-9]+ \\(file\\|catalog\\)s?\\)?\\|" - "\\( -- empty catalog\\)\\| -- device")) - -(efs-defun efs-parse-listing nos-ve (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a NOS/VE listing. - ;; Returns a hashtable. - (goto-char (point-min)) - (efs-save-match-data - (if (and (re-search-forward efs-nos-ve-file-line-regexp - (save-excursion (end-of-line) (point)) t) - (or (match-beginning 2) (match-beginning 4))) - (let ((tbl (efs-make-hashtable)) - size dir-p file) - (forward-line 1) - (while (re-search-forward efs-nos-ve-file-line-regexp - (save-excursion (end-of-line) (point)) t) - (setq size (and (match-beginning 1) - (buffer-substring - (match-beginning 1) (match-end 1))) - dir-p (null (null (or (match-beginning 2) - (match-beginning 4))))) - (if size - (let ((start 0) - res) - (while (string-match "," size start) - (setq res (concat res (substring size start - (match-beginning 0))) - start (match-end 0))) - (setq size (string-to-int - (concat res (substring size start)))))) - (beginning-of-line) - (forward-char 2) - (setq file (buffer-substring - (point) - (progn (skip-chars-forward "^ \t\n") (point)))) - (efs-put-hash-entry file (list dir-p size) - (or tbl (setq tbl (efs-make-hashtable)))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(efs-defun efs-allow-child-lookup nos-ve (host user dir file) - ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. Note that DIR is in directory syntax. - ;; i.e. /foo/bar/, not /foo/bar. - ;; Deal with dired. Anything else? - (not (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal (downcase dired-local-variables-file) - (downcase file))))) - -;;; Tree Dired - -(defconst efs-dired-nos-ve-re-exe "^.[^ \t\n]") -;; Matches no lines. Should it match something? - -(or (assq 'nos-ve efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'nos-ve efs-dired-nos-ve-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-nos-ve-re-dir " [0-9,]+ bytes in [0-9]+ file") - -(or (assq 'nos-ve efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'nos-ve efs-dired-nos-ve-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-fixup-listing nos-ve (file path &optional switches - wildcard) - ;; Need to turn the header line into something to masquerading as a file - ;; line, and need to remove the indentation. Both upset dired. - (goto-char (point-min)) - (while (search-forward "\n " nil t) - (delete-char -2)) - (goto-char (point-min)) - (if (looking-at "\\([^ \n]+ +\\)[0-9,]+ bytes in [0-9]+ file") - (progn - (delete-region (match-beginning 1) (match-end 1)) - (insert " Total of ")))) - -(defconst efs-dired-nos-ve-file-line-regexp - (concat - ".[ \t]+\\([][{}|\\\\a-z0-9@$_#]+\\) +" - "\\([>0-9,]+ bytes\\|-- \\(empty\\|device\\)\\)")) - -(efs-defun efs-dired-manual-move-to-filename nos-ve - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the NOS/VE version. - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (looking-at efs-dired-nos-ve-file-line-regexp) - (goto-char (match-beginning 1)) - (and raise-error (error "No file on this line")))) - -(efs-defun efs-dired-manual-move-to-end-of-filename nos-ve - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the NOS/VE version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "_a-z0-9$@#\\\\[]{}|") ; right char set? - (if (or (= opoint (point)) (/= (following-char) ?\ )) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;; end of efs-nos-ve.el
--- a/lisp/efs/efs-ovwrt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ovwrt.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: Utilities for overwriting functions with new definitions. -;; Author: Andy Norman <ange@hplb.hpl.hp.com> -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Although used by efs, these utilities could be of general use to other -;;; packages too. Keeping them separate from the main efs program -;;; makes it easier for other programs to require them. - -(provide 'efs-ovwrt) -(eval-when-compile - (condition-case nil - (require 'advice) - (error))) - -(defconst efs-ovwrt-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -(defvar efs-overwrite-fmt - "Note: This function has been modified to work with %s.") - -;; Make the byte compiler happy. -(defvar file-name-handler-alist) -(defvar inhibit-file-name-handlers) -(defvar inhibit-file-name-operation) - -(defun efs-safe-documentation (fun) - "A documentation function that isn't quite as fragile." - (condition-case () - (documentation fun) - (error nil))) - -(defun efs-overwrite-fn (package fun &optional newfun) - "Overwrites a function with a new definition from PACKAGE. -PACKAGE should be a string. The the function to be overwritten is FUN. -The new definition is obtained from the optional NEWFUN. If ommitted, -NEWFUN is taken to be PACKAGE-FUN. The original definition is stored in -PACKAGE-real-FUN. The original documentation is placed on the new -definition suitably augmented." - (let* ((name (symbol-name fun)) - (saved (intern (concat package "-real-" name))) - (new (or newfun (intern (concat package "-" name)))) - (nfun (symbol-function new)) - (exec-directory (if (or (equal (nth 3 command-line-args) "dump") - (equal (nth 4 command-line-args) "dump")) - "../etc/" - exec-directory))) - - (while (symbolp nfun) - (setq nfun (symbol-function nfun))) - - ;; Interpose the new function between the function symbol and the - ;; original definition of the function symbol AT TIME OF FIRST LOAD. - ;; We must only redefine the symbol-function of FUN the very first - ;; time, to avoid blowing away stuff that overloads FUN after this. - - ;; We direct the function symbol to the new function symbol - ;; rather than function definition to allow reloading of this file or - ;; redefining of the individual function (e.g., during debugging) - ;; later after some other code has been loaded on top of our stuff. - - (or (fboundp saved) - (let ((advised-p (and (featurep 'advice) - (ad-is-advised fun)))) - (if advised-p (ad-deactivate fun)) - (fset saved (symbol-function fun)) - (fset fun new) - (if advised-p (ad-activate fun)))) - - ;; Rewrite the doc string on the new function. This should - ;; be done every time the file is loaded (or a function is redefined), - ;; because the underlying overloaded function may have changed its doc - ;; string. - - (let* ((doc-str (efs-safe-documentation saved)) - (ndoc-str (concat doc-str (and doc-str "\n") - (format efs-overwrite-fmt package)))) - - (cond ((listp nfun) - ;; Probe to test whether function is in preloaded read-only - ;; memory, and if so make writable copy: - (condition-case nil - (setcar nfun (car nfun)) - (error - (setq nfun (copy-sequence nfun)) ; shallow copy only - (fset new nfun))) - (let ((ndoc-cdr (nthcdr 2 nfun))) - (if (stringp (car ndoc-cdr)) - ;; Replace the existing docstring. - (setcar ndoc-cdr ndoc-str) - ;; There is no docstring. Insert the overwrite msg. - (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) - (setcar ndoc-cdr (format efs-overwrite-fmt package))))) - (t - ;; it's an emacs19 compiled-code object - ;; - ;; XEmacs: can't use append on a compiled function - ;; as the latter is no longer a vector. Use the - ;; accessor functions instead. - (let ((new-code (nconc - (list (compiled-function-arglist nfun) - (compiled-function-instructions nfun) - (compiled-function-constants nfun) - (compiled-function-stack-depth nfun) - ndoc-str))) - spec) - (if (setq spec (compiled-function-interactive nfun)) - (setq new-code (nconc new-code (list (nth 1 spec))))) - (fset new (apply 'make-byte-code new-code)))))))) - - -;;; end of efs-ovwrt.el
--- a/lisp/efs/efs-pc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,980 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-pc.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: PC support for efs -;; Author: Sandy Rutherford <sandy@tsmi19.sissa.it> -;; Created: Thu Mar 18 13:06:25 1993 -;; Modified: Sun Nov 27 18:40:46 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Thanks to jrs@world.std.com (Rick Sladkey) for providing support for -;;; the Frontier Technologies Super-TCP server - -;;; Many thanks to the following people for beta testing: -;;; Mike Northam <mbn@hfglobe.intel.com> -;;; bagman@austin.ibm.com (Doug Bagley) -;;; Jens Petersen <J.Petersen@qmw.ac.uk> -;;; Jeff Morgenthaler <jpmorgen@wisp4.physics.wisc.edu> - -(provide 'efs-pc) -(require 'efs) - -(defconst efs-pc-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;----------------------------------------------------------------- -;;; PC support for efs -;;;----------------------------------------------------------------- - -;;; Works for the DOS FTP servers: -;;; Novell LAN WorkPlace v4.01 (NetWare & EXOS) -;;; PC/TCP Version 2.05 pl2 FTP Server by FTP Software -;;; Microsoft FTP Server service (beta 2) -;;; NCSA DOS ftp server. -;;; Frontier Technologies super tcp server (runs under MS WINDOWS) -;;; Alun's Windows FTP daemon for Winsock, v1.8b -;;; -;;; Works for IBM OS/2 TCP/IP FTP Version 1.2 - -;;; Currently support for all of the above FTP servers are in this file. -;;; Should they live in separate files? - -;;; host and listing type hierarchy in this file -;;; -;;; dos: dos:novell, dos:ftp, dos:ncsa, dos:microsoft, dos:stcp, dos:winsock -;;; os2: - -;;; DOS and OS/2 have slightly different filename syntaxes. -;;; -;;; DOS only allows at most one extension (".") per filename. -;;; A directory name usually has the extension ".DIR" implicit, but -;;; it seems that other extensions can be used. -;;; -;;; OS/2 running the FAT file system uses the same 8.3 format for -;;; filenames as DOS, except that extensions are allowed in directory names. -;;; OS/2 running the HPFS (high performance file system allows an arbitrary -;;; number of extensions in a filename. -;;; Mostly these differences are unimportant here, except in the dos -;;; definition of efs-allow-child-lookup. - -;;;; ---------------------------------------------------- -;;;; Utility functions and macros -;;;; ---------------------------------------------------- - -(defun efs-fix-pc-path (path &optional reverse) - ;; Convert PATH from UNIX-ish to DOS or OS/2. - ;; If REVERSE do just that. - (efs-save-match-data - (if reverse - (let ((n 0) - len res) - (if (string-match "^[a-zA-Z0-9]:" path) - ;; there's a disk - (setq res (concat "\\" path)) - (setq res (copy-sequence path))) - (setq len (length res)) - (while (< n len) - (and (= (aref res n) ?\\ ) (aset res n ?/)) - (setq n (1+ n))) - res) - (let ((n 0) - len res) - (if (string-match "^/[a-zA-Z0-9]:" path) - (setq res (substring path 1)) - (setq res (copy-sequence path))) - (setq len (length res)) - (while (< n len) - (and (= (aref res n) ?/) (aset res n ?\\ )) - (setq n (1+ n))) - res)))) - -(defmacro efs-dired-pc-move-to-end-of-filename (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the DOS and OS/2 version. It is common to all of the PC ftp - ;; servers since it depends only on the file name character set. - (` - (let ((opoint (point))) - (and selective-display - (null (, no-error)) - (eq (char-after - (1- (or (, bol) (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_+=a-zA-Z0-9.$~") - (if (= opoint (point)) - (if (, no-error) - nil - (error "No file on this line")) - (point))))) - -(defun efs-dired-pc-insert-headerline (dir) - ;; Insert a blank line for aesthetics. - (insert " \n") - (forward-char -2) - (efs-real-dired-insert-headerline dir)) - - -;;;;----------------------------------------------------------- -;;;; General DOS support -;;;;----------------------------------------------------------- - -;;; Regexps to be used for host and listing-type identification. - -(defconst efs-dos:ftp-file-line-regexp - (concat - " *\\([0-9]+\\|<dir>\\) +\\([-_+=a-zA-Z0-9$~.]+\\)" - " +\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\) " - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|" - "Oct\\|Nov\\|Dec\\) [0-3][0-9] ")) - -(defconst efs-dos:microsoft-file-line-regexp - ;; matches all the way to the first char of the filename. - (concat - "[01][0-9]-[0-3][0-9]-[0-9][0-9] +[012][0-9]:[0-5][0-9][AP]M +" - "\\(<DIR>\\|[0-9]+\\) +")) - -(defconst efs-dos:ncsa-file-line-regexp - "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(<DIR>\\|[0-9]+\\)[ \n]") - -(defconst efs-dos:stcp-file-line-regexp - (concat - "\\([-_+=a-zA-Z0-9$~.]+\\) +\\(<DIR>\\|[0-9]+\\) " - "+[0-9][0-9]?-[0-3][0-9]-[12][90][0-9][0-9] +" - "[0-9][0-9]?:[0-5][0-9]")) - -(defconst efs-dos:winsock-date-and-size-regexp - (concat - " \\([0-9]+\\) " - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" - "Dec\\) [ 0-3][0-9] \\( [12][0-9][0-9][0-9]\\|[0-2][0-9]:[0-6][0-9]\\) +")) - -(efs-defun efs-parse-listing dos - (host user dir path &optional switches) - ;; Examine the listing, which is assumed to be either a DOS or OS/2 - ;; listing, and determine the operating system type and FTP server. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - ;; No need to check for OS/2, as it gets ID'ed by a SYST in - ;; efs-guess-host-type. - (efs-save-match-data - (cond - - ;; Check for the Microsoft server - ((re-search-forward efs-dos:microsoft-file-line-regexp nil t) - (efs-add-listing-type 'dos:microsoft host user) - (efs-parse-listing 'dos:microsoft host user dir path switches)) - - ;; Check for the Novell FTP server - ((save-excursion - (goto-char (point-max)) - (forward-line -1) - (looking-at " [0-9]+ File(s)\n")) - (efs-add-listing-type 'dos:novell host user) - (efs-parse-listing 'dos:novell host user dir path switches)) - - ;; Check for FTP software's server - ((re-search-forward efs-dos:ftp-file-line-regexp nil t) - (efs-add-listing-type 'dos:ftp host user) - (efs-parse-listing 'dos:ftp host user dir path switches)) - - ;; Check for winsock - ((re-search-forward efs-dos:winsock-date-and-size-regexp nil t) - (efs-add-listing-type 'dos:winsock host user) - (efs-parse-listing 'dos:winsock host user dir path switches)) - - ;; Check for the NCSA FTP server - ((re-search-forward efs-dos:ncsa-file-line-regexp nil t) - (efs-add-listing-type 'dos:ncsa host user) - (efs-parse-listing 'dos:ncsa host user dir path switches)) - - ;; Check for Frontier's Super-TCP server - ((re-search-forward efs-dos:stcp-file-line-regexp nil t) - (efs-add-listing-type 'dos:stcp host user) - (efs-parse-listing 'dos:stcp host user dir path switches)) - - ((string-match "^/\\([A-Za-z0-9]:/\\)?$" dir) - ;; root always exists - (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)) - (t - ;; an error message? - nil)))) - -;; Some DOS servers (NCSA), return a 501 message for an empty disk. -(efs-defun efs-ls-dumb-check dos (line host file path lsargs msg noparse - noerror nowait cont) - (and (string-match "^501 " line) - (string-match "^/[A-Za-z0-9]:/?$" path) - (let ((parse (or (null noparse) (eq noparse 'parse) - (efs-parsable-switches-p lsargs t)))) - (efs-add-to-ls-cache file lsargs "\n" parse) - (if parse - (efs-set-files file (let ((tbl (efs-make-hashtable))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - (if nowait - (progn - (if cont - (efs-call-cont cont "\n")) - t) - (if cont - (efs-call-cont cont "\n")) - "\n")))) - -(efs-defun efs-fix-path dos (path &optional reverse) - (efs-fix-pc-path path reverse)) - -(efs-defun efs-fix-dir-path dos (dir-path) - ;; Convert path from UNIX-ish to DOS for a DIRectory listing. - (cond ((string-match "^/\\(.:\\)?$" dir-path) - (error "Can't list DOS or OS/2 disks")) - ;; Neither DOS nor OS/2 allows us to end the name of a directory - ;; with an "\". - ;; Adding *.* to the end also allows us to distinguish plain files from - ;; directories. All DOS servers seem to understand this except - ;; Frontier Technologies' super-tcp server. - ((string-match "/$" dir-path) - (concat (efs-fix-pc-path dir-path) "*.*")) - (t (efs-fix-pc-path dir-path)))) - -(efs-defun efs-get-pwd dos (host user &optional xpwd) - ;; Parses PWD output for the current working directory. Hopefully this is - ;; DOS proof. - (let* ((result (efs-send-cmd host user (list 'quote - (if xpwd 'xpwd 'pwd)) - "Getting PWD")) - (line (nth 1 result)) - dir) - (if (car result) - (efs-save-match-data - (and (or (string-match "\"\\([^\"]*\\)\"" line) - ;; FTP software's output. They should know better... - (string-match "Current working directory is +\\([^ ]+\\)$" - line)) - (setq dir (substring line - (match-beginning 1) - (match-end 1)))))) - (cons dir line))) - -(efs-defun efs-allow-child-lookup dos (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in DOS usually don't have an extension. - (not (string-match "\\." file))) - -;;;;----------------------------------- -;;;; Support for the Novell FTP server -;;;;----------------------------------- - -(defconst efs-dos:novell-file-line-regexp - ;; Matches from the first character of the filename to the end of the date. - ;; Does not match parent directories which the server might decide - ;; to put in front of the filename. - (concat - "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(<DIR>\\|[0-9]+\\) +" - "[ 0-9][0-9]-[0-9][0-9]-[0-9][0-9] ")) - -(efs-defun efs-parse-listing dos:novell - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (let ((tbl (efs-make-hashtable)) - file size dir-p) - (efs-save-match-data - ;; Can we check somehow if the listing is really for something - ;; that doesn't exist? - (goto-char (point-min)) - (while (re-search-forward efs-dos:novell-file-line-regexp - nil t) - (setq file (buffer-substring (match-beginning 1) - (match-end 1)) - size (buffer-substring (match-beginning 2) - (match-end 2))) - (if (string-equal size "<DIR>") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry file (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:novell-re-exe - "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") - -(or (assq 'dos:novell efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:novell efs-dired-dos:novell-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:novell-re-dir - "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +<DIR>") - -(or (assq 'dos:novell efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:novell efs-dired-dos:novell-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:novell (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:novell - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - ;; move over marker - (if (re-search-forward efs-dos:novell-file-line-regexp eol t) - (goto-char (match-beginning 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:novell - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:novell - (file path &optional switches wildcard) - ;; DOS may insert the entire directory name in front of the file name. - ;; Scrape it off. The Novell server seems to do weird things when insert - ;; the full-path, so be liberal with the hatchet. - (goto-char (point-min)) - (while (re-search-forward efs-dos:novell-file-line-regexp nil t) - (beginning-of-line) - (delete-region (point) (match-beginning 0)) - (forward-line 1)) - ;; the novell server outputs lines in seemingly random order - ;; this isn't as good as sorting switches, but at least it's not random. - (sort-fields 1 (point-min) (progn (goto-char (point-max)) - (forward-line -1) - (point)))) - -(efs-defun efs-dired-ls-trim dos:novell () - (goto-char (point-min)) - (let (case-fold-search) - (forward-line 1) - (if (looking-at " [0-9]+ File(s)\n") - (delete-region (match-beginning 0) (match-end 0))))) - - -;;;;----------------------------------------------- -;;;; PC/TCP (by FTP software) support -;;;;----------------------------------------------- - -(efs-defun efs-parse-listing dos:ftp - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an FTP Software DOS - ;; listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (let ((tbl (efs-make-hashtable)) - file size dir-p) - (efs-save-match-data - ;; Can we check somehow if an empty directory is really - ;; a nonexistent directory? - (goto-char (point-min)) - (goto-char (point-min)) - (while (looking-at efs-dos:ftp-file-line-regexp) - (setq file (buffer-substring (match-beginning 2) - (match-end 2)) - size (buffer-substring (match-beginning 1) - (match-end 1))) - (if (string-equal size "<dir>") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry file (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:ftp-re-exe - "^. [ \t]*[0-9]+ +[-_+=a-zA-Z0-9$~]+\\.exe ") - -(or (assq 'dos:ftp efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:ftp efs-dired-dos:ftp-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:ftp-re-dir - "^. [ \t]*<dir> ") - -(or (assq 'dos:ftp efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:ftp efs-dired-dos:ftp-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:ftp (dir) - (efs-dired-pc-insert-headerline dir)) - -;;; Because dos:ftp listings have the file names right justified, -;;; I have reversed what -move-to-filename and -move-to-end-of-filename -;;; actually do. This shouldn't confuse dired, and should make browsing -;;; a dos:ftp listing more aesthetically pleasing. - -(efs-defun efs-dired-manual-move-to-filename dos:ftp - (&optional raise-error bol eol) - ;; In dired, move to the *last* char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-dos:ftp-file-line-regexp eol t) - (goto-char (match-end 2)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:ftp - (&optional no-error bol eol) - ;; Assumes point is at the *end* of filename. Really moves the - ;; point to the beginning of the filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the DOS version. It is common to all of the DOS ftp servers - ;; since it depends only on the file name character set. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-backward "-_+=a-zA-Z0-9.$~" bol) - (if (= opoint (point)) - (if no-error - nil - (error "No file on this line")) - (point)))) - -;;;;----------------------------------------------- -;;;; NCSA FTP support -;;;;----------------------------------------------- - -(efs-defun efs-parse-listing dos:ncsa - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (let (tbl file size dir-p next) - (efs-save-match-data - (goto-char (point-min)) - (while (re-search-forward - efs-dos:ncsa-file-line-regexp - (setq next (save-excursion (forward-line 1) (point))) t) - (setq file (buffer-substring (match-beginning 1) - (match-end 1)) - size (buffer-substring (match-beginning 2) - (match-end 2))) - (if (string-equal size "<DIR>") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry file (list dir-p size) - (or tbl (setq tbl (efs-make-hashtable)))) - (goto-char next)) - ;; DOS does not put . and .. in the root directory. - (if (or tbl - ;; root always exists - (string-match "^/\\([A-Za-z0-9]:/\\)?$" dir)) - (progn - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl))) - tbl))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:ncsa-re-exe - "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") - -(or (assq 'dos:ncsa efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:ncsa-re-dir - "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +<DIR>") - -(or (assq 'dos:ncsa efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:ncsa (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:ncsa - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward "[-_+=a-zA-Z0-9$.~]+ +\\(<DIR>\\|[0-9]\\)" eol t) - (goto-char (match-beginning 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:ncsa - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:ncsa - (file path &optional switches wildcard) - ;; DOS may insert the entire directory name in front of the file name. - ;; Scrape it off. - (let (bonl) - (goto-char (point-min)) - (while (re-search-forward - efs-dos:ncsa-file-line-regexp - (setq bonl (save-excursion (forward-line 1) (point))) t) - (goto-char (match-beginning 0)) - (delete-region (point) (progn (beginning-of-line) (point))) - (goto-char bonl))) - ;; sort the buffer - (sort-fields 1 (point-min) (point-max))) - -(efs-defun efs-dired-ls-trim dos:ncsa () - (goto-char (point-min)) - (if (re-search-forward efs-dos:ncsa-file-line-regexp nil t) - (delete-region (point-min) (match-beginning 0)))) - -;;;;----------------------------------------------- -;;;; Microsoft DOS FTP support -;;;;----------------------------------------------- - -(defconst efs-dos:microsoft-valid-listing-regexp - (concat efs-dos:microsoft-file-line-regexp "\\.")) - -(efs-defun efs-parse-listing dos:microsoft - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - - ;; Use the existence of a "." file as confirmation that it's really - ;; a directory listing. - (goto-char (point-min)) - (efs-save-match-data - (if (or (string-match "^/.:/$" dir) - (re-search-forward efs-dos:microsoft-valid-listing-regexp nil t)) - (let ((tbl (efs-make-hashtable)) - size dir-p) - (goto-char (point-min)) - (while (re-search-forward efs-dos:microsoft-file-line-regexp nil t) - (setq size (buffer-substring (match-beginning 1) (match-end 1))) - (if (string-equal size "<DIR>") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry (buffer-substring (point) - (progn (end-of-line) - (point))) - (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:microsoft-re-exe - "^[^\n]+ +[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\)$") - -(or (assq 'dos:microsoft efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:microsoft-re-dir - "^[^\n]+ <DIR> ") - -(or (assq 'dos:microsoft efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:microsoft (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:microsoft - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-dos:microsoft-file-line-regexp eol t) - (goto-char (match-end 0)) ; returns (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:microsoft - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -;;;;----------------------------------------------- -;;;; Frontier's Super-TCP FTP Server for Windows -;;;;----------------------------------------------- - -(efs-defun efs-parse-listing dos:stcp - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a Super-TCP FTP listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - - ;; Use the existence of a strict file line pattern as - ;; confirmation that it's really a directory listing. - (goto-char (point-min)) - (efs-save-match-data - (let ((regexp (concat "^" efs-dos:stcp-file-line-regexp))) - (if (let ((eol (save-excursion (end-of-line) (point)))) - (re-search-forward regexp eol t)) - (let ((tbl (efs-make-hashtable)) - size dir-p) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (setq size (buffer-substring (match-beginning 2) (match-end 2))) - (if (string-equal size "<DIR>") - (setq size nil - dir-p t) - (setq size (string-to-int size) - dir-p nil)) - (efs-put-hash-entry (buffer-substring (match-beginning 1) - (match-end 1)) - (list dir-p size) tbl) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl))))) - -;;; Tree Dired Support - -(defconst efs-dired-dos:stcp-re-exe - "^[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\) ") - -(or (assq 'dos:stcp efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:stcp efs-dired-dos:stcp-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:stcp-re-dir - "^[^\n ]+ +<DIR> ") - -(or (assq 'dos:stcp efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:stcp efs-dired-dos:stcp-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:stcp (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:stcp - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-dos:stcp-file-line-regexp eol t) - (goto-char (match-beginning 0)) ; returns (point) - (if raise-error - (error "No file on this line") - (goto-char bol))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:stcp - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:stcp - (file path &optional switches wildcard) - ;; The Super-TCP server outputs lines in seemingly random order. - ;; This isn't as good as sorting switches, but at least it's not random. - (sort-fields 1 (point-min) (point-max))) - -;;;;---------------------------------------------------------- -;;;; Winsock DOS FTP server (Alun's FTP server) -;;;;---------------------------------------------------------- - -(efs-defun efs-parse-listing dos:winsock - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a DOS Winsock listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-dos:winsock-date-and-size-regexp nil t) - (let ((tbl (efs-make-hashtable)) - size dirp) - (while - (progn - (setq size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1))) - dirp (save-excursion - (beginning-of-line) - (skip-chars-forward " ") - (char-equal (following-char) ?d))) - (efs-put-hash-entry - (buffer-substring (point) (progn (end-of-line) (point))) - (list dirp size) tbl) - (re-search-forward efs-dos:winsock-date-and-size-regexp nil t))) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)))) - -(defconst efs-dired-dos:winsock-re-exe "\\.exe$") - -(or (assq 'dos:winsock efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'dos:winsock efs-dired-dos:winsock-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-dos:winsock-re-dir "^. +d") - -(or (assq 'dos:winsock efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'dos:winsock efs-dired-dos:winsock-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline dos:winsock (dir) - (efs-dired-pc-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename dos:winsock - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (re-search-forward efs-dos:winsock-date-and-size-regexp eol t) - (point) - (if raise-error - (error "No file on this line") - (goto-char bol))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename dos:winsock - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-fixup-listing dos:winsock - (file path &optional switches wildcard) - ;; The Winsock server outputs lines in seemingly random order. - ;; This isn't as good as sorting switches, but at least it's not random. - (sort-fields 9 (point-min) (point-max))) - -;;;;----------------------------------------------------------- -;;;; OS/2 Support -;;;;----------------------------------------------------------- - -;;; OS/2 has two types of file systems, FAT and HPFS. In the FAT file system -;;; filenames are restricted to the traditional DOS 8 + 3 syntax. In the -;;; HPFS file system, filenames can have arbitrarily many extensions (.'s). -;;; As well, file lines for "." and ".." are listed for HPFS. -;;; For the FAT FS, "." and ".." lines are only listed for sudirs, it seems. -;;; Go figure... - -(defconst efs-os2-file-line-regexp - (concat - " +\\([0-9]+\\) +\\([^ ]+\\)? +[01][0-9]-[0-3][0-9]-[0-9][0-9] +" - "[0-2][0-9]:[0-6][0-9] +")) - -(efs-defun efs-fix-path os2 (path &optional reverse) - (efs-fix-pc-path path reverse)) - -(efs-defun efs-fix-dir-path os2 (dir-path) - ;; Convert path from UNIX-ish to DOS for a DIRectory listing. - (cond ((string-match "^/\\(.:\\)?$" dir-path) - (error "Can't list DOS or OS/2 disks")) - ;; Neither DOS nor OS/2 allows us to end the name of a directory - ;; with an "\". - ;; Can't just hack it off, because if the dir is C:, we'll get the - ;; default dir. - ;; Don't apend the filename wildcard to distinguish - ;; plain files from directories, because OS/2 and DOS may - ;; not agree on what the wildcard is. Also, can't then tell - ;; the difference between plain files and empty directories. - ((string-match "/$" dir-path) - (concat (efs-fix-pc-path dir-path) ".")) - (t (efs-fix-pc-path dir-path)))) - -(defconst efs-os2-dot-line-regexp - (concat efs-os2-file-line-regexp "\\.\n")) - -(efs-defun efs-parse-listing os2 - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an OS/2 listing. - ;; To make sure that it is really a directory listing and not a bogus - ;; listing of a single file, make sure that there is an entry for ".". - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a full remote path - ;; PATH = directory in full efs-path syntax - (efs-save-match-data - (if (or - (string-match "^/.:/$" dir) ; FAT proofing - (progn - (goto-char (point-min)) - (re-search-forward efs-os2-dot-line-regexp nil t))) - (let ((tbl (efs-make-hashtable))) - (goto-char (point-min)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - (while (looking-at efs-os2-file-line-regexp) - (end-of-line) - (efs-put-hash-entry - (buffer-substring (match-end 0) (point)) - (list (and - (match-beginning 2) - (string-equal "DIR" - (buffer-substring (match-beginning 2) - (match-end 2)))) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - tbl) - (forward-line 1)) - tbl)))) - -;;; Tree Dired - -(defconst efs-dired-os2-re-exe - "^[^\n]+\\.EXEC?$") - -(or (assq 'os2 efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'os2 efs-dired-os2-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-os2-re-dir - "^ +[0-9]+ +DIR ") - -(or (assq 'os2 efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'os2 efs-dired-os2-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename os2 - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line. - ;; Returns (point) or nil if raise-error is nil, and there is no - ;; no filename on this line. - ;; This version is for OS/2 - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r") - (setq bol (point))) - (if (and - (> (- eol bol) 24) - (progn - (forward-char 2) - (looking-at efs-os2-file-line-regexp))) - (goto-char (match-end 0)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename os2 - (&optional no-error bol eol) - (efs-dired-pc-move-to-end-of-filename no-error bol eol)) - -(efs-defun efs-dired-insert-headerline os2 (dir) - (efs-dired-pc-insert-headerline dir)) - -;; end of efs-pc.el
--- a/lisp/efs/efs-plan9.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-plan9.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: efs support for the Plan 9 FTP Server -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Sat Jan 22 21:26:06 1994 by sandy on ibm550 -;; Modified: Sun Nov 27 18:41:05 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; Works for the plan 9 server plan9.att.com. Plan 9 is an -;;; AT&T operating system that is similar to unix. - -(provide 'efs-plan9) -(require 'efs) - -(defconst efs-plan9-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -(efs-defun efs-fix-dir-path plan9 (dir-path) - ;; Convert DIR-PATH from UN*X-ish to Plan 9. Does nothing actually. - ;; Avoids appending the "." that we do in unix. - dir-path) - -(efs-defun efs-allow-child-lookup plan9 (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Relies on the fact that directories can't have extensions in plan9, - ;; I think. - (and (not (and (string-equal dir "/") (string-equal file "."))) - (progn - ;; Makes sure that this is cached, before cd'ing - (efs-expand-tilde "~" 'plan9 host user) - (efs-raw-send-cd host user - (if (string-equal file ".") - (efs-internal-file-name-nondirectory - dir) - (concat dir file)) - t)))) - -;;; end of efs-plan9.el
--- a/lisp/efs/efs-report.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,215 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-report.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.9 $ -;; RCS: -;; Description: Function to report efs bugs in a usable way. -;; Author: Andy Norman, Dawn -;; Created: Tue May 18 08:34:45 1993 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-report) -(require 'efs) -(autoload 'reporter-submit-bug-report "reporter") -(defvar reporter-version) ; For the byte-compiler - -;;; Variables - -(defconst efs-report-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.9 $" 11 -2))) - -(defconst efs-report-salutations - ["Dear bug team:" - "Ciao bug team:" - "Salut bug team:" - "Gruss bug team:" - "To whom it may concern:" - "Fellow efs'ers:" - "Greetings earthlings:"]) - -(defvar efs-bug-address "efs-bugs@cuckoo.hpl.hp.com") - -(defconst efs-report-other-vars - ;; List of variables needed for efs-report, that aren't generated below. - '(efs-ftp-program-name - efs-ftp-program-args - efs-local-host-regexp - efs-ftp-local-host-regexp - efs-gateway-host - efs-gateway-type - reporter-version - features)) - -(defconst efs-report-avoid-vars - ;; List of variables we don't want to see. - '(efs-netrc-filename - efs-default-password - efs-default-account - efs-default-user)) - -;; Dynamically bound. Used to pass data to hooks. -(defvar efs-report-default-host nil) -(defvar efs-report-default-user nil) -(defvar efs-report-blurb nil) - -;;; Functions - -(defun efs-report-get-host-type-regexps () - "Return a list of host type regexp's which are non-nil." - (let ((list efs-host-type-alist) - ent result) - (while (setq ent (car list)) - (if (symbol-value (cdr ent)) - (setq result (cons (cdr ent) result))) - (setq list (cdr list))) - result)) - -(defun efs-report-get-versions () - ;; Return a list of efs versions variables. - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions - "efs-" obarray - (function - (lambda (sym) - (and (boundp sym) - (let ((name (symbol-name sym))) - (and (>= (length name) 8) - (string-equal (substring name -8) "-version")))))))) - 'string-lessp))) - -(defun efs-report-get-user-vars () - ;; Return a list of efs user variables. - (mapcar - 'intern - (sort - (let (completion-ignore-case) - (all-completions "efs-" obarray 'user-variable-p)) - 'string-lessp))) - -(defun efs-report-pre-hook () - ;; efs-report-default-host, efs-report-default-user, and - ;; efs-report-blurb are dynamically bound. - (save-excursion - (let ((end (progn (mail-position-on-field "subject") (point)))) - (beginning-of-line) - (search-forward ":" end) - (delete-region (point) end) - (insert - " EFS " - (or (and (boundp 'efs-version) (string-match "/" efs-version) - (concat (substring efs-version 0 (match-beginning 0)) - " ")) - "") - "bug: "))) - (let ((host (read-string "Bug occurred for remote host: " - efs-report-default-host)) - (user (read-string "Logged in as: " - efs-report-default-user)) - buff-name) - (if (string-match "^ *$" host) (setq host nil)) - (if (string-match "^ *$" user) (setq user nil)) - (if host - (insert "\nefs believes that the host type of " host " is " - (symbol-name (efs-host-type host)) - ".\n")) - (if efs-report-blurb - (insert "\n" efs-report-blurb "\n")) - (if (and host - user - (get-buffer (setq buff-name (efs-ftp-process-buffer host user))) - (save-window-excursion - (y-or-n-p - (progn - (with-output-to-temp-buffer "*Help*" - (princ - (format - "The contents of %s -will likely very useful for identifying any bugs. - -You will be given a chance to edit out any sensitive information. -Passwords are never written into this buffer." buff-name))) - (format "Insert contents of %s? " - buff-name))))) - (let ((header-1 (concat "Contents of " buff-name ":")) - (header-2 "Please edit sensitive or irrelevant information.")) - (insert "\n" header-1 "\n" header-2 "\n") - (insert-char ?= (max (length header-1) (length header-2))) - (insert "\n\n") - (insert-buffer-substring buff-name) - (insert "\n"))))) - -(defun efs-report-post-hook () - ;; Post hook run by report-submit-bug-report. - (save-excursion - (mail-position-on-field "subject") - (let ((subj (read-string "Subject header: "))) - (if (string-equal subj "") - (subst-char-in-region - (point) - (progn - (insert - (if (or (fboundp 'yow) (load "yow" t t)) (yow) "")) - (point)) - ?\n ?\ ) - (insert subj))))) - -;;;###autoload -(defun efs-report-bug (&optional default-host default-user blurb no-confirm) - "Submit a bug report for efs." - (interactive) - (let (;; reporter-confirm-p and reporter-package-abbrev appeared once - ;; as fluid vars in reporter.el. They aren't used any longer, - ;; but we let-bind them anyway in case the user has an old version - ;; of reporter. - (reporter-confirm-p nil) - (reporter-prompt-for-summary-p nil) - (reporter-package-abbrev "efs")) - ;; Look out for old reporter versions. - (or (boundp 'reporter-version) - (setq reporter-version - "Your version of reporter is obsolete. Please upgrade.")) - (if (or no-confirm - (y-or-n-p "Do you want to submit a bug report on efs? ")) - (let ((efs-report-default-host default-host) - (efs-report-default-user default-user) - (efs-report-blurb blurb) - (vars (nconc (efs-report-get-versions) - (efs-report-get-user-vars) - efs-report-other-vars - (efs-report-get-host-type-regexps))) - (avoids efs-report-avoid-vars) - path) - (cond - ((or efs-report-default-host efs-report-default-user)) - (efs-process-host - (setq efs-report-default-host efs-process-host - efs-report-default-user efs-process-user)) - ((setq path (or buffer-file-name - (and (eq major-mode 'dired-mode) - dired-directory))) - (let ((parsed (efs-ftp-path path))) - (setq efs-report-default-host (car parsed) - efs-report-default-user (nth 1 parsed))))) - (while avoids - (setq vars (delq (car avoids) vars)) - (setq avoids (cdr avoids))) - (reporter-submit-bug-report - efs-bug-address - "efs" - vars - (function efs-report-pre-hook) - (function efs-report-post-hook) - (aref efs-report-salutations - (% (+ (% (random) 1000) 1000) - (length efs-report-salutations)))))))) - -;;; end of efs-report.el
--- a/lisp/efs/efs-ti-explorer.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ti-explorer.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Explorer support for efs -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Created: Thu Dec 17 15:04:14 1992 -;; Modified: Sun Nov 27 18:42:47 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-ti-explorer) -(require 'efs) - -(defconst efs-ti-explorer-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; Explorer support. -;;;; ------------------------------------------------------------ - -;;; efs support for TI Explorer Lisp Machines. -;;; Symbolics Lispms use a different syntax, but I think that the -;;; MIT and LMI Lispms use the same syntax as Explorers. - -(defconst efs-ti-explorer-filename-regexp - (let* ((excluded-chars ":;<>.#\n\r\ta-z") - (token (concat "[^" excluded-chars "]+")) - (token* (concat "[^" excluded-chars "]*"))) - (concat "\\(" token ": *" "\\)?" ; optional device - "\\([^ " excluded-chars "]" token* "\\)" - "\\(\\." token "\\)*; *" ; directory - "\\(" token* "." token* "\\|\\) *" ; name and extension - "# *-?\\([0-9]+\\|>\\)"))) ; version - -(efs-defun efs-quote-string ti-explorer (string &optional not-space) - ;; ## This is an EVIL hack. Backslash is not what Explorers use to - ;; quote magic characters, and in addition, it is *incorrect* to quote - ;; spaces between the directory and filename: they are not a part of - ;; the filename, they are ignored. Quoting them would make them be - ;; significant. - (if not-space - string - (concat "\"" string "\""))) - -(efs-defun efs-send-pwd ti-explorer (host user &optional xpwd) -;; TI-EXPLORER output from pwd's needs to be specially parsed because -;; the fullpath syntax contains spaces. - (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) - (line (nth 1 result)) - dir) - (if (car result) - (efs-save-match-data - (and (string-match "^257 " line) - (setq dir (substring line 4))))) - (cons dir line))) - -(efs-defun efs-fix-path ti-explorer (path &optional reverse) - ;; Convert PATH from UNIX-ish to Explorer. If REVERSE given then convert - ;; from Explorer to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match - "^\\([^:]+:\\)? *\\([^:]+:\\)? *\\([^;]*\\); *\\(.*\\)$" - path) - (let (dir file) - ;; I don't understand how "devices" work, so I'm ignoring them. - ;; (if (match-beginning 2) - ;; (setq device (substring path - ;; (match-beginning 2) - ;; (1- (match-end 2))))) - (if (match-beginning 3) - (setq dir - (substring path (match-beginning 3) (match-end 3)))) - (if (match-beginning 4) - (setq file - (substring path (match-beginning 4) (match-end 4)))) - (cond (dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - dir))) - (if (string-match "^/" dir) - (setq dir (substring dir 1)) - (setq dir (concat "/" dir))))) - (concat - ;; (and device ":") device (and device ":") - dir (and dir "/") - file)) - (error "path %s didn't match explorer syntax" path)) - (let (dir file tmp) - ;; (if (string-match "^/[^:]+:" path) - ;; (setq device (substring path 1 - ;; (1- (match-end 0))) - ;; path (substring path (match-end 0)))) - (cond ((setq tmp (file-name-directory path)) - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?/) - (vector ?.) - (vector char)))) - (substring tmp 0 -1)))) - (if (string-match "^[.]" dir) - (setq dir (substring dir 1)) - (error "explorer pathnames can't be relative") - (setq dir (concat "." dir))))) - (setq file (file-name-nondirectory path)) - (concat - ;; (and device ":") device (and device ":") - dir - (and dir ";") - file))))) - -;; (efs-fix-path-for-explorer "/PUBLIC/ZMACS/ZYMURG.LISP#1") -;; (efs-fix-path-for-explorer "PUBLIC.ZMACS;ZYMURG.LISP#1" t) - -(efs-defun efs-fix-dir-path ti-explorer (dir-path) - ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. - (cond ((string-equal dir-path "/") - (efs-fix-path 'ti-explorer "/~/" nil)) - ((string-match "^/[-A-Z0-9_$]+:/" dir-path) - (error "Don't grok Explorer \"devices\" yet.")) - ((efs-fix-path 'ti-explorer dir-path nil)))) - -(defmacro efs-parse-ti-explorer-filename () - ;; Extract the next filename from an Explorer dired-like listing. - (` (if (re-search-forward - efs-ti-explorer-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0))))) - -(efs-defun efs-parse-listing ti-explorer - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be an Explorer directory - ;; listing, and return a hashtable as the result. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (while (setq file (efs-parse-ti-explorer-filename)) - ;; Explorer/Twenex listings might come out in absolute form. - (if (string-match "^[^;]*; *" file) - (setq file (substring file (match-end 0)))) - (if (string-match "\\.\\(DIRECTORY\\|directory\\)#[0-9]+$" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - (if (string-match "#[0-9]+$" file) ; deal with extension - ;; sans extension - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-really-file-p ti-explorer (file ent) - ;; Eliminates the version entries - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match "#[0-9]+$" file)))) - -(efs-defun efs-delete-file-entry ti-explorer (path &optional dir-p) - (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match "#[0-9]+$" file) - ;; Only delete entries with explicit version numbers. - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match "#[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry ti-explorer - (path dir-p size owner &optional modes nlinks mdtm) - ;; The ti-explorer version of this function needs to keep track - ;; of file versions. - (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - (if (string-match "#[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match "#[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file "#" (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-internal-file-name-as-directory ti-explorer (name) - (efs-save-match-data - (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(#[0-9>]\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -(efs-defun efs-allow-child-lookup ti-explorer (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in EXPLORER can't have an extension (other than .DIRECTORY, - ;; which we have truncated). - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-ti-explorer-re-dir - "^. *[^;\n\r]+;[^;\n\r.]+\\.\\(DIRECTORY\\|directory\\) *#" - "Regular expression to use to search for Explorer directories.") - -(or (assq 'ti-explorer efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'ti-explorer efs-dired-ti-explorer-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename ti-explorer - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the Explorer version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-ti-explorer-filename-regexp eol t) - (progn - (goto-char (match-beginning 0)) - ;; Explorer listings might come out in absolute form. - (if (looking-at "[^;]*; *") - (goto-char (match-end 0)) - (point))) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ti-explorer - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Explorer version. - (let (case-fold-search) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (looking-at efs-ti-explorer-filename-regexp) - (goto-char (match-end 0)) - (if no-error - nil - (error "No file on this line"))))) - -(efs-defun efs-dired-ls-trim ti-explorer () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward efs-ti-explorer-filename-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - -(efs-defun efs-internal-file-name-sans-versions ti-explorer - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match "#\\([0-9]+\\|>\\)$" name) - (substring name 0 (match-beginning 0)) - name))) - -;;; ### still need to ape these from vms: -;;; efs-dired-vms-clean-directory -;;; efs-dired-vms-collect-file-versions -;;; efs-dired-vms-trample-file-versions -;;; efs-dired-vms-flag-backup-files -;;; efs-dired-vms-backup-diff - -;;; end of efs-ti-explorer.el
--- a/lisp/efs/efs-ti-twenex.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,341 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-ti-twenex.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Support for a TI lisp machine in Twenex emulation mode. -;; Author: Jamie Zawinski <jwz@lucid.com> -;; Created: Thu Dec 17 15:04:14 1992 -;; Modified: Sun Nov 27 18:43:17 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-ti-twenex) -(require 'efs) - -(defconst efs-ti-twenex-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; Twenex support. -;;;; ------------------------------------------------------------ -;;; Written for an explorer in ti-twenex mode. Twenex is supposed to be just -;;; MIT's name for tops-20, but an explorer emulating twenex is not the same -;;; thing. - -(defconst efs-ti-twenex-filename-regexp - (let* ((excluded-chars ":;<>.#\n\r\ta-z") - (token (concat "[^" excluded-chars "]+")) - (token* (concat "[^" excluded-chars "]*"))) - (concat "\\(" token ": *" "\\)?" ; optional device - "<\\(" token "\\)?\\(\\." token "\\)*> *" ; directory - "\\(" token* "." token* "\\|\\) *" ; name and extension - "\\(\\. *-?\\([0-9]+\\|>\\)\\)?"))) ; version - -;;; The above isn't entirely accurate, because "/" can quote any character -;;; anywhere in a pathname. - -(efs-defun efs-fix-path ti-twenex (path &optional reverse) - ;; Convert PATH from UNIX-ish to Twenex. If REVERSE given then convert - ;; from Twenex to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match - "^\\([^:]+:\\)? *\\([^:]+:\\)? *<\\([^>]*\\)> *\\(.*\\)$" - path) - (let (dir file) - ;; I don't understand how "devices" work, so I'm ignoring them. - ;; (if (match-beginning 2) - ;; (setq device (substring path - ;; (match-beginning 2) - ;; (1- (match-end 2))))) - (if (match-beginning 3) - (setq dir - (substring path (match-beginning 3) (match-end 3)))) - (if (match-beginning 4) - (setq file - (substring path (match-beginning 4) (match-end 4)))) - (cond (dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - dir))) - (if (string-match "^/" dir) - (setq dir (substring dir 1)) - (setq dir (concat "/" dir))))) - (concat - ;; (and device ":") device (and device ":") - dir (and dir "/") - file)) - (error "path %s didn't match ti-twenex syntax" path)) - (let (dir file tmp) - ;; (if (string-match "^/[^:]+:" path) - ;; (setq device (substring path 1 - ;; (1- (match-end 0))) - ;; path (substring path (match-end 0)))) - (cond ((setq tmp (file-name-directory path)) - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?/) - (vector ?.) - (vector char)))) - (substring tmp 0 -1)))) - (if (string-match "^[.]" dir) - (setq dir (substring dir 1)) - (setq dir (concat "." dir))))) - (setq file (file-name-nondirectory path)) - (concat - ;; (and device ":") device (and device ":") - (and dir "<") - dir - (and dir ">") - file))))) - -;; (efs-fix-path-for-twenex "/PUBLIC/ZMACS/ZYMURG.LISP.1") -;; (efs-fix-path-for-twenex "<PUBLIC.ZMACS>ZYMURG.LISP.1" t) - -(efs-defun efs-fix-dir-path ti-twenex (dir-path) - ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. - (cond ((string-equal dir-path "/") - (efs-fix-path 'ti-twenex "/~/" nil)) - ((string-match "^/[-A-Z0-9_$]+:/" dir-path) - (error "Don't grok TWENEX \"devices\" yet.")) - ((efs-fix-path 'ti-twenex dir-path nil)))) - -(defmacro efs-parse-ti-twenex-filename () - ;; Extract the next filename from an Explorer dired-like listing. - (` (if (re-search-forward - efs-ti-twenex-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0))))) - -(efs-defun efs-parse-listing ti-twenex - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a TWENEX directory - ;; listing, and return a hashtable as the result. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (while (setq file (efs-parse-ti-twenex-filename)) - ;; Explorer/Twenex listings might come out in absolute form. - (if (string-match "^[^>]*> *" file) - (setq file (substring file (match-end 0)))) - (if (string-match "\\.\\(DIRECTORY\\|directory\\).[0-9]+$" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - (if (string-match "\\.[0-9]+$" file) ; deal with extension - ;; sans extension - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-really-file-p ti-twenex (file ent) - ;; Eliminates the version entries - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match "\\.[0-9]+$" file)))) - -(efs-defun efs-delete-file-entry ti-twenex (path &optional dir-p) - (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match "\\.[0-9]+$" file) - ;; Only delete versions with explicit version numbers. - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry ti-twenex - (path dir-p size owner &optional modes nlinks mdtm) - ;; The ti-twenex version of this function needs to keep track - ;; of ti-twenex's file versions. - (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file "." (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-internal-file-name-as-directory ti-twenex (name) - (efs-save-match-data - (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(\\.[0-9>]\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -(efs-defun efs-allow-child-lookup ti-twenex (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in TI-TWENEX can't have an extension (other than .DIRECTORY, - ;; which we have truncated). - (not (string-match "\\." file))) - -;;; Tree Dired - -(defconst efs-dired-ti-twenex-re-dir - "^. *[^>\n\r]+>[^>\n\r.]+\\.\\(DIRECTORY\\|directory\\)\\b" - "Regular expression to use to search for TWENEX directories.") - -(or (assq 'ti-twenex efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'ti-twenex efs-dired-ti-twenex-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename ti-twenex - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the Twenex version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-ti-twenex-filename-regexp eol t) - (progn - (goto-char (match-beginning 0)) - ;; Twenex listings might come out in absolute form. - (if (looking-at "[^>]*> *") - (goto-char (match-end 0)) - (point))) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename ti-twenex - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Explorer version. - (let (case-fold-search) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (if (looking-at efs-ti-twenex-filename-regexp) - (goto-char (match-end 0)) - (if no-error - nil - (error "No file on this line"))))) - -(efs-defun efs-internal-file-name-sans-versions ti-twenex - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -;;; ### still need to ape these from vms: -;;; efs-dired-vms-clean-directory -;;; efs-dired-vms-collect-file-versions -;;; efs-dired-vms-trample-file-versions -;;; efs-dired-vms-flag-backup-files -;;; efs-dired-vms-backup-diff - -;;; end of efs-ti-twenex.el
--- a/lisp/efs/efs-tops-20.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,353 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-tops-20.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: TOPS-20 support for efs -;; Author: Sandy Rutherford <sandy@math.ubc.ca, sandy@itp.ethz.ch> -;; Created: Fri Oct 23 08:52:00 1992 -;; Modified: Sun Nov 27 18:43:45 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(require 'efs) -(provide 'efs-tops-20) - -(defconst efs-tops-20-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; TOPS-20 support -;;;; ------------------------------------------------------------ - -(efs-defun efs-send-pwd tops-20 (host user &optional xpwd) - ;; pwd doesn't work for tops-20. Need to get the cwd from a dir listing - ;; this function returns the cwd in tops-20 syntax - (let* ((temp (efs-make-tmp-name host nil)) - (cmd (concat "dir * " (cdr temp))) - dir u-dir full-dir result) - (unwind-protect - (if (null (and (car (setq result (efs-raw-send-cmd - (efs-get-process host user) - cmd - "Getting TOPS-20 PWD"))) - (progn - (condition-case () - (delete-file (car temp)) (error nil)) - (car (setq result - (efs-raw-send-cmd - (efs-get-process host user) - cmd - "Trying to get TOPS-20 PWD, again.")))))) - (save-excursion - (set-buffer (get-buffer-create - efs-data-buffer-name)) - (erase-buffer) - (if (or (file-readable-p (car temp)) - (sleep-for efs-retry-time) - (file-readable-p (car temp))) - ;; Try again. - (insert-file-contents (car temp)) - (efs-error host user - (format - "list data file %s not readable" (car temp)))) - ;; get the cwd - (goto-char (point-min)) - (efs-save-match-data - (if (looking-at "[^ /:]+:<[^<>/ ]+>") - (progn - (setq dir (buffer-substring (match-beginning 0) - (match-end 0)) - u-dir (efs-internal-directory-file-name - (efs-fix-path 'tops-20 dir t)) - full-dir (format efs-path-format-string - user host u-dir)) - ;; cache the files too - (efs-set-files full-dir - (efs-parse-listing - 'tops-20 host user u-dir full-dir)) - (efs-add-to-ls-cache full-dir nil (buffer-string) t)))))) - (efs-del-tmp-name (car temp))) - (cons dir (nth 1 result)))) - -(efs-defun efs-fix-path tops-20 (path &optional reverse) - ;; Convert PATH from UNIX-ish to tops-20. If REVERSE given, then - ;; do just that. - (efs-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?<\\([^>.][^>]*\\)>.*$" path) - (let ((device (and (match-beginning 1) - (substring path (match-beginning 1) - (match-end 1)))) - (dir (substring path (match-beginning 2) - (match-end 2))) - (file (substring path (1+ (match-end 2))))) - (while (string-match "\\." dir) - (setq dir (concat (substring dir 0 (match-beginning 0)) - "/" - (substring dir (match-end 0))))) - (if device - (setq dir (concat "/" device "/" dir))) - (concat dir file)) - (error "path %s didn't match tops-20 syntax" path)) - (if (string-match "^\\(/[^:/]+:/\\)?\\([^./]+/\\)*\\([^/]*\\)$" path) - (let ((device (and (match-beginning 1) - (substring path 1 (1- (match-end 1))))) - (dir (and (match-beginning 2) - (substring path (match-beginning 2) - (1- (match-end 2))))) - (file (substring path (match-beginning 3) - (match-end 3)))) - (if dir - (progn - (while (string-match "/" dir) - (setq dir (concat (substring dir 0 (match-beginning 0)) - "." - (substring dir (match-end 0))))) - (if device - (concat device "<" dir ">" file) - (concat "<" dir ">" file))) - (if device - (error "%s is invalid relative syntax for tops-20" path) - file))) - (error "path %s is invalid syntax for tops-20" path))))) - -(efs-defun efs-fix-dir-path tops-20 (dir-path) - ;; Convert a path from UNIX-ish to Tops-20 fir a dir listing. - (cond ((string-equal "/" dir-path) - (error "Can't list tops-20 devices")) - ((string-match "/[^:/]+:/$" dir-path) - (error "Can't list all root directories on a tops-20 device")) - ((efs-fix-path 'tops-20 dir-path nil)))) - - -;; In tops-20 listings, the filename starts immediatley after the date regexp. - -(defconst efs-tops-20-date-regexp - (concat - " [1-3]?[0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\)-[0-9][0-9] [0-9][0-9]:[0-9][0-9]:[0-9][0-9] ")) - - -(efs-defun efs-parse-listing tops-20 - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a TOPS-20 directory - ;; listing, and return a hashtable as the result. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (if (looking-at " *[^/:]+:<\\([^/.<>]+\\.\\)+> *$") - ;; looking at the directory name - (forward-line 1)) - (while (re-search-forward efs-tops-20-date-regexp nil t) - (setq file (buffer-substring (point) - (progn (end-of-line) (point)))) - (if (string-match "\\.DIRECTORY\\.[0-9]+$" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - ;; sans extension - (if (string-match "\\.[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-really-file-p tops-20 (file ent) - ;; Eliminates the version entries - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match "\\.[0-9]+$" file)))) - -(efs-defun efs-delete-file-entry tops-20 (path &optional dir-p) - (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match "\\.[0-9]+$" file) - ;; Only delete explicit versions - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry tops-20 - (path dir-p size owner &optional modes nlinks mdtm) - ;; The tops-20 version of this function needs to keep track - ;; of tops-20's file versions. - (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match "\\.[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file "." (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-internal-file-name-as-directory tops-20 (name) - (efs-save-match-data - (if (string-match "\\.DIRECTORY\\(\\.[0-9>]\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -;;; Tree Dired - -(defconst efs-dired-tops-20-re-dir - "^[^\n]+\\.DIRECTORY\\(\\.[0-9]+\\)?$") - -(or (assq 'tops-20 efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'tops-20 efs-dired-tops-20-re-dir) - efs-dired-re-dir-alist))) - - -(efs-defun efs-dired-manual-move-to-filename tops-20 - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the Tops-20 version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-tops-20-date-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename tops-20 - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Tops-20 version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - ;; Is this the right character set? - (skip-chars-forward "-_A-Z0-9$.;") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-internal--file-name-sans-versions tops-20 - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match "\\.[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -(efs-defun efs-dired-insert-headerline tops-20 (dir) - ;; TOPS-20 inserts a headerline. I would prefer the headerline - ;; to be in efs format. This version tries to - ;; be careful, because we can't count on a headerline - ;; over ftp, and we wouldn't want to delete anything - ;; important. - (save-excursion - (if (looking-at "^ wildcard ") - (forward-line 1)) - (if (looking-at "^[ \n\t]*[^:/<>]+:<[^<>/]+> *\n") - (delete-region (point) (match-end 0))) - (insert " " (directory-file-name dir) ":\n\n"))) - -;;; end of efs-tops-20.el
--- a/lisp/efs/efs-vm.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,342 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-vm.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Allows the VM mail reader to access folders using efs. -;; If you are looking for support for VM/CMS, see efs-cms.el. -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Mon Nov 9 23:49:18 1992 by sandy on riemann -;; Modified: Sun Nov 27 18:44:07 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; If vm-get-new-mail (usually bound to "g") is given a prefix, it -;; will prompt for a folder from which to collect mail. With -;; efs-vm, this folder can be in efs syntax. As is usual -;; with VM, this folder will not be deleted. If at the folder prompt, -;; you give "/user@host:", efs-vm will collect mail from the -;; spool file on the remote machine. The spool file will be deleted if -;; the mail is successfully collected. It is not necessary for -;; movemail, nor even emacs, to be installed on the remote machine. -;; The functionality of movemail is mimicked with FTP commands. Both -;; local and remote crashboxes are used, so that mail will not be lost -;; if the FTP connection is lost. -;; -;; To use efs-vm, put (require 'efs-vm) in your .vm file. -;; -;; Works for vm 5.56 through 5.72. May not work with older versions. -;; If vm grows some file-name-handler-alist support, we should use it. -;; Actually it has. I just haven't gotten around to this yet. - -;;; Known Bugs: -;; -;; 1. efs-vm will not be able to collect mail from a spool file if -;; you do not have write permission in the spool directory. -;; I think that this precludes HP-UX. -;; I hope to do something about this. -;; -;; 2. efs-vm is as clever as at can be about spool file locking. -;; i.e. not very clever at all. At least it uses a rename command -;; to minimize the window for problems. Use POP if you want to -;; be careful. -;; - -;;; Provisions, requirements, and autoloads - -(provide 'efs-vm) -(require 'efs-cu) -(require 'efs-ovwrt) -(require 'vm) -;(require 'vm-folder) ; not provided -(if (or (not (fboundp 'vm-get-new-mail)) - (eq (car-safe (symbol-function 'vm-get-new-mail)) 'autoload)) - (load-library "vm-folder")) -(autoload 'efs-make-tmp-name "efs") -(autoload 'efs-del-tmp-name "efs") -(autoload 'efs-send-cmd "efs") -(autoload 'efs-re-read-dir "efs") -(autoload 'efs-copy-file-internal "efs") - -;;; User variables - -(defvar efs-vm-spool-files nil - "Association list of \( USER@MACHINE . SPOOLFILES \) pairs that -specify the location of the default remote spool file for MACHINE. SPOOLFILES -is a list of remote spool files.") - -(defvar efs-vm-crash-box "~/EFS.INBOX.CRASH" - "Local file where efs keeps its local crash boxes.") - -;;; Internal variables - -(defconst efs-vm-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - - -(defun efs-vm-get-new-mail (&optional arg) - "Documented as original" - (interactive "P") - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-virtual-folder) - (vm-error-if-folder-read-only) - (cond - ((null arg) - (if (not (eq major-mode 'vm-mode)) - (vm-mode)) - (if (consp (car (vm-spool-files))) - (message "Checking for new mail for %s..." buffer-file-name) - (message "Checking for new mail...")) - (let (new-messages totals-blurb) - (if (and (vm-get-spooled-mail) - (setq new-messages (vm-assimilate-new-messages t))) - (progn - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb)) - (if (consp (car (vm-spool-files))) - (message "No new mail for %s" buffer-file-name) - (message "No new mail.")) - (sit-for 4) - (message "")))) - (t - (let* ((buffer-read-only nil) - (folder (read-file-name "Gather mail from folder: " - vm-folder-directory t)) - (parsed (efs-ftp-path folder)) - mcount new-messages totals-blurb) - (if parsed - (if (string-equal (nth 2 parsed) "") - ;; a spool file - (if (not (and (efs-vm-get-remote-spooled-mail folder) - (setq new-messages - (vm-assimilate-new-messages t)))) - (progn - (message - "No new mail, or mail couldn't be retrieved by ftp.") - ;; don't let this message stay up forever... - (sit-for 4) - (message "")) - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb)) - - ;; a remote folder - (let ((tmp-file (car (efs-make-tmp-name nil (car parsed)))) - (folder (expand-file-name folder))) - (unwind-protect - (progn - (efs-copy-file-internal - folder parsed tmp-file nil t nil - (format "Getting %s" folder) - ;; asynch worries me here - nil nil) - (if (and vm-check-folder-types - (not (vm-compatible-folder-p tmp-file))) - (error - "Folder %s is not the same format as this folder." - folder)) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-max)) - (insert-file-contents tmp-file))) - (setq mcount (length vm-message-list)) - (if (setq new-messages (vm-assimilate-new-messages)) - (progn - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) - '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb) - ;; The gathered messages are actually still on disk - ;; unless the user deletes the folder himself. - ;; However, users may not understand what happened if - ;; the messages go away after a "quit, no save". - (setq vm-messages-not-on-disk - (+ vm-messages-not-on-disk - (- (length vm-message-list) - mcount)))) - (message "No messages gathered.")) - (efs-del-tmp-name tmp-file))))) - - ;; local - - (if (and vm-check-folder-types - (not (vm-compatible-folder-p folder))) - (error "Folder %s is not the same format as this folder." - folder)) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-max)) - (insert-file-contents folder))) - (setq mcount (length vm-message-list)) - (if (setq new-messages (vm-assimilate-new-messages)) - (progn - (if vm-arrived-message-hook - (while new-messages - (vm-run-message-hook (car new-messages) - 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages)))) - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb) - ;; The gathered messages are actually still on disk - ;; unless the user deletes the folder himself. - ;; However, users may not understand what happened if - ;; the messages go away after a "quit, no save". - (setq vm-messages-not-on-disk - (+ vm-messages-not-on-disk - (- (length vm-message-list) - mcount)))) - (message "No messages gathered."))))))) - -(defun efs-vm-gobble-remote-crash-box (remote-crash-box) - (let ((remote-crash-box (expand-file-name remote-crash-box)) - (crash-box (expand-file-name efs-vm-crash-box)) - lsize) - (if (file-exists-p vm-crash-box) - (progn - ;; This should never happen, but let's make sure that we never - ;; clobber mail. - (message "Recovering messages from local crash box...") - (vm-gobble-crash-box efs-vm-crash-box) - (message "Recovering messages from local crash box... done"))) - (efs-copy-file-internal remote-crash-box (efs-ftp-path remote-crash-box) - crash-box nil nil nil - (format "Getting %s" remote-crash-box) - ;; asynch worries me here - nil nil) - ;; only delete the remote crash box if we are sure that we have everything - (if (and (setq lsize (nth 7 (file-attributes crash-box))) - (eq lsize (nth 7 (file-attributes remote-crash-box))) - (vm-compatible-folder-p crash-box)) - (progn - (vm-gobble-crash-box crash-box) - (delete-file remote-crash-box)) - ;; don't leave garbage in the local crash box - (condition-case () (delete-file crash-box) (error nil)) - (error "Problem reading remote crash box %s" remote-crash-box)))) - -(defun efs-vm-get-remote-spooled-mail (remote-path) - ;; remote-path is usually of the form /user@machine: - ;; Usually vm sets inhibit-quit to t for this. This is probably - ;; a bad idea if there is ftp activity. - ;; I don't want to assume that the remote machine has movemail. - ;; Try to mimic movemail with ftp commands as best as possible. - ;; For this to work, we need to be able to create a subdirectory - ;; in the spool directory. - (if vm-block-new-mail - (error "Can't get new mail until you save this folder.")) - (let* ((parsed (efs-ftp-path remote-path)) - (host (car parsed)) - (user (nth 1 parsed)) - (spool-files - (or (cdr (assoc (concat user "@" host) - efs-vm-spool-files)) - (list (concat "/usr/spool/mail/" user)))) - got-mail) - (while spool-files - (let* ((s-file (car spool-files)) - (spool-file (format efs-path-format-string user host s-file)) - ;; rmdir and mkdir bomb if this path ends in a /. - (c-dir (concat s-file ".CRASHBOX")) - (rc-file (concat c-dir "/CRASHBOX")) - (crash-dir (concat spool-file ".CRASHBOX/")) - (remote-crash-file (concat crash-dir "CRASHBOX")) - (crash-box (expand-file-name efs-vm-crash-box))) - (if (file-exists-p crash-box) - (progn - (message "Recovering messages from crash box...") - (vm-gobble-crash-box crash-box) - (message "Recovering messages from crash box... done") - (setq got-mail t))) - (if (let ((efs-allow-child-lookup nil)) - (file-exists-p remote-crash-file)) - (progn - (message "Recovering messages from remote crash box...") - (efs-vm-gobble-remote-crash-box remote-crash-file) - (message "Recovering messages from remote crash box... done") - (setq got-mail t))) - (if (file-exists-p crash-box) - (progn - (message "Recovering messages from crash box...") - (vm-gobble-crash-box crash-box) - (message "Recovering messages from crash box... done") - (setq got-mail t))) - (unwind-protect - (if (car - (efs-send-cmd - host user (list 'mkdir c-dir) - (format "Making crash directory %s" crash-dir))) - (progn - (efs-re-read-dir crash-dir) - (message "Unable to make crash directory %s" crash-dir) - (ding)) - (or (car - (efs-send-cmd host user (list 'rename s-file rc-file) - (format "Checking spool file %s" spool-file))) - (progn - (message "Getting new mail from %s..." spool-file) - ;; The rename above wouldn't have updated the cash. - (efs-re-read-dir crash-dir) - (efs-vm-gobble-remote-crash-box remote-crash-file) - (message "Getting new mail from %s... done" spool-file) - (setq got-mail t)))) - (condition-case nil - (efs-send-cmd - host user (list 'rmdir c-dir) - "Removing crash directory") - (error nil)))) - (setq spool-files (cdr spool-files))) - got-mail)) - -;;; Overwrite existing functions - -(efs-overwrite-fn "efs" 'vm-get-new-mail) - -;;; end of efs-vm.el
--- a/lisp/efs/efs-vms.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,760 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-vms.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.13 $ -;; RCS: -;; Description: VMS support for efs -;; Authors: Andy Norman, Joe Wells, Sandy Rutherford <sandy@itp.ethz.ch> -;; Modified: Sun Nov 27 18:44:59 1994 by sandy on gandalf -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -(provide 'efs-vms) -(require 'efs) - -(defconst efs-vms-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.13 $" 11 -2))) - -;;;; ------------------------------------------------------------ -;;;; VMS support. -;;;; ------------------------------------------------------------ - -;;; efs has full support for VMS hosts, including tree dired support. It -;;; should be able to automatically recognize any VMS machine. However, if it -;;; fails to do this, you can use the command efs-add-vms-host. As well, -;;; you can set the variable efs-vms-host-regexp in your .emacs file. We -;;; would be grateful if you would report any failures to automatically -;;; recognize a VMS host as a bug. -;;; -;;; Filename Syntax: -;;; -;;; For ease of *implementation*, the user enters the VMS filename syntax in a -;;; UNIX-y way. For example: -;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 -;;; would be entered as: -;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 -;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: -;;; [.CSV.POLICY]RULES.MEM -;;; you would type: -;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM -;;; -;;; A legal VMS filename is of the form: FILE.TYPE;## -;;; where FILE can be up to 39 characters -;;; TYPE can be up to 39 characters -;;; ## is a version number (an integer between 1 and 32,767) -;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ -;;; $ cannot begin a filename, and - cannot be used as the first or last -;;; character. -;;; -;;; Tips: -;;; 1. To access the latest version of file under VMS, you use the filename -;;; without the ";" and version number. You should always edit the latest -;;; version of a file. If you want to edit an earlier version, copy it to a -;;; new file first. This has nothing to do with efs, but is simply -;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is -;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you -;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find -;;; that VMS will not allow you to save the file because it will refuse to -;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and -;;; attach the buffer to this file. To get out of this situation, M-x -;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to -;;; latest version of the file. For this reason, in tree dired "f" -;;; (dired-find-file), always loads the file sans version, whereas "v", -;;; (dired-view-file), always loads the explicit version number. The -;;; reasoning being that it reasonable to view old versions of a file, but -;;; not to edit them. -;;; 2. EMACS has a feature in which it does environment variable substitution -;;; in filenames. Therefore, to enter a $ in a filename, you must quote it -;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the -;;; $'s in the default directory when it writes it in the minibuffer. You -;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug -;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26 -;;; or newer), you will not have this problem. - - -;; Because some VMS ftp servers convert filenames to lower case -;; we allow a-z in the filename regexp. - -(defconst efs-vms-filename-regexp - "\\([_A-Za-z0-9$][-_A-Za-z0-9$]*\\)?\\.\\([-_A-Za-z0-9$]*\\);[0-9]+") -;; Regular expression to match for a valid VMS file name in Dired buffer. - -(defvar efs-vms-month-alist - '(("JAN" . 1) ("FEB". 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6) - ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10) - ("NOV" . 11) ("DEC" . 12))) - -(defvar efs-vms-date-regexp - (concat - "\\([0-3]?[0-9]\\)-" - "\\(JAN\\|FEB\\|MAR\\|APR\\|MAY\\|JUN\\|" - "JUL\\|AUG\\|SEP\\|OCT\\|NOV\\|DEC\\)-" - "\\([0-9][0-9][0-9]?[0-9]?\\) \\(\\([0-5][0-9]\\):\\([0-5][0-9]\\)" - "\\(:[0-5][0-9]\\)?\\)? ")) - - -;;; The following two functions are entry points to this file. -;;; They are defined as efs-autoloads in efs.el - -(efs-defun efs-fix-path vms (path &optional reverse) - ;; Convert PATH from UNIX-ish to VMS. - ;; If REVERSE given then convert from VMS to UNIX-ish. - (efs-save-match-data - (if reverse - (if (string-match - "^\\([^:]+:\\)?\\(\\[[^]]+\\]\\)?\\([^][]*\\)$" path) - (let (drive dir file) - (if (match-beginning 1) - (setq drive (substring path - (match-beginning 1) - (match-end 1)))) - (if (match-beginning 2) - (setq dir - (substring path (match-beginning 2) (match-end 2)))) - (if (match-beginning 3) - (setq file - (substring path (match-beginning 3) (match-end 3)))) - (and dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - (substring dir 1 -1))))) - (concat (and drive - (concat "/" drive "/")) - dir (and dir "/") - file)) - (error "path %s didn't match" path)) - (let (drive dir file) - (if (string-match "^/[^:/]+:/" path) - (setq drive (substring path 1 (1- (match-end 0))) - path (substring path (1- (match-end 0))))) - (setq dir (file-name-directory path) - file (efs-internal-file-name-nondirectory path)) - (if dir - (let ((len (1- (length dir))) - (n 0)) - (if (<= len 0) - (setq dir nil) - (while (<= n len) - (and (char-equal (aref dir n) ?/) - (cond - ((zerop n) (aset dir n ?\[)) - ((= n len) (aset dir n ?\])) - (t (aset dir n ?.)))) - (setq n (1+ n)))))) - (concat drive dir file))))) - -;; It is important that this function barf for directories for which we know -;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". -;; This is because it saves an unnecessary FTP error, or possibly the listing -;; might succeed, but give erroneous info. This last case is particularly -;; likely for OS's (like MTS) for which we need to use a wildcard in order -;; to list a directory. - -(efs-defun efs-fix-dir-path vms (dir-path) - ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. - ;; Should there be entries for .. -> [-] and . -> [] below. Don't - ;; think so, because expand-filename should have already short-circuited - ;; them. - (cond ((string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.")) - ((string-match "^/[-A-Z0-9_$]+:/$" dir-path) - (error "Cannot get listing for device.")) - ((efs-fix-path 'vms dir-path)))) - -;; These parsing functions are as general as possible because the syntax -;; of ftp listings from VMS hosts is a bit erratic. What saves us is that -;; the VMS filename syntax is so rigid. If they bomb on a listing in the -;; standard VMS Multinet format, then this is a bug. If they bomb on a listing -;; from vms.weird.net, then too bad. - -(defmacro efs-parse-vms-filename () - "Extract the next filename from a VMS dired-like listing." - (` (if (re-search-forward - efs-vms-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0))))) - -(defun efs-parse-vms-listing () - ;; Parse the current buffer which is assumed to be a VMS DIR - ;; listing (either a short (NLIST) or long listing). - ;; Assumes that point is at the beginning of the buffer. - (let ((tbl (efs-make-hashtable)) - file) - (goto-char (point-min)) - (efs-save-match-data - (while (setq file (efs-parse-vms-filename)) - (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) - ;; deal with directories - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(t) tbl) - (efs-put-hash-entry file '(nil) tbl) - (if (string-match ";[0-9]+$" file) ; deal with extension - ;; sans extension - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) '(nil) tbl))) - (forward-line 1)) - ;; Would like to look for a "Total" line, or a "Directory" line to - ;; make sure that the listing isn't complete garbage before putting - ;; in "." and "..", but we can't even count on all VAX's giving us - ;; either of these. - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl)) - tbl)) - -(efs-defun efs-parse-listing vms - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a VMS FTP dir - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - ;; check for a DIR/FULL monstrosity - (if (search-forward "\nSize:" nil t) - (progn - (efs-add-listing-type 'vms:full host user) - ;; This will cause the buffer to be refilled with an NLIST - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (goto-char (point-min)) - (efs-parse-vms-listing)) - (efs-parse-vms-listing)))) - - -;;;; Sorting of listings - -(efs-defun efs-t-converter vms (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-vms-filename-regexp nil t) - (let (list-start start end list) - (beginning-of-line) - (setq list-start (point)) - (while (and (looking-at efs-vms-filename-regexp) - (progn - (setq start (point)) - (goto-char (match-end 0)) - (forward-line (if (eolp) 2 1)) - (setq end (point)) - (goto-char (match-end 0)) - (re-search-forward efs-vms-date-regexp nil t))) - (setq list - (cons - (cons - (nconc - (list (string-to-int (buffer-substring - (match-beginning 3) - (match-end 3))) ; year - (cdr (assoc - (buffer-substring (match-beginning 2) - (match-end 2)) - efs-vms-month-alist)) ; month - (string-to-int (buffer-substring - (match-beginning 1) - (match-end 1)))) ;day - (if (match-beginning 4) - (list - (string-to-int (buffer-substring - (match-beginning 5) - (match-end 5))) ; hour - (string-to-int (buffer-substring - (match-beginning 6) - (match-end 6))) ; minute - (if (match-beginning 7) - (string-to-int (buffer-substring - (1+ (match-beginning 7)) - (match-end 7))) ; seconds - 0)) - (list 0 0 0))) - (buffer-substring start end)) - list)) - (goto-char end)) - (if list - (progn - (setq list - (mapcar 'cdr - (sort list 'efs-vms-t-converter-sort-pred))) - (if reverse (setq list (nreverse list))) - (delete-region list-start (point)) - (apply 'insert list))) - t))))) - -(defun efs-vms-t-converter-sort-pred (elt1 elt2) - (let* ((data1 (car elt1)) - (data2 (car elt2)) - (year1 (car data1)) - (year2 (car data2)) - (month1 (nth 1 data1)) - (month2 (nth 1 data2)) - (day1 (nth 2 data1)) - (day2 (nth 2 data2)) - (hour1 (nth 3 data1)) - (hour2 (nth 3 data2)) - (minute1 (nth 4 data1)) - (minute2 (nth 4 data2))) - (or (> year1 year2) - (and (= year1 year2) - (or (> month1 month2) - (and (= month1 month2) - (or (> day1 day2) - (and (= day1 day2) - (or (> hour1 hour2) - (and (= hour1 hour2) - (or (> minute1 minute2) - (and (= minute1 minute2) - (or (> (nth 5 data1) - (nth 5 data2))) - )))))))))))) - - -(efs-defun efs-X-converter vms (&optional regexp reverse) - ;; Sorts by extension - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-vms-filename-regexp nil t) - (let (list-start start list) - (beginning-of-line) - (setq list-start (point)) - (while (looking-at efs-vms-filename-regexp) - (setq start (point)) - (goto-char (match-end 0)) - (forward-line (if (eolp) 2 1)) - (setq list - (cons - (cons (buffer-substring (match-beginning 2) - (match-end 2)) - (buffer-substring start (point))) - list))) - (setq list - (mapcar 'cdr - (sort list - (if reverse - (function - (lambda (x y) - (string< (car y) (car x)))) - (function - (lambda (x y) - (string< (car x) (car y)))))))) - (delete-region list-start (point)) - (apply 'insert list) - t))))) - -;; This version only deletes file entries which have -;; explicit version numbers, because that is all VMS allows. - -(efs-defun efs-delete-file-entry vms (path &optional dir-p) - (let ((ignore-case (memq 'vms efs-case-insensitive-host-types))) - (if dir-p - (let ((path (file-name-as-directory path)) - files) - (efs-del-hash-entry path efs-files-hashtable ignore-case) - (setq path (directory-file-name path) - files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case)) - (if files - (efs-del-hash-entry (efs-get-file-part path) - files ignore-case))) - (efs-save-match-data - (let ((file (efs-get-file-part path))) - (if (string-match ";[0-9]+$" file) - ;; In VMS you can't delete a file without an explicit - ;; version number, or wild-card (e.g. FOO;*) - ;; For now, we give up on wildcards. - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((root (substring file 0 - (match-beginning 0))) - (completion-ignore-case ignore-case) - (len (match-beginning 0))) - (efs-del-hash-entry file files ignore-case) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (or (all-completions - root files - (function - (lambda (sym) - (string-match ";[0-9]+$" - (symbol-name sym) len)))) - (efs-del-hash-entry root files - ignore-case))))))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-add-file-entry vms (path dir-p size owner - &optional modes nlinks mdtm) - ;; The vms version of this function needs to keep track - ;; of vms's file versions. - (let ((ignore-case (memq 'vms efs-case-insensitive-host-types)) - (ent (let ((dir-p (null (null dir-p)))) - (if mdtm - (list dir-p size owner nil nil mdtm) - (list dir-p size owner))))) - (if dir-p - (let* ((path (directory-file-name path)) - (files (efs-get-hash-entry (file-name-directory path) - efs-files-hashtable - ignore-case))) - (if files - (efs-put-hash-entry (efs-get-file-part path) - ent files ignore-case))) - (let ((files (efs-get-hash-entry - (file-name-directory path) - efs-files-hashtable ignore-case))) - (if files - (let ((file (efs-get-file-part path))) - (efs-save-match-data - ;; In VMS files must have an extension. If there isn't - ;; one, it will be added. - (or (string-match "^[^;]*\\." file) - (if (string-match ";" file) - (setq file (concat - (substring file 0 (match-beginning 0)) - ".;" - (substring file (match-end 0)))) - (setq file (concat file ".")))) - (if (string-match ";[0-9]+$" file) - (efs-put-hash-entry - (substring file 0 (match-beginning 0)) - ent files ignore-case) - ;; Need to figure out what version of the file - ;; is being added. - (let* ((completion-ignore-case ignore-case) - (len (length file)) - (versions (all-completions - file files - (function - (lambda (sym) - (string-match ";[0-9]+$" - (symbol-name sym) len))))) - (N (1+ len)) - (max (apply - 'max - (cons 0 (mapcar - (function - (lambda (x) - (string-to-int (substring x N)))) - versions))))) - ;; No need to worry about case here. - (efs-put-hash-entry - (concat file ";" (int-to-string (1+ max))) ent files)))) - (efs-put-hash-entry file ent files ignore-case))))) - (efs-del-from-ls-cache path t ignore-case))) - -(efs-defun efs-really-file-p vms (file ent) - ;; Returns whether the hash entry FILE with entry ENT is a real file. - (or (car ent) ; file-directory-p - (efs-save-match-data - (string-match ";" file)))) - -(efs-defun efs-internal-file-name-as-directory vms (name) - (efs-save-match-data - (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (let (file-name-handler-alist) - (file-name-as-directory name)))) - -(efs-defun efs-remote-directory-file-name vms (dir) - ;; Returns the VMS filename in unix directory syntax for directory DIR. - ;; This is something like /FM/SANDY/FOOBAR.DIR;1 - (efs-save-match-data - (setq dir (directory-file-name dir)) - (concat dir - (if (string-match "[a-z]" (nth 2 (efs-ftp-path dir))) - ".dir;1" - ".DIR;1")))) - -(efs-defun efs-allow-child-lookup vms (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - - ;; Subdirs in VMS can't have an extension (other than .DIR, which we - ;; have truncated). - (not (or (string-match "\\." file) - (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file file))))) - -;;; Tree dired support: - -;; For this code I have borrowed liberally from Sebastian Kremer's -;; dired-vms.el - - -;; These regexps must be anchored to beginning of line. -;; Beware that the ftpd may put the device in front of the filename. - -(defconst efs-dired-vms-re-exe - "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]") - -(or (assq 'vms efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'vms efs-dired-vms-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-vms-re-dir - "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]") - -(or (assq 'vms efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'vms efs-dired-vms-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline vms (dir) - ;; VMS inserts a headerline. I would prefer the headerline - ;; to be in efs format. This version tries to - ;; be careful, because we can't count on a headerline - ;; over ftp, and we wouldn't want to delete anything - ;; important. - (save-excursion - (if (looking-at "^ \\(list \\)?wildcard ") - (forward-line 1)) - ;; This is really aggressive. Too aggressive? - (let ((start (point))) - (skip-chars-forward " \t\n") - (if (looking-at efs-vms-filename-regexp) - (beginning-of-line) - (forward-line 1) - (skip-chars-forward " \t\n") - (beginning-of-line)) - (delete-region start (point))) - (insert " \n")) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-fixup-listing vms (file path &optional switches wildcard) - ;; Some vms machines list the entire path. Scrape this off. - (setq path (efs-fix-path - 'vms - ;; Need the file-name-directory, in case of widcards. - ;; Note that path is a `local' path rel. the remote host. - ;; Lose on wildcards in parent dirs. Fix if somebody complains. - (let (file-name-handler-alist) - (file-name-directory path)))) - ;; Some machines put a Node name down too. - (let ((regexp (concat "^\\([_A-Za-z0-9][-_A-Za-z0-9]*\\$\\)?" - (regexp-quote path)))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (delete-region (match-beginning 0) (match-end 0)))) - ;; Now need to deal with continuation lines. - (goto-char (point-min)) - (let (col start end) - (while (re-search-forward - ";[0-9]+[ \t]*\\(\n[ \t]+\\)[^; \t\n]+[^\n;]*\n" nil t) - (setq start (match-beginning 1) - end (match-end 1)) - ;; guess at the column dimensions - (or col - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - (concat efs-vms-filename-regexp - "[ \t]+[^ \t\n\r]") nil t) - (setq col (- (goto-char (match-end 0)) - (progn (beginning-of-line) (point)) - 1)) - (setq col 0)))) - ;; join cont. lines. - (delete-region start end) - (goto-char start) - (insert-char ? (max (- col (current-column)) 2)))) - ;; Some vms dir listings put a triple null line before the total line. - (goto-char (point-min)) - (skip-chars-forward "\n") - (if (search-forward "\n\n\n" nil t) - (delete-char -1))) - -(efs-defun efs-dired-manual-move-to-filename vms - (&optional raise-error bol eol) - ;; In dired, move to first char of filename on this line. - ;; Returns position (point) or nil if no filename on this line. - ;; This is the VMS version. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-vms-filename-regexp eol t) - (goto-char (match-beginning 0)) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename vms - (&optional no-error bol eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the VMS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-_A-Za-z0-9$.;") - (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?\t ?\n ?\r)))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-ls-trim vms () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward efs-vms-filename-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - -(efs-defun efs-internal-file-name-sans-versions vms - (name &optional keep-backup-version) - (efs-save-match-data - (if (string-match ";[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -(efs-defun efs-dired-collect-file-versions vms () - ;; If it looks like file FN has versions, return a list of the versions. - ;; That is a list of strings which are file names. - ;; The caller may want to flag some of these files for deletion. - (let ((completion-ignore-case (memq 'vms efs-case-insensitive-host-types)) - result) - (dired-map-dired-file-lines - (function - (lambda (fn) - (if (string-match ";[0-9]+$" fn) - (let* ((base-fn (substring fn 0 (match-beginning 0))) - (base-version (file-name-nondirectory - (substring fn 0 (1+ (match-beginning 0))))) - (bv-length (length base-version)) - (possibilities (and - (null (assoc base-fn result)) - (file-name-all-completions - base-version - (file-name-directory fn))))) - (if possibilities - (setq result - (cons (cons base-fn - ;; code this explicitly - ;; using backup-extract-version has a - ;; lot of function-call overhead. - (mapcar (function - (lambda (fn) - (string-to-int - (substring fn bv-length)))) - possibilities)) result)))))))) - result)) - -(efs-defun efs-dired-flag-backup-files vms (&optional unflag-p) - (interactive "P") - (let ((dired-kept-versions 1) - (kept-old-versions 0) - marker msg) - (if unflag-p - (setq marker ?\040 msg "Unflagging old versions") - (setq marker dired-del-marker msg "Purging old versions")) - (dired-clean-directory 1 marker msg))) - -(efs-defun efs-internal-diff-latest-backup-file vms (fn) - ;; For FILE;#, returns the filename FILE;N, where N - ;; is the largest number less than #, for which this file exists. - ;; Returns nil if none found. - (efs-save-match-data - (and (string-match ";[0-9]+$" fn) - (let ((base (substring fn 0 (1+ (match-beginning 0)))) - (num (1- (string-to-int (substring fn - (1+ (match-beginning 0)))))) - found file) - (while (and (setq found (> num 0)) - (not (file-exists-p - (setq file - (concat base (int-to-string num)))))) - (setq num (1- num))) - (and found file))))) - -;;;;-------------------------------------------------------------- -;;;; Support for VMS DIR/FULL listings. (listing type vms:full) -;;;;-------------------------------------------------------------- - -(efs-defun efs-parse-listing vms:full - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be a VMS FTP dir - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - (efs-parse-vms-listing))) - -;;; Tree Dired - -(or (assq 'vms:full efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'vms:full efs-dired-vms-re-exe) - efs-dired-re-exe-alist))) - -(or (assq 'vms:full efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'vms:full efs-dired-vms-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-insert-headerline vms:full (dir) - ;; Insert a blank line for aesthetics. - (insert " \n") - (forward-char -2) - (efs-real-dired-insert-headerline dir)) - -(efs-defun efs-dired-manual-move-to-filename vms:full - (&optional raise-error bol eol) - (let ((efs-dired-listing-type 'vms)) - (efs-dired-manual-move-to-filename raise-error bol eol))) - -(efs-defun efs-dired-manual-move-to-end-of-filename vms:full - (&optional no-error bol eol) - (let ((efs-dired-listing-type 'vms)) - (efs-dired-manual-move-to-end-of-filename no-error bol eol))) - -;;; end of efs-vms.el
--- a/lisp/efs/efs-vos.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-vos.el -;; Description: VOS support for efs -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Sat Apr 3 03:05:00 1993 by sandy on ibm550 -;; Modified: Sun Nov 27 18:45:24 1994 by sandy on gandalf -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This file is part of efs. See efs.el for copyright -;;; (it's copylefted) and warrranty (there isn't one) information. - -;;; The original ange-ftp VOS support was written by Joe Wells <jbw@cs.bu.edu> - -;;; Thank you to Jim Franklin <jimf%shared@uunet.uu.net> for providing -;;; information on the VOS operating system. - -(provide 'efs-vos) -(require 'efs) - -(defconst efs-vos-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.1 $" 11 -2))) - -;;;;--------------------------------------------------------------- -;;;; VOS support for efs -;;;;--------------------------------------------------------------- - -;;; A legal VOS pathname is of the form: -;;; %systemname#diskname>dirname>dirname>dir-or-filename -;;; -;;; Each of systemname, diskname, dirname, dir-or-filename can be -;;; at most 32 characters. -;;; Valid characters are all alpha, upper and lower case, all digits, -;;; plus: @[]\^`{|}~"$+,-./:_ -;;; restrictions: name cannot begin with hyphen (-) or period (.) -;;; name must not end with a period (.) -;;; name must not contain two adjacent periods (.) -;;; -;;; Invalid characters are: -;;; non-printing control characters -;;; SPACE and DEL -;;; !#%&'()*;<=>? -;;; all other ascii chars -;;; -;;; The full pathname must be less than or equal to 256 characters. -;;; VOS pathnames are CASE-SENSITIVE. -;;; The may be a directory depth limitation of 10 (newer versions may have -;;; eliminated this). - -;;; entry points - -(efs-defun efs-fix-path vos (path &optional reverse) - ;; Convert PATH from UNIX-ish to VOS. - ;; If REVERSE given then convert from VOS to UNIX-ish. - ;; Does crude checking for valid path syntax, but is by no means exhaustive. - (efs-save-match-data - (if reverse - (if (string-match "^\\(\\(%[^#>%]+\\)?#[^>#%]+\\)?>[^>#%]" path) - (let ((marker (1- (match-end 0))) - (result "/") - system drive) - (if (match-beginning 1) - (if (match-beginning 2) - (setq system (substring path 1 (match-end 2)) - drive (substring path (1+ (match-end 2)) - (match-end 1))) - (setq drive (substring 1 (match-end 1))))) - (while (string-match ">" path marker) - (setq result (concat result - (substring path marker - (match-beginning 0)) - "/") - marker (match-end 0))) - (if drive - (if system - (concat "/" system "/" drive result - (substring path marker)) - (concat "/" drive result (substring path marker))) - (concat result (substring path marker)))) - (error "Invalid VOS pathname %s" path)) - (if (string-match "^/\\([^/]+\\)/\\([^/]+\\)/[^/]" path) - (let ((marker (1- (match-end 0))) - (result (concat "%" - (substring path - (match-beginning 1) - (match-end 1)) - "#" - (substring path - (match-beginning 2) - (match-end 2)) - ">"))) - ;; I'm guessing that VOS doesn't have a directory syntax. - (setq path (efs-internal-directory-file-name path)) - (while (string-match "/" path marker) - (setq result - (concat result - (substring path marker - (match-beginning 0)) - ">") - marker (match-end 0))) - (concat result (substring path marker))) - (error "Cannot convert path %s to VOS." path))))) - -(efs-defun efs-fix-dir-path vos (dir-path) - ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. - (cond ((string-equal dir-path "/") - (error "Cannot gork VOS system names")) - ((string-match "^/[^/]/$" dir-path) - (error "Cannot grok VOS devices")) - ((efs-fix-path 'vos dir-path)))) - -(defconst efs-vos-date-and-time-regexp - (concat - "\\(^\\| \\)" ; For links, this must match at the beginning of the line. - "[678901][0-9]-[01][0-9]-[0-3][0-9] [012][0-9]:[0-6][0-9]:[0-6][0-9] ")) -;; Regexp to match a VOS file line. The end of the regexp must correspond -;; to the start of the filename. - -(defmacro efs-vos-parse-filename () - ;; Return the VOS filename on the current line of a listing. - ;; Assumes that the point is at the beginning of the line. - ;; Return nil if no filename is found. - (` (let ((eol (save-excursion (end-of-line) (point)))) - (and (re-search-forward efs-vos-date-and-time-regexp eol t) - (buffer-substring (point) eol))))) - -(efs-defun efs-parse-listing vos - (host user dir path &optional switches) - ;; Parse the current buffer which is assumed to be in MultiNet FTP dir - ;; format, and return a hashtable as the result. SWITCHES are never used, - ;; but they must be specified in the argument list for compatibility - ;; with the unix version of this function. - ;; HOST = remote host name - ;; USER = user name - ;; DIR = directory in as a full remote path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches (not relevant here) - (goto-char (point-min)) - (efs-save-match-data - (let (tbl file) - ;; Look file files. - (if (search-forward "\nFiles: " nil t) - (progn - (setq tbl (efs-make-hashtable)) - (forward-line 1) - (skip-chars-forward "\n") - (while (setq file (efs-vos-parse-filename)) - (efs-put-hash-entry file '(nil) tbl) - (forward-line 1)))) - ;; Look for directories. - (if (search-forward "\nDirs: " nil t) - (progn - (or tbl (setq tbl (efs-make-hashtable))) - (forward-line 1) - (skip-chars-forward "\n") - (while (setq file (efs-vos-parse-filename)) - (efs-put-hash-entry file '(t) tbl) - (forward-line 1)))) - ;; Look for links - (if (search-forward "\nLinks: " nil t) - (let (link) - (or tbl (setq tbl (efs-make-hashtable))) - (forward-line 1) - (skip-chars-forward "\n") - (while (setq file (efs-vos-parse-filename)) - (if (string-match " -> \\([^ ]+\\)" file) - ;; VOS puts a trailing blank after the name of a symlink - ;; target. Go figure... - (setq link (substring file (match-beginning 1) (match-end 1)) - file (substring file 0 (match-beginning 0))) - (setq link "")) ; weird? - (efs-put-hash-entry file (list link) tbl) - (forward-line 1)))) - ;; This returns nil if no headings for files, dirs, or links - ;; are found. In this case, we're assuming that it isn't a valid - ;; listing. - (if tbl - (progn - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl))) - tbl))) - -(efs-defun efs-allow-child-lookup vos (host user dir file) - ;; Returns t if FILE in directory DIR could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. - ;; Directoried don't have a size. - (string-match ": not a file\\.$" - (cdr (efs-send-size host user (concat dir file))))) - -;;; Tree Dired Support - -(defconst efs-dired-vos-re-exe - "^. +e ") - -(or (assq 'vos efs-dired-re-exe-alist) - (setq efs-dired-re-exe-alist - (cons (cons 'vos efs-dired-vos-re-exe) - efs-dired-re-exe-alist))) - -(defconst efs-dired-vos-re-dir - "^. +[nsm] +[0-9]+ +[678901][0-9]-") - -(or (assq 'vos efs-dired-re-dir-alist) - (setq efs-dired-re-dir-alist - (cons (cons 'vos efs-dired-vos-re-dir) - efs-dired-re-dir-alist))) - -(efs-defun efs-dired-manual-move-to-filename vos - (&optional raise-error bol eol) - ;; In dired, move to the first char of filename on this line, where - ;; line can be delimited by either \r or \n. - ;; Returns (point) or nil if raise-error is nil and there is no - ;; filename on this line. In the later case, leaves the point at the - ;; beginning of the line. - ;; This version is for VOS. - (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) - (let (case-fold-search) - (if bol - (goto-char bol) - (skip-chars-backward "^\n\r")) - (if (re-search-forward efs-vos-date-and-time-regexp eol t) - (point) - (and raise-error (error "No file on this line"))))) - -(efs-defun efs-dired-manual-move-to-end-of-filename vos - (&optional no-error bol eol) - ;; Assumes point is at the beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t) - ;; On failure signals an error, or returns nil. - ;; This is the VOS version. - (let ((opoint (point))) - (and selective-display - (null no-error) - (eq (char-after - (1- (or bol (save-excursion - (skip-chars-backward "^\r\n") - (point))))) - ?\r) - ;; File is hidden or omitted. - (cond - ((dired-subdir-hidden-p (dired-current-directory)) - (error - (substitute-command-keys - "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) - ((error - (substitute-command-keys - "File line is omitted. Type \\[dired-omit-toggle] to un-omit." - ))))) - (skip-chars-forward "-a-zA-Z0-9@[]\\^`{|}~\"$+,./:_") - (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) - (if no-error - nil - (error "No file on this line")) - (point)))) - -(efs-defun efs-dired-fixup-listing vos (file path &optional switches wildcard) - ;; VOS listing contain some empty lines, which is inconvenient for dired. - (goto-char (point-min)) - (skip-chars-forward "\n") - (delete-region (point-min) (point)) - (while (search-forward "\n\n" nil t) - (forward-char -2) - (delete-char 1))) - -(efs-defun efs-dired-ls-trim vos () - ;; Trims VOS dir listings for single files, so that they are exactly one line - ;; long. - (goto-char (point-min)) - (let (case-fold-search) - (re-search-forward efs-vos-date-and-time-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - -;;; end of efs-vos.el
--- a/lisp/efs/efs-x19.15.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs-x19.15.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.2 $ -;; RCS: -;; Description: efs support for XEmacs, versions 19.15, and later. -;; Author: Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Tue Aug 2 17:40:32 1994 by sandy on ibm550 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(provide 'efs-x19\.15) -(require 'efs-cu) -(require 'efs-ovwrt) - -(defconst efs-x19\.15-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.2 $" 11 -2))) - -;;; Functions requiring special defs. for these XEmacs versions. - -(defun efs-abbreviate-file-name (filename &optional hack-homedir) - ;; XEmacs version of abbreviate-file-name for remote files. - (let (file-name-handler-alist) - (if (and hack-homedir (efs-ftp-path filename)) - ;; Do replacements from directory-abbrev-alist - (apply 'efs-unexpand-parsed-filename - (efs-ftp-path (abbreviate-file-name filename nil))) - (abbreviate-file-name filename hack-homedir)))) - -(defun efs-set-buffer-file-name (filename) - ;; Sets the buffer local variables for filename appropriately. - ;; A special function because XEmacs and FSF do this differently. - (setq buffer-file-name filename) - (if (and efs-compute-remote-buffer-file-truename - (memq (efs-host-type (car (efs-ftp-path filename))) - efs-unix-host-types)) - (compute-buffer-file-truename) - (setq buffer-file-truename filename))) - -;; Only XEmacs has this function. Why do we need both this and -;; set-visited-file-modtime? - -(defun efs-set-buffer-modtime (buffer &optional time) - ;; For buffers visiting remote files, set the buffer modtime. - (or time - (progn - (setq time - (let* ((file (save-excursion - (set-buffer buffer) buffer-file-name)) - (parsed (efs-ftp-path file))) - (efs-get-file-mdtm (car parsed) (nth 1 parsed) - (nth 2 parsed) file))) - (if time - (setq time (cons (car time) (nth 1 time))) - (setq time '(0 . 0))))) - (let (file-name-handler-alist) - (set-buffer-modtime buffer time))) - -;;; For the file-name-handler-alist - -(put 'set-buffer-modtime 'efs 'efs-set-buffer-modtime) - -;;; end of efs-x19.15.el
--- a/lisp/efs/efs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10917 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: efs.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.56 $ -;; RCS: -;; Description: Transparent FTP support for the original GNU Emacs -;; from FSF and XEmacs -;; Authors: Andy Norman <ange@hplb.hpl.hp.com>, -;; Sandy Rutherford <sandy@ibm550.sissa.it> -;; Created: Thu Oct 12 14:00:05 1989 (as ange-ftp) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The following restrictions apply to all of the files in the efs -;;; distribution. -;;; -;;; Copyright (C) 1993 Andy Norman / Sandy Rutherford -;;; -;;; Authors: -;;; Andy Norman (ange@hplb.hpl.hp.com) -;;; Sandy Rutherford (sandy@ibm550.sissa.it) -;;; -;;; The authors of some of the sub-files of efs are different -;;; from the above. We are very grateful to people who have -;;; contributed code to efs. -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's authors (send electronic mail to ange@hplb.hpl.hp.com) or -;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -;;; MA 02139, USA. - -;;; Description: -;;; -;;; This package attempts to make accessing files and directories on -;;; remote computers from within GNU Emacs as simple and transparent -;;; as possible. Currently all remote files are accessed using FTP. -;;; The goal is to make the entire internet accessible as a virtual -;;; file system. - -;;; Acknowledgements: << please add to this list >> -;;; -;;; Corny de Souza for writing efs-mpe.el. -;;; Jamie Zawinski for writing efs-ti-twenex.el and efs-ti-explorer.el -;;; Joe Wells for writing the first pass at vms support for ange-ftp.el. -;;; Sebastian Kremer for helping with dired support. -;;; Ishikawa Ichiro for MULE support. -;;; -;;; Many other people have contributed code, advice, and beta testing -;;; (sometimes without even realizing it) to both ange-ftp and efs: -;;; -;;; Rob Austein, Doug Bagley, Andy Caiger, Jim Franklin, Noah -;;; Friedman, Aksnes Knut-Havard, Elmar Heeb, John Interrante, Roland -;;; McGrath, Jeff Morgenthaler, Mike Northam, Jens Petersen, Jack -;;; Repenning, Joerg-Martin Schwarz, Michael Sperber, Svein Tjemsland, -;;; Andy Whitcroft, Raymond A. Wiker -;;; -;;; Also, thank you to all the people on the efs-testers mailing list. -;;; - -;;; -------------------------------------------------------------- -;;; Documentation: -;;; -------------------------------------------------------------- -;;; -;;; If you have any problems with efs, please read this section -;;; *before* submitting a bug report. - -;;; Installation: -;;; -;;; For byte compiling the efs package, a Makefile is provided. -;;; You should follow the instructions at the top of the Makefile. -;;; If you have any problems, please let us know so that we can fix -;;; them for other users. Don't even consider using efs without -;;; byte compiling it. It will be far too slow. -;;; -;;; If you decide to byte compile efs by hand, it is important that -;;; the file efs-defun.el be byte compiled first, followed by efs.el. -;;; The other files may be byte compiled in any order. -;;; -;;; To use efs, simply put the byte compiled files in your load path -;;; and add -;;; -;;; (require 'efs) -;;; -;;; in your .emacs file. Note this takes awhile, and some users have -;;; found this to be unbearably slow. Therefore ... -;;; -;;; If you would like efs to be autoloaded when you attempt to access -;;; a remote file, put -;;; -;;; (require 'efs-auto) -;;; -;;; in your .emacs file. Note that there are some limitations associated -;;; with autoloading efs. A discussion of them is given at the top of -;;; efs-auto.el. - -;;; Configuration variables: -;;; -;;; It is important that you read through the section on user customization -;;; variables (search forward for the string ">>>"). If your local network -;;; is not fully connected to the internet, but accesses the internet only -;;; via a gateway, then it is vital to set the appropriate variables to -;;; inform efs about the geometry of your local network. Also, see the -;;; paragraph on gateways below. - -;;; Usage: -;;; -;;; Once installed, efs operates largely transparently. All files -;;; normally accessible to you on the internet, become part of a large -;;; virtual file system. These files are accessed using an extended -;;; file name syntax. To access file <path> on remote host <host> by -;;; logging in as user <user>, you simply specify the full path of the -;;; file as /<user>@<host>:<path>. Nearly all GNU Emacs file handling -;;; functions work for remote files. It is not possible to access -;;; remote files using shell commands in an emacs *shell* buffer, as such -;;; commands are passed directly to the shell, and not handled by emacs. -;;; FTP is the underlying utility that efs uses to operate on remote files. -;;; -;;; For example, if find-file is given a filename of: -;;; -;;; /ange@anorman:/tmp/notes -;;; -;;; then efs will spawn an FTP process, connect to the host 'anorman' as -;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the -;;; contents of that file as if it were on the local file system. If efs -;;; needed a password to connect then it would prompt the user in the -;;; minibuffer. For further discussion of the efs path syntax, see the -;;; paragraph on extended file name syntax below. - -;;; Ports: -;;; -;;; efs supports the use of nonstandard ports on remote hosts. -;;; To specify that port <port> should be used, give the host name as -;;; host#<port>. Host names may be given in this form anywhere that efs -;;; normally expects a host name. This includes in the .netrc file. -;;; Logically, efs treats different ports to correspond to different -;;; remote hosts. - -;;; Extended filename syntax: -;;; -;;; The default full efs path syntax is -;;; -;;; /<user>@<host>#<port>:<path> -;;; -;;; Both the `#<port>' and `<user>@' may be omitted. -;;; -;;; If the `#<port>' is omitted, then the default port is taken to be 21, -;;; the usual FTP port. For most users, the port syntax will only -;;; very rarely be necessary. -;;; -;;; If the `<user>@' is omitted, then efs will use a default user. If a -;;; login token is specified in your .netrc file, then this will be used as -;;; the default user for <host>. Otherwise, it is determined based on the -;;; value of the variable efs-default-user. -;;; -;;; This efs path syntax can be customised to a certain extent by -;;; changing a number of variables in the subsection Internal Variables. -;;; To undertake such a customization requires some knowledge about the -;;; internal workings of efs. - -;;; Passwords: -;;; -;;; A password is required for each host / user pair. This will be -;;; prompted for when needed, unless already set by calling -;;; efs-set-passwd, or specified in a *valid* ~/.netrc file. -;;; -;;; When efs prompts for a password, it provides defaults from its -;;; cache of currently known passwords. The defaults are ordered such -;;; that passwords for accounts which have the same user name as the -;;; login which is currently underway have priority. You can cycle -;;; through your list of defaults with C-n to cycle forwards and C-p -;;; to cycle backwards. The list is circular. - -;;; Passwords for user "anonymous": -;;; -;;; Passwords for the user "anonymous" (or "ftp") are handled -;;; specially. The variable efs-generate-anonymous-password controls -;;; what happens. If the value of this variable is a string, then this -;;; is used as the password; if non-nil, then a password is created -;;; from the name of the user and the hostname of the machine on which -;;; GNU Emacs is running; if nil (the default) then the user is -;;; prompted for a password as normal. - -;;; "Dumb" UNIX hosts: -;;; -;;; The FTP servers on some UNIX machines have problems if the "ls" -;;; command is used. efs will try to correct for this automatically, -;;; and send the "dir" command instead. If it fails, you can call the -;;; function efs-add-host, and give the host type as dumb-unix. Note -;;; that this change will take effect for the current GNU Emacs -;;; session only. To make this specification for future emacs -;;; sessions, put -;;; -;;; (efs-add-host 'dumb-unix "hostname") -;;; -;;; in your .emacs file. Also, please report any failure to automatically -;;; recognize dumb unix to the "bugs" address given below, so that we can -;;; fix the auto recognition code. - -;;; File name completion: -;;; -;;; Full file-name completion is supported on every type of remote -;;; host. To do filename completion, efs needs a listing from the -;;; remote host. Therefore, for very slow connections, it might not -;;; save any time. However, the listing is cached, so subsequent uses -;;; of file-name completion will be just as fast as for local file -;;; names. - -;;; FTP processes: -;;; -;;; When efs starts up an FTP process, it leaves it running for speed -;;; purposes. Some FTP servers will close the connection after a period of -;;; time, but efs should be able to quietly reconnect the next time that -;;; the process is needed. -;;; -;;; The FTP process will be killed should the associated "*ftp user@host*" -;;; buffer be deleted. This should not cause efs any grief. - -;;; Showing background FTP activity on the mode-line: -;;; -;;; After efs is loaded, the command efs-display-ftp-activity will cause -;;; background FTP activity to be displayed on the mode line. The variable -;;; efs-mode-line-format is used to determine how this data is displayed. -;;; efs does not continuously track the number of active sessions, as this -;;; would cause the display to change too rapidly. Rather, it uses a heuristic -;;; algorithm to determine when there is a significant change in FTP activity. - -;;; File types: -;;; -;;; By default efs will assume that all files are ASCII. If a file -;;; being transferred matches the value of efs-binary-file-name-regexp -;;; then the file will be assumed to be a binary file, and efs will -;;; transfer it using "type image". ASCII files will be transferred -;;; using a transfer type which efs computes to be correct according -;;; to its knowledge of the file system of the remote host. The -;;; command `efs-prompt-for-transfer-type' toggles the variable -;;; `efs-prompt-for-transfer-type'. When this variable is non-nil, efs -;;; will prompt the user for the transfer type to use for every FTP -;;; transfer. Having this set all the time is annoying, but it is -;;; useful to give special treatment to a small set of files. -;;; There is also variable efs-text-file-name-regexp. This is tested before -;;; efs-binary-file-name-regexp, so if you set efs-text-file-name-regexp -;;; to a non-trivial regular expression, and efs-binary-file-name-regexp -;;; to ".*", the result will to make image the default tranfer type. -;;; -;;; Also, if you set efs-treat-crlf-as-nl, then efs will use type image -;;; to transfer files between hosts whose file system differ only in that -;;; one specifies end of line as CR-LF, and the other as NL. This is useful -;;; if you are transferring files between UNIX and DOS machines, and have a -;;; package such as dos-mode.el, that handles the extra ^M's. - -;;; Account passwords: -;;; -;;; Some FTP servers require an additional password which is sent by -;;; the ACCOUNT command. efs will detect this and prompt the user for -;;; an account password if the server expects one. Also, an account -;;; password can be set by calling efs-set-account, or by specifying -;;; an account token in the .netrc file. -;;; -;;; Some operating systems, such as CMS, require that ACCOUNT be used to -;;; give a write access password for minidisks. efs-set-account can be used -;;; to set a write password for a specific minidisk. Also, tokens of the form -;;; minidisk <minidisk name> <password> -;;; may be added to host lines in your .netrc file. Minidisk tokens must be -;;; at the end of the host line, however there may be an arbitrary number of -;;; them for any given host. - -;;; Preloading: -;;; -;;; efs can be preloaded, but must be put in the site-init.el file and -;;; not the site-load.el file in order for the documentation strings for the -;;; functions being overloaded to be available. - -;;; Status reports: -;;; -;;; Most efs commands that talk to the FTP process output a status -;;; message on what they are doing. In addition, efs can take advantage -;;; of the FTP client's HASH command to display the status of transferring -;;; files and listing directories. See the documentation for the variables -;;; efs-hash-mark-size, efs-send-hash and efs-verbose for more details. - -;;; Caching of directory information: -;;; -;;; efs keeps an internal cache of file listings from remote hosts. -;;; If this cache gets out of synch, it can be renewed by reverting a -;;; dired buffer for the appropriate directory (dired-revert is usually -;;; bound to "g"). -;;; -;;; Alternatively, you can add the following two lines to your .emacs file -;;; if you want C-r to refresh efs's cache whilst doing filename -;;; completion. -;;; (define-key minibuffer-local-completion-map "\C-r" 'efs-re-read-dir) -;;; (define-key minibuffer-local-must-match-map "\C-r" 'efs-re-read-dir) - -;;; Gateways: -;;; -;;; Sometimes it is necessary for the FTP process to be run on a different -;;; machine than the machine running GNU Emacs. This can happen when the -;;; local machine has restrictions on what hosts it can access. -;;; -;;; efs has support for running the ftp process on a different (gateway) -;;; machine. The way it works is as follows: -;;; -;;; 1) Set the variable 'efs-gateway-host' to the name of a machine -;;; that doesn't have the access restrictions. If you need to use -;;; a nonstandard port to access this host for gateway use, then -;;; specify efs-gateway-host as "<hostname>#<port>". -;;; -;;; 2) Set the variable 'efs-ftp-local-host-regexp' to a regular expression -;;; that matches hosts that can be contacted from running a local ftp -;;; process, but fails to match hosts that can't be accessed locally. For -;;; example: -;;; -;;; "\\.hp\\.com$\\|^[^.]*$" -;;; -;;; will match all hosts that are in the .hp.com domain, or don't have an -;;; explicit domain in their name, but will fail to match hosts with -;;; explicit domains or that are specified by their ip address. -;;; -;;; 3) Set the variable `efs-local-host-regexp' to machines that you have -;;; direct TCP/IP access. In other words, you must be able to ping these -;;; hosts. Usually, efs-ftp-local-host-regexp and efs-local-host-regexp -;;; will be the same. However, they will differ for so-called transparent -;;; gateways. See #7 below for more details. -;;; -;;; 4) Set the variable 'efs-gateway-tmp-name-template' to the name of -;;; a directory plus an identifying filename prefix for making temporary -;;; files on the gateway. For example: "/tmp/hplose/ange/efs" -;;; -;;; 5) If the gateway and the local host share cross-mounted directories, -;;; set the value of `efs-gateway-mounted-dirs-alist' accordingly. It -;;; is particularly useful, but not mandatory, that the directory -;;; of `efs-gateway-tmp-name-template' be cross-mounted. -;;; -;;; 6) Set the variable `efs-gateway-type' to the type gateway that you have. -;;; This variable is a list, the first element of which is a symbol -;;; denoting the type of gateway. Following elements give further -;;; data on the gateway. -;;; -;;; Supported gateway types: -;;; -;;; a) local: -;;; This means that your local host is itself the gateway. However, -;;; it is necessary to use a different FTP client to gain access to -;;; the outside world. If the name of the FTP client were xftp, you might -;;; set efs-gateway-type to -;;; -;;; (list 'local "xftp" efs-ftp-program-args) -;;; -;;; If xftp required special arguments, then give them in place of -;;; efs-ftp-program-args. See the documentation for efs-ftp-program-args -;;; for the syntax. -;;; -;;; b) proxy: -;;; This indicates that your gateway works by first FTP'ing to it, and -;;; then issuing a USER command of the form -;;; -;;; USER <username>@<host> -;;; -;;; In this case, you might set efs-gateway-type to -;;; -;;; (list 'proxy "ftp" efs-ftp-program-args) -;;; -;;; If you need to use a nonstandard client, such as iftp, give this -;;; instead of "ftp". If this client needs to take special arguments, -;;; give them instead of efs-ftp-program-args. -;;; -;;; c) remsh: -;;; For this type of gateway, you need to start a remote shell on -;;; your gateway, using either remsh or rsh. You should set -;;; efs-gateway-type to something like -;;; -;;; (list 'remsh "remsh" nil "ftp" efs-ftp-program-args) -;;; -;;; If you use rsh instead of remsh, change the second element from -;;; "remsh" to "rsh". Note that the symbol indicating the gateway -;;; type should still be 'remsh. If you want to pass arguments -;;; to the remsh program, give them as the third element. For example, -;;; if you need to specify a user, make this (list "-l" "sandy"). -;;; If you need to use a nonstandard FTP client, specify that as the fourth -;;; element. If your FTP client needs to be given special arguments, -;;; give them instead of efs-ftp-program-args. -;;; -;;; d) interactive: -;;; This indicates that you need to establish a login on the gateway, -;;; using either telnet or rlogin. -;;; You should set efs-gateway-type to something like -;;; -;;; (list 'interactive "rlogin" nil "exec ftp" efs-ftp-program-args) -;;; -;;; If you need to use telnet, then give "telnet" in place of the second -;;; element "rlogin". If your login program needs to be given arguments, -;;; then they should be given in the third slot. The fourth element -;;; is for the name of the FTP client program. Giving this as "exec ftp", -;;; instead of "ftp", ensures that you are logged out if the FTP client -;;; dies. If the FTP client takes special arguments, give these instead -;;; of efs-ftp-program-args. Furthermore, you should see the documentation -;;; at the top of efs-gwp.el. You may need to set the variables -;;; efs-gwp-setup-term-command, and efs-gwp-prompt-pattern. -;;; -;;; e) raptor: -;;; This is a type of gateway where efs is expected to specify a gateway -;;; user, and send a password for this user using the ACCOUNT command. -;;; For example, to log in to foobar.edu as sandy, while using the account -;;; ange on the gateway, the following commands would be sent: -;;; -;;; open raptorgate.com -;;; quote USER sandy@foobar.edu ange -;;; quote pass <sandy's password on foobar> -;;; quote account <ange's password on raptorgate> -;;; -;;; For such a gateway, you would set efs-gateway-type to -;;; -;;; (list 'raptor efs-ftp-program efs-ftp-program-args <GATEWAY USER>) -;;; -;;; where <GATEWAY USER> is the name of your account on the gateway. In -;;; the above example, this would be "ange". You can set your gateway -;;; password by simply setting an account password for the gateway host. -;;; This can be done with either efs-set-account, or within your .netrc -;;; file. If no password is set, you will be prompted for one. -;;; -;;; f) interlock: -;;; This is a type of gateway where you are expected to send a PASS -;;; command after opening the connection to the gateway. -;;; The precise login sequence is -;;; -;;; open interlockgate -;;; quote PASS <sandy's password on interlockgate> -;;; quote USER sandy@foobar.edu -;;; quote PASS <sandy's password on foobar.edu> -;;; -;;; For such a gateway, you should set efs-gateway-type to -;;; -;;; (list 'interlock efs-ftp-program efs-ftp-program-args) -;;; -;;; If you need to use a nonstandard name for your FTP client, -;;; then replace efs-ftp-program with this name. If your FTP client -;;; needs to take nonstandard arguments, then replace efs-ftp-program-args -;;; with these arguments. See efs-ftp-program-args <V> for the required -;;; syntax. -;;; -;;; If your gateway returns both a 220 code and a 331 code to the -;;; "open interlockgate" command, then you should add a regular -;;; expression to efs-skip-msgs <V> that matches the 220 response. -;;; Returning two response codes to a single FTP command is not permitted -;;; in RFC 959. It is not possible for efs to ignore the 220 by default, -;;; because than it would hang for interlock installations which do not -;;; require a password. -;;; -;;; g) kerberos: -;;; With this gateway, you need to authenticate yourself by getting a -;;; kerberos "ticket" first. Usually, this is done with the kinit program. -;;; Once authenticated, you connect to foobar.com as user sandy with the -;;; sequence: (Note that the "-n" argument inhibits automatic login. -;;; Although, in manual use you probably don't use it, efs always uses it.) -;;; -;;; iftp -n -;;; open foobar.com -;;; user sandy@foobar.com -;;; -;;; You should set efs-gateway-type to something like -;;; -;;; (list 'kerberos "iftp" efs-ftp-program-args "kinit" <KINIT-ARGS>) -;;; -;;; If you use an FTP client other than iftp, insert its name instead -;;; of "iftp" above. If your FTP client needs special arguments, give -;;; them as a list of strings in place of efs-ftp-program-args. If -;;; the program that you use to collect a ticket in not called "kinit", -;;; then give its name in place of "kinit" above. <KINIT-ARGS> should be -;;; any arguments that you need to pass to your kinit program, given as a -;;; list of strings. Most likely, you will give this as nil. -;;; -;;; See the file efs-kerberos.el for more configuration variables. If you -;;; need to adjust any of these variables, please report this to us so that -;;; we can fix them for other users. -;;; -;;; If efs detects that you are not authenticated to use the gateway, it -;;; will run the kinit program automatically, prompting you for a password. -;;; If you give a password in your .netrc file for login the value of -;;; efs-gateway-host <V> and user kerberos, then efs will use this to -;;; obtain gateway authentication. -;;; -;;; 7) Transparent gateways: -;;; -;;; If your gateway is completely transparent (for example it uses -;;; socks), then you should set efs-gateway-type to nil. Also, -;;; set efs-ftp-local-host-regexp to ".*". However, efs-local-host-regexp, -;;; must still be set to a regular expression matching hosts in your local -;;; domain. efs uses this to determine which machines that it can -;;; open-network-stream to. Furthermore, you should still set -;;; efs-gateway-host to the name of your gateway machine. That way efs -;;; will know that this is a special machine having direct TCP/IP access -;;; to both hosts in the outside world, and hosts in your local domain. -;;; -;;; 8) Common Problems with Gateways: -;;; -;;; a) Spurious 220 responses: -;;; Some proxy-style gateways (eg gateway type 'proxy or 'raptor), -;;; return two 3-digit FTP reply codes to the USER command. -;;; For example: -;;; -;;; open gateway.weird -;;; 220 Connected to gateway.weird -;;; quote USER sandy@foobar -;;; 220 Connected to foobar -;;; 331 Password required for sandy -;;; -;;; This is wrong, according to the FT Protocol. Each command must return -;;; exactly one 3-digit reply code. It may be preceded by continuation -;;; lines. What should really be returned is: -;;; -;;; quote USER sandy@foobar -;;; 331-Connected to foobar. -;;; 331 Password required for sandy. -;;; -;;; or even -;;; -;;; quote USER sandy@foobar -;;; 331-220 Connected to foobar. -;;; 331 Password required for sandy. -;;; -;;; Even though the "331-220" looks strange, it is correct protocol, and -;;; efs will parse it properly. -;;; -;;; If your gateway is returning a spurious 220 to USER, a work-around -;;; is to add a regular expression to `efs-skip-msgs' that matches -;;; this line. It must not match the 220 line returned to the open -;;; command. This work-around may not work, as some system FTP clients -;;; also get confused by the spurious 220. In this case, the only -;;; solution is to patch the gateway server. In either case, please -;;; send a bug report to the author of your gateway software. -;;; -;;; b) Case-sensitive parsing of FTP commands: -;;; Some gateway servers seem to treat FTP commands case-sensitively. -;;; This is incorrect, as RFC 959 clearly states that FTP commands -;;; are always to be case-insensitive. If this is a problem with your -;;; gateway server, you should send a bug report to its author. -;;; If efs is using a case for FTP commands that does not suit your server, -;;; a possible work-around is to edit the efs source so that the required -;;; case is used. However, we will not be making any changes to the -;;; standard efs distribution to support this type of server behaviour. -;;; If you need help changing the efs source, you should enquire with the -;;; efs-help mailing list. -;;; - -;;; --------------------------------------------------------------- -;;; Tips for using efs: -;;; --------------------------------------------------------------- - -;;; 1) Beware of compressing files on non-UNIX hosts. efs will do it by -;;; copying the file to the local machine, compressing it there, and then -;;; sending it back. Binary file transfers between machines of different -;;; architectures can be a risky business. Test things out first on some -;;; test files. See "Bugs" below. Also, note that efs sometimes -;;; copies files by moving them through the local machine. Again, -;;; be careful when doing this with binary files on non-Unix -;;; machines. -;;; -;;; 2) Beware that dired over ftp will use your setting of dired-no-confirm -;;; (list of dired commands for which confirmation is not asked). -;;; You might want to reconsider your setting of this variable, -;;; because you might want confirmation for more commands on remote -;;; direds than on local direds. For example, I strongly recommend -;;; that you not include compress in this list. If there is enough -;;; demand it might be a good idea to have an alist -;;; efs-dired-no-confirm of pairs ( TYPE . LIST ), where TYPE is an -;;; operating system type and LIST is a list of commands for which -;;; confirmation would be suppressed. Then remote dired listings -;;; would take their (buffer-local) value of dired-no-confirm from -;;; this alist. Who votes for this? -;;; -;;; 3) Some combinations of FTP clients and servers break and get out of sync -;;; when asked to list a non-existent directory. Some of the ai.mit.edu -;;; machines cause this problem for some FTP clients. Using -;;; efs-kill-ftp-process can be used to restart the ftp process, which -;;; should get things back in synch. -;;; -;;; 4) Some ftp servers impose a length limit on the password that can -;;; be sent. If this limit is exceeded they may bomb in an -;;; incomprehensible way. This sort of behaviour is common with -;;; MVS servers. Therefore, you should beware of this possibility -;;; if you are generating a long password (like an email address) -;;; with efs-generate-anonymous-password. -;;; -;;; 5) Some antiquated FTP servers hang when asked for an RNFR command. -;;; efs sometimes uses this to test whether its local cache is stale. -;;; If your server for HOST hangs when asked for this command, put -;;; (efs-set-host-property HOST 'rnfr-failed t) -;;; in your efs-ftp-startup-function-alist entry for HOST. -;;; - -;;; ----------------------------------------------------------------------- -;;; Where to get the latest version of efs: -;;; ----------------------------------------------------------------------- -;;; -;;; The authors are grateful to anyone or any organization which -;;; provides anonymous FTP distribution for efs. -;;; -;;; -;;; Europe: -;;; -;;; Switzerland -;;; /anonymous@itp.ethz.ch:/sandy/efs/ -;;; -;;; North America: -;;; -;;; Massachusetts, USA -;;; /anonymous@alpha.gnu.ai.mit.edu:/efs/ -;;; -;;; California, USA -;;; /anonymous@ftp.hmc.edu:/pub/emacs/packages/efs/ -;;; -;;; Australia and New Zealand: -;;; -;;; ???????????? -;;; -;;; Japan: -;;; -;;; ???????????? - -;;; --------------------------------------------------------------------- -;;; Non-UNIX support: -;;; --------------------------------------------------------------------- - -;;; efs has full support, incuding file name completion and tree dired -;;; for: -;;; -;;; VMS, CMS, MTS, MVS, ti-twenex, ti-explorer (the last two are lisp -;;; machines), TOPS-20, DOS (running the Distinct, Novell, FTP -;;; software, NCSA, Microsoft in both unix and DOS mode, Super TCP, and -;;; Hellsoft FTP servers), unix descriptive listings (dl), KA9Q, OS/2, -;;; VOS, NOS/VE, CMS running the KNET server, Tandem's Guardian OS, COKE -;;; -;;; efs should be able to automatically recognize any of the operating -;;; systems and FTP servers that it supports. Please report any -;;; failure to do so to the "bugs" address below. You can specify a -;;; certain host as being of a given host type with the command -;;; -;;; (efs-add-host <host-type> <host>) -;;; -;;; <host-type> is a symbol, <host> is a string. If this command is -;;; used interactively, then <host-type> is prompted for with -;;; completion. Some host types have regexps that can be used to -;;; specify a class of host names as being of a certain type. Note -;;; that if you specify a host as being of a certain type, efs does -;;; not verify that that is really the type of the host. This calls -;;; for caution when using regexps to specify host types, as an -;;; inadvertent match to a regexp might have unpleasant consequences. -;;; -;;; See the respective efs-TYPE.el files for more information. -;;; When or if we get a tex info file, it should contain some more -;;; details on the non-unix support. - -;;; ------------------------------------------------------------------ -;;; Bugs and other things that go clunk in the night: -;;; ------------------------------------------------------------------ - -;;; How to report a bug: -;;; -------------------- -;;; -;;; Type M-x efs-report-bug -;;; or -;;; send mail to efs-bugs@cuckoo.hpl.hp.com. -;;; -;;; efs is a "free" program. This means that you didn't (or shouldn't -;;; have) paid anything for it. It also means that nobody is paid to -;;; maintain it, and the authors weren't paid for writing it. -;;; Therefore, please try to write your bug report in a clear and -;;; complete fashion. It will greatly enhance the probability that -;;; something will be done about your problem. -;;; -;;; Note that efs relies heavily in cached information, so the bug may -;;; depend in a complicated fashion on commands that were performed on -;;; remote files from the beginning of your emacs session. Trying to -;;; reproduce your bug starting from a fresh emacs session is usually -;;; a good idea. -;;; - -;;; Fan/hate mail: -;;; -------------- -;;; -;;; efs has its own mailing list called efs-help. All users of efs -;;; are welcome to subscribe (see below) and to discuss aspects of -;;; efs. New versions of efs are posted periodically to the mailing -;;; list. -;;; -;;; To [un]subscribe to efs-help, or to report mailer problems with the -;;; list, please mail one of the following addresses: -;;; -;;; efs-help-request@cuckoo.hpl.hp.com -;;; or -;;; efs-help-request%cuckoo.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Please don't forget the -request part. -;;; -;;; For mail to be posted directly to efs-help, send to one of the -;;; following addresses: -;;; -;;; efs-help@cuckoo.hpl.hp.com -;;; or -;;; efs-help%cuckoo.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Alternatively, there is a mailing list that only gets -;;; announcements of new efs releases. This is called efs-announce, -;;; and can be subscribed to by e-mailing to the -request address as -;;; above. Please make it clear in the request which mailing list you -;;; wish to join. -;;; - -;;; Known bugs: -;;; ----------- -;;; -;;; If you hit a bug in this list, please report it anyway. Most of -;;; the bugs here remain unfixed because they are considered too -;;; esoteric to be a high priority. If one of them gets reported -;;; enough, we will likely change our view on that. -;;; -;;; 1) efs does not check to make sure that when creating a new file, -;;; you provide a valid filename for the remote operating system. -;;; If you do not, then the remote FTP server will most likely -;;; translate your filename in some way. This may cause efs to -;;; get confused about what exactly is the name of the file. -;;; -;;; 2) For CMS support, we send too many cd's. Since cd's are cheap, I haven't -;;; worried about this too much. Eventually, we should have some caching -;;; of the current minidisk. This is complicated by the fact that some -;;; CMS servers lie about the current minidisk, so sending redundant -;;; cd's helps us recover in this case. -;;; -;;; 3) The code to do compression of files over ftp is not as careful as it -;;; should be. It deletes the old remote version of the file, before -;;; actually checking if the local to remote transfer of the compressed -;;; file succeeds. Of course to delete the original version of the file -;;; after transferring the compressed version back is also dangerous, -;;; because some OS's have severe restrictions on the length of filenames, -;;; and when the compressed version is copied back the "-Z" or ".Z" may be -;;; truncated. Then, efs would delete the only remaining version of -;;; the file. Maybe efs should make backups when it compresses files -;;; (of course, the backup "~" could also be truncated off, sigh...). -;;; Suggestions? -;;; -;;; 4) If a dir listing is attempted for an empty directory on (at least -;;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and -;;; I don't know how to get efs work to around it. -;;; -;;; 5) efs gets confused by directories containing file names with -;;; embedded newlines. A temporary solution is to add "q" to your -;;; dired listing switches. As long as your dired listing switches -;;; also contain "l" and either "a" or "A", efs will use these -;;; switches to get listings for its internal cache. The "q" switch -;;; should force listings to be exactly one file per line. You -;;; still will not be able to access a file with embedded newlines, -;;; but at least it won't mess up the parsing of the rest of the files. -;;; -;;; 6) efs cannot parse symlinks which have an embedded " -> " -;;; in their name. It's alright to have an embedded " -> " in the name -;;; of any other type of file. A fix is possible, but probably not worth -;;; the trouble. If you disagree, send us a bug report. -;;; -;;; 7) efs doesn't handle context-dep. files in H-switch listings on -;;; HP's. It wouldn't be such a big roaring deal to fix this. I'm -;;; waiting until I get an actual bug report though. -;;; -;;; 8) If a hard link is added or deleted, efs will not update its -;;; internal cache of the link count for other names of the file. -;;; This may cause file-nlinks to return incorrectly. Reverting -;;; any dired buffer containing other names for the file will -;;; cause the file data to be updated, including the link counts. -;;; A fix for this problem is known and will be eventually -;;; implemented. How it is implemented will depend on how we decide -;;; to handle inodes. See below. -;;; -;;; 9) efs is unable to parse R-switch listings from remote unix hosts. -;;; This is inefficient, because efs will insist on doing individual -;;; listings of the subdirectories to get its file information. -;;; This may be fixed if there is enough demand. -;;; -;;; 10) In file-attributes, efs returns a fake inode number. Of course -;;; this is necessary, but this inode number is not even necessarily -;;; unique. It is simply the sum of the characters (treated as -;;; integers) in the host name, user name, and file name. Possible -;;; ways to get a unique inode number are: -;;; a) Simply keep a count of all remote file in the cache, and -;;; return the file's position in this count as a negative number. -;;; b) For unix systems, we could actually get at the real inode -;;; number on the remote host, by adding an "i" to the ls switches. -;;; The inode numbers would then be removed from the listing -;;; returned by efs-ls, if the caller hadn't requested the "i" -;;; switch. We could then make a unique number out of the host name -;;; and the real inode number. -;;; -;;; 11) efs tries to determine if a file is readable or writable by comparing -;;; the file modes, file owner, and user name under which it is logged -;;; into the remote host. This does not take into account groups. -;;; We simply assume that the user belongs to all groups. As a result -;;; we may assume that a file is writable, when in fact it is not. -;;; Groups are tough to handle correctly over FTP. Suggestions? -;;; (For new FTP servers, can do a "QUOTE SITE EXEC groups" to -;;; handle this.) - -;;; ----------------------------------------------------------- -;;; Technical information on this package: -;;; ----------------------------------------------------------- - -;;; efs hooks onto the following functions using the -;;; file-name-handler-alist. Depending on which version of emacs you -;;; are using, not all of these functions may access this alist. In -;;; this case, efs overloads the definitions of these functions with -;;; versions that do access the file-name-handler-alist. These -;;; overloads are done in efs's version-specific files. -;;; -;;; abbreviate-file-name -;;; backup-buffer -;;; copy-file -;;; create-file-buffer -;;; delete-directory -;;; delete-file -;;; directory-file-name -;;; directory-files -;;; file-attributes -;;; file-directory-p -;;; file-exists-p -;;; file-local-copy -;;; file-modes -;;; file-name-all-completions -;;; file-name-as-directory -;;; file-name-completion -;;; file-name-directory -;;; file-name-nondirectory -;;; file-name-sans-versions -;;; file-newer-than-file-p -;;; file-readable-p -;;; file-executable-p -;;; file-accessible-directory-p -;;; file-symlink-p -;;; file-writable-p -;;; get-file-buffer -;;; insert-directory -;;; insert-file-contents -;;; list-directory -;;; make-directory-internal -;;; rename-file -;;; set-file-modes -;;; set-visited-file-modtime -;;; substitute-in-file-name -;;; verify-visited-file-modtime -;;; write-region -;;; -;;; The following functions are overloaded in efs.el, because they cannot -;;; be handled via the file-name-handler-alist. -;;; -;;; expand-file-name -;;; load -;;; read-file-name-internal (Emacs 18, only) -;;; require -;;; -;;; The following dired functions are handled by hooking them into the -;;; the file-name-handler-alist. This is done in efs-dired.el. -;;; -;;; efs-dired-compress-file -;;; eds-dired-print-file -;;; efs-dired-make-compressed-filename -;;; efs-compress-file -;;; efs-dired-print-file -;;; efs-dired-create-directory -;;; efs-dired-recursive-delete-directory -;;; efs-dired-uncache -;;; efs-dired-call-process -;;; -;;; In efs-dired.el, the following dired finctions are overloaded. -;;; -;;; dired-collect-file-versions -;;; dired-find-file -;;; dired-flag-backup-files -;;; dired-get-filename -;;; dired-insert-headerline -;;; dired-move-to-end-of-filename -;;; dired-move-to-filename -;;; dired-run-shell-command -;;; -;;; efs makes use of the following hooks -;;; -;;; diff-load-hook -;;; dired-before-readin-hook -;;; find-file-hooks -;;; dired-grep-load-hook - -;;; LISPDIR ENTRY for the Elisp Archive: -;;; -;;; LCD Archive Entry: -;;; efs|Andy Norman and Sandy Rutherford -;;; |ange@hplb.hpl.hp.com and sandy@ibm550.sissa.it -;;; |transparent FTP Support for GNU Emacs -;;; |$Date: 1997/10/03 00:11:00 $|$efs release: 1.15 beta $| - -;;; Host and listing type notation: -;;; -;;; The functions efs-host-type and efs-listing-type, and the -;;; variable efs-dired-host-type follow the following conventions -;;; for remote host types. -;;; -;;; nil = local host type, whatever that is (probably unix). -;;; Think nil as in "not a remote host". This value is used by -;;; efs-dired-host-type for local buffers. -;;; (efs-host-type nil) => nil -;;; -;;; 'type = a remote host of TYPE type. -;;; -;;; 'type:list = a remote host using listing type 'type:list. -;;; This is currently used for Unix dl (descriptive -;;; listings), when efs-dired-host-type is set to -;;; 'unix:dl, and to support the myriad of DOS FTP -;;; servers. - -;;; Supported host and listing types: -;;; -;;; unknown, unix, dumb-unix, bsd-unix, sysV-unix, next-unix, -;;; super-dumb-unix, dumb-apollo-unix, -;;; apollo-unix, unix:dl, dos-distinct, ka9q, dos, dos:ftp, dos:novell, -;;; dos:ncsa, dos:winsock, vos, hell, dos:microsoft, super-dumb-unix -;;; vms, cms, mts, mvs, mvs:tcp mvs:nih tops-20, mpe, ti-twenex, -;;; ti-explorer, os2, vos, -;;; vms:full, guardian, ms-unix (This is the Microsoft NT Windows server -;;; in unix mode.), plan9, unix:unknown, nos-ve (actually NOS/VE). - -;;; Host and listing type hierarchy: -;;; -;;; unknown: unix, dumb-unix, sysV-unix, bsd-unix, next-unix, apollo-unix, -;;; ka9q, dos-distinct, unix:dl, hell, -;;; super-dumb-unix, dumb-apollo-unix -;;; unix: sysV-unix, bsd-unix, next-unix, apollo-unix, unix:dl -;;; dos: dos:ftp, dos:novell, dos:ncsa, dos:microsoft, dos:winsock -;;; dumb-unix: -;;; bsd-unix: -;;; sysV-unix: -;;; next-unix: -;;; apollo-unix: -;;; dumb-apollo-unix: -;;; unix:dl: -;;; unix:unknown: unix:dl, unix -;;; super-dumb-unix: -;;; dos-distinct: -;;; dos:ftp: -;;; dos:novell: -;;; dos:microsoft -;;; ka9q: -;;; vms: vms:full -;;; cms: -;;; mts: -;;; mvs: mvs:tcp, mvs:nih -;;; mvs:tcp: -;;; mvs:nih: -;;; tops-20: -;;; ti-twenex: -;;; ti-explorer: -;;; os2: -;;; vos: -;;; vms:full: -;;; dos:ncsa: -;;; dos:winsock: -;;; vos: -;;; hell: -;;; guardian: -;;; ms-unix: -;;; plan9: -;;; nos-ve: -;;; coke: -;;; - - -;;;; ================================================================ -;;;; >0 -;;;; Table of Contents for efs.el -;;;; ================================================================ -;; -;; Each section of efs.el is labelled by >#, where # is the number of -;; the section. -;; -;; 1. Provisions, requirements, and autoloads. -;; 2. Variable definitions. -;; 3. Utilities. -;; 4. Hosts, users, accounts, and passwords. -;; 5. FTP client process and server responses. -;; 6. Sending commands to the FTP server. -;; 7. Parsing and storing remote file system data. -;; 8. Redefinitions of standard GNU Emacs functions. -;; 9. Multiple host type support. -;; 10. Attaching onto the appropriate emacs version. - - -;;;; ================================================================ -;;;; >1 -;;;; General provisions, requirements, and autoloads. -;;;; Host type, and local emacs type dependent loads, and autoloads -;;;; are in the last two sections of this file. -;;;; ================================================================ - -;;;; ---------------------------------------------------------------- -;;;; Provide the package (Do this now to avoid an infinite loop) -;;;; ---------------------------------------------------------------- - -(provide 'efs) - -;;;; ---------------------------------------------------------------- -;;;; Our requirements. -;;;; ---------------------------------------------------------------- - -(require 'backquote) -(require 'comint) -(require 'efs-defun) -(require 'efs-netrc) -(require 'efs-cu) -(require 'efs-ovwrt) -;; Do this last, as it installs efs into the file-name-handler-alist. -(require 'efs-fnh) - -(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) -(autoload 'efs-gwp-start "efs-gwp" ; For interactive gateways. - "Login to the gateway machine and fire up an FTP client.") -(autoload 'efs-kerberos-login "efs-kerberos") -(autoload 'efs-insert-directory "efs-dired" "Insert a directory listing.") -(autoload 'efs-set-mdtm-of "efs-cp-p") -(autoload 'diff-latest-backup-file "diff") -(autoload 'read-passwd "passwd" "Read a password from the minibuffer." t) - - -;;;; ============================================================ -;;;; >2 -;;;; Variable Definitions -;;;; **** The user configuration variables are in **** -;;;; **** the second subsection of this section. **** -;;;; ============================================================ - -;;;; ------------------------------------------------------------ -;;;; Constant Definitions -;;;; ------------------------------------------------------------ - -(defconst efs-version - (concat (substring "$efs release: 1.15 $" 14 -2) - "/" - (substring "#Revision: 1.56 $" 11 -2))) - -(defconst efs-time-zero 1970) ; we count time from midnight, Jan 1, 1970 GMT. - -(defconst efs-dumb-host-types - '(dumb-unix super-dumb-unix vms cms mts ti-twenex ti-explorer dos mvs - tops-20 mpe ka9q dos-distinct os2 vos hell guardian - netware cms-knet nos-ve coke dumb-apollo-unix) - "List of host types that can't take UNIX ls-style listing options.") -;; dos-distinct only ignores ls switches; it doesn't barf. -;; Still treat it as dumb. - -(defconst efs-unix-host-types - '(unix sysV-unix bsd-unix next-unix apollo-unix dumb-unix - dumb-apollo-unix super-dumb-unix) - "List of unix host types.") - -(defconst efs-version-host-types '(vms tops-20 ti-twenex ti-explorer) - "List of host-types which associated a version number to all files. -This is not the same as associating version numbers to only backup files.") -;; Note that on these systems, -;; (file-name-sans-versions EXISTING-FILE) does not exist as a file. - -(defconst efs-single-extension-host-types - '(vms tops-20 ti-twenex ti-explorer cms mvs dos ka9q dos-distinct hell - netware ms-unix plan9 cms-knet nos-ve) - "List of host types which allow at most one extension on a file name. -Extensions are deliminated by \".\". In addition, these host-types must -allow \"-\" in file names, because it will be used to add additional extensions -to indicate compressed files.") - -(defconst efs-idle-host-types - (append '(coke unknown) efs-unix-host-types)) -;; List of host types for which it is possible that the SITE IDLE command -;; is supported. - -(defconst efs-listing-types - '(unix:dl unix:unknown - dos:novell dos:ftp dos:ncsa dos:microsoft dos:stcp dos:winsock - mvs:nih mvs:tcp mvs:tcp - vms:full) - "List of supported listing types") - -(defconst efs-nlist-listing-types - '(vms:full)) -;; Listing types which give a long useless listing when asked for a -;; LIST. For these, use an NLST instead. This can only be done -;; when there is some way to distinguish directories from -;; plain files in an NLST. - -(defconst efs-opaque-gateways '(remsh interactive)) -;; List of gateway types for which we need to do explicit file handling on -;; the gateway machine. - -;;;; ------------------------------------------------------------------ -;;;; User customization variables. Please read through these carefully. -;;;; ------------------------------------------------------------------ - -;;;>>>> If you are not fully connected to the internet, <<<< -;;;>>>> and need to use a gateway (no matter how transparent) <<<< -;;;>>>> you will need to set some of the following variables. <<<< -;;;>>>> Read the documentation carefully. <<<< - -(defvar efs-local-host-regexp ".*" - "Regexp to match names of local hosts. -These are hosts to which it is possible to obtain a direct internet -connection. Even if the host is accessible by a very transparent FTP gateway, -it does not qualify as a local host. The test to determine if machine A is -local to your machine is if it is possible to ftp from A _back_ to your -local machine. Also, open-network-stream must be able to reach the host -in question.") - -(defvar efs-ftp-local-host-regexp ".*" - "Regexp to match the names of hosts reachable by a direct ftp connection. -This regexp should match the names of hosts which can be reached using ftp, -without requiring any explicit connection to a gateway. If you have a smart -ftp client which is able to transparently go through a gateway, this will -differ from `efs-local-host-regexp'.") - -(defvar efs-gateway-host nil - "If non-nil, this must be the name of your ftp gateway machine. -If your net world is divided into two domains according to -`efs-local-ftp-host-regexp', set this variable to the name of the -gateway machine.") - -(defvar efs-gateway-type nil - "Specifies which type of gateway you wish efs to use. -This should be a list, the first element of which is a symbol denoting the -gateway type, and following elements give data on how to use the gateway. - -The following possibilities are supported: - - '(local FTP-PROGRAM FTP-PROGRAM-ARGS) - This means that your local host is itself the gateway. However, - you need to run a special FTP client to access outside hosts. - FTP-PROGRAM should be the name of this FTP client, and FTP-PROGRAM-ARGS - is a list of arguments to pass to it \(probably set this to the value of - efs-ftp-program-args <V>\). Note that if your gateway is of this type, - then you would set efs-gateway-host to nil. - - '(proxy FTP-PROGRAM FTP-PROGRAM-ARGS) - This indicates that your gateway works by first FTP'ing to it, and - then giving a USER command of the form \"USER <username>@<host>\". - FTP-PROGRAM is the FTP program to use to connect to the gateway; this - is most likely \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to - pass to it. You likely want this to be set to the value of - efs-ftp-program-args <V>. If the connection to the gateway FTP server - is to be on a port different from 21, set efs-gateway-host to - \"<host>#<port>\". - - '(raptor FTP-PROGRAM FTP-PROGRAM-ARGS USER) - This is for the gateway called raptor by Eagle. After connecting to the - the gateway, the command \"user <user>@host USER\" is issued to login - as <user> on <host>, where USER is an authentication username for the - gateway. After issuing the password for the remote host, efs will - send the password for USER on efs-gateway-host <V> as an account command. - - '(interlock FTP-PROGRAM FTP-PROGRAM-ARGS) - This is for the interlock gateway. The exact login sequence is to - connect to the gateway specified by efs-gateway-host <V>, send the - gateway password with a PASS command, send the command - \"user <user>@<host>\" to connect to remote host <host> as user <user>, - and finally to send the password for <user> on <host> with a second - PASS command. - - '(kerberos FTP-PROGRAM FTP-PROGRAM-ARGS KINIT-PROGRAM KINIT-PROGRAM-ARGS) - This is for the kerberos gateway where you need to run a program (kinit) to - obtain a ticket for gateway authroization first. FTP-PROGRAM should be - the name of the FTP client that you use to connect to the gateway. This - may likely be \"iftp\". FTP-PROGRAM-ARGS are the arguments that you need - to pass to FTP-PROGRAM. This is probably the value of - efs-ftp-program-args <V>. KINIT-PROGRAM is the name of the program to - run in order to obtain a ticket. This is probably \"kinit\". - KINIT-PROGRAM-ARGS is a list og strings indicating any arguments that you - need to pass to KINIT-PROGRAM. Most likely this is nil. - - '(remsh GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM FTP-PROGRAM-ARGS) - This indicates that you wish to run FTP on your gateway using a remote shell. - GATEWAY-PROGRAM is the name of the program to use to start a remote shell. - It is assumed that it is not necessary to provide a password to start - this remote shell. Likely values are \"remsh\" or \"rsh\". - GATEWAY-PROGRAM-ARGS is a list of arguments to pass to GATEWAY-PROGRAM. - FTP-PROGRAM is the name of the FTP program on the gateway. A likely setting - of this is \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass to - FTP-PROGRAM. Most likely these should be set to the value of - efs-ftp-program-args <V>. - - '(interactive GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM - FTP-PROGRAM-ARGS) - This indicates that you need to start an interactive login on your gatway, - using rlogin, telnet, or something similar. GATEWAY-PROGRAM is the name - of the program to use to log in to the gateway, and GATEWAY-PROGRAM-ARGS - is a list of arguments to pass to it. FTP-PROGRAM is the name of the FTP - program on the gateway. A likely setting for this variable would be - \"exec ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass - to FTP-PROGRAM. You probably want to set these to the same value as - efs-ftp-program-args <V>. If you are using this option, read the - documentation at the top of efs-gwp.el, and see - efs-gwp-setup-term-command <V>.") - -(defvar efs-gateway-hash-mark-size nil - "*Value of `efs-hash-mark-size' for FTP clients on `efs-gateway-host'. -See the documentation of these variables for more information.") - -(defvar efs-gateway-incoming-binary-hm-size nil - "*Value of `efs-incoming-binary-hm-size' for `efs-gateway-host'. -See documentation of these variables for more information.") - -(defvar efs-gateway-tmp-name-template "/tmp/efs" - "Template used to create temporary files when ftp-ing through a gateway. -This should be the name of the file on the gateway, and not necessarily -the name on the local host.") - -(defvar efs-gateway-mounted-dirs-alist nil - "An alist of directories cross-mounted between the gateway and local host. -Each entry is of the form \( DIR1 . DIR2 \), where DIR1 is the name of the -directory on the local host, and DIR2 is its name on the remote host. Both -DIR1 and DIR2 must be specified in directory syntax, i.e. end in a slash. -Note that we will assume that subdirs of DIR1 and DIR2 are also accessible -on both machines.") - -(defvar efs-gateway-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" - "*Regular expression to match the prompt of the gateway FTP client.") - -;;; End of gateway config variables. - -(defvar efs-tmp-name-template "/tmp/efs" - "Template used to create temporary files. -If you are worried about security, make this a directory in some -bomb-proof cave somewhere. efs does clean up its temp files, but -they do live for short periods of time.") - -(defvar efs-generate-anonymous-password t - "*If t, use a password of `user@host' when logging in as the anonymous user. -`host' is generated by the function `efs-system-fqdn'. If `system name' returns -a fully qualified domain name, `efs-system-fqdn' will return this. Otherwise, -it will attempt to use nslookup to obtain a fully qualified domain name. If -this is unsuccessful, the returned value will be the same as `system-name', -whether this is a fully qualified domain name or not. - -If a string then use that as the password. - -If nil then prompt the user for a password. - -Beware that some operating systems, such as MVS, restrict substantially -the password length. The login will fail with a weird error message -if you exceed it.") - -(defvar efs-high-security-hosts nil - "*Indicates host user pairs for which passwords should not be cached. -If non-nil, should be a regexp matching user@host constructions for which -efs should not store passwords in its internal cache.") - -;; The following regexps are tested in the following order: -;; efs-binary-file-host-regexp, efs-36-bit-binary-file-name-regexp, -;; efs-binary-file-name-regexp, efs-text-file-name-regexp. -;; File names which match nothing are transferred in 'image mode. - -;; If we're not careful, we're going to blow the regexp stack here. -;; Probably should move to a list of regexps. Slower, but safer. -;; This is not a problem in Emacs 19. -(defvar efs-binary-file-name-regexp - (concat "\\." ; the dot - ;; extensions - "\\([zZ]\\|t?gz\\|lzh\\|arc\\|zip\\|zoo\\|ta[rz]\\|dvi\\|sit\\|" - "ps\\|elc\\|gif\\|Z-part-..\\|tpz\\|exe\\|[jm]pg\\|TZ[a-z]?\\|lib\\)" - "\\(~\\|~[0-9]+~\\)?$" ; backups - "\\|" - ;; UPPER CASE LAND - "\\." - "\\(ARC\\|ELC\\|TAGS\\|EXE\\|ZIP\\|DVI\|ZOO\\|GIF\\|T?GZ\\|" - "[JM]PG\\)" - "\\([.#;][0-9]+\\)?$" ; versions - ) - "*Files whose names match this regexp will be considered to be binary. -By binary here, we mean 8-bit binary files (the usual unix binary files). -If nil, no files will be considered to be binary.") - -(defvar efs-binary-file-host-regexp nil - "*All files on hosts matching this regexp are treated as 8-bit binary. -Setting this to nil, inhibits this feature.") - -(defvar efs-36-bit-binary-file-name-regexp nil - "*Files whose names match this regexp will be considered to PDP 10 binaries. -These are 36-bit word-aligned binary files. This is really only relevant for -files on PDP 10's, and similar machines. If nil, no files will be considered -to be PDP 10 binaries.") - -(defvar efs-text-file-name-regexp ".*" - "*Files whose names match this regexp will be considered to be text files.") - -(defvar efs-prompt-for-transfer-type nil - "*If non-nil, efs will prompt for the transfer type for each file transfer. -The command efs-prompt-for-transfer-type can be used to toggle its value.") - -(defvar efs-treat-crlf-as-nl nil - "*Controls how file systems using CRLF as end of line are treated. -If non-nil, such file systems will be considered equivalent to those which use -LF as end of line. This is particularly relevant to transfers between DOS -systems and UNIX. Setting this to be non-nil will cause all file transfers -between DOS and UNIX systems to use be image or binary transfers.") - -(defvar efs-send-hash t - "*If non-nil, send the HASH command to the FTP client.") - -(defvar efs-hash-mark-size nil - "*Default size, in bytes, between hash-marks when transferring a file. -If this is nil then efs will attempt to assign a value based on the -output of the HASH command. Also, if this variable is incorrectly set, -then efs will try to correct it based on the size of the last file -transferred, and the number hashes outputed by the client during the -transfer. - -The variable `efs-gateway-hash-mark-size' defines the corresponding value -for the FTP client on the gateway, if you are using a gateway. - -Some client-server combinations do not correctly compute the number of hash -marks for incoming binary transfers. In this case, a separate variable -`efs-incoming-binary-hm-size' can be used to set a default value of the -hash mark size for incoming binary transfers.") - -(defvar efs-incoming-binary-hm-size nil - "*Default hash mark size for incoming binary transfers. -If this is nil, incoming binary transfers will use `efs-hash-mark-size' as -the default. See the documentation of this variable for more details.") - -(defvar efs-verbose t - "*If non-NIL then be chatty about interaction with the FTP process. -If 0 do not give % transferred reports for asynchronous commands and status -reports for commands verifying file modtimes, but report on everything else.") - -(defvar efs-message-interval 0 - "*Defines the minimum time in seconds between status messages. -A new status message is not displayed, if one has already been given -within this period of time.") - -(defvar efs-max-ftp-buffer-size 3000 - "*Maximum size in characters of FTP process buffer, before it is trimmed. -The buffer is trimmed to approximately half this size. Setting this to nil -inhibits trimming of FTP process buffers.") - -(defvar efs-ls-cache-max 5 - "*Maximum number of directory listings to be cached in efs-ls-cache.") - -(defvar efs-mode-line-format " ftp(%d)" - "Format string used to determine how FTP activity is shown on the mode line. -It is passed to format, with second argument the number of active FTP -sessions as an integer.") - -(defvar efs-show-host-type-in-dired t - "If non-nil, show the system type on the mode line of remote dired buffers.") - -(defvar efs-ftp-activity-function nil - "Function called to indicate FTP activity. -It must have exactly one argument, the number of active FTP sessions as an -integer.") - -(defvar efs-ftp-program-name "ftp" - "Name of FTP program to run.") - -(defvar efs-ftp-program-args '("-i" "-n" "-g" "-v") - "*A list of arguments passed to the FTP program when started.") - -(defvar efs-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" - "*Regular expression to match the prompt of your FTP client.") - -(defvar efs-nslookup-program "nslookup" - "*If non-NIL then a string naming nslookup program." ) - -(defvar efs-nslookup-on-connect nil - "*If non-NIL then use nslookup to resolve the host name before connecting.") - -(defvar efs-nslookup-threshold 1000 - "How many iterations efs waits on the nslookup program. -Applies when nslookup is used to compute a fully qualified domain name -for the local host, in the case when `system-name' does not return one. -If you set this to nil, efs will wait an arbitrary amount of time to get -output.") - -(defvar efs-remote-shell-file-name - (if (memq system-type '(hpux usg-unix-v)) ; hope that's right - "remsh" - "rsh") - "Remote shell used by efs.") - -(defvar efs-remote-shell-takes-user - (null (null (memq system-type '(aix aix-v3 hpux silicon-graphics-unix - berkeley-unix)))) - ;; Complete? Doubt it. - "Set to non-nil if your remote shell command takes \"-l USER\".") - -(defvar efs-make-backup-files efs-unix-host-types - "*A list of operating systems for which efs will make Emacs backup files. -The backup files are made on the remote host. - -For example: -'\(unix sysV-unix bsd-unix apollo-unix dumb-unix\) makes sense, but -'\(unix vms\) would be silly, since vms makes its own backups.") - -;; Is this variable really useful? We should try to figure a way to -;; do local copies on a remote machine that doesn't take forever. -(defvar efs-backup-by-copying nil - "*Version of `backup by copying' for remote files. -If non-nil, remote files will be backed up by copying, instead of by renaming. -Note the copying will be done by moving the file through the local host -- a -very time consuming operation.") - -;;; Auto-save variables. Relevant for auto-save.el - -(defvar efs-auto-save 0 - "*If 1, allows efs files to be auto-saved. -If 0, suppresses auto-saving of efs files. -Don't use any other value.") - -(defvar efs-auto-save-remotely nil - "*Determines where remote files are auto-saved. - -If nil, auto-saves for remote files will be written in `auto-save-directory' -or `auto-save-directory-fallback' if this isn't defined. - -If non-nil, causes the auto-save file for an efs file to be written in -the remote directory containing the file, rather than in a local directory. -For remote files, this overrides a non-nil `auto-save-directory'. Local files -are unaffected. If you want to use this feature, you probably only want to -set this true in a few buffers, rather than globally. You might want to give -each buffer its own value using `make-variable-buffer-local'. It is usually -a good idea to auto-save remote files locally, because it is not only faster, -but provides protection against a connection going down. - -See also variable `efs-auto-save'.") - -(defvar efs-short-circuit-to-remote-root nil - "*Defines whether \"//\" short-circuits to the remote or local root.") - -;; Can we somehow grok this from system type? No. -(defvar efs-local-apollo-unix - (eq 0 (string-match "//" (or (getenv "HOME") (getenv "SHELL") ""))) - "*Defines whether the local machine is an apollo running Domain. -This variable has nothing to do with efs, and should be basic to all -of emacs.") - -(defvar efs-root-umask nil - "*umask to use for root logins.") - -(defvar efs-anonymous-umask nil - "*umask to use for anonymous logins.") - -(defvar efs-umask nil - "*umask to use for efs sessions. -If this is nil, then the setting of umask on the local host is used.") - -;; Eliminate these variables when Sun gets around to getting its FTP server -;; out of the stone age. -(defvar efs-ding-on-umask-failure t - "*Ring the bell if the umask command fails on a unix host. Many servers don't -support this command, so if you get a lot of annoying failures, set this -to nil.") - -(defvar efs-ding-on-chmod-failure t - "*Ring the bell if the chmod command fails on a unix host. Some servers don't -support this command, so if you get a lot of annoying failures, set this -to nil.") - -;; Please let us know if you can contribute more entries to this guessing game. -(defvar efs-nlist-cmd - (cond - ;; Covers Ultrix, SunOS, and NeXT. - ((eq system-type 'berkeley-unix) - "ls") - ((memq system-type '(hpux aix-v3 silicon-graphics-unix)) - "nlist") - ;; Blind guess - ("ls")) - "*FTP client command for getting a brief listing (NLST) from the FTP server. -We try to guess this based on the local system-type, but obviously if you -are using a gateway, you'll have to set it yourself.") - -(defvar efs-compute-remote-buffer-file-truename nil - "*If non-nil, `buffer-file-truename' will be computed for remote buffers. -In emacs 19, each buffer has a local variable, `buffer-file-truename', -which is used to ensure that symbolic links will not confuse emacs into -visiting the same file with two buffers. This variable is computed by -chasing all symbolic links in `buffer-file-name', both at the level of the -file and at the level of all parent directories. Since this operation can be -very time-consuming over FTP, this variable can be used to inhibit it.") - -(defvar efs-buffer-name-case nil - "*Selects the case used for buffer names of case-insensitive file names. -Case-insensitive file names are files on hosts whose host type is in -`efs-case-insensitive-host-types'. - -If this is 'up upper case is used, if it is 'down lower case is used. -If this has any other value, the case is inherited from the name used -to access the file.") - -(defvar efs-fancy-buffer-names "%s@%s" - "Format used to compute names of buffers attached to remote files. - -If this is nil, buffer names are computed in the usual way. - -If it is a string, then the it is passed to format with second and third -arguments the host name and file name. - -Otherwise, it is assumed to be function taking three arguments, the host name, -the user name, and the truncated file name. It should returns the name to -be used for the buffer.") - -(defvar efs-verify-anonymous-modtime nil - "*Determines if efs checks modtimes for remote files on anonymous logins. -If non-nil, efs runs `verify-visited-file-modtime' for remote files on -anonymous ftp logins. Since verify-visited-file-modtime slows things down, -and most people aren't editing files on anonymous ftp logins, this is nil -by default.") - -(defvar efs-verify-modtime-host-regexp ".*" - "*Regexp to match host names for which efs checks file modtimes. -If non-nil, efs will run `verify-visited-file-modtime' for remote -files on hosts matching this regexp. If nil, verify-visited-file-modtime -is supressed for all remote hosts. This is tested before -`efs-verify-anonymous-modtime'.") - -(defvar efs-maximize-idle nil - "*If non-nil, efs will attempt to maximize the idle time out period. -At some idle moment in the connection after login, efs will attempt to -set the idle time out period to the maximum amount allowed by the server. -It applies only to non-anonymous logins on unix hosts.") - -(defvar efs-expire-ftp-buffers t - "*If non-nil ftp buffers will be expired. -The buffers will be killed either after `efs-ftp-buffer-expire-time' has -elapsed with no activity, or the remote FTP server has timed out.") - -(defvar efs-ftp-buffer-expire-time nil - "*If non-nil, the time after which ftp buffers will be expired. -If nil, ftp buffers will be expired only when the remote server has timed out. -If an integer, ftp buffers will be expired either when the remote server -has timed out, or when this many seconds on inactivity has elapsed.") - -;; If you need to increase this variable much, it is likely that -;; the true problem is timing errors between the efs process filter -;; and the FTP server. This could either be caused by the server -;; not following RFC959 response codes, or a bug in efs. In either -;; case please report the problem to us. If it's a bug, we'll fix it. -;; If the server is at fault we may try to do something. Our rule -;; of thumb is that we will support non-RFC959 behaviour, as long as -;; it doesn't risk breaking efs for servers which behave properly. - -(defvar efs-retry-time 5 - "*Number of seconds to wait before retrying if data doesn't arrive. -The FTP command isn't retried, rather efs just takes a second look -for the data file. This might need to be increased for very slow FTP -clients.") - -(defvar efs-pty-check-threshold 1000 - "*How long efs waits before deciding that it doesn't have a pty. -Specifically it is the number of iterations through `accept-process-output' -that `efs-pty-p' waits before deciding that the pty is really a pipe. -Set this to nil to inhibit checking for pty's. If efs seems to be -mistaking some pty's for pipes, try increasing this number.") - -(defvar efs-pty-check-retry-time 5 - "*Number of seconds that efs waits before retrying a pty check. -This can be lengthened, if your FTP client is slow to start.") - -(defvar efs-suppress-abort-recursive-edit-and-then nil - "*If non-nil, `efs-abort-recursive-edit-and-then' will not run its function. -This means that when a recursive edit is in progress, automatic popping of the -FTP process buffer, and automatic popping of the bug report buffer will not -work. `efs-abort-recursive-edit-and-then' works by forking a \"sleep 0\" -process. On some unix implementations the forked process might be of the same -size as the original GNU Emacs process. Forking such a large process just to -do a \"sleep 0\" is probably not good.") - -(defvar efs-ftp-buffer-format "*ftp %s@%s*" - "Format to construct the name of FTP process buffers. -This string is fed to `format' with second and third arguments the user -name and host name.") -;; This does not affect the process name of the FTP client process. -;; That is always *ftp USER@HOST* - -(defvar efs-debug-ftp-connection nil - "*If non-nil, the user will be permitted to debug the FTP connection. -This means that typing a C-g to the FTP process filter will give the user -the option to type commands at the FTP connection. Normally, the connection -is killed first. Note that doing this may result in the FTP process filter -getting out of synch with the FTP client, so using this feature routinely -isn't recommended.") - -(defvar efs-use-passive-mode nil - "*If non-nil, the ftp client will specify passive mode for all transfers.") - -;;; Hooks and crooks. - -(defvar efs-ftp-startup-hook nil - "Hook to run immediately after starting the FTP client. -This hook is run before the FTP OPEN command is sent.") - -(defvar efs-ftp-startup-function-alist nil - "Association list of functions to running after FTP login. -This should be an alist of the form '\(\(REGEXP . FUNCTION\) ...\), where -REGEXP is a regular expression matched against the name of the remote host, -and FUNCTION is a function of two arguments, HOST and USER. REGEXP is -compared to the host name with `case-fold-search' bound to t. Only the first -match in the alist is run.") - -(defvar efs-load-hook nil - "Hook to run immediately after loading efs.el. -You can use it to alter definitions in efs.el, but why would you want -to do such a thing?") - -;;;; ----------------------------------------------------------- -;;;; Regexps for parsing FTP server responses. -;;;; ----------------------------------------------------------- -;;; -;;; If you have to tune these variables, please let us know, so that -;;; we can get them right in the next release. - -(defvar efs-multi-msgs - ;; RFC959 compliant codes - "^[1-5][0-5][0-7]-") -;; Regexp to match the start of an FTP server multiline reply. - -(defvar efs-skip-msgs - ;; RFC959 compliant codes - (concat - "^110 \\|" ; Restart marker reply. - "^125 \\|" ; Data connection already open; transfer starting. - "^150 ")) ; File status OK; about to open connection. -;; Regexp to match an FTP server response which we wish to ignore. - -(defvar efs-cmd-ok-msgs - ;; RFC959 compliant - "^200 \\|^227 ") -;; Regexp to match the server command OK response. -;; Because PORT commands return this we usually ignore it. However, it is -;; a valid response for TYPE, SITE, and a few other commands (cf. RFC 959). -;; If we are explicitly sending a PORT, or one of these other commands, -;; then we don't want to ignore this response code. Also use this to match -;; the return code for PASV, as some clients burp these things out at odd -;; times. - -(defvar efs-pending-msgs - ;; RFC959 compliant - "^350 ") ; Requested file action, pending further information. -;; Regexp to match the \"requested file action, pending further information\" -;; message. These are usually ignored, except if we are using RNFR to test for -;; file existence. - -(defvar efs-cmd-ok-cmds - (concat - "^quote port \\|^type \\|^quote site \\|^chmod \\|^quote noop\\|" - "^quote pasv\\|^passive")) -;; Regexp to match commands for which efs-cmd-ok-msgs is a valid server -;; response for success. - -(defvar efs-passwd-cmds - "^quote pass \\|^quote acct \\|^quote site gpass ") -;; Regexp to match commands for sending passwords. -;; All text following (match-end 0) will be replaced by "Turtle Power!" - -(defvar efs-bytes-received-msgs - ;; Strictly a client response - "^[0-9]+ bytes ") -;; Regexp to match the reply from the FTP client that it has finished -;; receiving data. - -(defvar efs-server-confused-msgs - ;; ka9q uses this to indicate an incorrectly set transfer mode, and - ;; then does send a second completion code for the command. This does - ;; *not* conform to RFC959. - "^100 Warning: type is ") -;; Regexp to match non-standard response from the FTP server. This can -;; sometimes be the result of an incorrectly set transfer mode. In this case -;; we do not rely on the server to tell us when the data transfer is complete, -;; but check with the client. - -(defvar efs-good-msgs - (concat - ;; RFC959 compliant codes - "^2[01345][0-7] \\|" ; 2yz = positive completion reply - "^22[02-7] \\|" ; 221 = successful logout - ; (Sometimes get this with a timeout, - ; so treat as fatal.) - "^3[0-5][0-7] \\|" ; 3yz = positive intermediate reply - ;; passive - "^[Pp]assive \\|" - ;; client codes - "^[Hh]ash mark ")) -;; Response to indicate that the requested action was successfully completed. - -(defvar efs-failed-msgs - (concat - ;; RFC959 compliant codes - "^120 \\|" ; Service ready in nnn minutes. - "^450 \\|" ; File action not taken; file is unavailable, or busy. - "^452 \\|" ; Insufficient storage space on system. - "^5[0-5][0-7] \\|" ; Permanent negative reply codes. - ;; When clients tell us that a file doesn't exist, or can't access. - "^\\(local: +\\)?/[^ ]* +" - "\\([Nn]o such file or directory\\|[Nn]ot a plain file\\|" - "The file access permissions do not allow \\|Is a directory\\b\\)")) -;; Regexp to match responses for failed commands. However, the ftp connection -;; is assumed to be good. - -(defvar efs-fatal-msgs - (concat - ;; RFC959 codes - "^221 \\|" ; Service closing control connection. - "^421 \\|" ; Service not available. - "^425 \\|" ; Can't open data connection. - "^426 \\|" ; Connection closed, transfer aborted. - "^451 \\|" ; Requested action aborted, local error in processing. - ;; RFC959 non-compliant codes - "^552 Maximum Idle Time Exceded\\.$\\|" ; Hellsoft server uses this to - ; indicate a timeout. 552 is - ; supposed to be used for exceeded - ; storage allocation. Note that - ; they also misspelled the error - ; message. - ;; client problems - "^ftp: \\|^Not connected\\|^rcmd: \\|^No control connection\\|" - "^unknown host\\|: unknown host$\\|^lost connection\\|" - "^[Ss]egmentation fault\\|" - ;; Make sure that the "local: " isn't just a message about a file. - "^local: [^/]\\|" - ;; Gateways - "^iftp: cannot authenticate to server\\b" - )) -;; Regexp to match responses that something has gone drastically wrong with -;; either the client, server, or connection. We kill the ftp process, and start -;; anew. - -(defvar efs-unknown-response-msgs - "^[0-9][0-9][0-9] ") -;; Regexp to match server response codes that we don't understand. This -;; is tested after all the other regexp, so it can match everything. - -(defvar efs-pasv-msgs - ;; According to RFC959. - "^227 .*(\\([0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+\\))$") -;; Matches the output of a PASV. (match-beginning 1) and (match-end 1) -;; must bracket the IP address and port. - -(defvar efs-syst-msgs "^215 \\|^210 ") -;; 215 is RFC959. Plan 9 FTP server returns a 210. 210 is not assigned in -;; RFC 959. -;; The plan 9 people tell me that they fixed this. -- sr 18/4/94 -;; Matches the output of a SYST. - -(defvar efs-mdtm-msgs - (concat - "^213 [0-9][0-9][0-9][0-9][0-9][0-9][0-9]" - "[0-9][0-9][0-9][0-9][0-9][0-9][0-9]$")) -;; Regexp to match the output of a quote mdtm command. - -(defvar efs-idle-msgs - "^200 [^0-9]+ \\([0-9]+\\)[^0-9]* max \\([0-9]+\\)") -;; Regexp to match the output of a SITE IDLE command. -;; Match 1 should refer to the current idle time, and match 2 the maximum -;; idle time. - -(defvar efs-write-protect-msgs "^532 ") ; RFC959 -;; Regexp to match a server ressponse to indicate that a STOR failed -;; because of insufficient write privileges. - -(defvar efs-hash-mark-msgs - "[hH]ash mark [^0-9]*\\([0-9]+\\)") -;; Regexp matching the FTP client's output upon doing a HASH command. - -(defvar efs-xfer-size-msgs - (concat - ;; UN*X - "^150 .* connection for .* (\\([0-9]+\\) bytes)\\|" - ;; Wollongong VMS server. - "^125 .* transfer started for .* (\\([0-9]+\\) bytes)\\|" - ;; TOPS-20 server - "^150 .* retrieve of .* ([0-9]+ pages?, \\([0-9]+\\) 7-bit bytes)")) -;; Regular expression used to determine the number of bytes -;; in a FTP transfer. The first (match-beginning #) which is non-nil is assumed -;; to give the size. - -(defvar efs-expand-dir-msgs "^550 \\([^: ]+\\):") -;; Regexp to match the error response from a "get ~sandy". -;; By parsing the error, we can get a quick expansion of ~sandy -;; According to RFC 959, should be a 550. - -(defvar efs-gateway-fatal-msgs - "No route to host\\|Connection closed\\|No such host\\|Login incorrect") -;; Regular expression matching messages from the rlogin / telnet process that -;; indicates that logging in to the gateway machine has gone wrong. - -(defvar efs-too-many-users-msgs - ;; The test for "two many" is because some people can't spell. - ;; I allow for up to two adjectives before "users". - (concat - "\\b[Tt][wo]o many\\( +[^ \n]+\\)?\\( +[^ \n]+\\)? +users\\b\\|" - "\\btry back later\\b")) -;; Regular expresion to match what servers output when there are too many -;; anonymous logins. It is assumed that this is part of a 530 or 530- response -;; to USER or PASS. - -;;;; ------------------------------------------------------------- -;;;; Buffer local FTP process variables -;;;; ------------------------------------------------------------- - -;;; Variables buffer local to the process buffers are -;;; named with the prefix efs-process- - -(defvar efs-process-q nil) -;; List of functions to be performed asynch. -(make-variable-buffer-local 'efs-process-q) - -(defvar efs-process-cmd-waiting nil) -;; Set to t if a process has a synchronous cmd waiting to execute. -;; In this case, it will allow the synch. cmd to run before returning to -;; the cmd queue. -(make-variable-buffer-local 'efs-process-cmd-waiting) - -(defvar efs-process-server-confused nil) -(make-variable-buffer-local 'efs-process-server-confused) - -(defvar efs-process-cmd nil) -;; The command currently being executed, as a string. -(make-variable-buffer-local 'efs-process-cmd) - -(defvar efs-process-xfer-size 0) -(make-variable-buffer-local 'efs-process-xfer-size) - -(defvar efs-process-umask nil) -;; nil if the umask hash not been set -;; an integer (the umask) if the umask has been set -(make-variable-buffer-local 'efs-process-umask) - -(defvar efs-process-idle-time nil) -;; If non-nil, the idle time of the server in seconds. -(make-variable-buffer-local 'efs-process-idle-time) - -(defvar efs-process-busy nil) -(make-variable-buffer-local 'efs-process-busy) - -(defvar efs-process-result-line "") -(make-variable-buffer-local 'efs-process-result-line) - -(defvar efs-process-result nil) -(make-variable-buffer-local 'efs-process-result) - -(defvar efs-process-result-cont-lines "") -(make-variable-buffer-local 'efs-process-result-cont-lines) - -(defvar efs-process-msg "") -(make-variable-buffer-local 'efs-process-msg) - -(defvar efs-process-nowait nil) -(make-variable-buffer-local 'efs-process-nowait) - -(defvar efs-process-string "") -(make-variable-buffer-local 'efs-process-string) - -(defvar efs-process-continue nil) -(make-variable-buffer-local 'efs-process-continue) - -(defvar efs-process-hash-mark-count 0) -(make-variable-buffer-local 'efs-process-hash-mark-count) - -(defvar efs-process-hash-mark-unit nil) -(make-variable-buffer-local 'efs-process-hash-mark-unit) - -(defvar efs-process-last-percent -1) -(make-variable-buffer-local 'efs-process-last-percent) - -(defvar efs-process-host nil) -(make-variable-buffer-local 'efs-process-host) - -(defvar efs-process-user nil) -(make-variable-buffer-local 'efs-process-user) - -(defvar efs-process-host-type nil) -;; Holds the host-type as a string, for showing it on the mode line. -(make-variable-buffer-local 'efs-process-host-type) - -(defvar efs-process-xfer-type nil) -;; Set to one of 'ascii, 'ebcdic, 'image, 'tenex, or nil to indicate -;; the current setting of the transfer type for the connection. nil means -;; that we don't know. -(make-variable-buffer-local 'efs-process-xfer-type) - -(defvar efs-process-client-altered-xfer-type nil) -;; Sometimes clients alter the xfer type, such as doing -;; an ls it is changed to ascii. If we are using quoted commands -;; to do xfers the client doesn't get a chance to set it back. -(make-variable-buffer-local 'efs-process-client-altered-xfer-type) - -(defvar efs-process-prompt-regexp nil) -;; local value of prompt of FTP client. -(make-variable-buffer-local 'efs-process-prompt-regexp) - -(defvar efs-process-cmd-counter 0) -;; Counts FTP commands, mod 16. -(make-variable-buffer-local 'efs-process-cmd-counter) - -;;;; ------------------------------------------------------------ -;;;; General Internal Variables. -;;;; ------------------------------------------------------------ - -;;; For the byte compiler -;; -;; These variables are usually unbound. We are just notifying the -;; byte compiler that we know what we are doing. - -(defvar bv-length) ; getting file versions. -(defvar default-file-name-handler-alist) ; for file-name-handler-alist -(defvar efs-completion-dir) ; for file name completion predicates -(defvar dired-directory) ; for default actions in interactive specs -(defvar dired-local-variables-file) ; for inhibiting child look ups -(defvar dired-in-query) ; don't clobber dired queries with stat messages -(defvar after-load-alist) ; in case we're in emacs 18. -(defvar comint-last-input-start) -(defvar comint-last-input-end) -(defvar explicit-shell-file-name) - -;;; fluid vars - -(defvar efs-allow-child-lookup t) -;; let-bind to nil, if want to inhibit child lookups. - -(defvar efs-nested-cmd nil) -;; let-bound to t, when a cmd is executed by a cont or pre-cont. -;; Such cmds will never end by looking at the next item in the queue, -;; if they are run synchronously, but rely on their calling function -;; to do this. - -;;; polling ftp buffers - -(defvar efs-ftp-buffer-poll-time 300 - "Period, in seconds, which efs will poll ftp buffers for activity. -Used for expiring \(killing\) inactive ftp buffers.") - -(defconst efs-ftp-buffer-alist nil) -;; alist of ftp buffers, and the total number of seconds that they -;; have been idle. - -;;; load extensions - -(defvar efs-load-lisp-extensions '(".elc" ".el" "") - "List of extensions to try when loading lisp files.") - -;;; mode-line - -(defvar efs-mode-line-string "") -;; Stores the string that efs displays on the mode line. - -;;; data & temporary buffers - -(defvar efs-data-buffer-name " *ftp data*") -;; Buffer name to hold directory listing data received from ftp process. - -(defvar efs-data-buffer-name-2 " *ftp data-2*") -;; A second buffer name in which to hold directory listings. -;; Used for listings which are made during another directory listing. - -;;; process names - -(defvar efs-ctime-process-name-format "*efs ctime %s*") -;; Passed to format with second arg the host name. - -;;; For temporary files. - -;; This is a list of symbols. -(defconst efs-tmp-name-files ()) -;; Here is where these symbols live: -(defconst efs-tmp-name-obarray (make-vector 7 0)) -;; We put our version of the emacs PID here: -(defvar efs-pid nil) - -;;; For abort-recursive-edit - -(defvar efs-abort-recursive-edit-data nil) -(defvar efs-abort-recursive-edit-delay 5) -;; Number of seconds after which efs-abort-recursive-edit-and-then -;; will decide not to runs its sentinel. The assumption is that something -;; went wrong. - -;;; hashtables (Use defconst's to clobber any user silliness.) - -(defconst efs-files-hashtable (efs-make-hashtable 97)) -;; Hash table for storing directories and their respective files. - -(defconst efs-expand-dir-hashtable (efs-make-hashtable)) -;; Hash table of tilde expansions for remote directories. - -(defconst efs-ls-converter-hashtable (efs-make-hashtable 37)) -;; Hashtable for storing functions to convert listings from one -;; format to another. Keys are the required switches, and the values -;; are alist of the form ((SWITCHES . CONVERTER)...) where is SWITCHES -;; are the listing switches for the original listing, and CONVERTER is a -;; function of one-variable, the listing-type, to do the conversion -;; on data in the current buffer. SWITCHES is either a string, or nil. -;; nil means that the listing can be converted from cache in -;; efs-files-hashtable, a string from cache in efs-ls-cache. For the latter, -;; listings with no switches (dumb listings), represent SWITCHES as a string -;; consisting only of the ASCII null character. - -;;; cache variables (Use defconst's to clobber any user sillines.) - -(defconst efs-ls-cache nil - "List of results from efs-ls. -Each entry is a list of four elements, the file listed, the switches used -\(nil if none\), the listing string, and whether this string has already been -parsed.") - -(defvar efs-ls-uncache nil) -;; let-bind this to t, if you want to be sure that efs-ls will replace any -;; cache entries. - -;; This is a cache to see if the user has changed -;; completion-ignored-extensions. -(defconst efs-completion-ignored-extensions completion-ignored-extensions - "This variable is internal to efs. Do not set. -See completion-ignored-extensions, instead.") - -;; We cache the regexp we use for completion-ignored-extensions. This -;; saves building a string every time we do completion. String construction -;; is costly in emacs. -(defconst efs-completion-ignored-pattern - (mapconcat (function - (lambda (s) (if (stringp s) - (concat (regexp-quote s) "$") - "/"))) ; / never in filename - efs-completion-ignored-extensions - "\\|") - "This variable is internal to efs. Do not set. -See completion-ignored-extensions, instead.") - -(defvar efs-system-fqdn nil - "Cached value of the local systems' fully qualified domain name.") - -;;; The file-type-alist - -;; efs-file-type-alist is an alist indexed by host-type -;; which stores data on how files are structured on the given -;; host-type. Each entry is a list of three elements. The first is the -;; definition of a `byte', the second the native character representation, -;; and the third, the file structure. -;; -;; Meanings of the symbols: -;; ------------------------ -;; The byte symbols: -;; 8-bit = bytes of 8-bits -;; 36-bit-wa = 36-bit word aligned. Precisely, the addressing unit is that -;; of a PDP-10 using the "<440700,,0> byte pointer". -;; -;; The native character set symbols: -;; 8-ascii = 8-bit NVT-ASCII -;; 7-ascii = 7-bit ascii as on a PDP-10 -;; ebcdic = EBCDIC as on an IBM mainframe -;; lispm = the native character set on a lispm (Symbolics and LMI) -;; mts = native character representation in the Michigan Terminal System -;; (which runs on IBM and Amdal mainframes), similar to ebcdic -;; -;; The file structure symbols: -;; -;; file-nl = data is stored as a contiguous sequence of data bytes -;; with EOL denoted by <NL>. -;; file-crlf = data is stored as a contiguous sequence of data bytes -;; with EOL denoted by <CR-LF> -;; record = data is stored as a sequence of records -;; file-lispm = data as stored on a lispm. i.e. a sequence of bits -;; with EOL denoted by character code 138 (?) -;; -;; If we've messed anything up here, please let us know. - -(defvar efs-file-type-alist - '((unix . (8-bit 8-ascii file-nl)) - (sysV-unix . (8-bit 8-ascii file-nl)) - (bsd-unix . (8-bit 8-ascii file-nl)) - (apollo-unix . (8-bit 8-ascii file-nl)) - (dumb-apollo-unix . (8-bit 8-ascii file-nl)) - (dumb-unix . (8-bit 8-ascii file-nl)) - (super-dumb-unix . (8-bit 8-ascii file-nl)) - (guardian . (8-bit ascii file-nl)) - (plan9 . (8-bit 8-ascii file-nl)) - (dos . (8-bit 8-ascii file-crlf)) - (ms-unix . (8-bit 8-ascii file-crlf)) - (netware . (8-bit 8-ascii file-crlf)) - (os2 . (8-bit 8-ascii file-crlf)) - (tops-20 . (36-bit-wa 7-ascii file-crlf)) - (mpe . (8-bit 8-ascii record)) - (mvs . (8-bit ebcdic record)) - (cms . (8-bit ebcdic record)) - (cms-knet . (8-bit ebcdic record)) - (mts . (8-bit mts record)) ; mts seems to have its own char rep. - ; Seems to be close to ebcdic, but not the same. - (dos-distinct . (8-bit 8-ascii file-crlf)) - (ka9q . (8-bit 8-ascii file-crlf)) - (vms . (8-bit 8-ascii record)) ; The mysteries of VMS's RMS. - (hell . (8-bit 8-ascii file-crlf)) - (vos . (8-bit 8-ascii record)) - (ti-explorer . (8-bit lispm file-lispm)) ; lispms use a file structure, but - ; use an out of range char to - ; indicate EOL. - (ti-twenex . (8-bit lispm file-lispm)) - (nos-ve . (8-bit 8-ascii record)) - (coke . (8-bit 8-ascii file-nl)) ; only support 8-bit beverages - (nil . (8-bit 8-ascii file-nl)))) ; the local host - -;;; Status messages - -(defvar efs-last-message-time -86400) ; yesterday -;; The time of the last efs status message. c.f. efs-message-interval - -;;; For handling dir listings - -;; This MUST match all the way to to the start of the filename. -;; This version corresponds to what dired now uses (sandy, 14.1.93) -(defvar efs-month-and-time-regexp - (concat - " \\([0-9]+\\) +" ; file size - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct" - ; June and July are for HP-UX 9.0 - "\\|Nov\\|Dec\\) \\([ 0-3][0-9]\\)\\(" - " [012][0-9]:[0-6][0-9] \\|" ; time - " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo - ; HP-UX, A/UX - " [12][90][0-9][0-9] \\)" ; year on AIX - )) - -(defvar efs-month-alist - '(("Jan" . 1) ("Feb". 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) - ("June" . 6) ("Jul" . 7) ("July" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) - ("Nov" . 11) ("Dec" . 12))) - -;; Matches the file modes, link number, and owner string. -;; The +/- is for extended file access permissions. -(defvar efs-modes-links-owner-regexp - (concat - "\\([^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ]\\)[-+]? *\\([0-9]+\\)" - " +\\([^ ]+\\) ")) - -;;;; --------------------------------------------------------------- -;;;; efs-dired variables -;;;; --------------------------------------------------------------- - -;; These variables must be here, instead of in efs-dired.el, because -;; the efs-HOST-TYPE.el files need to add to it. -(defvar efs-dired-re-exe-alist nil - "Association list of regexps which match file lines of executable files.") - -(defvar efs-dired-re-dir-alist nil - "Association list of regexps which match file lines of subdirectories.") - -(defvar efs-dired-host-type nil - "Host type of a dired buffer. \(buffer local\)") -(make-variable-buffer-local 'efs-dired-host-type) - -(defvar efs-dired-listing-type nil - "Listing type of a dired buffer. \(buffer local\)") -(make-variable-buffer-local 'efs-dired-listing-type) - -(defvar efs-dired-listing-type-string nil) -(make-variable-buffer-local 'efs-dired-listing-type-string) - -;;;; ------------------------------------------------------------- -;;;; New error symbols. -;;;; ------------------------------------------------------------- - -(put 'ftp-error 'error-conditions '(ftp-error file-error error)) -;; (put 'ftp-error 'error-message "FTP error") - - -;;;; ============================================================= -;;;; >3 -;;;; Utilities -;;;; ============================================================= - -;;; ------------------------------------------------------------------- -;;; General Macros (Make sure that macros are defined before they're -;;; used, for the byte compiler. -;;; ------------------------------------------------------------------- - -(defmacro efs-kbd-quit-protect (proc &rest body) - ;; When an efs function controlling an FTP connection gets a kbd-quit - ;; this tries to make sure that everything unwinds consistently. - (let ((temp (make-symbol "continue"))) - (list 'let - (list '(quit-flag nil) - '(inhibit-quit nil) - (list temp t)) - (list - 'while temp - (list 'setq temp nil) - (list - 'condition-case nil - (cons 'progn - body) - (list 'quit - (list 'setq temp - (list 'efs-kbd-quit-protect-cover-quit proc)))))))) - -(defun efs-kbd-quit-protect-cover-quit (proc) - ;; This function exists to keep the macro expansion of the - ;; efs-kbd-quit-protect down to a reasonable size. - (let ((pop-up-windows t) - (buff (get-buffer (process-buffer proc))) - res) - (if (save-window-excursion - (if buff - (progn - (pop-to-buffer buff) - (goto-char (point-max)) - (recenter (- (window-height) - 2)))) - (setq res (efs-kill-ftp-buffer-with-prompt proc buff))) - (progn - (if (eq res 0) - (if (eq (selected-window) - (minibuffer-window)) - (efs-abort-recursive-edit-and-then - (function - (lambda (buff) - (if (get-buffer buff) - (display-buffer buff)))) - buff) - (if (get-buffer buff) - (display-buffer buff)) - (signal 'quit nil)) - (if (eq (selected-window) (minibuffer-window)) - (abort-recursive-edit) - (signal (quote quit) nil))) - nil) - (sit-for 0) - (message "Waiting on %s..." (or (car (efs-parse-proc-name proc)) - "a whim")) - t))) - -(put 'efs-kbd-quit-protect 'lisp-indent-hook 1) - -(defmacro efs-save-buffer-excursion (&rest forms) - "Execute FORMS, restoring the current buffer afterwards. -Unlike, save-excursion, this does not restore the point." - (let ((temp (make-symbol "saved-buff"))) - (list 'let - (list (list temp '(current-buffer))) - (list 'unwind-protect - (cons 'progn forms) - (list 'condition-case nil - (list 'set-buffer temp) - '(error nil)))))) - -(put 'efs-save-buffer-excursion 'lisp-indent-hook 0) - -(defmacro efs-unquote-dollars (string) - ;; Unquote $$'s to $'s in STRING. - (` (let ((string (, string)) - (start 0) - new) - (while (string-match "\\$\\$" string start) - (setq new (concat new (substring - string start (1+ (match-beginning 0)))) - start (match-end 0))) - (if new - (concat new (substring string start)) - string)))) - -(defmacro efs-get-file-part (path) - ;; Given PATH, return the file part used for looking up the file's entry - ;; in a hashtable. - ;; This need not be the same thing as file-name-nondirectory. - (` (let ((file (file-name-nondirectory (, path)))) - (if (string-equal file "") - "." - file)))) - -(defmacro efs-ftp-path-macro (path) - ;; Just a macro version of efs-ftp-path, for speed critical - ;; situations. Could use (inline ...) instead, but not everybody - ;; uses the V19 byte-compiler. Also, doesn't call efs-save-match-data, - ;; but assumes that the calling function does it. - (` - (let ((path (, path))) - (or (string-equal path efs-ftp-path-arg) - (setq efs-ftp-path-res - (and (string-match efs-path-regexp path) - (let ((host (substring path (match-beginning 2) - (match-end 2))) - (user (and (match-beginning 1) - (substring path (match-beginning 1) - (1- (match-end 1))))) - (rpath (substring path (1+ (match-end 2))))) - (list (if (string-equal host "") - (setq host (system-name)) - host) - (or user (efs-get-user host)) - rpath))) - ;; Set this last, in case efs-get-user calls this function, - ;; which would modify an earlier setting. - efs-ftp-path-arg path)) - efs-ftp-path-res))) - -(defmacro efs-canonize-switches (switches) - ;; Converts a switches string, into a lexographically ordered string, - ;; omitting - and spaces. Should we remove duplicate characters too? - (` (if (, switches) - (mapconcat - 'char-to-string - (sort (delq ?- (delq ?\ (mapcar 'identity (, switches)))) '<) "") - ;; For the purpose of interning in a hashtable, represent the nil - ;; switches, as a string consisting of the ascii null character. - (char-to-string 0)))) - -(defmacro efs-canonize-file-name (fn) - ;; Canonizes the case of file names. - (` (let ((parsed (efs-ftp-path (, fn)))) - (if parsed - (let ((host (car parsed))) - (if (memq (efs-host-type host) efs-case-insensitive-host-types) - (downcase (, fn)) - (format efs-path-format-string (nth 1 parsed) (downcase host) - (nth 2 parsed)))) - (, fn))))) - -(defmacro efs-get-files-hashtable-entry (fn) - (` (efs-get-hash-entry (efs-canonize-file-name (, fn)) efs-files-hashtable))) - -;;;; ------------------------------------------------------------ -;;;; Utility Functions -;;;; ------------------------------------------------------------ - -(defun efs-kill-ftp-buffer-with-prompt (proc buffer) - ;; Does a 3-way prompt to kill a ftp PROC and BUFFER. - ;; Returns t if buffer was killed, 0 if only process, nil otherwise. - (let ((inhibit-quit t) - (cursor-in-echo-area t) - char) - (message - (if efs-debug-ftp-connection - "Kill ftp process and buffer (y[es], n[o], c[lose], d[ebug] ) " - "Kill ftp process and buffer? (y or n, c to only close process) ")) - (setq char (read-char)) - (prog1 - (cond - ((memq char '(?y ?Y ?\ )) - (set-process-sentinel proc nil) - (condition-case nil - (kill-buffer buffer) - (error nil)) - t) - ((memq char '(?c ?C)) - (set-process-sentinel proc nil) - (condition-case nil - (save-excursion - (set-buffer buffer) - (setq efs-process-busy nil - efs-process-q nil) - (delete-process proc)) - (error nil)) - 0) - ((memq char '(?n ?N)) - (message "") - nil) - ((and efs-debug-ftp-connection - (memq char '(?d ?D))) - (condition-case nil - (save-excursion - (set-buffer buffer) - (setq efs-process-busy nil - efs-process-q nil)) - (error nil)) - 0) - (t - (message - (if efs-debug-ftp-connection - "Type one of y, n, c or d." - "Type one of y, n or c.")) - (ding) - (sit-for 1) - (setq quit-flag nil) - (efs-kill-ftp-buffer-with-prompt proc buffer)))))) - -(defun efs-barf-if-not-directory (directory) - ;; Signal an error if DIRECTORY is not one. - (or (file-directory-p directory) - (signal 'file-error - (list "Opening directory" - (if (file-exists-p directory) - "not a directory" - "no such file or directory") - directory)))) - -(defun efs-call-cont (cont &rest args) - "Call the function specified by CONT. -CONT can be either a function or a list of a function and some args. -The first parameters passed to the function will be ARGS. The remaining -args will be taken from CONT if a list was passed." - (if cont - (let ((efs-nested-cmd t)) ; let-bound so that conts don't pop any queues - (efs-save-buffer-excursion - (if (and (listp cont) - (not (eq (car cont) 'lambda))) - (apply (car cont) (append args (cdr cont))) - (apply cont args)))))) - -(defun efs-replace-path-component (fullpath path) - "For FULLPATH matching efs-path-regexp replace the path component with PATH." - (efs-save-match-data - (if (string-match efs-path-root-regexp fullpath) - (concat (substring fullpath 0 (match-end 0)) path) - path))) - -(defun efs-abort-recursive-edit-and-then (fun &rest args) - ;; Does an abort-recursive-edit, and runs fun _after_ emacs returns to - ;; top level. - (if (get-process "efs-abort-recursive-edit") - ;; Don't queue these things. Clean them out. - (delete-process "efs-abort-recursive-edit")) - (or efs-suppress-abort-recursive-edit-and-then - (progn - (setq efs-abort-recursive-edit-data (cons (nth 1 (current-time)) - (cons fun args))) - (condition-case nil - (set-process-sentinel - (let ((default-directory exec-directory) - (process-connection-type nil)) - (start-process "efs-abort-recursive-edit" nil "sleep" "0")) - (function - (lambda (proc string) - (let ((data efs-abort-recursive-edit-data)) - (setq efs-abort-recursive-edit-data) - (if (and data - (integerp (car data)) - (<= (- (nth 1 (current-time)) (car data)) - efs-abort-recursive-edit-delay)) - (apply (nth 1 data) (nthcdr 2 data))))))) - (error nil)))) - (abort-recursive-edit)) - -(defun efs-occur-in-string (char string) - ;; Return the number of occurrences of CHAR in STRING. - (efs-save-match-data - (let ((regexp (regexp-quote (char-to-string char))) - (count 0) - (start 0)) - (while (string-match regexp string start) - (setq start (match-end 0) - count (1+ count))) - count))) - -(defun efs-parse-proc-name (proc) - ;; Parses the name of process to return a list \(host user\). - (efs-save-match-data - (let ((name (process-name proc))) - (and name - (string-match "^\\*ftp \\([^@]*\\)@\\([^*]+\\)\\*$" name) - (list (substring name (match-beginning 2) (match-end 2)) - (substring name (match-beginning 1) (match-end 1))))))) - -;;;; ------------------------------------------------------------ -;;;; Of Geography, connectivity, and the internet... Gateways. -;;;; ------------------------------------------------------------ - -(defun efs-use-gateway-p (host &optional opaque-p) -;; Returns whether to access this host via a gateway. -;; Returns the gateway type as a symbol. See efs-gateway-type <V>. -;; If optional OPAQUE-P is non-nil, only returns non-nil if the gateway -;; type is in the list efs-opaque-gateways <V>. - (and efs-gateway-type - host ;local host is nil - (efs-save-match-data - (and (not (string-match efs-ftp-local-host-regexp host)) - (let ((type (car efs-gateway-type))) - (if opaque-p - (and (memq type efs-opaque-gateways) type) - type)))))) - -(defun efs-local-to-gateway-filename (filename &optional reverse) - ;; Converts a FILENAME on the local host to its name on the gateway, - ;; using efs-gateway-mounted-dirs-alist. If REVERSE is non-nil, does just - ;; that. If the there is no corresponding name because non of its parent - ;; directories are mounted, returns nil. - (if efs-gateway-mounted-dirs-alist - (let ((len (length filename)) - (alist efs-gateway-mounted-dirs-alist) - result elt elt-len) - (if reverse - (while (setq elt (car alist)) - (if (and (>= len (setq elt-len (length (cdr elt)))) - (string-equal (cdr elt) (substring filename 0 elt-len))) - (setq result (concat (car elt) - (substring filename elt-len)) - alist nil) - (setq alist (cdr alist)))) - (while (setq elt (car alist)) - (if (and (>= len (setq elt-len (length (car elt)))) - (string-equal (car elt) (substring filename 0 elt-len))) - (setq result (concat (cdr elt) - (substring filename elt-len)) - alist nil) - (setq alist (cdr alist))))) - result))) - -;;; ------------------------------------------------------------ -;;; Enhanced message support. -;;; ------------------------------------------------------------ - -(defun efs-message (fmt &rest args) - "Output the given message, truncating to the size of the minibuffer window." - (let ((msg (apply (function format) fmt args)) - (max (window-width (minibuffer-window)))) - (if (>= (length msg) max) - (setq msg (concat "> " (substring msg (- 3 max))))) - (message "%s" msg))) - -(defun efs-message-p () - ;; Returns t, if efs is allowed to display a status message. - (not - (or (and (boundp 'dired-in-query) dired-in-query) - (boundp 'search-message) - cursor-in-echo-area - (and (/= efs-message-interval 0) - (let ((diff (- efs-last-message-time - (setq efs-last-message-time - (nth 1 (current-time)))))) - (and - (> diff (- efs-message-interval)) - (< diff 0))))))) ; in case the clock wraps. - -(efs-define-fun efs-relativize-filename (file &optional dir new) - "Abbreviate the given filename relative to DIR . -If DIR is nil, use the value of `default-directory' for the currently selected -window. If the optional parameter NEW is given and the -non-directory parts match, only return the directory part of the file." - (let* ((dir (or dir (save-excursion - (set-buffer (window-buffer (selected-window))) - default-directory))) - (dlen (length dir)) - (result file)) - (and (> (length file) dlen) - (string-equal (substring file 0 dlen) dir) - (setq result (substring file dlen))) - (and new - (string-equal (file-name-nondirectory result) - (file-name-nondirectory new)) - (or (setq result (file-name-directory result)) - (setq result "./"))) - (abbreviate-file-name result))) - -;;; ------------------------------------------------------------ -;;; Temporary file location and deletion... -;;; ------------------------------------------------------------ - -(defun efs-get-pid () - ;; Half-hearted attempt to get the current process's id. - (setq efs-pid (substring (make-temp-name "") 1))) - -(defun efs-make-tmp-name (host1 host2) - ;; Returns the name of a new temp file, for moving data between HOST1 - ;; and HOST2. This temp file must be directly accessible to the - ;; FTP client connected to HOST1. Using nil for either HOST1 or - ;; HOST2 means the local host. The return value is actually a list - ;; whose car is the name of the temp file wrto to the local host - ;; and whose cdr is the name of the temp file wrto to the host - ;; on which the client connected to HOST1 is running. If the gateway - ;; is only accessible by FTP, then the car of this may be in efs extended - ;; file name syntax. - (let ((pid (or efs-pid (efs-get-pid))) - (start ?a) - file entry template rem-template template-len) - ;; Compute the templates. - (if (null (and host1 (efs-use-gateway-p host1 t))) - ;; file must be local - (if (null (and host2 (efs-use-gateway-p host2 t))) - (setq template efs-tmp-name-template) - (setq template (or (efs-local-to-gateway-filename - efs-gateway-tmp-name-template t) - efs-tmp-name-template))) - ;; file must be on the gateway -- make sure that the gateway - ;; configuration is sensible. - (efs-save-match-data - (or (string-match efs-ftp-local-host-regexp efs-gateway-host) - (error "Gateway %s must be directly ftp accessible." - efs-gateway-host))) - (setq rem-template efs-gateway-tmp-name-template - template (or (efs-local-to-gateway-filename - efs-gateway-tmp-name-template t) - (format efs-path-format-string - (efs-get-user efs-gateway-host) - efs-gateway-host - efs-gateway-tmp-name-template)) - template-len (length template))) - ;; Compute a new file name. - (while (let (efs-verbose) - (setq file (format "%s%c%s" template start pid) - entry (intern file efs-tmp-name-obarray)) - (or (memq entry efs-tmp-name-files) - (file-exists-p file))) - (if (> (setq start (1+ start)) ?z) - (progn - (setq template (concat template "X")) - (setq start ?a)))) - (setq efs-tmp-name-files - (cons entry efs-tmp-name-files)) - (if rem-template - (cons file (concat rem-template (substring file template-len))) - (cons file file)))) - -(defun efs-del-tmp-name (temp) - ;; Deletes file TEMP, a string. - (setq efs-tmp-name-files - (delq (intern temp efs-tmp-name-obarray) - efs-tmp-name-files)) - (condition-case () - (let (efs-verbose) - (delete-file temp)) - (error nil))) - - -;;;; ============================================================== -;;;; >4 -;;;; Hosts, Users, Accounts, and Passwords -;;;; ============================================================== -;;; -;;; A lot of the support for this type of thing is in efs-netrc.el. - -;;;; ------------------------------------------------------------ -;;;; Password support. -;;;; ------------------------------------------------------------ - -(defun efs-lookup-passwd (host user) - ;; Look up the password for HOST and USER. - (let ((ent (efs-get-host-user-property host user 'passwd))) - (and ent (efs-code-string ent)))) - -(defun efs-system-fqdn () - "Returns a fully qualified domain name for the current host, if possible." - (or efs-system-fqdn - (setq efs-system-fqdn - (let ((sys (system-name))) - (if (string-match "\\." sys) - sys - (if efs-nslookup-program - (let ((proc (let ((default-directory exec-directory) - (process-connection-type nil)) - (start-process " *nslookup*" " *nslookup*" - efs-nslookup-program sys))) - (res sys) - (n 0)) - (process-kill-without-query proc) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((quit-flag nil) - (inhibit-quit nil)) - (if efs-nslookup-threshold - (progn - (while (and (memq (process-status proc) - '(run open)) - (< n efs-nslookup-threshold)) - (accept-process-output) - (setq n (1+ n))) - (if (>= n efs-nslookup-threshold) - (progn - (with-output-to-temp-buffer "*Help*" - (princ (format "\ -efs is unable to determine a fully qualified domain name -for the local host to send as an anonymous ftp password. - -The function `system-name' is not returning a fully qualified -domain name. An attempt to obtain a fully qualified domain name -with `efs-nslookup-program' (currently set to \"%s\") has -elicited no response from that program. Consider setting -`efs-generate-anonymous-password' to an email address for anonymous -ftp passwords. - -For more information see the documentation (use C-h v) for the -variables `efs-nslookup-program' and `efs-nslookup-threshold'." - efs-nslookup-program))) - (error "No response from %s" - efs-nslookup-program)))) - (while (memq (process-status proc) '(run open)) - (accept-process-output proc))) - (goto-char (point-min)) - (if (re-search-forward - (format "^Name: *\\(%s\\.[^ \n\t]+\\)" - sys) nil t) - (setq res (buffer-substring - (match-beginning 1) - (match-end 1))) - (kill-buffer (current-buffer))))) - res) - sys)))))) - -(defun efs-passwd-unique-list (alist) - ;; Preserving the relative order of ALIST, remove all entries with duplicate - ;; cars. - (let (result) - (while alist - (or (assoc (car alist) result) - (setq result (cons (car alist) result))) - (setq alist (cdr alist))) - (nreverse result))) - -(defun efs-get-passwd-list (user host) - ;; Returns an alist of the form '((pass host user) ...). - ;; The order is essentially arbitrary, except that entries with user - ;; equal to USER will appear first. Followed by entries with host equal to - ;; HOST. Also, there will be no entries with duplicate values of pass. - (efs-parse-netrc) - (let* ((user-template (concat "/" user)) - (ulen (length user-template)) - (hlen (length host)) - primaries secondaries tertiaries) - (efs-save-match-data - (efs-map-hashtable - (function - (lambda (key passwd) - (cond ((null passwd) nil) - ((and (> (length key) ulen) - (string-equal user-template - (substring key (- ulen)))) - (setq primaries (cons (list (efs-code-string passwd) - (substring key 0 (- ulen)) - (substring user-template 1)) - primaries))) - ((and (> (length key) hlen) - (string-equal host (substring key 0 hlen)) - (memq (aref key hlen) '(?/ ?.))) - (if (string-match "/" key hlen) - (setq secondaries - (cons (list (efs-code-string passwd) - (substring key 0 (match-beginning 0)) - (substring key (match-end 0))) - secondaries)))) - ((string-match "/" key) - (setq tertiaries - (cons (list (efs-code-string passwd) - (substring key 0 (match-beginning 0)) - (substring key (match-end 0))) - tertiaries)))))) - efs-host-user-hashtable 'passwd)) - (efs-passwd-unique-list (nconc primaries secondaries tertiaries)))) - -(defun efs-get-passwd (host user) - "Given a HOST and USER, return the FTP password, prompting if it was not -previously set." - (efs-parse-netrc) - - ;; look up password in the hash table first; user might have overriden the - ;; defaults. - (cond ((efs-lookup-passwd host user)) - - ;; see if default user and password set from the .netrc file. - ((and (stringp efs-default-user) - efs-default-password - (string-equal user efs-default-user)) - (copy-sequence efs-default-password)) - - ;; anonymous ftp password is handled specially since there is an - ;; unwritten rule about how that is used on the Internet. - ((and (efs-anonymous-p user) - efs-generate-anonymous-password) - (if (stringp efs-generate-anonymous-password) - (copy-sequence efs-generate-anonymous-password) - (concat (user-login-name) "@" (efs-system-fqdn)))) - - ;; see if same user has logged in to other hosts; if so then prompt - ;; with the password that was used there. - (t - (let (others defaults passwd) - (unwind-protect - (progn - (setq others (efs-get-passwd-list user host) - defaults (mapcar - (function - (lambda (x) - (cons - (format - "Passwd for %s@%s (same as %s@%s): " - user host (nth 2 x) (nth 1 x)) - (car x)))) - others)) - (setq passwd - (read-passwd - (or defaults - (format "Password for %s@%s: " user host))))) - (while others - (fillarray (car (car others)) 0) - (setq others (cdr others)))) - (or (null passwd) - (and efs-high-security-hosts - (efs-save-match-data - (string-match efs-high-security-hosts - (format "%s@%s" user host)))) - (efs-set-passwd host user passwd)) - passwd)))) - -;;;; ------------------------------------------------------------ -;;;; Account support -;;;; ------------------------------------------------------------ - -(defun efs-get-account (host user &optional minidisk really) - "Given a HOST, USER, and optional MINIDISK return the FTP account password. -If the optional REALLY argument is given, prompts the user if it can't find -one." - (efs-parse-netrc) - (let ((account (if minidisk - (efs-get-hash-entry - (concat (downcase host) "/" user "/" minidisk) - efs-minidisk-hashtable - (memq (efs-host-type host) - efs-case-insensitive-host-types)) - (efs-get-host-user-property host user 'account)))) - (if account - (efs-code-string account) - ;; Do we really want to send the default-account passwd for all - ;; minidisks? - (if (and (stringp efs-default-user) - (string-equal user efs-default-user) - efs-default-account) - efs-default-account - (and really - (let ((acct - (read-passwd - (if minidisk - (format - "Write access password for minidisk %s on %s@%s: " - minidisk user host) - (format - "Account password for %s@%s: " user host))))) - (or (and efs-high-security-hosts - (efs-save-match-data - efs-high-security-hosts - (format "%s@%s" user host))) - (efs-set-account host user minidisk acct)) - acct)))))) - -;;;; ------------------------------------------------------------- -;;;; Special classes of users. -;;;; ------------------------------------------------------------- - -(defun efs-anonymous-p (user) - ;; Returns t if USER should be treated as an anonymous FTP login. - (let ((user (downcase user))) - (or (string-equal user "anonymous") (string-equal user "ftp")))) - - -;;;; ============================================================= -;;;; >5 -;;;; FTP client process, and server responses -;;;; ============================================================= - -;;;; --------------------------------------------------------- -;;;; Support for asynch process queues. -;;;; --------------------------------------------------------- - -(defun efs-add-to-queue (host user item) - "To the end of the command queue for HOST and USER, adds ITEM. -Does nothing if there is no process buffer for HOST and USER." - (let ((buff (efs-ftp-process-buffer host user))) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-q - (nconc efs-process-q (list item))))))) - -;;;; ------------------------------------------------------- -;;;; Error recovery for the process filter. -;;;; ------------------------------------------------------- - -;;; Could make this better, but it's such an unlikely error to hit. -(defun efs-process-scream-and-yell (line) - (let* ((buff (buffer-name (current-buffer))) - (host (and (string-match "@\\(.*\\)\\*$" buff) - (substring buff (match-beginning 1) (match-end 1))))) - (with-output-to-temp-buffer "*Help*" - (princ - (concat - "efs is unable to identify the following reply code -from the ftp server " host ":\n\n" line " - -Please send a bug report to ange@hplb.hpl.hp.com. -In your report include a transcript of your\n" -buff " buffer.")))) - (error "Unable to identify server code.")) - -(defun efs-error (host user msg) - "Signal \'ftp-error for the FTP connection for HOST and USER. -The error gives the string MSG as text. The process buffer for the FTP -is popped up in another window." - (let ((cur (selected-window)) - (pop-up-windows t) - (buff (get-buffer (efs-ftp-process-buffer host user)))) - (if buff - (progn - (pop-to-buffer buff) - (goto-char (point-max)) - (select-window cur)))) - (signal 'ftp-error (list (format "FTP Error: %s" msg)))) - -;;;; -------------------------------------------------------------------- -;;;; Process filter and supporting functions for handling FTP codes. -;;;; -------------------------------------------------------------------- - -(defun efs-process-handle-line (line proc) - ;; Look at the given LINE from the ftp process PROC and try to catagorize it. - (cond ((string-match efs-xfer-size-msgs line) - (let ((n 1)) - ;; this loop will bomb with an args out of range error at 10 - (while (not (match-beginning n)) - (setq n (1+ n))) - (setq efs-process-xfer-size - (ash (string-to-int (substring line - (match-beginning n) - (match-end n))) - -10)))) - - ((string-match efs-multi-msgs line) - (setq efs-process-result-cont-lines - (concat efs-process-result-cont-lines line "\n"))) - - ((string-match efs-skip-msgs line)) - - ((string-match efs-cmd-ok-msgs line) - (if (string-match efs-cmd-ok-cmds efs-process-cmd) - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line))) - - ((string-match efs-pending-msgs line) - (if (string-match "^quote rnfr " efs-process-cmd) - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line))) - - ((string-match efs-bytes-received-msgs line) - (if efs-process-server-confused - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line))) - - ((string-match efs-server-confused-msgs line) - (setq efs-process-server-confused t)) - - ((string-match efs-good-msgs line) - (setq efs-process-busy nil - efs-process-result nil - efs-process-result-line line)) - - ((string-match efs-fatal-msgs line) - (set-process-sentinel proc nil) - (delete-process proc) - (setq efs-process-busy nil - efs-process-result 'fatal - efs-process-result-line line)) - - ((string-match efs-failed-msgs line) - (setq efs-process-busy nil - efs-process-result 'failed - efs-process-result-line line)) - - ((string-match efs-unknown-response-msgs line) - (setq efs-process-busy nil - efs-process-result 'weird - efs-process-result-line line) - (efs-process-scream-and-yell line)))) - -(efs-define-fun efs-process-log-string (proc str) - ;; For a given PROCESS, log the given STRING at the end of its - ;; associated buffer. - (let ((buff (get-buffer (process-buffer proc)))) - (if buff - (efs-save-buffer-excursion - (set-buffer buff) - (comint-output-filter proc str))))) - -(defun efs-process-filter (proc str) - ;; Build up a complete line of output from the ftp PROCESS and pass it - ;; on to efs-process-handle-line to deal with. - (let ((inhibit-quit t) - (buffer (get-buffer (process-buffer proc))) - (efs-default-directory default-directory)) - - ;; see if the buffer is still around... it could have been deleted. - (if buffer - (efs-save-buffer-excursion - (set-buffer (process-buffer proc)) - (efs-save-match-data - - ;; handle hash mark printing - (if efs-process-busy - (setq str (efs-process-handle-hash str) - efs-process-string (concat efs-process-string str))) - (efs-process-log-string proc str) - (while (and efs-process-busy - (string-match "\n" efs-process-string)) - (let ((line (substring efs-process-string - 0 - (match-beginning 0)))) - (setq efs-process-string (substring - efs-process-string - (match-end 0))) - ;; If we are in synch with the client, we should - ;; never get prompts in the wrong place. Just to be safe, - ;; chew them off. - (while (string-match efs-process-prompt-regexp line) - (setq line (substring line (match-end 0)))) - (efs-process-handle-line line proc))) - - ;; has the ftp client finished? if so then do some clean-up - ;; actions. - (if (not efs-process-busy) - (progn - (efs-correct-hash-mark-size) - ;; reset process-kill-without-query - (process-kill-without-query proc) - ;; issue the "done" message since we've finished. - (if (and efs-process-msg - (efs-message-p) - (null efs-process-result)) - (progn - - (efs-message "%s...done" efs-process-msg) - (setq efs-process-msg nil))) - - (if (and efs-process-nowait - (null efs-process-cmd-waiting)) - - (progn - ;; Is there a continuation we should be calling? - ;; If so, we'd better call it, making sure we - ;; only call it once. - (if efs-process-continue - (let ((cont efs-process-continue)) - (setq efs-process-continue nil) - (efs-call-cont - cont - efs-process-result - efs-process-result-line - efs-process-result-cont-lines))) - ;; If the cmd was run asynch, run the next - ;; cmd from the queue. For synch cmds, this - ;; is done by efs-send-cmd. For asynch - ;; cmds we don't care about - ;; efs-nested-cmd, since nothing is - ;; waiting for the cmd to complete. If - ;; efs-process-cmd-waiting is t, exit - ;; to let this command run. - (if (and efs-process-q - ;; Be careful to check efs-process-busy - ;; again, because the cont may have started - ;; some new ftp action. - ;; wheels within wheels... - (null efs-process-busy)) - (let ((next (car efs-process-q))) - (setq efs-process-q - (cdr efs-process-q)) - (apply 'efs-send-cmd - efs-process-host - efs-process-user - next)))) - - (if efs-process-continue - (let ((cont efs-process-continue)) - (setq efs-process-continue nil) - (efs-call-cont - cont - efs-process-result - efs-process-result-line - efs-process-result-cont-lines)))) - - ;; Update the mode line - ;; We can't test nowait to see if we changed the - ;; modeline in the first place, because conts - ;; may be running now, which will confuse the issue. - ;; The logic is simpler if we update the modeline - ;; before the cont, but then the user sees the - ;; modeline track the cont execution. It's dizzying. - (if (and (or efs-mode-line-format - efs-ftp-activity-function) - (null efs-process-busy)) - (efs-update-mode-line))))) - - ;; Trim buffer, if required. - (and efs-max-ftp-buffer-size - (zerop efs-process-cmd-counter) - (> (point-max) efs-max-ftp-buffer-size) - (= (point-min) 1) ; who knows, the user may have narrowed. - (null (get-buffer-window (current-buffer))) - (save-excursion - (goto-char (/ efs-max-ftp-buffer-size 2)) - (forward-line 1) - (delete-region (point-min) (point)))))))) - -;;;; ------------------------------------------------------------------ -;;;; Functions for counting hashes and reporting on bytes transferred. -;;;; ------------------------------------------------------------------ - -(defun efs-set-xfer-size (host user bytes) - ;; Set the size of the next FTP transfer in bytes. - (let ((proc (efs-get-process host user))) - (if proc - (let ((buf (process-buffer proc))) - (if buf - (save-excursion - (set-buffer buf) - (setq efs-process-xfer-size (ash bytes -10)))))))) - -(defun efs-guess-incoming-bin-hm-size () - ;; Guess at the hash mark size for incoming binary transfers by taking - ;; the average value for such transfers to other hosts. - (let ((total 0) - (n 0)) - (efs-map-hashtable - (function - (lambda (host hm-size) - (if hm-size (setq total (+ total hm-size) - n (1+ n))))) - efs-host-hashtable - 'incoming-bin-hm-size) - (and (> n 0) (/ total n)))) - -(defun efs-set-hash-mark-unit (host user &optional incoming) - ;; Sets the value of efs-process-hash-mark-unit according to the xfer-type. - ;; efs-hash-mark-unit is the number of bytes represented by a hash mark, - ;; in units of 16. If INCOMING is non-nil, the xfer will be a GET. - (if efs-send-hash - (let ((buff (efs-ftp-process-buffer host user)) - (gate-p (efs-use-gateway-p host t))) - (if buff - (save-excursion - (set-buffer buff) - (setq efs-process-hash-mark-unit - (ash (or - (and incoming (eq efs-process-xfer-type 'image) - (or (efs-get-host-property - host 'incoming-bin-hm-size) - (if gate-p - efs-gateway-incoming-binary-hm-size - efs-incoming-binary-hm-size) - (let ((guess - (efs-guess-incoming-bin-hm-size))) - (and guess - (efs-set-host-property - host 'incoming-bin-hm-size - guess))))) - (if gate-p - efs-gateway-hash-mark-size - efs-hash-mark-size) - 1024) ; make sure that we have some integer - -4))))))) - -(defun efs-correct-hash-mark-size () - ;; Corrects the value of efs-{ascii,binary}-hash-mark-size. - ;; Must be run in the process buffer. - (and efs-send-hash - efs-process-hash-mark-unit - (> efs-process-xfer-size 0) - (< efs-process-xfer-size 524288) ; 2^19, prevent overflows - (> efs-process-hash-mark-count 0) - (or (> efs-process-last-percent 100) - (< (ash (* efs-process-hash-mark-unit - (1+ efs-process-hash-mark-count )) -6) - efs-process-xfer-size)) - (let ((val (ash (/ (ash efs-process-xfer-size 6) - efs-process-hash-mark-count) 4))) - (if (and (eq efs-process-xfer-type 'image) - (>= (length efs-process-cmd) 4) - (string-equal (downcase (substring efs-process-cmd 0 4)) - "get ")) - (efs-set-host-property efs-process-host 'incoming-bin-hm-size val) - (set (if (efs-use-gateway-p efs-process-host t) - 'efs-gateway-hash-mark-size - 'efs-hash-mark-size) - val))))) - -(defun efs-process-handle-hash (str) - ;; Remove hash marks from STRING and display count so far. - (if (string-match "^#+$" str) - (progn - (setq efs-process-hash-mark-count - (+ efs-process-hash-mark-count - (- (match-end 0) (match-beginning 0)))) - (and - efs-process-msg - efs-process-hash-mark-unit - (not (and efs-process-nowait - (or (eq efs-verbose 0) - (eq (selected-window) (minibuffer-window))))) - (efs-message-p) - (let* ((big (> efs-process-hash-mark-count 65536)) ; 2^16 - (kbytes (if big - (* efs-process-hash-mark-unit - (ash efs-process-hash-mark-count -6)) - (ash (* efs-process-hash-mark-unit - efs-process-hash-mark-count) - -6)))) - (if (zerop efs-process-xfer-size) - (or (zerop kbytes) - (efs-message "%s...%dk" efs-process-msg kbytes)) - (let ((percent (if big - (/ (* 100 (ash kbytes -7)) - (ash efs-process-xfer-size -7)) - (/ (* 100 kbytes) efs-process-xfer-size)))) - ;; Don't display %'s betwwen 100 and 110 - (and (> percent 100) (< percent 110) (setq percent 100)) - ;; cut out the redisplay of identical %-age messages. - (or (eq percent efs-process-last-percent) - (progn - (setq efs-process-last-percent percent) - (efs-message "%s...%d%%" efs-process-msg percent))))))) - (concat (substring str 0 (match-beginning 0)) - (and (/= (length str) (match-end 0)) - (substring str (1+ (match-end 0)))))) - str)) - -;;;; ------------------------------------------------------------------ -;;;; Keeping track of the number of active background connections. -;;;; ------------------------------------------------------------------ - -(defun efs-ftp-processes-active () - ;; Return the number of FTP processes busy. - (save-excursion - (length - (delq nil - (mapcar - (function - (lambda (buff) - (set-buffer buff) - (and (boundp 'efs-process-busy) - efs-process-busy))) - (buffer-list)))))) - -(defun efs-update-mode-line () - ;; Updates the mode with FTP activity, and runs `efs-ftp-activity-function'. - (let ((num (efs-ftp-processes-active))) - (if efs-mode-line-format - (progn - (if (zerop num) - (setq efs-mode-line-string "") - (setq efs-mode-line-string (format efs-mode-line-format num))) - ;; fake emacs into re-calculating all the mode lines. - (save-excursion (set-buffer (other-buffer))) - (set-buffer-modified-p (buffer-modified-p)))) - (if efs-ftp-activity-function - (funcall efs-ftp-activity-function num)))) - -;;;###autoload -(defun efs-display-ftp-activity () - "Displays the number of active background ftp sessions in the modeline. -Uses the variable `efs-mode-line-format' to determine how this will be -displayed." - (interactive) - (or (memq 'efs-mode-line-string global-mode-string) - (if global-mode-string - (nconc global-mode-string '(efs-mode-line-string)) - (setq global-mode-string '("" efs-mode-line-string))))) - -;;;; ------------------------------------------------------------------- -;;;; Expiring inactive ftp buffers. -;;;; ------------------------------------------------------------------- - -(defun efs-start-polling () - ;; Start polling FTP buffers, to look for idle ones. - (or (null efs-expire-ftp-buffers) - (let ((proc (get-process "efs poll"))) - (or (and proc (eq (process-status proc) 'run)))) - (let ((default-directory exec-directory) - (process-connection-type nil) - new-proc) - (condition-case nil - (delete-process "efs poll") - (error nil)) - (setq new-proc (start-process - "efs poll" nil - (concat exec-directory "wakeup") - (int-to-string efs-ftp-buffer-poll-time))) - (set-process-filter new-proc (function efs-expire-ftp-buffers-filter)) - (process-kill-without-query new-proc)))) - -(defun efs-connection-visited-p (host user) - ;; Returns t if there are any buffers visiting files on HOST and USER. - (save-excursion - (let ((list (buffer-list)) - (case-fold (memq (efs-host-type host) - efs-case-insensitive-host-types)) - (visited nil) - parsed) - (setq host (downcase host)) - (if case-fold (setq user (downcase user))) - (while list - (set-buffer (car list)) - (if (or (and buffer-file-name - (setq parsed (efs-ftp-path buffer-file-name)) - (string-equal host (downcase (car parsed))) - (string-equal user (if case-fold - (downcase (nth 1 parsed)) - (nth 1 parsed)))) - (and (boundp 'dired-directory) - (stringp dired-directory) - efs-dired-host-type - (setq parsed (efs-ftp-path dired-directory)) - (string-equal host (downcase (car parsed))) - (string-equal user (if case-fold - (downcase (nth 1 parsed)) - (nth 1 parsed))))) - (setq visited t - list nil) - (setq list (cdr list)))) - visited))) - -(defun efs-expire-ftp-buffers-filter (proc string) - ;; Check all ftp buffers, and kill them if they have been inactive - ;; for the minimum of efs-ftp-buffer-expire-time and their local - ;; time out time. - (if efs-expire-ftp-buffers - (let ((list (buffer-list)) - new-alist) - (save-excursion - (while list - (set-buffer (car list)) - (if (eq major-mode 'efs-mode) - (let* ((proc (get-buffer-process (current-buffer))) - (proc-p (and proc (memq (process-status proc) - '(run open))))) - (if (or efs-ftp-buffer-expire-time - efs-process-idle-time - (null proc-p)) - (let ((elt (assq (car list) efs-ftp-buffer-alist)) - (wind-p (get-buffer-window (car list)))) - (if (or (null elt) (buffer-modified-p) - efs-process-busy wind-p) - (progn - (setq new-alist (cons (cons (car list) 0) - new-alist)) - (or wind-p (set-buffer-modified-p nil))) - (let ((idle (+ (cdr elt) - efs-ftp-buffer-poll-time))) - (if (and proc-p - (< idle - (if efs-ftp-buffer-expire-time - (if efs-process-idle-time - (min efs-ftp-buffer-expire-time - efs-process-idle-time) - efs-ftp-buffer-expire-time) - efs-process-idle-time))) - (progn - (setq new-alist (cons (cons (car list) idle) - new-alist)) - (set-buffer-modified-p nil)) - ;; If there are still buffers for host & user, - ;; don't wipe the cache. - (and proc - (efs-connection-visited-p - efs-process-host efs-process-user) - (set-process-sentinel proc nil)) - (kill-buffer (car list))))))))) - (setq list (cdr list)))) - (setq efs-ftp-buffer-alist new-alist)) - (condition-case nil - (delete-process "efs poll") - (error nil)))) - -;;;; ------------------------------------------------------------------- -;;;; When the FTP client process dies... -;;;; ------------------------------------------------------------------- - -(defun efs-process-sentinel (proc str) - ;; When ftp process changes state, nuke all file-entries in cache. - (let ((buff (process-buffer proc))) - ;; If the client dies, make sure that efs doesn't think that - ;; there is a running process. - (save-excursion - (condition-case nil - (progn - (set-buffer buff) - (setq efs-process-busy nil)) - (error nil))) - (let ((parsed (efs-parse-proc-name proc))) - (if parsed - (progn - (apply 'efs-wipe-file-entries parsed) - (apply 'efs-wipe-from-ls-cache parsed)))) - (if (or efs-mode-line-format efs-ftp-activity-function) - (efs-update-mode-line)))) - -(defun efs-kill-ftp-process (buffer) - "Kill an FTP connection and its associated process buffer. -If the BUFFER's visited file name or default-directory is an efs remote -file name, it is the connection for that file name that is killed." - (interactive "bKill FTP process associated with buffer: ") - (or buffer (setq buffer (current-buffer))) - (save-excursion - (set-buffer buffer) - (if (eq major-mode 'efs-mode) - (kill-buffer buffer) - (let ((file (or (buffer-file-name) default-directory))) - (if file - (let ((parsed (efs-ftp-path (expand-file-name file)))) - (if parsed - (let ((host (nth 0 parsed)) - (user (nth 1 parsed))) - (kill-buffer - (efs-ftp-process-buffer host user)))))))))) - -(defun efs-close-ftp-process (buffer) - "Close an FTP connection. -This kills the FTP client process, but unlike `efs-kill-ftp-process' this -neither kills the process buffer, nor deletes cached data for the connection." - (interactive "bClose FTP process associated with buffer: ") - (or buffer (setq buffer (current-buffer))) - (save-excursion - (set-buffer buffer) - (if (eq major-mode 'efs-mode) - (let ((process (get-buffer-process buffer))) - (if process - (progn - (set-process-sentinel process nil) - (setq efs-process-busy nil - efs-process-q nil) - (if (or efs-mode-line-format efs-ftp-activity-function) - (efs-update-mode-line)) - (delete-process process)))) - (let ((file (or (buffer-file-name) default-directory))) - (if file - (let ((parsed (efs-ftp-path (expand-file-name file)))) - (if parsed - (let ((process (get-process - (format "*ftp %s@%s*" - (nth 1 parsed) (car parsed))))) - (if process - (progn - (set-buffer (process-buffer process)) - (set-process-sentinel process nil) - (setq efs-process-busy nil - efs-process-q nil) - (if (or efs-mode-line-format - efs-ftp-activity-function) - (efs-update-mode-line)) - (delete-process process))))))))))) - -(defun efs-ping-ftp-connection (buffer) - "Ping a connection by sending a NOOP command. -Useful for waking up a possible expired connection." - (interactive "bPing FTP connection associated with buffer: ") - (or buffer (setq buffer (current-buffer))) - (efs-save-buffer-excursion - (set-buffer buffer) - (let (file host user parsed) - (if (or (and (eq major-mode 'efs-mode) - (setq host efs-process-host - user efs-process-user)) - (and (setq file (or (buffer-file-name) default-directory)) - (setq parsed (efs-ftp-path file)) - (setq host (car parsed) - user (nth 1 parsed)))) - (or (car - (efs-send-cmd - host user '(quote noop) - (format "Pinging connection %s@%s" user host))) - (message "Connection %s@%s is alive." user host)))))) - -(defun efs-display-ftp-process-buffer (buffer) - "Displays the FTP process buffer associated with the current buffer." - (interactive "bDisplay FTP buffer associated with buffer: ") - (if (null buffer) (setq buffer (current-buffer))) - (let ((file (or (buffer-file-name) default-directory)) - parsed proc-buffer) - (if (and file (setq parsed (efs-ftp-path file)) - (setq proc-buffer (get-buffer (efs-ftp-process-buffer - (car parsed) - (nth 1 parsed))))) - (display-buffer proc-buffer) - (error "Buffer %s not associated with an FTP process" buffer)))) - -;;;; ------------------------------------------------------------------- -;;;; Starting the FTP client process -;;;; ------------------------------------------------------------------- - -(defun efs-ftp-process-buffer (host user) - "Return name of the process buffer for ftp process for HOST and USER." - ;; Host names on the internet are case-insensitive. - (format efs-ftp-buffer-format user (downcase host))) - -(defun efs-pty-check (proc threshold) - ;; Checks to see if PROC is a pty. Beware, it clobbers the process - ;; filter, so run this before you set the filter. - ;; THRESHOLD is an integer to tell it how long to wait for output. - (sit-for 0) ; Update the display before doing any waiting. - (let ((efs-pipe-p t) - (n 0)) - (set-process-filter proc (function (lambda (proc string) - (setq efs-pipe-p nil)))) - (while (and (< n threshold) efs-pipe-p) - (accept-process-output) - (setq n (1+ n))) - (if efs-pipe-p - (progn - (sit-for 0) ; update display - ;; Use a sleep-for as I don't want pty-checking to depend - ;; on pending input. - (sleep-for efs-pty-check-retry-time))) - (accept-process-output) - (if efs-pipe-p - (if (or noninteractive - (progn - ;; in case the user typed something during the wait. - (discard-input) - (y-or-n-p - (format "%s seems not a pty. Kill? " proc)))) - (progn - (kill-buffer (process-buffer proc)) - (if (eq (selected-window) (minibuffer-window)) - (abort-recursive-edit) - (signal 'quit nil)))) - ;; Need to send a \n to make sure, because sometimes we get the startup - ;; prompt from a pipe. - (sit-for 0) - (process-send-string proc "\n") - (setq efs-pipe-p t - n 0) - (while (and (< n threshold) efs-pipe-p) - (accept-process-output) - (setq n (1+ n))) - (if efs-pipe-p - (progn - (sit-for 0) - (sleep-for efs-pty-check-retry-time))) - (accept-process-output) - (if (and efs-pipe-p - (or noninteractive - (progn - ;; in case the user typed something during the wait. - (discard-input) - (y-or-n-p - (format "%s seems not a pty. Kill? " proc))))) - (progn - (kill-buffer (process-buffer proc)) - (if (eq (selected-window) (minibuffer-window)) - (abort-recursive-edit) - (signal 'quit nil))))))) - -(defun efs-start-process (host user name) - "Spawn a new ftp process ready to connect to machine HOST as USER. -If HOST is only ftp-able through a gateway machine then spawn a shell -on the gateway machine to do the ftp instead. NAME is the name of the -process." - (let* ((use-gateway (efs-use-gateway-p host)) - (buffer (get-buffer-create (efs-ftp-process-buffer host user))) - (process-connection-type t) - (opaque-p (memq use-gateway efs-opaque-gateways)) - proc) - (save-excursion - (set-buffer buffer) - (efs-mode host user (if opaque-p - efs-gateway-ftp-prompt-regexp - efs-ftp-prompt-regexp))) - (cond - ((null use-gateway) - (message "Opening FTP connection to %s..." host) - (setq proc (apply 'start-process name buffer efs-ftp-program-name - efs-ftp-program-args))) - ((eq use-gateway 'interactive) - (setq proc (efs-gwp-start host user name))) - ((eq use-gateway 'remsh) - (message "Opening FTP connection to %s via %s..." host efs-gateway-host) - (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) - (append (list efs-gateway-host) - (nth 2 efs-gateway-type) - (list (nth 3 efs-gateway-type)) - (nth 4 efs-gateway-type))))) - ((memq use-gateway '(proxy raptor interlock kerberos)) - (message "Opening FTP connection to %s via %s..." host efs-gateway-host) - (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) - (nth 2 efs-gateway-type)))) - ((eq use-gateway 'local) - (message "Opening FTP connection to %s..." host) - (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) - (nth 2 efs-gateway-type)))) - ((error "Never heard of gateway type %s" use-gateway))) - (process-kill-without-query proc) - (if opaque-p - (accept-process-output proc) - (if efs-pty-check-threshold - (efs-pty-check proc efs-pty-check-threshold) - (accept-process-output proc))) - (set-process-sentinel proc (function efs-process-sentinel)) - (set-process-filter proc (function efs-process-filter)) - (efs-start-polling) - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (set-marker (process-mark proc) (point))) - proc)) - -(defun efs-get-process-internal (host user) - ;; Get's the first process for HOST and USER. If HOST runs a - ;; a case insignificant OS, then case is not considered in USER. - (let ((list (process-list)) - (case-fold (memq (efs-host-type host) - efs-case-insensitive-host-types)) - (len (+ (length host) (length user) 7)) - fmt name found) - (setq host (downcase host)) - (if case-fold (setq user (downcase user))) - (while (and (not found) list) - (setq name (process-name (car list))) - (if (and (= (length name) len) - (string-equal (substring name 0 5) "*ftp ") - (string-equal - (if case-fold (downcase (substring name 5)) (substring name 5)) - (or fmt (setq fmt (format "%s@%s*" user host)))) - (memq (process-status (car list)) '(run open))) - (setq found (car list)) - (setq list (cdr list)))) - found)) - -;; efs-guess-host-type calls this -;; function recursively. The (if (and proc... avoids an infinite -;; loop. We should make sure that this won't hang things if the -;; connection goes wrong. - -(defun efs-get-process (host user) - "Return the process object for the FTP process for HOST and USER. -Create a new process if needed." - - (let ((proc (efs-get-process-internal host user))) - (if (and proc (memq (process-status proc) '(run open))) - proc - - ;; Make sure that the process isn't around in some strange state. - - (setq host (downcase host)) - (let ((name (concat "*ftp " user "@" host "*"))) - (if proc (condition-case nil (delete-process proc) (error nil))) - - ;; grab a suitable process. - (setq proc (efs-start-process host user name)) - - (efs-save-match-data - (efs-save-buffer-excursion - (set-buffer (process-buffer proc)) - - ;; Run any user-specified hooks. - (run-hooks 'efs-ftp-startup-hook) - - ;; login to FTP server. - (efs-login host user proc) - - ;; Beware, the process may have died if the login went bad. - (if (memq (process-status proc) '(run open)) - - (progn - ;; Tell client to send back hash-marks as progress. It isn't - ;; usually fatal if this command fails. - (efs-guess-hash-mark-size proc) - - (if efs-use-passive-mode - (efs-passive-mode host user)) - - ;; Run any user startup functions - (let ((alist efs-ftp-startup-function-alist) - (case-fold-search t)) - (while alist - (if (string-match (car (car alist)) host) - (progn - (funcall (cdr (car alist)) host user) - (setq alist nil)) - (setq alist (cdr alist))))) - - ;; Guess at the host type. - (efs-guess-host-type host user) - - ;; Check the idle time. - (efs-check-idle host user) - - proc) - - ;; Hopefully a recursive retry worked. - (or (efs-get-process-internal host user) - (error "No FTP process for %s@%s" user host))))))))) - -(defun efs-guess-hash-mark-size (proc) - ;; Doesn't run efs-save-match-data. You must do that yourself. - (if efs-send-hash - (save-excursion - (set-buffer (process-buffer proc)) - (let ((line (nth 1 (efs-raw-send-cmd proc "hash"))) - (gate-p (efs-use-gateway-p efs-process-host t))) - ;; Don't guess if the hash-mark-size is already set. - (or (if gate-p efs-gateway-hash-mark-size efs-hash-mark-size) - (if (string-match efs-hash-mark-msgs line) - (let ((size (substring line (match-beginning 1) - (match-end 1)))) - (if (string-match "^[0-9]+$" size) - (set (if gate-p - 'efs-gateway-hash-mark-size - 'efs-hash-mark-size) - (string-to-int size)))))))))) - -(defun efs-passive-mode (host user) - ;; put ftp into passive mode - (efs-send-cmd host user '(passive))) - -;;;; ------------------------------------------------------------ -;;;; Simple FTP process shell support. -;;;; ------------------------------------------------------------ - -(defun efs-mode (host user prompt) - "Major mode for interacting with an FTP process. -The user interface for sending commands to the FTP process is `comint-mode'. -For more information see the documentation for `comint-mode'. This command -is not intended for interactive use. -Takes arguments: HOST USER PROMPT - -Runs efs-mode-hook if it is not nil. - -Key map: -\\{comint-mode-map}" - (let ((proc (get-buffer-process (current-buffer)))) - ;; Running comint-mode will kill-all-local-variables. - (comint-mode) - ;; All these variables are buffer local. - (setq major-mode 'efs-mode - mode-name "efs" - default-directory (file-name-directory efs-tmp-name-template) - comint-prompt-regexp prompt - efs-process-host host - efs-process-user user - efs-process-prompt-regexp prompt) - (set (make-local-variable 'paragraph-start) comint-prompt-regexp) - ;; Old versions of comint don't have this. It does no harm for - ;; the newer ones. - (set (make-local-variable 'comint-last-input-start) (make-marker)) - (goto-char (point-max)) - ;; in case there is a running process - (if proc (set-marker (process-mark proc) (point))) - (run-hooks 'efs-mode-hook))) - - -;;;; ============================================================= -;;;; >6 -;;;; Sending commands to the FTP server. -;;;; ============================================================= - -;;;; ------------------------------------------------------------- -;;;; General purpose functions for sending commands. -;;;; ------------------------------------------------------------- - -(defun efs-raw-send-cmd (proc cmd &optional msg pre-cont cont nowait) -;; Low-level routine to send the given ftp CMD to the ftp PROCESS. -;; MSG is an optional message to output before and after the command. -;; If PRE-CONT is non-nil, it is called immediately after execution -;; of the command starts, but without waiting for it to finish. -;; If CONT is non-NIL then it is either a function or a list of function and -;; some arguments. The function will be called when the ftp command has -;; completed. -;; If CONT is NIL then this routine will return \( RESULT . LINE \) where -;; RESULT is whether the command was successful, and LINE is the line from -;; the FTP process that caused the command to complete. -;; If NOWAIT is nil then we will wait for the command to complete before -;; returning. If NOWAIT is 0, then we will wait until the command starts, -;; executing before returning. NOWAIT of 1 is like 0, except that the modeline -;; will indicate an asynch FTP command. -;; If NOWAIT has any other value, then we will simply queue the -;; command. In all cases, CONT will still be called - - (if (memq (process-status proc) '(run open)) - (efs-save-buffer-excursion - (set-buffer (process-buffer proc)) - - (if efs-process-busy - ;; This function will always wait on a busy process. - ;; Queueing is done by efs-send-cmd. - (let ((efs-process-cmd-waiting t)) - (efs-kbd-quit-protect proc - (while efs-process-busy - (accept-process-output))))) - - (setq efs-process-string "" - efs-process-result-line "" - efs-process-result-cont-lines "" - efs-process-busy t - efs-process-msg (and efs-verbose msg) - efs-process-continue cont - efs-process-server-confused nil - efs-process-nowait nowait - efs-process-hash-mark-count 0 - efs-process-last-percent -1 - efs-process-xfer-size 0 - efs-process-cmd-counter (% (1+ efs-process-cmd-counter) 16)) - (process-kill-without-query proc t) - (and efs-process-msg - (efs-message-p) - (efs-message "%s..." efs-process-msg)) - (goto-char (point-max)) - (move-marker comint-last-input-start (point)) - (move-marker comint-last-input-end (point)) - ;; don't insert the password into the buffer on the USER command. - (efs-save-match-data - (if (string-match efs-passwd-cmds cmd) - (insert (setq efs-process-cmd - (substring cmd 0 (match-end 0))) - " Turtle Power!\n") - (setq efs-process-cmd cmd) - (insert cmd "\n"))) - (process-send-string proc (concat cmd "\n")) - (set-marker (process-mark proc) (point)) - ;; Update the mode-line - (if (and (or efs-mode-line-format efs-ftp-activity-function) - (memq nowait '(t 1))) - (efs-update-mode-line)) - (if pre-cont - (let ((efs-nested-cmd t)) - (save-excursion - (apply (car pre-cont) (cdr pre-cont))))) - (prog1 - (if nowait - nil - ;; hang around for command to complete - ;; Some clients die after the command is sent, if the server - ;; times out. Don't wait on dead processes. - (efs-kbd-quit-protect proc - (while (and efs-process-busy - ;; Need to recheck nowait, since it may get reset - ;; in a cont. - (null efs-process-nowait) - (memq (process-status proc) '(run open))) - (accept-process-output proc))) - - ;; cont is called by the process filter - (if cont - ;; Return nil if a cont was called. - ;; Can't return process-result - ;; and process-line since executing - ;; the cont may have changed - ;; the state of the process buffer. - nil - (list efs-process-result - efs-process-result-line - efs-process-result-cont-lines))) - - ;; If the process died, the filter would have never got the chance - ;; to call the cont. Try to jump start things. - - (if (and (not (memq (process-status proc) '(run open))) - (string-equal efs-process-result-line "") - cont - (equal cont efs-process-continue)) - (progn - (setq efs-process-continue nil - efs-process-busy nil) - ;; The process may be in some strange state. Get rid of it. - (condition-case nil (delete-process proc) (error nil)) - (efs-call-cont cont 'fatal "" ""))))) - - (error "FTP process %s has died." (process-name proc)))) - -(efs-defun efs-quote-string nil (string &optional not-space) - "Quote any characters in STRING that may confuse the ftp process. -If NOT-SPACE is non-nil, then blank characters are not quoted, because -it is assumed that the string will be surrounded by \"'s." - (apply (function concat) - (mapcar (function - (lambda (char) - (if (or (< char ?\ ) - (and (null not-space) (= char ?\ )) - (> char ?\~) - (= char ?\") - (= char ?\\)) - (vector ?\\ char) - (vector char)))) - string))) - -(efs-defun efs-fix-path nil (path &optional reverse) - "Convert PATH from a unix format to a non-unix format. -If optional REVERSE, convert in the opposite direction." - (identity path)) - -(efs-defun efs-fix-dir-path nil (dir-path) - "Convert DIR-PATH from unix format to a non-unix format for a dir listing" - ;; The default def runs for dos-distinct, ka9q, and all the unix's. - ;; To be more careful about distinguishing dirs from plain files, - ;; we append a ".". - (let ((len (length dir-path))) - (if (and (not (zerop len)) (= (aref dir-path (1- len)) ?/)) - (concat dir-path ".") - dir-path))) - -(defun efs-send-cmd (host user cmd - &optional msg pre-cont cont nowait noretry) - "Find an ftp process connected to HOST logged in as USER and send it CMD. -MSG is an optional status message to be output before and after issuing the -command. - -See the documentation for efs-raw-send-cmd for a description of CONT, PRE-CONT -and NOWAIT. Normally, if the command fails it is retried. If NORETRY is -non-nil, this is not done." - ;; Handles conversion to remote pathname syntax and remote ls option - ;; capability. Also, sends umask if nec. - - (let ((proc (efs-get-process host user))) - - (if (and - (eq nowait t) - (save-excursion - (set-buffer (process-buffer proc)) - (or efs-process-busy - efs-process-cmd-waiting))) - - (progn - (efs-add-to-queue - host user - ;; Not nec. to store host and user, because the queue is for - ;; a specific host user pair anyway. Because the queue is always - ;; examined when efs-process-busy - ;; is nil, it should be impossible to get into a loop - ;; where we keep re-queueing over and over. To be on the safe - ;; side, store nowait as 1. - (list cmd msg pre-cont cont 1 noretry)) - nil) - - ;; Send a command. - - (let (cmd-string afsc-result afsc-line afsc-cont-lines) - - (let ((efs-nested-cmd t) - (cmd0 (car cmd)) - (cmd1 (nth 1 cmd)) - (cmd2 (nth 2 cmd)) - (cmd3 (nth 3 cmd))) - - (cond - - ((eq cmd0 'quote) - ;; QUOTEd commands - (cond - - ((eq cmd1 'site) - ;; SITE commands - (cond - ((memq cmd2 '(umask idle dos exec nfs group gpass)) - ;; For UMASK cmd3 = value of umask - ;; For IDLE cmd3 = idle setting, or nil if we're querying. - ;; For DOS and NFS cmd3 is nil. - ;; For EXEC cmd3 is the command to be exec'ed -- a string. - (if cmd3 (setq cmd3 (concat " " cmd3))) - (setq cmd-string (concat "quote site " (symbol-name cmd2) - cmd3))) - ((eq cmd2 'chmod) - (let* ((host-type (efs-host-type host user)) - (cmd4 (efs-quote-string - host-type (efs-fix-path host-type (nth 4 cmd))))) - (setq cmd-string (concat "quote site chmod " cmd3 " " - cmd4)))) - (t (error "efs: Don't know how to send %s %s %s %s" - cmd0 cmd1 cmd2 cmd3)))) - - ((memq cmd1 '(pwd xpwd syst pasv noop)) - (setq cmd-string (concat "quote " (symbol-name cmd1)))) - - ;; PORT command (cmd2 is IP + port address) - ((eq cmd1 'port) - (setq cmd-string (concat "quote port " cmd2))) - - ((memq cmd1 '(appe retr)) - (let ((host-type (efs-host-type host user))) - ;; Set an xfer type - (if cmd3 (efs-set-xfer-type host user cmd3 t)) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "quote " (symbol-name cmd1) " " - cmd2)))) - - ((eq cmd1 'stor) - (let ((host-type (efs-host-type host user))) - (if (memq host-type efs-unix-host-types) - (efs-set-umask host user)) - ;; Set an xfer type - (if cmd3 (efs-set-xfer-type host user cmd3 t)) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "quote stor " cmd2)))) - - ((memq cmd1 '(size mdtm rnfr)) - (let ((host-type (efs-host-type host user))) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "quote " - (symbol-name cmd1) " " cmd2)))) - - ((memq cmd1 '(pass user)) - (setq cmd-string (concat "quote " (symbol-name cmd1) " " cmd2))) - - (t - (error "efs: Don't know how to send %s %s %s %s" - cmd0 cmd1 cmd2 cmd3)))) - - ;; TYPE command - ((eq cmd0 'type) - (setq cmd-string (concat "type " (symbol-name cmd1)))) - - ;; DIR command - ;; cmd == 'dir "remote-path" "local-path" "ls-switches" - ((memq cmd0 '(dir nlist)) - (let ((host-type (efs-host-type host user)) - (listing-type (efs-listing-type host user))) - (setq cmd1 (efs-fix-dir-path host-type cmd1)) - (cond - ((memq listing-type efs-nlist-listing-types) - (setq cmd-string (concat efs-nlist-cmd " " - (efs-quote-string host-type cmd1) - " " cmd2))) - ((or (memq host-type efs-dumb-host-types) - (null cmd3)) - (setq cmd-string (format "%s %s %s" - (if (eq cmd0 'nlist) - efs-nlist-cmd - "dir") - (efs-quote-string host-type cmd1) - cmd2))) - ((setq cmd-string - (format "%s \"%s %s\" %s" - (if (eq cmd0 'nlist) - efs-nlist-cmd - "ls") - cmd3 (efs-quote-string host-type cmd1 t) - ;; cmd2 is a temp file, not nec. to quote. - cmd2)))))) - - ;; First argument is the remote pathname - ((memq cmd0 '(delete mkdir rmdir cd)) - (let ((host-type (efs-host-type host user))) - (setq cmd1 (efs-quote-string host-type - (efs-fix-path host-type cmd1)) - cmd-string (concat (symbol-name cmd0) " " cmd1)))) - - ;; GET command - ((eq cmd0 'get) - (let ((host-type (efs-host-type host user))) - (if cmd3 (efs-set-xfer-type host user cmd3)) - (efs-set-hash-mark-unit host user t) - (setq cmd1 (efs-quote-string host-type - (efs-fix-path host-type cmd1)) - cmd2 (efs-quote-string host-type cmd2) - cmd-string (concat "get " cmd1 " " cmd2)))) - - ;; PUT command - ((eq cmd0 'put) - (let ((host-type (efs-host-type host user))) - (if (memq host-type efs-unix-host-types) - (efs-set-umask host user)) - (if cmd3 (efs-set-xfer-type host user cmd3)) - (efs-set-hash-mark-unit host user) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd1 (efs-quote-string host-type cmd1) - cmd-string (concat "put " cmd1 " " cmd2)))) - - ;; APPEND command - ((eq cmd0 'append) - (let ((host-type (efs-host-type host user))) - (if cmd3 (efs-set-xfer-type host user cmd3)) - (efs-set-hash-mark-unit host user) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd1 (efs-quote-string host-type cmd1) - cmd-string (concat "append " cmd1 " " cmd2)))) - - ;; CHMOD command - ((eq cmd0 'chmod) - (let ((host-type (efs-host-type host user))) - (setq cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "chmod " cmd1 " " cmd2)))) - - ;; Both arguments are remote pathnames - ((eq cmd0 'rename) - (let ((host-type (efs-host-type host user))) - (setq cmd1 (efs-quote-string host-type - (efs-fix-path host-type cmd1)) - cmd2 (efs-quote-string host-type - (efs-fix-path host-type cmd2)) - cmd-string (concat "rename " cmd1 " " cmd2)))) - - ;; passive command - ((eq cmd0 'passive) - (setq cmd-string "passive")) - - (t - (error "efs: Don't know how to send %s %s %s %s" - cmd0 cmd1 cmd2 cmd3)))) - - ;; Actually send the resulting command. - ;; Why do we use this complicated binding of afsc-{result,line}, - ;; rather then use the fact that efs-raw-send-cmd returns? - ;; Because efs-raw-send-cmd returns the result of the first - ;; attempt only. efs-send-cmd should return the result of - ;; the retry, if one was necessary. - ;; Maybe it would be better if efs-raw-send-cmd returned - ;; the result of cont, if nowait was nil? Or maybe still return - ;; \(result line \)? As long as nowait is nil, it should - ;; return something useful. - - ;; Beware, if some of the above FTP commands had to restart - ;; the process, PROC won't be set to the right process object. - (setq proc (efs-get-process host user)) - - (efs-raw-send-cmd - proc - cmd-string - msg - pre-cont - (efs-cont (result line cont-lines) (host user proc cmd msg pre-cont - cont nowait noretry) - (cond ((and (null noretry) (eq result 'fatal)) - (let ((retry - (efs-send-cmd - host user cmd msg pre-cont cont - (if (eq nowait t) 1 nowait) t))) - (or cont nowait - (setq afsc-result (car retry) - afsc-line (nth 1 retry) - afsc-cont-lines (nth 2 retry))))) - ((and (eq result 'failed) - (or (memq (car cmd) '(append rename put)) - (and (eq (car cmd) 'quote) - (eq (nth 1 cmd) 'stor))) - (efs-save-match-data - (string-match efs-write-protect-msgs line))) - (let ((retry (efs-write-recover - (efs-host-type host) - line cont-lines host user cmd msg pre-cont - cont nowait noretry))) - (or cont nowait - (setq afsc-result (car retry) - afsc-line (nth 1 retry) - afsc-cont-lines (nth 2 retry))))) - - (t (if cont - (efs-call-cont cont result line cont-lines) - (or nowait - (setq afsc-result result - afsc-line line - afsc-cont-lines cont-lines)))))) - nowait) - - (prog1 - (if (or nowait cont) - nil - (list afsc-result afsc-line afsc-cont-lines)) - - ;; Check the queue - (or nowait - efs-nested-cmd - (let ((buff (efs-ftp-process-buffer host user))) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (if efs-process-q - (let ((next (car efs-process-q))) - (setq efs-process-q (cdr efs-process-q)) - (apply 'efs-send-cmd host user next)))))))))))) - -(efs-defun efs-write-recover nil - (line cont-lines host user cmd msg pre-cont cont nowait noretry) - "Called when a write command fails with `efs-write-protect-msgs'. -Should return \(result line cont-lines\), like `efs-raw-send-cmd'." - ;; This default version doesn't do anything. - (if cont - (progn - (efs-call-cont cont 'failed line cont-lines) - nil) - (if nowait nil (list 'failed line cont-lines)))) - -;;;; --------------------------------------------------------------------- -;;;; The login sequence. (The follows RFC959 rather tightly. If a server -;;;; can't even get the login codes right, it is -;;;; pretty much scrap metal.) -;;;; --------------------------------------------------------------------- - -;;;###autoload -(defun efs-nslookup-host (host) - "Attempt to resolve the given HOSTNAME using nslookup if possible." - (interactive "sHost: ") - (if efs-nslookup-program - (let* ((default-directory exec-directory) - (default-major-mode 'fundamental-mode) - (process-connection-type nil) - (proc (start-process " *nslookup*" " *nslookup*" - efs-nslookup-program host)) - (res host)) - (process-kill-without-query proc) - (save-excursion - (set-buffer (process-buffer proc)) - (let ((quit-flag nil) - (inhibit-quit nil)) - (while (memq (process-status proc) '(run open)) - (accept-process-output proc))) - (goto-char (point-min)) - (if (re-search-forward - "Name:.*\nAddress\\(es\\)?: *\\([.0-9]+\\)$" nil t) - (setq res (buffer-substring (match-beginning 2) - (match-end 2)))) - (kill-buffer (current-buffer))) - (if (interactive-p) - (message "%s: %s" host res)) - res) - (if (interactive-p) - (message - "No nslookup program. See the variable efs-nslookup-program.")) - host)) - -(defun efs-login (host user proc) - "Connect to the FTP-server on HOST as USER. -PROC is the process to the FTP-client. Doesn't call efs-save-match-data. -You must do that yourself." - (let ((gate (efs-use-gateway-p host))) - (if (eq gate 'kerberos) - (progn - (setq proc (efs-kerberos-login host user proc)) - (efs-login-send-user host user proc gate)) - (let ((to (if (memq gate '(proxy raptor)) - efs-gateway-host - host)) - port cmd result) - (if (string-match "#" to) - (setq port (substring to (match-end 0)) - to (substring to 0 (match-beginning 0)))) - (and efs-nslookup-on-connect - (string-match "[^0-9.]" to) - (setq to (efs-nslookup-host to))) - (setq cmd (concat "open " to)) - (if port (setq cmd (concat cmd " " port))) - - ;; Send OPEN command. - (setq result (efs-raw-send-cmd proc cmd nil)) - - (and (eq gate 'interlock) (string-match "^331 " (nth 1 result)) - (setq result (efs-login-send-pass - efs-gateway-host - (efs-get-user efs-gateway-host) proc))) - - ;; Analyze result of OPEN. - (if (car result) - (progn - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "OPEN request failed: " - (nth 1 result)))) - (efs-login-send-user host user proc gate)))))) - -(defun efs-login-send-user (host user proc &optional gate retry) - "Send user command to HOST and USER. PROC is the ftp client process. -Optional argument GATE specifies which type of gateway is being used. -RETRY argument specifies to try twice if we get a 421 response." - (let ((cmd (cond - ((memq gate '(proxy interlock)) - (format "quote USER \"%s\"@%s" user - (if (and efs-nslookup-on-connect - (string-match "[^0-9.]" host)) - (efs-nslookup-host host) - host))) - ((eq gate 'raptor) - (format "quote USER \"%s\"@%s %s" user - (if (and efs-nslookup-on-connect - (string-match "[^0-9.]" host)) - (efs-nslookup-host host) - host) - (nth 3 efs-gateway-type))) - ((eq gate 'kerberos) - (let ((to host) - port) - (if (string-match "#" host) - (progn - (setq to (substring host 0 (match-beginning 0)) - port (substring host (match-end 0))) - (and efs-nslookup-on-connect - (string-match "[^0-9.]" to) - (efs-nslookup-host to)) - (setq to (concat to "@" port)))) - (format "quote user \"%s\"@%s" user to))) - (t - (format "quote user \"%s\"" user)))) - (msg (format "Logging in as user %s%s..." user - (if (memq gate '(proxy raptor kerberos)) - (concat "@" host) ""))) - result code) - - ;; Send the message by hand so that we can report on the size - ;; of the MOTD. - (message msg) - - ;; Send USER command. - (setq result (efs-raw-send-cmd proc cmd nil)) - - ;; Analyze result of USER (this follows RFC959 strictly) - (if (< (length (nth 1 result)) 4) - (progn - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user - (concat "USER request failed: " (nth 1 result)))) - - (setq code (substring (nth 1 result) 0 4)) - (cond - - ((string-equal "331 " code) - ;; Need password - (setq result (efs-login-send-pass host user proc gate))) - - ((string-equal "332 " code) - ;; Need an account, but no password - (setq result (efs-login-send-acct host user proc gate))) - - ((null (car result)) - ;; logged in proceed - nil) - - ((and (or (string-equal "530 " code) (string-equal "421 " code)) - (efs-anonymous-p user) - (or (string-match efs-too-many-users-msgs (nth 1 result)) - (string-match efs-too-many-users-msgs (nth 2 result)))) - (if (save-window-excursion - (condition-case nil - (display-buffer (process-buffer proc)) - (error nil)) - (y-or-n-p (format - "Too many users for %s@%s. Try again? " - user host))) - (progn - ;; Set result to nil if we are doing a retry, so done - ;; message only gets sent once. - (setq result nil) - (if (string-equal code "530 ") - (efs-login-send-user host user proc gate t) - (efs-get-process host user))) - (signal 'quit nil))) - - ((and retry (string-equal code "421 ")) - (setq result nil) - (efs-get-process host user)) - - (t ; bombed - (condition-case nil (delete-process proc) (error nil)) - ;; Wrong username? - (efs-set-user host nil) - (efs-error host user - (concat "USER request failed: " (nth 1 result))))) - (and (null (car result)) - (stringp (nth 2 result)) - (message "%sdone%s" msg - (let ((n (efs-occur-in-string ?\n (nth 2 result)))) - (if (> n 1) - (format "; MOTD of %d lines" n) - ""))))))) - -(defun efs-login-send-pass (host user proc &optional gate) - "Sends password to HOST and USER. PROC is the ftp client process. -Doesn't call efs-save-match data. You must do that yourself." - ;; Note that efs-get-password always returns something. - ;; It prompts the user if necessary. Even if the returned password is - ;; \"\", send it, because we wouldn't be running this function - ;; if the server wasn't insisting on a password. - (let* ((pass "") - (qpass "") - (cmd "") - (result (unwind-protect - (progn - (condition-case nil - (setq pass (efs-get-passwd host user)) - (quit (condition-case nil - (kill-buffer (process-buffer proc)) - (error nil)) - (signal 'quit nil))) - (setq cmd (concat - "quote pass " - (setq qpass (efs-quote-string nil pass t)))) - (efs-raw-send-cmd proc cmd)) - (fillarray pass 0) - (fillarray qpass 0) - (fillarray cmd 0))) - (code (and (>= (length (nth 1 result)) 4) - (substring (nth 1 result) 0 4)))) - (or code (setq code "")) - ;; Analyze the result. - (cond - ((string-equal code "332 ") - ;; require an account passwd - (setq result (efs-login-send-acct host user proc gate))) - ((null (car result)) - ;; logged in proceed - nil) - ((or (string-equal code "530 ") (string-equal code "421 ")) - ;; Give the user another chance - (condition-case nil - (if (efs-anonymous-p user) - (if (or (string-match efs-too-many-users-msgs (nth 1 result)) - (string-match efs-too-many-users-msgs (nth 2 result))) - (if (save-window-excursion - (condition-case nil - (display-buffer (process-buffer proc)) - (error nil)) - (y-or-n-p (format - "Too many users for %s@%s. Try again? " - user host))) - (progn - ;; Return nil if we are doing a retry, so done - ;; message only gets sent once. - (setq result nil) - (if (string-equal code "530 ") - (efs-login-send-user host user proc gate) - (efs-get-process host user))) - (signal 'quit nil)) - (unwind-protect - (efs-set-passwd - host user - (save-window-excursion - (condition-case nil - (display-buffer (process-buffer proc)) - (error nil)) - (setq pass - (read-passwd - (format - "Password for %s@%s failed. Try again: " - user host))))) - (fillarray pass 0)) - (setq result nil) - (efs-login-send-user host user proc gate)) - (unwind-protect - (efs-set-passwd - host user - (setq pass - (read-passwd - (format "Password for %s@%s failed. Try again: " - user host)))) - (fillarray pass 0)) - (setq result nil) - (efs-login-send-user host user proc gate)) - (quit (condition-case nil (delete-process proc) (error nil)) - (efs-set-user host nil) - (efs-set-passwd host user nil) - (signal 'quit nil)) - (error (condition-case nil (delete-process proc) (error nil)) - (efs-set-user host nil) - (efs-set-passwd host user nil) - (efs-error host user "PASS request failed.")))) - (t ; bombed for unexplained reasons - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "PASS request failed: " (nth 1 result))))) - result)) - -(defun efs-login-send-acct (host user proc &optional gate) - "Sends account password to HOST and USER. PROC is the ftp client process. -Doesn't call efs-save-match data. You must do that yourself." - (let* ((acct "") - (qacct "") - (cmd "") - (result (unwind-protect - (progn - ;; The raptor gateway requires us to send a gateway - ;; authentication password for account. What if the - ;; remote server wants one too? - (setq acct (if (eq gate 'raptor) - (efs-get-account - efs-gateway-host - (nth 3 efs-gateway-type) nil t) - (efs-get-account host user nil t)) - qacct (efs-quote-string nil acct t) - cmd (concat "quote acct " qacct)) - (efs-raw-send-cmd proc cmd)) - (fillarray acct 0) - (fillarray qacct 0) - (fillarray cmd 0)))) - ;; Analyze the result - (cond - ((null (car result)) - ;; logged in proceed - nil) - ((eq (car result) 'failed) - ;; Give the user another chance - (condition-case nil - (progn - (unwind-protect - (progn - (setq acct (read-passwd - (format - "Account password for %s@%s failed. Try again: " - user host))) - (or (and efs-high-security-hosts - (string-match efs-high-security-hosts - (format "%s@%s" user host))) - (efs-set-account host user nil acct))) - (fillarray acct 0)) - (setq result (efs-login-send-user host user proc gate))) - (quit (condition-case nil (delete-process proc) (error nil))) - (error (condition-case nil (delete-process proc) (error nil)) - (efs-error host user "ACCT request failed.")))) - (t ; bombed for unexplained reasons - (condition-case nil (delete-process proc) (error nil)) - (efs-error host user (concat "ACCT request failed: " (nth 1 result))))) - result)) - -;;;; ---------------------------------------------------------------------- -;;;; Changing working directory. -;;;; ---------------------------------------------------------------------- - -(defun efs-raw-send-cd (host user dir &optional no-error) - ;; If NO-ERROR, doesn't barf, but just returns success (t) or failure (nil). - ;; This does not use efs-send-cmd. - ;; Also DIR must be in the syntax of the remote host-type. - (let* ((cmd (concat "cd " dir)) - cd-result cd-line) - (efs-raw-send-cmd - (efs-get-process host user) - cmd nil nil - (efs-cont (result line cont-lines) (cmd) - (if (eq result 'fatal) - (efs-raw-send-cmd - (efs-get-process host user) - cmd nil nil - (function (lambda (result line cont-lines) - (setq cd-result result - cd-line line)))) - (setq cd-result result - cd-line line)))) - (if no-error - (null cd-result) - (if cd-result - (efs-error host user (concat "CD failed: " cd-line)))))) - -;;;; -------------------------------------------------------------- -;;;; Getting a PWD. -;;;; -------------------------------------------------------------- - -(defun efs-unquote-quotes (string) - ;; Unquote \"\"'s in STRING to \". - (let ((start 0) - new) - (while (string-match "\"\"" string start) - (setq new (concat new (substring - string start (1+ (match-beginning 0)))) - start (match-end 0))) - (if new - (concat new (substring string start)) - string))) - -(efs-defun efs-send-pwd nil (host user &optional xpwd) - "Attempts to get the current working directory for the given HOST/USER pair. -Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found, -and LINE is the relevant success or fail line from the FTP-server. If the -optional arg XPWD is given, uses this server command instead of PWD." - (let* ((result (efs-send-cmd host user - (list 'quote (if xpwd 'xpwd 'pwd)) - "Getting pwd")) - (line (nth 1 result)) - dir) - (or (car result) - (efs-save-match-data - (if (string-match "\"\\(.*\\)\"[^\"]*$" line) - (setq dir (efs-unquote-quotes (substring line (match-beginning 1) - (match-end 1)))) - (if (string-match " \\([^ ]+\\) " line) ; stone-age servers! - (setq dir (substring line - (match-beginning 1) - (match-end 1))))))) - (cons dir line))) - -(efs-defun efs-send-pwd super-dumb-unix (host user &optional xpwd) - ;; Guess at the pwd for a unix host that doesn't support pwd. - (if (efs-anonymous-p user) - ;; guess - (cons "/" "") - ;; Who knows? - (message "Can't obtain pwd for %s" host) - (ding) - (sleep-for 2) - (message "All file names must be specified as full paths.") - (cons nil ""))) - -;;;; -------------------------------------------------------- -;;;; Getting the SIZE of a remote file. -;;;; -------------------------------------------------------- - -(defun efs-send-size (host user file) - "For HOST and USER, get the size of FILE in bytes. -This returns a list \( SIZE . LINE \), where SIZE is the file size in bytes, -or nil if this couldn't be determined, and LINE is the output line of the -FTP server." - (efs-save-match-data - (let ((result (efs-send-cmd host user (list 'quote 'size file)))) - (setcar result - (and (null (car result)) - (string-match "^213 +\\([0-9]+\\)$" (nth 1 result)) - (string-to-int - (substring - (cdr result) - (match-beginning 1) (match-end 1))))) - result))) - -;;;; ------------------------------------------------------------ -;;;; umask support -;;;; ------------------------------------------------------------ - -(defun efs-umask (user) - "Returns the umask that efs will use for USER. -If USER is root or anonymous, then the values of efs-root-umask -and efs-anonymous-umask, respectively, take precedence, to be followed -by the value of efs-umask, and if this is nil, it returns your current -umask on the local machine. Returns nil if this can't be determined." - (or - (and (string-equal user "root") efs-root-umask) - (and (efs-anonymous-p user) - efs-anonymous-umask) - efs-umask - (let* ((shell (or (and (boundp 'explicit-shell-file-name) - explicit-shell-file-name) - (getenv "ESHELL") - (getenv "SHELL") - "/bin/sh")) - (default-major-mode 'fundamental-mode) - (default-directory exec-directory) - (buff (get-buffer-create " *efs-umask-data*"))) - (unwind-protect - (save-excursion - (set-buffer buff) - (call-process shell nil buff nil "-c" "umask") - (goto-char (point-min)) - (if (re-search-forward "[0-7]?[0-7]?[0-7]" nil t) - (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))))) - (kill-buffer buff))))) - -(defun efs-send-umask (host user mask) - "Sets the umask on HOST for USER to MASK. -Returns t for success, nil for failure." - (interactive - (let* ((path (or buffer-file-name - (and (eq major-mode 'dired-mode) - dired-directory))) - (parsed (and path (efs-ftp-path path))) - (default-host (car parsed)) - (default-user (nth 1 parsed)) - (default-mask (efs-umask default-user))) - (list - (read-string "Host: " default-host) - (read-string "User: " default-user) - (read-string "Umask: " (int-to-string default-mask))))) - (let (int-mask) - (if (integerp mask) - (setq int-mask mask - mask (int-to-string mask)) - (setq int-mask (string-to-int mask))) - (or (string-match "^ *[0-7]?[0-7]?[0-7] *$" mask) - (error "Invalid umask %s" mask)) - (efs-send-cmd host user - (list 'quote 'site 'umask mask) - (concat "Setting umask to " mask) - (list - (function - (lambda (int-mask) - (let ((buff (efs-ftp-process-buffer host user))) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-umask int-mask)))))) - int-mask) - (efs-cont (result line cont-lines) (host user mask) - (if result - (let ((buff (efs-ftp-process-buffer host user))) - (efs-set-host-property host 'umask-failed t) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-umask nil))) - (message - "Unable to set umask to %s on %s" mask host) - (if efs-ding-on-umask-failure - (progn - (ding) - (sit-for 1)))))) - 0))) ; Do this NOWAIT = 0 - -(defun efs-set-umask (host user) - "Sets the umask for HOST and USER, if it has not already been set." - (save-excursion - (set-buffer (process-buffer (efs-get-process host user))) - (if (or efs-process-umask (efs-get-host-property host 'umask-failed)) - nil - (let ((umask (efs-umask user))) - (efs-send-umask host user umask) - t)))) ; Tell the caller that we did something. - -(defun efs-modes-from-umask (umask) - ;; Given the 3 digit octal integer umask, returns the decimal integer - ;; according to chmod that a file would be written with. - ;; Assumes only ordinary files, so ignores x bits. - (let* ((others (% umask 10)) - (umask (/ umask 10)) - (group (% umask 10)) - (umask (/ umask 10)) - (owner (% umask 10)) - (factor 1)) - (apply '+ - (mapcar - (function - (lambda (x) - (prog1 - (* factor (- 6 (- x (% x 2)))) - (setq factor (* factor 8))))) - (list others group owner))))) - -;;;; ------------------------------------------------------------ -;;;; Idle time manipulation. -;;;; ------------------------------------------------------------ - -(defun efs-check-idle (host user) - ;; We just toss it in the queue to run whenever there's time. - ;; Just fail quietly if this doesn't work. - (if (and (or efs-maximize-idle efs-expire-ftp-buffers) - (memq (efs-host-type host) efs-idle-host-types) - (null (efs-get-host-property host 'idle-failed))) - (let ((buffname (efs-ftp-process-buffer host user))) - (efs-add-to-queue - host user - (list '(quote site idle) - nil nil - (efs-cont (result line cont-lines) (host user buffname) - (efs-save-match-data - (if (and (null result) - (string-match efs-idle-msgs line)) - (let ((max (substring line (match-beginning 2) - (match-end 2)))) - (if (get-buffer buffname) - (save-excursion - (set-buffer buffname) - (setq efs-process-idle-time - (string-to-int - (substring line (match-beginning 1) - (match-end 1)))))) - (if (and efs-maximize-idle - (not (efs-anonymous-p user))) - (efs-add-to-queue - host user - (list - (list 'quote 'site 'idle max) - nil nil - (efs-cont (result line cont-lines) (buffname - max) - (and (null result) - (get-buffer buffname) - (save-excursion - (set-buffer buffname) - (setq efs-process-idle-time - (string-to-int max))))) - 0)))) - (efs-set-host-property host 'idle-failed t)))) - 0 nil))))) ; Using NOWAIT = 0 inhibits mode line toggling. - - -;;;; ------------------------------------------------------------ -;;;; Sending the SYST command for system type. -;;;; ------------------------------------------------------------ - -(defun efs-get-syst (host user) - "Use SYST to get the remote system type. -Returns the system type as a string if this succeeds, otherwise nil." - (let* ((result (efs-send-cmd host user '(quote syst))) - (line (nth 1 result))) - (efs-save-match-data - (and (null (car result)) - (string-match efs-syst-msgs line) - (substring line (match-end 0)))))) - -;;;; ------------------------------------------------------------ -;;;; File transfer representation type support -;;;; ------------------------------------------------------------ - -;;; Legal representation types are: image, ascii, ebcdic, tenex - -(efs-defun efs-file-type nil (path) - ;; Returns the file type for PATH, the full efs path, with filename FILE. - ;; The return value is one of 'text, '8-binary, or '36-binary. - (let ((parsed (efs-ftp-path path))) - (efs-save-match-data - (cond - ;; There is no special significance to temp names, but we assume that - ;; they exist on an 8-bit byte machine. - ((or (null path) - (let ((temp (intern-soft path efs-tmp-name-obarray))) - (and temp (memq temp efs-tmp-name-files)))) - '8-binary) - ((and (null parsed) (file-exists-p path)) - (efs-local-file-type path)) - ;; test special hosts - ((and parsed - efs-binary-file-host-regexp - (let ((case-fold-search t)) - (string-match efs-binary-file-host-regexp (car parsed)))) - '8-binary) - (t - ;; Test file names - (let ((file (efs-internal-file-name-nondirectory - (or (nth 2 parsed) path)))) - (cond - ;; test for PDP-10 binaries - ((and efs-36-bit-binary-file-name-regexp - (string-match efs-36-bit-binary-file-name-regexp file)) - '36-binary) - ((and efs-binary-file-name-regexp - (string-match efs-binary-file-name-regexp file)) - '8-binary) - ((and efs-text-file-name-regexp - (string-match efs-text-file-name-regexp file)) - 'text) - ;; by default - (t - '8-binary)))))))) - -(efs-define-fun efs-local-file-type (file) - ;; Looks at the beginning (magic-cookie) of a local file to determine - ;; if it is a text file or not. If it's not a text file, it doesn't care - ;; about what type of binary file, so this doesn't really look for a magic - ;; cookie. - ;; Doesn't call efs-save-match-data. The caller should do so. - (save-excursion - (set-buffer (get-buffer-create efs-data-buffer-name)) - (erase-buffer) - (insert-file-contents file nil 0 16) - (if (looking-at "[ -~\n\r\C-L]*\\'") - 'text - '8-binary))) - -(defun efs-rationalize-file-type (f-type t-type) - ;; When the original and new names for a file indicate - ;; different file types, this function applies an ad hoc heuristic - ;; to return a single file type. - (cond - ((eq f-type t-type) - f-type) - ((memq '36-binary (list f-type t-type)) - '36-binary) - ((memq '8-binary (list f-type t-type)) - '8-binary) - (t - 'text))) - -(defun efs-prompt-for-transfer-type (arg) - "Toggles value of efs-prompt-for-transfer-type. -With prefix arg, turns prompting on if arg is positive, otherwise turns -prompting off." - (interactive "P") - (if (if arg - (> (prefix-numeric-value arg) 0) - (null efs-prompt-for-transfer-type)) - ;; turn prompting on - (prog1 - (setq efs-prompt-for-transfer-type t) - (message "Prompting for FTP transfer TYPE is on.")) - (prog1 - (setq efs-prompt-for-transfer-type nil) - (message "Prompting for FTP transfer TYPE is off.")))) - -(defun efs-read-xfer-type (path) - ;; Prompt for the transfer type to use for PATH - (let ((type - (completing-read - (format "FTP transfer TYPE for %s: " (efs-relativize-filename path)) - '(("binary") ("image") ("ascii") ("ebcdic") ("tenex")) - nil t))) - (if (string-equal type "binary") - 'image - (intern type)))) - -(defun efs-xfer-type (f-host-type f-path t-host-type t-path - &optional via-local) - ;; Returns the transfer type for transferring a file. - ;; F-HOST-TYPE = the host type of the machine on which the file is from. - ;; F-PATH = path, in full efs-syntax, of the original file - ;; T-HOST-TYPE = host-type of the machine to which the file is being - ;; transferred. - ;; VIA-LOCAL = non-nil of the file is being moved through the local, or - ;; a gateway machine. - ;; Set F-PATH or T-PATH to nil, to indicate that the file is being - ;; transferred from/to a temporary file, whose name has no significance. - (let (temp) - (and f-path - (setq temp (intern-soft f-path efs-tmp-name-obarray)) - (memq temp efs-tmp-name-files) - (setq f-path nil)) - (and t-path - (setq temp (intern-soft t-path efs-tmp-name-obarray)) - (memq temp efs-tmp-name-files) - (setq t-path nil))) - (if (or (null (or f-host-type t-host-type)) (null (or f-path t-path))) - 'image ; local copy? - (if efs-prompt-for-transfer-type - (efs-read-xfer-type (if f-path f-path t-path)) - (let ((f-fs (cdr (assq f-host-type efs-file-type-alist))) - (t-fs (cdr (assq t-host-type efs-file-type-alist)))) - (if (and f-fs t-fs - (if efs-treat-crlf-as-nl - (and (eq (car f-fs) (car t-fs)) - (eq (nth 1 f-fs) (nth 1 t-fs)) - (let ((f2-fs (nth 2 f-fs)) - (t2-fs (nth 2 t-fs))) - (or (eq f2-fs t2-fs) - (and (memq f2-fs '(file-crlf file-nl)) - (memq t2-fs '(file-crlf file-nl)))))) - (equal f-fs t-fs))) - 'image - (let ((type (cond - ((and f-path t-path) - (efs-rationalize-file-type - (efs-file-type t-host-type t-path) - (efs-file-type f-host-type f-path))) - (f-path - (efs-file-type f-host-type f-path)) - (t-path - (efs-file-type t-host-type t-path))))) - (cond - ((eq type '36-binary) - 'image) - ((eq type '8-binary) - (if (or (eq (car f-fs) '36-bit-wa) - (eq (car t-fs) '36-bit-wa)) - 'tenex - 'image)) - (t ; handles 'text - (if (and t-fs f-fs (eq (nth 1 f-fs) 'ebcdic) - (eq (nth 1 t-fs) 'ebcdic) (null via-local)) - 'ebcdic - 'ascii))))))))) - -(defun efs-set-xfer-type (host user type &optional clientless) - ;; Sets the xfer type for HOST and USER to TYPE. - ;; If the connection is already using the required type, does nothing. - ;; If clientless is non-nil, we are using a quoted xfer command, and - ;; need to check if the client has changed things. - (save-excursion - (let ((buff (process-buffer (efs-get-process host user)))) - (set-buffer buff) - (or (if (and clientless efs-process-client-altered-xfer-type) - (or (eq type efs-process-client-altered-xfer-type) - (setq efs-process-client-altered-xfer-type nil)) - ;; We are sending a non-clientless command, so the client - ;; gets back in synch. - (setq efs-process-client-altered-xfer-type nil) - (and efs-process-xfer-type - (eq type efs-process-xfer-type))) - (let ((otype efs-process-xfer-type)) - ;; Set this now in anticipation that the TYPE command will work, - ;; in case other commands, such as efs-set-hash-mark-unit want to - ;; grok this before the TYPE command completes. - (setq efs-process-xfer-type type) - (efs-send-cmd - host user (list 'type type) - nil nil - (efs-cont (result line cont-lines) (host user type otype buff) - (if result - (unwind-protect - (efs-error host user (format "TYPE %s failed: %s" - (upcase (symbol-name type)) - line)) - (if (get-buffer buff) - (save-excursion - (set-buffer buff) - (setq efs-process-xfer-type otype)))))) - 0)))))) ; always send type commands NOWAIT = 0 - - -;;;; ------------------------------------------------------------ -;;;; Obtaining DIR listings. -;;;; ------------------------------------------------------------ - -(defun efs-ls-guess-switches () - ;; Tries to determine what would be the most useful switches - ;; to use for a DIR listing. - (if (and (boundp 'dired-listing-switches) - (stringp dired-listing-switches) - (efs-parsable-switches-p dired-listing-switches t)) - dired-listing-switches - "-al")) - -(efs-defun efs-ls-dumb-check nil (line host file path lsargs msg noparse - noerror nowait cont) - nil) - -(efs-defun efs-ls-dumb-check unknown (line host file path lsargs - msg noparse noerror nowait cont) - ;; Checks to see if the host type might be dumb unix. If so, returns the - ;; listing otherwise nil. - (and - lsargs - (string-match - ;; Some CMU servers return a 530 here. 550 is correct. - (concat "^5[35]0 \\(The file \\)?" - (regexp-quote (concat lsargs " " path))) - ;; 550 is for a non-accessible file -- RFC959 - line) - (progn - (if (eq (efs-host-type host) 'apollo-unix) - (efs-add-host 'dumb-apollo-unix host) - (efs-add-host 'dumb-unix host)) - ;; try again - (if nowait - t ; return t if asynch - ; This is because dumb-check can't run asynch. - ; This means that we can't recognize dumb hosts asynch. - ; Shouldn't be a problem. - (efs-ls file nil - (if (eq msg t) - (format "Relisting %s" (efs-relativize-filename file)) - msg) - noparse noerror nowait cont))))) - -;; With no-error nil, this function returns: -;; an error if file is not an efs-path -;; (This should never happen.) -;; an error if either the listing is unreadable or there is an ftp error. -;; the listing (a string), if everything works. -;; -;; With no-error t, it returns: -;; an error if not an efs-path -;; error if listing is unreable (most likely caused by a slow connection) -;; nil if ftp error (this is because although asking to list a nonexistent -;; directory on a remote unix machine usually (except -;; maybe for dumb hosts) returns an ls error, but no -;; ftp error, if the same is done on a VMS machine, -;; an ftp error is returned. Need to trap the error -;; so we can go on and try to list the parent.) -;; the listing, if everything works. - -(defun efs-ls (file lsargs msg &optional noparse noerror nowait cont nlist) - "Return the output of a `DIR' or `ls' command done over ftp. -FILE is the full name of the remote file, LSARGS is any args to pass to the -`ls' command. MSG is a message to be displayed while listing, if MSG is given -as t, a suitable message will be computed. If nil, no message will be -displayed. If NOPARSE is non-nil, then the listing will not be parsed and -stored in internal cache. Otherwise, the listing will be parsed, if LSARGS -allow it. If NOERROR is non-nil, then we return nil if the listing fails, -rather than signal an error. If NOWAIT is non-nil, we do the listing -asynchronously, returning nil. If CONT is non-nil it is called with first -argument the listing string." - ;; If lsargs are nil, this forces a one-time only dumb listing using dir. - (setq file (efs-expand-file-name file)) - (let ((parsed (efs-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (host-type (efs-host-type host user)) - (listing-type (efs-listing-type host user)) - (parse (cond - ((null noparse) - (efs-parsable-switches-p lsargs t)) - ((eq noparse 'parse) - t) - (t nil))) - (switches lsargs) - cache) - - (if (memq host-type efs-dumb-host-types) - (setq lsargs nil)) - (if (and (null efs-ls-uncache) - (setq cache - (or (efs-get-from-ls-cache file switches) - (and switches - (efs-convert-from-ls-cache - file switches host-type listing-type))))) - ;; The listing is in the mail, errr... cache. - (let (listing) - (if (stringp cache) - (setq listing cache) - (setq listing (car cache)) - (if (and parse (null (nth 1 cache))) - (save-excursion - (set-buffer - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create - efs-data-buffer-name))) - (erase-buffer) - (insert listing) - (goto-char (point-min)) - (efs-set-files - file - (efs-parse-listing listing-type - host user path - file lsargs)) - ;; Note that we have parsed it now. - (setcar (cdr cache) t)))) - (if cont (efs-call-cont cont listing)) - listing) - - (if cache - (efs-del-from-ls-cache file nil nil)) - ;; Need to get the listing via FTP. - (let* ((temp (efs-make-tmp-name host nil)) - (temp-file (car temp)) - listing-result) - (efs-send-cmd - host user - (list (if nlist 'nlist 'dir) path (cdr temp) lsargs) - (if (eq msg t) - (format "Listing %s" (efs-relativize-filename file)) - msg) - nil - (efs-cont (result line cont-lines) - (host-type listing-type host user temp-file path - switches file lsargs noparse parse noerror - msg nowait cont) - ;; The client flipped to ascii, remember this. - (let ((buff (get-buffer - (efs-ftp-process-buffer host user)))) - (if buff - (efs-save-buffer-excursion - (set-buffer buff) - (setq efs-process-client-altered-xfer-type - 'ascii)))) - (unwind-protect - (if result - (or (setq listing-result - (efs-ls-dumb-check - (and (or (eq host-type 'unknown) - (eq listing-type 'unix:unknown)) - 'unknown) - line host file path lsargs msg - noparse noerror nowait cont)) - ;; If dumb-check returns non-nil - ;; then it would have handled any error recovery - ;; and conts. listing-result would only be set to - ;; t if nowait was non-nil. Therefore, the final - ;; return for efs-ls could never be t, even if I - ;; set listing-result to t here. - (if noerror - (if cont - (efs-call-cont cont nil)) - (efs-error host user - (concat "DIR failed: " - line)))) - - ;; listing worked - (if (efs-ftp-path temp-file) - (efs-add-file-entry (efs-host-type efs-gateway-host) - temp-file nil nil nil)) - (save-excursion - ;; A hack to get around a jka-compr problem. - ;; Do we still need it? - (let ((default-major-mode 'fundamental-mode) - efs-verbose jka-compr-enabled) - (set-buffer (get-buffer-create - efs-data-buffer-name)) - (erase-buffer) - (if (or (file-readable-p temp-file) - (sleep-for efs-retry-time) - (file-readable-p temp-file)) - (insert-file-contents temp-file) - (efs-error host user - (format - "list data file %s not readable" - temp-file)))) - (if parse - (progn - (efs-set-files - file - (efs-parse-listing listing-type host user path - file lsargs)) - ;; Parsing may update the host type. - (and lsargs (memq (efs-host-type host) - efs-dumb-host-types) - (setq lsargs nil)))) - (let ((listing (buffer-string))) - (efs-add-to-ls-cache file lsargs listing parse) - (if (and (null lsargs) switches) - ;; Try to convert - (let ((conv (efs-get-ls-converter switches))) - (and conv - (setq conv (assoc - (char-to-string 0) - conv)) - (funcall (cdr conv) listing-type nil) - (setq listing (buffer-string))))) - (or nowait (setq listing-result listing)) - ;; Call the ls cont, with first arg the - ;; listing string. - (if cont - (efs-call-cont cont listing))))) - (efs-del-tmp-name temp-file))) - nowait) - (and (null nowait) listing-result)))) - (error "Attempt to get a remote listing for the local file %s" file)))) - - -;;;; =============================================================== -;;;; >7 -;;;; Parsing and storing remote file system data. -;;;; =============================================================== - -;;; The directory listing parsers do some host type guessing. -;;; Most of the host type guessing is done when the PWD output -;;; is parsed. A bit is done when the error codes for DIR are -;;; analyzed. - -;;;; ----------------------------------------------------------- -;;;; Caching directory listings. -;;;; ----------------------------------------------------------- - -;;; Aside from storing files data in a hashtable, a limited number -;;; of listings are stored in complete form in `efs-ls-cache'. - -(defun efs-del-from-ls-cache (file &optional parent-p dir-p) - ;; Deletes from the ls cache the listing for FILE. - ;; With optional PARENT-P, deletes any entry for the parent - ;; directory of FILE too. - ;; If DIR-P is non-nil, then the directory listing of FILE is to be deleted. - (if dir-p - (setq file (file-name-as-directory file)) - (setq file (directory-file-name file))) - (setq file (efs-canonize-file-name file)) - (if parent-p - (setq parent-p (file-name-directory - (if dir-p - (directory-file-name file) - file)))) - (setq efs-ls-cache - (delq nil - (mapcar - (if parent-p - (function - (lambda (x) - (let ((f-ent (car x))) - (and (not (string-equal file f-ent)) - (not (string-equal parent-p f-ent)) - x)))) - (function - (lambda (x) - (and (not (string-equal file (car x))) - x)))) - efs-ls-cache)))) - -(defun efs-wipe-from-ls-cache (host user) - ;; Remove from efs-ls-cache all listings for HOST and USER. - (let ((host (downcase host)) - (case-insens (memq (efs-host-type host) - efs-case-insensitive-host-types))) - (if case-insens (setq user (downcase user))) - (setq efs-ls-cache - (delq nil - (mapcar - (function - (lambda (x) - (let ((parsed (efs-ftp-path (car x)))) - (and (not - (and (string-equal (car parsed) host) - (string-equal (if case-insens - (downcase (nth 1 parsed)) - (nth 1 parsed)) - user))) - x)))) - efs-ls-cache))))) - -(defun efs-get-from-ls-cache (file switches) - ;; Returns the value in `ls-cache' for FILE and SWITCHES. - ;; Returns a list consisting of the listing string, and whether its - ;; already been parsed. This list is eq to the nthcdr 2 of the actual - ;; cache entry, so you can setcar it. - ;; For dumb listings, SWITCHES will be nil. - (let ((list efs-ls-cache) - (switches (efs-canonize-switches switches)) - (file (efs-canonize-file-name file))) - (catch 'done - (while list - (if (and (string-equal file (car (car list))) - (string-equal switches (nth 1 (car list)))) - (throw 'done (nthcdr 2 (car list))) - (setq list (cdr list))))))) - -(defun efs-add-to-ls-cache (file switches listing parsed) - ;; Only call after efs-get-from-cache returns nil, to avoid duplicate - ;; entries. PARSED should be t, if the listing has already been parsed. - (and (> efs-ls-cache-max 0) - (let ((switches (efs-canonize-switches switches)) - (file (efs-canonize-file-name file))) - (if (= efs-ls-cache-max 1) - (setq efs-ls-cache - (list (list file switches listing parsed))) - (if (>= (length efs-ls-cache) efs-ls-cache-max) - (setcdr (nthcdr (- efs-ls-cache-max 2) efs-ls-cache) nil)) - (setq efs-ls-cache (cons (list file switches listing parsed) - efs-ls-cache)))))) - -;;;; -------------------------------------------------------------- -;;;; Converting listings from cache. -;;;; -------------------------------------------------------------- - -(defun efs-get-ls-converter (to-switches) - ;; Returns converter alist for TO-SWITCHES - (efs-get-hash-entry (efs-canonize-switches to-switches) - efs-ls-converter-hashtable)) - -(defun efs-add-ls-converter (to-switches from-switches converter) - ;; Adds an entry to `efs-ls-converter-hashtable'. - ;; If from-switches is t, the converter converts from internal files - ;; hashtable. - (let* ((to-switches (efs-canonize-switches to-switches)) - (ent (efs-get-hash-entry to-switches efs-ls-converter-hashtable)) - (add (cons (or (eq from-switches t) - (efs-canonize-switches from-switches)) - converter))) - (if ent - (or (member add ent) - (nconc ent (list add))) - (efs-put-hash-entry to-switches (list add) efs-ls-converter-hashtable)))) - -(defun efs-convert-from-ls-cache (file switches host-type listing-type) - ;; Returns a listing by converting the switches from a cached listing. - (let ((clist (efs-get-ls-converter switches)) - (dir-p (= ?/ (aref file (1- (length file))))) - elt listing result regexp alist) - (while file ; this loop will iterate at most twice. - (setq alist clist) - (while alist - (setq elt (car alist)) - (if (eq (car elt) t) - (if (and dir-p (setq result (funcall (cdr elt) host-type - (let ((efs-ls-uncache t)) - (efs-get-files file)) - regexp))) - (setq alist nil - file nil) - (setq alist (cdr alist))) - (if (and (setq listing - (efs-get-from-ls-cache file (car elt))) - (save-excursion - (set-buffer - (let ((default-major-mode 'fundamental-mode)) - (get-buffer-create efs-data-buffer-name))) - (erase-buffer) - (insert (car listing)) - (and (funcall (cdr elt) listing-type regexp) - (setq result (buffer-string))))) - (setq alist nil - file nil) - (setq alist (cdr alist))))) - ;; Look for wildcards. - (if (and file (null dir-p) (null regexp)) - (setq regexp (efs-shell-regexp-to-regexp - (file-name-nondirectory file)) - file (file-name-directory file) - dir-p t) - (setq file nil))) - result)) - -;;; Define some converters - -(defun efs-unix-t-converter-sort-pred (elt1 elt2) - (let* ((data1 (car elt1)) - (data2 (car elt2)) - (year1 (car data1)) - (year2 (car data2)) - (month1 (nth 1 data1)) - (month2 (nth 1 data2)) - (day1 (nth 2 data1)) - (day2 (nth 2 data2)) - (hour1 (nth 3 data1)) - (hour2 (nth 3 data2)) - (minutes1 (nth 4 data1)) - (minutes2 (nth 4 data2))) - (if year1 - (and year2 - (or (> year1 year2) - (and (= year1 year2) - (or (> month1 month2) - (and (= month1 month2) - (> day1 day2)))))) - (if year2 - t - (or (> month1 month2) - (and (= month1 month2) - (or (> day1 day2) - (and (= day1 day2) - (or (> hour1 hour2) - (and (= hour1 hour2) - (> minutes1 minutes2))))))))))) - -(defun efs-unix-t-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let ((current-month (cdr (assoc (substring - (current-time-string) 4 7) - efs-month-alist))) - list-start start end list year month day hour minutes) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (forward-line 1) - (setq end (point)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp end t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq month (% (+ (- 11 current-month) - (cdr (assoc - (buffer-substring (match-beginning 2) - (match-end 2)) - efs-month-alist))) 12) - day (string-to-int - (buffer-substring (match-beginning 3) (match-end 3))) - year (buffer-substring (match-beginning 4) (match-end 4))) - (if (string-match ":" year) - (setq hour (string-to-int (substring year 0 - (match-beginning 0))) - minutes (string-to-int (substring year (match-end 0))) - year nil) - (setq hour nil - minutes nil - year (string-to-int year))) - (setq list (cons - (cons - (list year month day hour minutes) - (buffer-substring start end)) - list)) - (goto-char end)) - (setq list - (mapcar 'cdr - (sort list 'efs-unix-t-converter-sort-pred))) - (if reverse (setq list (nreverse list))) - (delete-region list-start (point)) - (apply 'insert list) - t))))) - -(efs-defun efs-t-converter nil (&optional regexp reverse) - ;; Converts listing without the t-switch, to ones with it. - nil) ; by default assume that we cannot work. - -(efs-fset 'efs-t-converter 'unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'sysV-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'apollo-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'bsd-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'dumb-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'dumb-apollo-unix 'efs-unix-t-converter) -(efs-fset 'efs-t-converter 'super-dumb-unix 'efs-unix-t-converter) - -(defun efs-rt-converter (listing-type &optional regexp) - ;; Reverse time sorting - (efs-t-converter listing-type regexp t)) - -(defun efs-unix-alpha-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let (list list-start end start next) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (end-of-line) - (setq end (point) - next (1+ end)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp end t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq list - (cons - (cons (buffer-substring (point) end) - (buffer-substring start next)) - list)) - (goto-char next)) - (delete-region list-start (point)) - (apply 'insert - (mapcar 'cdr - (sort list (if reverse - (function - (lambda (x y) - (string< (car y) (car x)))) - (function - (lambda (x y) - (string< (car x) (car y)))))))) - t))))) - -(efs-defun efs-alpha-converter nil (&optional regexp reverse) - ;; Converts listing to lexigraphical order. - nil) ; by default assume that we cannot work. - -(efs-fset 'efs-alpha-converter 'unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'sysV-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'apollo-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'bsd-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'dumb-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'dumb-apollo-unix 'efs-unix-alpha-converter) -(efs-fset 'efs-alpha-converter 'super-dumb-unix 'efs-unix-alpha-converter) - -(defun efs-ralpha-converter (listing-type &optional regexp) - ;; Reverse alphabetic - (efs-alpha-converter listing-type regexp t)) - -(defun efs-unix-S-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let (list list-start start next) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (forward-line 1) - (setq next (point)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp next t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq list - (cons - (cons (string-to-int - (buffer-substring (match-beginning 1) - (match-end 1))) - (buffer-substring start next)) - list)) - (goto-char next)) - (delete-region list-start (point)) - (apply 'insert - (mapcar 'cdr - (sort list (if reverse - (function - (lambda (x y) - (< (car x) (car y)))) - (function - (lambda (x y) - (> (car x) (car y)))))))) - t))))) - -(efs-defun efs-S-converter nil (&optional regexp reverse) - ;; Converts listing without the S-switch, to ones with it. - nil) ; by default assume that we cannot work. - -(efs-fset 'efs-S-converter 'unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'sysV-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'apollo-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'bsd-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'dumb-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'dumb-apollo-unix 'efs-unix-S-converter) -(efs-fset 'efs-S-converter 'super-dumb-unix 'efs-unix-S-converter) - -(defun efs-rS-converter (listing-type &optional regexp) - ;; Reverse S switch. - (efs-S-converter listing-type regexp t)) - -(defun efs-unix-X-converter (&optional regexp reverse) - (if regexp - nil - (goto-char (point-min)) - (efs-save-match-data - (if (re-search-forward efs-month-and-time-regexp nil t) - (let (next list list-start fnstart eol start end link-p) - (beginning-of-line) - (setq list-start (point)) - (while (progn - (setq start (point)) - (skip-chars-forward "0-9 ") - (setq link-p (= (following-char) ?l)) - (end-of-line) - (setq eol (point) - next (1+ eol)) - (goto-char start) - (re-search-forward efs-month-and-time-regexp eol t)) - ;; Need to measure wrto the current month - ;; There is a bug here if because of time-zone shifts, the - ;; local machine and the remote one are on different months. - (setq fnstart (point)) - (or (and link-p (search-forward " -> " eol t) - (goto-char (match-beginning 0))) - (goto-char eol)) - (setq end (point)) - (skip-chars-backward "^." fnstart) - (setq list - (cons - (cons - (if (= (point) fnstart) - "" - (buffer-substring (point) end)) - (buffer-substring start next)) - list)) - (goto-char next)) - (delete-region list-start (point)) - (apply 'insert - (mapcar 'cdr - (sort list (if reverse - (function - (lambda (x y) - (string< (car y) (car x)))) - (function - (lambda (x y) - (string< (car x) (car y)))))))) - t))))) - -(efs-defun efs-X-converter nil (&optional regexp reverse) - ;; Sort on file name extension. By default do nothing - nil) - -(defun efs-rX-converter (listing-type &optional regexp) - (efs-X-converter listing-type regexp t)) - -(efs-fset 'efs-X-converter 'unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'sysV-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'apollo-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'bsd-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'dumb-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'dumb-apollo-unix 'efs-unix-X-converter) -(efs-fset 'efs-X-converter 'super-dumb-unix 'efs-unix-X-converter) - -;;; Brief listings - -;;; The following functions do a heap better at packing than -;;; the usual ls listing. A variable column width is used. -(defun efs-column-widths (columns list &optional across) - ;; Returns the column widths for breaking LIST into - ;; COLUMNS number of columns. - (cond - ((null list) - nil) - ((= columns 1) - (list (apply 'max (mapcar 'length list)))) - ((let* ((len (length list)) - (col-length (/ len columns)) - (remainder (% len columns)) - (i 0) - (j 0) - (max-width 0) - widths padding) - (if (zerop remainder) - (setq padding 0) - (setq col-length (1+ col-length) - padding (- columns remainder))) - (setq list (nconc (copy-sequence list) (make-list padding nil))) - (setcdr (nthcdr (1- (+ len padding)) list) list) - (while (< i columns) - (while (< j col-length) - (setq max-width (max max-width (length (car list))) - list (if across (nthcdr columns list) (cdr list)) - j (1+ j))) - (setq widths (cons (+ max-width 2) widths) - max-width 0 - j 0 - i (1+ i)) - (if across (setq list (cdr list)))) - (setcar widths (- (car widths) 2)) - (nreverse widths))))) - -(defun efs-calculate-columns (list &optional across) - ;; Returns a list of integers which are the column widths that best pack - ;; LIST, a list of strings, onto the screen. - (and list - (let* ((width (1- (window-width))) - (columns (max 1 (/ width - (+ 2 (apply 'max (mapcar 'length list)))))) - col-list last-col-list) - (while (<= (apply '+ (setq col-list - (efs-column-widths columns list across))) - width) - (setq columns (1+ columns) - last-col-list col-list)) - (or last-col-list col-list)))) - -(defun efs-format-columns-of-files (files &optional across) - ;; Returns the number of lines used. - ;; If ACROSS is non-nil, sorts across rather than down the buffer, like - ;; ls -x - ;; A beefed up version of the function in dired. Thanks Sebastian. - (and files - (let* ((columns (efs-calculate-columns files across)) - (ncols (length columns)) - (ncols1 (1- ncols)) - (nfiles (length files)) - (nrows (+ (/ nfiles ncols) - (if (zerop (% nfiles ncols)) 0 1))) - (space-left (- (window-width) (apply '+ columns) 1)) - (stretch (/ space-left ncols1)) - (float-stretch (if (zerop ncols1) 0 (% space-left ncols1))) - (i 0) - (j 0) - (result "") - file padding) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* ncols nrows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j nrows) - (while (< i ncols) - (setq result (concat result (setq file (car files)))) - (setq padding (- (nth i columns) (length file))) - (or (= i ncols1) - (progn - (setq padding (+ padding stretch)) - (if (< i float-stretch) (setq padding (1+ padding))))) - (setq result (concat result (make-string padding ?\ ))) - (setq files (if across (cdr files) (nthcdr nrows files)) - i (1+ i))) - (setq result (concat result "\n")) - (setq i 0 - j (1+ j)) - (or across (setq files (cdr files)))) - result))) - -(defun efs-brief-converter (host-type file-table F a A p x C &optional regexp) - ;; Builds a brief directory listing for file cache, with - ;; possible switches F, a, A, p, x. - (efs-save-match-data - (let (list ent modes) - (efs-map-hashtable - (function - (lambda (key val) - (if (and - (efs-really-file-p host-type key val) - (or a - (and A (not (or (string-equal "." key) - (string-equal ".." key)))) - (/= (string-to-char key) ?.)) - (or (null regexp) - (string-match regexp key))) - (setq ent (car val) - modes (nth 3 val) - list (cons - (cond ((null (or F p)) - key) - ((eq t ent) - (concat key "/")) - ((cond - ((null F) - key) - ((stringp ent) - (concat key "@")) - ((null modes) - key) - ((eq (string-to-char modes) ?s) - ;; a socket - (concat key "=")) - ((or - (memq (elt modes 3) '(?x ?s ?t)) - (memq (elt modes 6) '(?x ?s ?t)) - (memq (elt modes 9) '(?x ?s ?t))) - (concat key "*")) - (t - key)))) - list))))) - file-table) - (setq list (sort list 'string<)) - (if (or C x) - (efs-format-columns-of-files list x) - (concat (mapconcat 'identity list "\n") "\n"))))) - -;;; Store converters. - -;; The cheaters. -(efs-add-ls-converter "-al" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) -(efs-add-ls-converter "-Al" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) -(efs-add-ls-converter "-alF" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) -(efs-add-ls-converter "-AlF" nil (function - (lambda (listing-type &optional regexp) - (null regexp)))) - -(efs-add-ls-converter "-alt" "-al" 'efs-t-converter) -(efs-add-ls-converter "-Alt" "-Al" 'efs-t-converter) -(efs-add-ls-converter "-lt" "-l" 'efs-t-converter) -(efs-add-ls-converter "-altF" "-alF" 'efs-t-converter) -(efs-add-ls-converter "-AltF" "-AlF" 'efs-t-converter) -(efs-add-ls-converter "-ltF" "-lF" 'efs-t-converter) -(efs-add-ls-converter "-alt" nil 'efs-t-converter) -(efs-add-ls-converter "-altF" nil 'efs-t-converter) -(efs-add-ls-converter "-Alt" nil 'efs-t-converter) ; cheating a bit -(efs-add-ls-converter "-AltF" nil 'efs-t-converter) ; cheating a bit - -(efs-add-ls-converter "-altr" "-al" 'efs-rt-converter) -(efs-add-ls-converter "-Altr" "-Al" 'efs-rt-converter) -(efs-add-ls-converter "-ltr" "-l" 'efs-rt-converter) -(efs-add-ls-converter "-altFr" "-alF" 'efs-rt-converter) -(efs-add-ls-converter "-AltFr" "-AlF" 'efs-rt-converter) -(efs-add-ls-converter "-ltFr" "-lF" 'efs-rt-converter) -(efs-add-ls-converter "-altr" nil 'efs-rt-converter) -(efs-add-ls-converter "-Altr" nil 'efs-rt-converter) - -(efs-add-ls-converter "-alr" "-alt" 'efs-alpha-converter) -(efs-add-ls-converter "-Alr" "-Alt" 'efs-alpha-converter) -(efs-add-ls-converter "-lr" "-lt" 'efs-alpha-converter) -(efs-add-ls-converter "-alFr" "-alFt" 'efs-alpha-converter) -(efs-add-ls-converter "-AlFr" "-AlFt" 'efs-alpha-converter) -(efs-add-ls-converter "-lFr" "-lFt" 'efs-alpha-converter) - -(efs-add-ls-converter "-al" "-alt" 'efs-alpha-converter) -(efs-add-ls-converter "-Al" "-Alt" 'efs-alpha-converter) -(efs-add-ls-converter "-l" "-lt" 'efs-alpha-converter) -(efs-add-ls-converter "-alF" "-alFt" 'efs-alpha-converter) -(efs-add-ls-converter "-AlF" "-AlFt" 'efs-alpha-converter) -(efs-add-ls-converter "-lF" "-lFt" 'efs-alpha-converter) -(efs-add-ls-converter nil "-alt" 'efs-alpha-converter) - -(efs-add-ls-converter "-alr" "-al" 'efs-ralpha-converter) -(efs-add-ls-converter "-Alr" "-Al" 'efs-ralpha-converter) -(efs-add-ls-converter "-lr" "-l" 'efs-ralpha-converter) -(efs-add-ls-converter "-alFr" "-alF" 'efs-ralpha-converter) -(efs-add-ls-converter "-lAFr" "-lAF" 'efs-ralpha-converter) -(efs-add-ls-converter "-lFr" "-lF" 'efs-ralpha-converter) -(efs-add-ls-converter "-alr" nil 'efs-ralpha-converter) - -(efs-add-ls-converter "-alr" "-alt" 'efs-ralpha-converter) -(efs-add-ls-converter "-Alr" "-Alt" 'efs-ralpha-converter) -(efs-add-ls-converter "-lr" "-lt" 'efs-ralpha-converter) -(efs-add-ls-converter "-alFr" "-alFt" 'efs-ralpha-converter) -(efs-add-ls-converter "-lAFr" "-lAFt" 'efs-ralpha-converter) -(efs-add-ls-converter "-lFr" "-lFt" 'efs-ralpha-converter) - -(efs-add-ls-converter "-alS" "-al" 'efs-S-converter) -(efs-add-ls-converter "-AlS" "-Al" 'efs-S-converter) -(efs-add-ls-converter "-lS" "-l" 'efs-S-converter) -(efs-add-ls-converter "-alSF" "-alF" 'efs-S-converter) -(efs-add-ls-converter "-AlSF" "-AlF" 'efs-S-converter) -(efs-add-ls-converter "-lSF" "-lF" 'efs-S-converter) -(efs-add-ls-converter "-alS" nil 'efs-S-converter) - -(efs-add-ls-converter "-alSr" "-al" 'efs-rS-converter) -(efs-add-ls-converter "-AlSr" "-Al" 'efs-rS-converter) -(efs-add-ls-converter "-lSr" "-l" 'efs-rS-converter) -(efs-add-ls-converter "-alSFr" "-alF" 'efs-rS-converter) -(efs-add-ls-converter "-AlSFr" "-AlF" 'efs-rS-converter) -(efs-add-ls-converter "-lSFr" "-lF" 'efs-rS-converter) -(efs-add-ls-converter "-alSr" nil 'efs-rS-converter) - -(efs-add-ls-converter "-alS" "-alt" 'efs-S-converter) -(efs-add-ls-converter "-AlS" "-Alt" 'efs-S-converter) -(efs-add-ls-converter "-lS" "-lt" 'efs-S-converter) -(efs-add-ls-converter "-alSF" "-alFt" 'efs-S-converter) -(efs-add-ls-converter "-AlSF" "-AlFt" 'efs-S-converter) -(efs-add-ls-converter "-lSF" "-lFt" 'efs-S-converter) - -(efs-add-ls-converter "-alSr" "-alt" 'efs-rS-converter) -(efs-add-ls-converter "-AlSr" "-Alt" 'efs-rS-converter) -(efs-add-ls-converter "-lSr" "-lt" 'efs-rS-converter) -(efs-add-ls-converter "-alSFr" "-alFt" 'efs-rS-converter) -(efs-add-ls-converter "-AlSFr" "-AlFt" 'efs-rS-converter) -(efs-add-ls-converter "-lSFr" "-lFt" 'efs-rS-converter) - -(efs-add-ls-converter "-AlX" nil 'efs-X-converter) -(efs-add-ls-converter "-alX" nil 'efs-X-converter) -(efs-add-ls-converter "-AlXr" nil 'efs-rX-converter) -(efs-add-ls-converter "-alXr" nil 'efs-rX-converter) - -(efs-add-ls-converter "-alX" "-al" 'efs-X-converter) -(efs-add-ls-converter "-AlX" "-Al" 'efs-X-converter) -(efs-add-ls-converter "-lX" "-l" 'efs-X-converter) -(efs-add-ls-converter "-alXF" "-alF" 'efs-X-converter) -(efs-add-ls-converter "-AlXF" "-AlF" 'efs-X-converter) -(efs-add-ls-converter "-lXF" "-lF" 'efs-X-converter) - -(efs-add-ls-converter "-alXr" "-al" 'efs-rX-converter) -(efs-add-ls-converter "-AlXr" "-Al" 'efs-rX-converter) -(efs-add-ls-converter "-lXr" "-l" 'efs-rX-converter) -(efs-add-ls-converter "-alXFr" "-alF" 'efs-rX-converter) -(efs-add-ls-converter "-AlXFr" "-AlF" 'efs-rX-converter) -(efs-add-ls-converter "-lXFr" "-lF" 'efs-rX-converter) - -;;; Converters for efs-files-hashtable - -(efs-add-ls-converter - "" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil nil nil nil regexp)))) -(efs-add-ls-converter - "-C" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil nil nil t regexp)))) -(efs-add-ls-converter - "-F" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - t nil nil nil nil nil regexp)))) -(efs-add-ls-converter - "-p" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil t nil nil regexp)))) -(efs-add-ls-converter - "-CF" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - t nil nil nil nil t regexp)))) -(efs-add-ls-converter - "-Cp" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil nil t nil t regexp)))) -(efs-add-ls-converter - "-x" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files - nil nil nil nil t nil regexp)))) -(efs-add-ls-converter - "-xF" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t nil nil nil t nil regexp)))) -(efs-add-ls-converter - "-xp" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil nil t t nil regexp)))) -(efs-add-ls-converter - "-Ca" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil nil nil t regexp)))) -(efs-add-ls-converter - "-CFa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t t nil nil nil t regexp)))) -(efs-add-ls-converter - "-Cpa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil t nil t regexp)))) -(efs-add-ls-converter - "-xa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil nil t nil regexp)))) -(efs-add-ls-converter - "-xFa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t t nil nil t nil regexp)))) -(efs-add-ls-converter - "-xpa" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil t nil t t nil regexp)))) -(efs-add-ls-converter - "-CA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t nil nil t regexp)))) -(efs-add-ls-converter - "-CFA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t nil t nil nil t regexp)))) -(efs-add-ls-converter - "-CpA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t t nil t regexp)))) -(efs-add-ls-converter - "-xA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t nil t nil regexp)))) -(efs-add-ls-converter - "-xFA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files t nil t nil t nil regexp)))) -(efs-add-ls-converter - "-xpA" t (function - (lambda (host-type files &optional regexp) - (efs-brief-converter host-type files nil nil t t t nil regexp)))) - -;;;; ------------------------------------------------------------ -;;;; Directory Listing Parsers -;;;; ------------------------------------------------------------ - -(defconst efs-unix:dl-listing-regexp - "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") - -;; Note to progammers: -;; Below are a series of macros and functions used for parsing unix -;; file listings. They are intended only to be used together, so be careful -;; about using them out of context. - -(defmacro efs-ls-parse-file-line () - ;; Extract the filename, size, and permission string from the current - ;; line of a dired-like listing. Assumes that the point is at - ;; the beginning of the line, leaves it just before the size entry. - ;; Returns a list (name size perm-string nlinks owner). - ;; If there is no file on the line, returns nil. - (` (let ((eol (save-excursion (end-of-line) (point))) - name size modes nlinks owner) - (skip-chars-forward " 0-9" eol) - (and - (looking-at efs-modes-links-owner-regexp) - (setq modes (buffer-substring (match-beginning 1) - (match-end 1)) - nlinks (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))) - owner (buffer-substring (match-beginning 3) (match-end 3))) - (re-search-forward efs-month-and-time-regexp eol t) - (setq name (buffer-substring (point) eol) - size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (list name size modes nlinks owner))))) - -(defun efs-relist-symlink (host user symlink path switches) - ;; Does a re-list of a single symlink in efs-data-buffer-name-2, - ;; HOST = remote host - ;; USER = remote username - ;; SYMLINK = symbolic link name as a remote fullpath - ;; PATH = efs full path syntax for the dir. being listed - ;; SWITCHES = ls switches to use for the re-list - ;; Returns (symlink-name symlink-target), as given by the listing. Returns - ;; nil if the listing fails. - ;; Does NOT correct for any symlink marking. - (let* ((temp (efs-make-tmp-name host nil)) - (temp-file (car temp)) - (default-major-mode 'fundamental-mode) - spot) - (unwind-protect - (and - (prog1 - (null - (car - (efs-send-cmd host user - (list 'dir symlink (cdr temp) switches) - (format "Listing %s" - (efs-relativize-filename - (efs-replace-path-component - path symlink)))))) - ;; Put the old message back. - (if (and efs-verbose - (not (and (boundp 'dired-in-query) dired-in-query))) - (message "Listing %s..." - (efs-relativize-filename path)))) - (save-excursion - (if (efs-ftp-path temp-file) - (efs-add-file-entry (efs-host-type efs-gateway-host) - temp-file nil nil nil)) - (set-buffer (get-buffer-create efs-data-buffer-name-2)) - (erase-buffer) - (if (or (file-readable-p temp-file) - (sleep-for efs-retry-time) - (file-readable-p temp-file)) - (let (efs-verbose) - (insert-file-contents temp-file)) - (efs-error host user - (format - "list data file %s not readable" temp-file))) - (skip-chars-forward " 0-9") - (and - (eq (following-char) ?l) - (re-search-forward efs-month-and-time-regexp nil t) - (setq spot (point)) - (re-search-forward " -> " nil t) - (progn - (end-of-line) - (list - ;; We might get the full path in the listing. - (file-name-nondirectory - (buffer-substring spot (match-beginning 0))) - (buffer-substring (match-end 0) (point))))))) - (efs-del-tmp-name temp-file)))) - -(defun efs-ls-sysV-p (host user dir linkname path) - ;; Returns t if the symlink is listed in sysV style. i.e. The - ;; symlink name is marked with an @. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory being listed as a remote full path. - ;; LINKNAME = relative name of symbolic link as derived from an ls -..F... - ;; this is assumed to end with an @ - ;; PATH = efs full path synatx for the directory - (let ((link (car (efs-relist-symlink - host user - (concat dir (substring linkname 0 -1)) - path "-lFd" )))) - (and link (string-equal link linkname)))) - -(defun efs-ls-next-p (host user dir linkname target path) - ;; Returns t is the symlink is marked in the NeXT style. - ;; i.e. The symlink destination is marked with an @. - ;; This assumes that the host-type has already been identified - ;; as NOT sysV-unix, and that target ends in an "@". - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = remote directory being listed, as a remore full path - ;; LINKNAME = relative name of symbolic link - ;; Since we've eliminated sysV, it won't be marked with an @ - ;; TARGET = target of symbolic link, as derived from an ls -..F.. - ;; PATH = directory being listed in full efs path syntax. - (let ((no-F-target (nth 1 (efs-relist-symlink - host user - (concat dir linkname) - path "-ld")))) - (and no-F-target - (string-equal (concat no-F-target "@") target)))) - -;; This deals with the F switch. Should also do something about -;; unquoting names obtained with the SysV b switch and the GNU Q -;; switch. See Sebastian's dired-get-filename. - -(defun efs-ls-parser (host-type host user dir path switches) - ;; Meant to be called by efs-parse-listing. - ;; Assumes that point is at the beginning of the first file line. - ;; Assumes that SWITCHES has already been bound to nil for a dumb host. - ;; HOST-TYPE is the remote host-type - ;; HOST is the remote host name - ;; USER is the remote user name - ;; DIR is the remote directory as a full path - ;; PATH is the directory in full efs syntax, and directory syntax. - ;; SWITCHES is the ls listing switches - (let ((tbl (efs-make-hashtable)) - (used-F (and switches (string-match "F" switches))) - (old-tbl (efs-get-files-hashtable-entry path)) - file-type symlink directory file size modes nlinks owner) - (while (setq file (efs-ls-parse-file-line)) - (setq size (nth 1 file) - modes (nth 2 file) - nlinks (nth 3 file) - owner (nth 4 file) - file (car file) - file-type (string-to-char modes) - directory (eq file-type ?d)) - (if (eq file-type ?l) - (if (string-match " -> " file) - (setq symlink (substring file (match-end 0)) - file (substring file 0 (match-beginning 0))) - ;; Shouldn't happen - (setq symlink "")) - (setq symlink nil)) - (if used-F - ;; The F-switch jungle - (let ((socket (eq file-type ?s)) - (fifo (eq file-type ?p)) - (executable - (and (not symlink) ; x bits don't mean a thing for symlinks - (or (memq (elt modes 3) '(?x ?s ?t)) - (memq (elt modes 6) '(?x ?s ?t)) - (memq (elt modes 9) '(?x ?s ?t)))))) - ;; Deal with marking of directories, executables, and sockets. - (if (or (and executable (string-match "*$" file)) - (and socket (string-match "=$" file)) - (and fifo (string-match "|$" file))) - (setq file (substring file 0 -1)) - ;; Do the symlink dance. - (if symlink - (let ((fat-p (string-match "@$" file)) - (sat-p (string-match "@$" symlink))) - (cond - ;; Those that mark the file - ((and (memq host-type '(sysV-unix apollo-unix)) fat-p) - (setq file (substring file 0 -1))) - ;; Those that mark nothing - ((memq host-type '(bsd-unix dumb-unix))) - ;; Those that mark the target - ((and (eq host-type 'next-unix) sat-p) - (setq symlink (substring symlink 0 -1))) - ;; We don't know - ((eq host-type 'unix) - (if fat-p - (cond - ((efs-ls-sysV-p host user dir - file path) - (setq host-type 'sysV-unix - file (substring file 0 -1)) - (efs-add-host 'sysV-unix host) - (efs-add-listing-type 'sysV-unix host user)) - ((and sat-p - (efs-ls-next-p host user dir file symlink - path)) - (setq host-type 'next-unix - symlink (substring symlink 0 -1)) - (efs-add-host 'next-unix host) - (efs-add-listing-type 'next-unix host user)) - (t - (setq host-type 'bsd-unix) - (efs-add-host 'bsd-unix host) - (efs-add-listing-type 'bsd-unix host user))) - (if (and sat-p - (efs-ls-next-p host user dir file - symlink path)) - (progn - (setq host-type 'next-unix - symlink (substring symlink 0 -1)) - (efs-add-host 'next-unix host) - (efs-add-listing-type 'next-unix host user)) - (setq host-type 'bsd-unix) - (efs-add-host 'bsd-unix host) - (efs-add-listing-type 'bsd-unix host user))))) - ;; Look out for marking of symlink - ;; If we really wanted to, at this point we - ;; could distinguish aix from hp-ux, ultrix, irix and a/ux, - ;; allowing us to skip the re-list in the future, for the - ;; later 4 host types. Another version... - (if (string-match "[=|*]$" symlink) - (let ((relist (efs-relist-symlink - host user (concat dir file) - path "-dl"))) - (if relist (setq symlink (nth 1 relist)))))))))) - ;; Strip / off the end unconditionally. It's not a valid file character - ;; anyway. - (if (string-match "/$" file) (setq file (substring file 0 -1))) - (let ((mdtm (and old-tbl (nth 5 (efs-get-hash-entry file old-tbl))))) - (if mdtm - (efs-put-hash-entry file (list (or symlink directory) size owner - modes nlinks mdtm) tbl) - (efs-put-hash-entry file (list (or symlink directory) size owner - modes nlinks) tbl))) - (forward-line 1)) - (efs-put-hash-entry "." '(t) tbl) - (efs-put-hash-entry ".." '(t) tbl) - tbl)) - -(efs-defun efs-parse-listing nil (host user dir path &optional switches) - ;; Parse the a listing which is assumed to be from some type of unix host. - ;; Note that efs-key will be bound to the actual host type. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches used for the listing - (efs-save-match-data - (cond - ;; look for total line - ((looking-at "^total [0-9]+$") - (forward-line 1) - ;; Beware of machines that put a blank line after the totals line. - (skip-chars-forward " \t\n") - (efs-ls-parser efs-key host user dir path switches)) - ;; look for errors - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - nil) - ((eobp) ; i.e. zerop buffer-size - nil) ; assume an ls error message - ;; look for listings without total lines - ((re-search-forward efs-month-and-time-regexp nil t) - (beginning-of-line) - (efs-ls-parser efs-key host user dir path switches)) - (t nil)))) - -(efs-defun efs-parse-listing unix:unknown - (host user dir path &optional switches) - ;; Parse the a listing which is assumed to be from some type of unix host, - ;; possibly one doing a dl listing. - ;; HOST = remote host name - ;; USER = remote user name - ;; DIR = directory as a remote full path - ;; PATH = directory in full efs path syntax - ;; SWITCHES = ls switches used for the listing - (efs-save-match-data - (cond - ;; look for total line - ((looking-at "^total [0-9]+$") - (forward-line 1) - ;; Beware of machines that put a blank line after the totals line. - (skip-chars-forward " \t\n") - ;; This will make the listing-type track the host-type. - (efs-add-listing-type nil host user) - (efs-ls-parser 'unix host user dir path switches)) - ;; look for errors - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - nil) - ((eobp) ; i.e. zerop buffer-size - nil) ; assume an ls error message - ;; look for listings without total lines - ((and (re-search-forward efs-month-and-time-regexp nil t) - (progn - (beginning-of-line) - (looking-at efs-modes-links-owner-regexp))) - (efs-add-listing-type nil host user) - (efs-ls-parser 'unix host user dir path switches)) - ;; look for dumb listings - ((re-search-forward - (concat (regexp-quote switches) - " not found\\|\\(^ls: +illegal option -- \\)") - (save-excursion (end-of-line) (point)) t) - (if (eq (efs-host-type host) 'apollo-unix) - (progn - (efs-add-host 'dumb-apollo-unix host) - (efs-add-listing-type 'dumb-apollo-unix host user)) - (efs-add-host 'dumb-unix host) - (efs-add-listing-type 'dumb-unix host user)) - (if (match-beginning 1) - ;; Need to try to list again. - (let ((efs-ls-uncache t)) - (efs-ls - path nil (format "Relisting %s" (efs-relativize-filename path)) t) - (goto-char (point-min)) - (efs-parse-listing nil host user dir path switches)) - (if (re-search-forward "^total [0-9]+$" nil t) - (progn - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (efs-ls-parser 'dumb-unix host user dir path switches))))) - ;; Look for dl listings. - ((re-search-forward efs-unix:dl-listing-regexp nil t) - (efs-add-host 'unix host) - (efs-add-listing-type 'unix:dl host user) - (efs-parse-listing 'unix:dl host user dir path switches)) - ;; don't know, return nil - (t nil)))) - -(defun efs-ls-parse-1-liner (filename buffer &optional symlink) - ;; Parse a 1-line listing for FILENAME in BUFFER, and update - ;; the cached info for FILENAME. - ;; Optional SYMLINK arg gives the expected target of a symlink. - ;; Since one-line listings are usually used to update info for - ;; newly created files, we usually know what sort of a file to expect. - ;; Actually trying to parse out the symlink target could be impossible - ;; for some types of switches. - (efs-save-buffer-excursion - (set-buffer buffer) - (goto-char (point-min)) - (skip-chars-forward " 0-9") - (efs-save-match-data - (let (modes nlinks owner size) - (and - (looking-at efs-modes-links-owner-regexp) - (setq modes (buffer-substring (match-beginning 1) (match-end 1)) - nlinks (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))) - owner (buffer-substring (match-beginning 3) (match-end 3))) - (re-search-forward efs-month-and-time-regexp nil t) - (setq size (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (let* ((filename (directory-file-name filename)) - (files (efs-get-files-hashtable-entry - (file-name-directory filename)))) - (if files - (let* ((key (efs-get-file-part filename)) - (ignore-case (memq (efs-host-type - (car (efs-ftp-path filename))) - efs-case-insensitive-host-types)) - (ent (efs-get-hash-entry key files ignore-case)) - (mdtm (nth 5 ent)) - type) - (if (= (string-to-char modes) ?l) - (setq type - (cond - ((stringp symlink) - symlink) - ((stringp (car ent)) - (car ent)) - (t ; something weird happened. - ""))) - (if (= (string-to-char modes) ?d) - (setq type t))) - (efs-put-hash-entry - key (list type size owner modes nlinks mdtm) - files ignore-case))))))))) - -(efs-defun efs-update-file-info nil (file buffer &optional symlink) - "For FILE, update cache information from a single file listing in BUFFER." - ;; By default, this does nothing. - nil) - -(efs-defun efs-update-file-info unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info sysV-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info bsd-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info next-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info apollo-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info dumb-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info dumb-apollo-unix - (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) -(efs-defun efs-update-file-info super-dumb-unix (file buffer &optional symlink) - (efs-ls-parse-1-liner file buffer)) - -;;;; ---------------------------------------------------------------- -;;;; The 'unknown listing parser. This does some host-type guessing. -;;;; ---------------------------------------------------------------- - -;;; Regexps for host and listing type guessing from the listing syntax. - -(defconst efs-ka9q-listing-regexp - (concat - "^\\([0-9,.]+\\|No\\) files\\. [0-9,.]+ bytes free\\. " - "Disk size [0-9,]+ bytes\\.$")) -;; This version of the regexp is really for hosts which allow some switches, -;; but not ours. Rather than determine which switches we could be using -;; we just assume that it's dumb. -(defconst efs-dumb-unix-listing-regexp - (concat - "^[Uu]sage: +ls +-[a-zA-Z0-9]+[ \n]\\|" - ;; Unitree server - "^Error getting stats for \"-[a-zA-Z0-9]+\"")) - -(defconst efs-dos-distinct-date-and-time-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " - "[ 12][0-9]:[0-5][0-9] ")) -;; Regexp to match the output from the hellsoft ftp server to an -;; ls -al. Unfortunately, this looks a lot like some unix ls error -;; messages. -(defconst efs-hell-listing-regexp - (concat - "ls: file or directory not found\n\\'\\|" - "[-d]\\[[-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z]\\]")) - -(efs-defun efs-parse-listing unknown - (host user dir path &optional switches) - "Parse the current buffer which is assumed to contain a dir listing. -Return a hashtable as the result. If the listing is not really a -directory listing, then return nil. - -HOST is the remote host's name. -USER is the remote user name. -DIR is the directory as a full remote path. -PATH is the directory in full efs path synatx. -SWITCHES are the switches passed to ls. If SWITCHES is nil, then a -dumb \(with dir\) listing has been done." - (efs-save-match-data - (cond - - ;; look for total line - ((looking-at "^total [0-9]+$") - (efs-add-host 'unix host) - (forward-line 1) - ;; Beware of machines that put a blank line after the totals line. - (skip-chars-forward " \t\n") - (efs-ls-parser 'unix host user dir path switches)) - - ;; Look for hellsoft. Need to do this before looking - ;; for ls errors, since the hellsoft output looks a lot like an ls error. - ((looking-at efs-hell-listing-regexp) - (if (null (car (efs-send-cmd host user '(quote site dos)))) - (let* ((key (concat host "/" user "/~")) - (tilde (efs-get-hash-entry - key efs-expand-dir-hashtable))) - (efs-add-host 'hell host) - ;; downcase the expansion of ~ - (if (and tilde (string-match "^[^a-z]+$" tilde)) - (efs-put-hash-entry key (downcase tilde) - efs-expand-dir-hashtable)) - ;; Downcase dir, in case its got some upper case stuff in it. - (setq dir (downcase dir) - path (efs-replace-path-component path dir)) - (let ((efs-ls-uncache t)) - ;; This will force the data buffer to be re-filled - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'hell host user dir path)) - ;; Don't know, give unix a try. - (efs-add-host 'unix host) - nil)) - - ;; look for ls errors - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - (efs-add-host 'unix host) - nil) - - ((eobp) ; i.e. (zerop (buffer-size)) - ;; This could be one of: - ;; (1) An Ultrix ls error message - ;; (2) A listing with the A switch of an empty directory - ;; on a machine which doesn't give a total line. - ;; (3) The result of an attempt at an nlist. (This would mean a - ;; dumb host.) - ;; (4) The twilight zone. - (cond - ((save-excursion - (set-buffer (process-buffer - (efs-get-process host user))) - (save-excursion - (goto-char (point-max)) - (and - ;; The dir ftp output starts with a 200 cmd. - (re-search-backward "^150 " nil t) - ;; We never do an nlist (it's a short listing). - ;; If the machine thinks that we did, it's dumb. - (looking-at "[^\n]+ NLST ")))) - ;; It's dumb-unix or ka9q. Anything else? - ;; This will re-fill the data buffer with a dumb listing. - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (cond - ;; check for dumb-unix - ((re-search-forward efs-month-and-time-regexp nil t) - (efs-add-host 'dumb-unix host) - (beginning-of-line) - (efs-parse-listing 'dumb-unix host user dir path)) - ;; check for ka9q - ((save-excursion - (goto-char (point-max)) - (forward-line -1) - (looking-at efs-ka9q-listing-regexp)) - (efs-add-host 'ka9q host) - (efs-parse-listing 'ka9q host user dir path)) - (t ; Don't know, try unix. - (efs-add-host 'unix host) - nil))) - ;; check for Novell Netware - ((null (car (efs-send-cmd host user '(quote site nfs)))) - (efs-add-host 'netware host) - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'netware host user dir path)) - (t - ;; Assume (1), an Ultrix error message. - (efs-add-host 'unix host) - nil))) - - ;; unix without a total line - ((re-search-forward efs-month-and-time-regexp nil t) - (efs-add-host 'unix host) - (beginning-of-line) - (efs-ls-parser 'unix host user dir path switches)) - - ;; Now we look for host-types, or listing-types which are auto-rec - ;; by the listing parser, because it's not possible to pick them out - ;; from a pwd. - - ;; check for dumb-unix - ;; (Guessing of dumb-unix hosts which return an ftp error message is - ;; done in efs-ls.) - ((re-search-forward efs-dumb-unix-listing-regexp nil t) - (efs-add-host 'dumb-unix host) - ;; This will force the data buffer to be re-filled - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'dumb-unix host user dir path)) - - ;; check for Distinct's DOS ftp server - ((re-search-forward efs-dos-distinct-date-and-time-regexp nil t) - (efs-add-host 'dos-distinct host) - (efs-parse-listing 'dos-distinct host user dir path)) - - ;; check for KA9Q pseudo-unix (LINUX?) - ((save-excursion - (goto-char (point-max)) - (forward-line -1) - (looking-at efs-ka9q-listing-regexp)) - (efs-add-host 'ka9q host) - ;; This will re-fill the data buffer. - ;; Need to do this because ka9q is a dumb host. - (let ((efs-ls-uncache t)) - (efs-ls path nil (format "Relisting %s" - (efs-relativize-filename path)) - t)) - (efs-parse-listing 'ka9q host user dir path)) - - ;; Check for a unix descriptive (dl) listing - ;; Do this last, because it's hard to guess. - ((re-search-forward efs-unix:dl-listing-regexp nil t) - (efs-add-host 'unix host) - (efs-add-listing-type 'unix:dl host user) - (efs-parse-listing 'unix:dl host user dir path switches)) - - ;; Don't know what's going on. Return nil, and assume unix. - (t - (efs-add-host 'unix host) - nil)))) - -;;;; ------------------------------------------------------------ -;;;; Directory information hashtable. -;;;; ------------------------------------------------------------ - -(efs-defun efs-really-file-p nil (file ent) - ;; efs-files-hashtable sometimes contains fictitious entries, when - ;; some OS's allow a file to be accessed by another name. For example, - ;; in VMS the highest version of a file may be accessed by omitting the - ;; the file version number. This function should return t if the - ;; filename FILE is really a file. ENT is the hash entry of the file. - t) - -(efs-defun efs-add-file-entry nil (path type size owner - &optional modes nlinks mdtm) - ;; Add a new file entry for PATH - ;; TYPE is nil for a plain file, t for a directory, and a string - ;; (the target of the link) for a symlink. - ;; SIZE is the size of the file in bytes. - ;; OWNER is the owner of the file, as a string. - ;; MODES is the file modes, as a string. In Unix, this will be 10 cars. - ;; NLINKS is the number of links for the file. - ;; MDTM is the last modtime obtained for the file. This is for - ;; short-term cache only, as emacs often has sequences of functions - ;; doing modtime lookup. If you really want to be sure of the modtime, - ;; use efs-get-file-mdtm, which asks the remote server. - - (and (eq type t) - (setq path (directory-file-name path))) - (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) - (if files - (efs-put-hash-entry - (efs-get-file-part path) - (cond (mdtm - (list type size owner modes nlinks - mdtm)) - (nlinks - (list type size owner modes nlinks)) - (modes (list type size owner modes)) - (t (list type size owner))) - files - (memq efs-key efs-case-insensitive-host-types))) - (efs-del-from-ls-cache path t nil))) - -(efs-defun efs-delete-file-entry nil (path &optional dir-p) - "Delete the file entry for PATH, if its directory info exists." - (if dir-p - (progn - (setq path (file-name-as-directory path)) - (efs-del-hash-entry (efs-canonize-file-name path) - efs-files-hashtable) - ;; Note that file-name-as-directory followed by - ;; (substring path 0 -1) - ;; serves to canonicalize directory file names to their unix form. - ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO - ;; PATH is supposed to be s fully expanded efs-style path. - (setq path (substring path 0 -1)))) - (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) - (if files - (efs-del-hash-entry - (efs-get-file-part path) - files - (memq (efs-host-type (car (efs-ftp-path path))) - efs-case-insensitive-host-types)))) - (efs-del-from-ls-cache path t nil) - (if dir-p (efs-del-from-ls-cache path nil t))) - -(defun efs-set-files (directory files) - "For DIRECTORY, set or change the associated FILES hashtable." - (if files - (efs-put-hash-entry - (efs-canonize-file-name (file-name-as-directory directory)) - files efs-files-hashtable))) - -(defun efs-parsable-switches-p (switches &optional full-dir) - ;; Returns non-nil if SWITCHES would give an ls listing suitable for parsing - ;; If FULL-DIR is non-nil, the switches must be suitable for parsing a full - ;; ditectory. - (or (null switches) - (efs-save-match-data - (and (string-match "[aA]" switches) - ;; g is not good enough, need l or o for owner. - (string-match "[lo]" switches) - ;; L shows link target, rather than link. We need both. - (not (string-match "[RfL]" switches)) - (not (and full-dir (string-match "d" switches))))))) - -(defun efs-get-files (directory &optional no-error) - "For DIRECTORY, return a hashtable of file entries. -This will give an error or return nil, depending on the value of -NO-ERROR, if a listing for DIRECTORY cannot be obtained." - (let ((directory (file-name-as-directory directory))) - (or (efs-get-files-hashtable-entry directory) - (and (efs-ls directory (efs-ls-guess-switches) t 'parse no-error) - (efs-get-files-hashtable-entry directory))))) - -(efs-defun efs-allow-child-lookup nil (host user dir file) - ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir - ;; according to its file-name syntax, and therefore a child listing should - ;; be attempted. Note that DIR is in directory syntax. - ;; i.e. /foo/bar/, not /foo/bar. - ;; Deal with dired. Anything else? - (not (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file file)))) - -(defmacro efs-ancestral-check (host-type path ignore-case) - ;; Checks to see if something in a path's ancient parentage - ;; would make it impossible for the path to exist in the directory - ;; tree. In this case it returns nil. Otherwise returns t (there - ;; is essentially no information returned in this case, the file - ;; may exist or not). - ;; This macro should make working with RCS more efficient. - ;; It also helps with FTP servers that go into fits if we ask to - ;; list a non-existent dir. - ;; Yes, I know that the function mapped over the hashtable can - ;; be written more cleanly with a concat, but this is faster. - ;; concat's cause a lot of consing. So do regexp-quote's, but we can't - ;; avoid it. - ;; Probably doesn't make much sense for this to be an efs-defun, since - ;; the host-type dependence is very mild. - (` - (let ((path (, path)) ; expand once - (ignore-case (, ignore-case)) - str) - ;; eliminate flat file systems -- should have a constant for this - (or (memq (, host-type) '(mts cms mvs cms-knet)) - (efs-save-match-data - (catch 'foo - (efs-map-hashtable - (function - (lambda (key val) - (and (eq (string-match (regexp-quote key) path) 0) - (setq str (substring path (match-end 0))) - (string-match "^[^/]+" str) - (not (efs-hash-entry-exists-p - (substring str 0 (match-end 0)) - val ignore-case)) - (throw 'foo nil)))) - efs-files-hashtable) - t)))))) - -(defun efs-file-entry-p (path) - ;; Return whether there is a file entry for PATH. - ;; Under no circumstances does this cause FTP activity. - (let* ((path (directory-file-name (efs-canonize-file-name path))) - (dir (file-name-directory path)) - (file (efs-get-file-part path)) - (tbl (efs-get-files-hashtable-entry dir))) - (and tbl (efs-hash-entry-exists-p - file tbl - (memq (efs-host-type (car (efs-ftp-path dir))) - efs-case-insensitive-host-types)) t))) - -(defun efs-get-file-entry (path) - "Return the given file entry for PATH. -This is a list of the form \(type size owner modes nlinks modtm\), -where type is nil for a normal file, t for a directory, and a string for a -symlink, size is the size of the file in bytes, if known, and modes are -the permission modes of the file as a string. modtm is short-term the -cache of the file modtime. It is not used by `verify-visited-file-modtime'. -If the file isn't in the hashtable, this returns nil." - (let* ((path (directory-file-name (efs-canonize-file-name path))) - (dir (file-name-directory path)) - (file (efs-get-file-part path)) - (parsed (efs-ftp-path dir)) - (host (car parsed)) - (host-type (efs-host-type host)) - (ent (efs-get-files-hashtable-entry dir)) - (ignore-case (memq host-type efs-case-insensitive-host-types))) - (if ent - (efs-get-hash-entry file ent ignore-case) - (let ((user (nth 1 parsed)) - (r-dir (nth 2 parsed))) - (and (efs-ancestral-check host-type path ignore-case) - (or (and efs-allow-child-lookup - (efs-allow-child-lookup host-type - host user r-dir file) - (setq ent (efs-get-files path t)) - (efs-get-hash-entry "." ent)) - ;; i.e. it's a directory by child lookup - (efs-get-hash-entry - file (efs-get-files dir) ignore-case))))))) - -(defun efs-wipe-file-entries (host user) - "Remove cache data for all files on HOST and USER. -This replaces the file entry information hashtable with one that -doesn't have any entries for the given HOST, USER pair." - (let ((new-tbl (efs-make-hashtable (length efs-files-hashtable))) - (host (downcase host)) - (case-fold (memq (efs-host-type host) - efs-case-insensitive-host-types))) - (if case-fold (setq user (downcase user))) - (efs-map-hashtable - (function - (lambda (key val) - (let ((parsed (efs-ftp-path key))) - (if parsed - (let ((h (nth 0 parsed)) - (u (nth 1 parsed))) - (or (and (string-equal host (downcase h)) - (string-equal user (if case-fold (downcase u) u))) - (efs-put-hash-entry key val new-tbl))))))) - efs-files-hashtable) - (setq efs-files-hashtable new-tbl))) - - -;;;; ============================================================ -;;;; >8 -;;;; Redefinitions of standard GNU Emacs functions. -;;;; ============================================================ - -;;;; ------------------------------------------------------------ -;;;; expand-file-name and friends... -;;;; ------------------------------------------------------------ - -;; New filename expansion code for efs. -;; The overall structure is based around the following internal -;; functions and macros. Since these are internal, they do NOT -;; call efs-save-match-data. This is done by their calling -;; function. -;; -;; efs-expand-tilde -;; - expands all ~ constructs, both local and remote. -;; efs-short-circuit-file-name -;; - short-circuits //'s and /~'s, for both local and remote paths. -;; efs-de-dot-file-name -;; - canonizes /../ and /./'s in both local and remote paths. -;; -;; The following two functions overload existing emacs functions. -;; They are the entry points to this filename expansion code, and as such -;; call efs-save-match-data. -;; -;; efs-expand-file-name -;; efs-substitute-in-file-name - -;;; utility macros - -(defmacro efs-short-circuit-file-name (filename) - ;; Short-circuits //'s and /~'s in filenames. - ;; Returns a list consisting of the local path, - ;; host-type, host, user. For local hosts, - ;; host-type, host, and user are all nil. - (` - (let ((start 0) - (string (, filename)) - backskip regexp lbackskip - lregexp parsed host-type host user) - - (if efs-local-apollo-unix - (setq lregexp ".//+" - lbackskip 2) - (setq lregexp "//+" - lbackskip 1)) - - ;; Short circuit /user@mach: roots. It is important to do this - ;; now to avoid unnecessary ftp connections. - - (while (string-match efs-path-root-short-circuit-regexp string start) - (setq start (1+ (match-beginning 0)))) - (or (zerop start) (setq string (substring string start) - start 0)) - - ;; identify remote root - - (if (setq parsed (efs-ftp-path-macro string)) - (if (memq (setq string (nth 2 parsed) - host-type - (efs-host-type (setq host (car parsed)) - (setq user (nth 1 parsed)))) - '(apollo-unix dumb-apollo-unix)) - (setq regexp ".//+" - backskip 2) - (setq regexp "//+" - backskip 1)) - (setq regexp lregexp - backskip lbackskip)) - - ;; Now short-circuit in an apollo and efs sensitive way. - - (while (cond ((string-match regexp string start) - (setq start (- (match-end 0) backskip))) - ((string-match "/~" string start) - (setq start (1- (match-end 0))))) - - (and host-type - (null efs-short-circuit-to-remote-root) - (setq host-type nil - regexp lregexp - backskip lbackskip))) - (or (zerop start) (setq string (substring string start))) - (list string host-type (and host-type host) (and host-type user))))) - -(defmacro efs-expand-tilde (tilde host-type host user) - ;; Expands a TILDE (~ or ~sandy type construction) - ;; Takes as an arg a filename (not directory name!) - ;; and returns a filename. HOST-TYPE is the type of remote host. - ;; nil is the type of the local host. - (` - (if (, host-type) ; nil host-type is the local machine - (let* ((host (downcase (, host))) - (host-type (, host-type)) - (ignore-case (memq host-type - efs-case-insensitive-host-types)) - (tilde (, tilde)) - (user (, user)) - (key (concat host "/" user "/" tilde)) - (res (efs-get-hash-entry - key efs-expand-dir-hashtable ignore-case))) - (or res - ;; for real accounts on unix systems, use the get trick - (and (not (efs-anonymous-p user)) - (memq host-type efs-unix-host-types) - (let ((line (nth 1 (efs-send-cmd - host user - (list 'get tilde "/dev/null") - (format "expanding %s" tilde))))) - (setq res - (and (string-match efs-expand-dir-msgs line) - (substring line - (match-beginning 1) - (match-end 1)))) - (if res - (progn - (setq res (efs-internal-directory-file-name res)) - (efs-put-hash-entry - key res efs-expand-dir-hashtable ignore-case) - res)))) - (progn - (setq res - (if (string-equal tilde "~") - (car (efs-send-pwd - host-type host user)) - (let* ((home-key (concat host "/" user "/~")) - (home (efs-get-hash-entry - home-key efs-expand-dir-hashtable - ignore-case)) - pwd-result) - (if home - (setq home - (efs-fix-path - host-type - (efs-internal-file-name-as-directory - host-type home))) - (if (setq home - (car - (setq pwd-result - (efs-send-pwd - host-type - host user)))) - (efs-put-hash-entry - home-key - (efs-internal-directory-file-name - (efs-fix-path host-type home 'reverse)) - efs-expand-dir-hashtable ignore-case) - (efs-error host user - (concat "PWD failed: " - (cdr pwd-result))))) - (unwind-protect - (and (efs-raw-send-cd host user - (efs-fix-path - host-type tilde) t) - (car - (efs-send-pwd - host-type host user))) - (efs-raw-send-cd host user home))))) - (if res - (progn - (setq res (efs-internal-directory-file-name - (efs-fix-path host-type res 'reverse))) - (efs-put-hash-entry - key res efs-expand-dir-hashtable ignore-case) - res))) - (if (string-equal tilde "~") - (error "Cannot get home directory on %s" host) - (error "User %s is not known on %s" (substring tilde 1) host)))) - ;; local machine - (efs-real-expand-file-name (, tilde))))) - -(defmacro efs-de-dot-file-name (string) - ;; Takes a string as arguments, and removes /../'s and /./'s. - (` - (let ((string (, string)) - (start 0) - new make-dir) - ;; to make the regexp's simpler, canonicalize to directory name. - (if (setq make-dir (string-match "/\\.\\.?$" string)) - (setq string (concat string "/"))) - (while (string-match "/\\./" string start) - (setq new (concat new - (substring string - start (match-beginning 0))) - start (1- (match-end 0)))) - - (if new (setq string (concat new (substring string start)))) - - (while (string-match "/[^/]+/\\.\\./" string) - ;; Is there a way to avoid all this concating and copying? - (setq string (concat (substring string 0 (1+ (match-beginning 0))) - (substring string (match-end 0))))) - - ;; Do /../ and //../ special cases. They should expand to - ;; / and //, respectively. - (if (string-match "^\\(/+\\)\\.\\./" string) - (setq string (concat (substring string 0 (match-end 1)) - (substring string (match-end 0))))) - - (if (and make-dir - (not (string-match "^/+$" string))) - (substring string 0 -1) - string)))) - -(defun efs-substitute-in-file-name (string) - "Documented as original." - ;; Because of the complicated interaction between short-circuiting - ;; and environment variable substitution, this can't call the macro - ;; efs-short-circuit-file-name. - (efs-save-match-data - (let ((start 0) - var new root backskip regexp lbackskip - lregexp parsed fudge-host-type rstart error) - - (if efs-local-apollo-unix - (setq lregexp ".//+" - lbackskip 2) - (setq lregexp "//+" - lbackskip 1)) - - ;; Subst. existing env variables - (while (string-match "\\$" string start) - (setq new (concat new (substring string start (match-beginning 0))) - start (match-end 0)) - (cond ((eq (string-match "\\$" string start) start) - (setq start (1+ start) - new (concat new "$$"))) - ((eq (string-match "{" string start) start) - (if (and (string-match "}" string start) - (setq var (getenv - (substring string (1+ start) - (1- (match-end 0)))))) - (setq start (match-end 0) - new (concat new var)) - (setq new (concat new "$")))) - ((eq (string-match "[a-zA-Z0-9]+" string start) start) - (if (setq var (getenv - (substring string start (match-end 0)))) - (setq start (match-end 0) - new (concat new var)) - (setq new (concat new "$")))) - ((setq new (concat new "$"))))) - (if new (setq string (concat new (substring string start)) - start 0)) - - ;; Short circuit /user@mach: roots. It is important to do this - ;; now to avoid unnecessary ftp connections. - - (while (string-match efs-path-root-short-circuit-regexp - string start) - (setq start (1+ (match-beginning 0)))) - (or (zerop start) (setq string (substring string start) - start 0)) - - ;; Look for invalid environment variables in the root. If one is found, - ;; we set the host-type to 'unix. Since we can't login in to determine - ;; it. There is a good chance that we will bomb later with an error, - ;; but the day may yet be saved if the root is short-circuited off. - - (if (string-match efs-path-root-regexp string) - (progn - (setq root (substring string 0 (match-end 0)) - start (match-end 0)) - (if (string-match "[^$]\\(\\$\\$\\)*\\$[^$]" root) - (progn - (setq rstart (1- (match-end 0)) - fudge-host-type t) - (cond - ((eq (elt root rstart) ?{) - (setq - error - (if (string-match "}" root rstart) - (concat - "Subsituting non-existent environment variable " - (substring root (1+ rstart) (match-beginning 0))) - "Missing \"}\" in environment-variable substitution"))) - ((eq (string-match "[A-Za-z0-9]+" root rstart) rstart) - (setq - error - (concat - "Subsituting non-existent environment variable " - (substring root rstart (match-beginning 0))))) - (t - (setq - error - "Bad format environment-variable substitution"))))) - (setq root (efs-unquote-dollars root) - parsed (efs-ftp-path root)) - - (if (and (not fudge-host-type) - ;; This may trigger an FTP connection - (memq (efs-host-type (car parsed) (nth 1 parsed)) - '(apollo-unix dumb-apollo-unix))) - (setq regexp ".//+" - backskip 2) - (setq regexp "//+" - backskip 1))) - ;; no root, we're local - (setq regexp lregexp - backskip lbackskip)) - - ;; Now short-circuit in an apollo and efs sensitive way. - - (while (cond ((string-match regexp string start) - (setq start (- (match-end 0) backskip))) - ((string-match "/~" string start) - (setq start (1- (match-end 0))))) - - (and root - (null efs-short-circuit-to-remote-root) - (setq root nil - regexp lregexp - backskip lbackskip))) - - ;; If we still have a bad root, barf. - (if (and root error) (error error)) - - ;; look for non-existent evironment variables in the path - - (if (string-match - "\\([^$]\\|^\\)\\(\\$\\$\\)*\\$\\([^$]\\|$\\)" string start) - (progn - (setq start (match-beginning 3)) - (cond - ((eq (length string) start) - (error "Empty string is an invalid environment variable")) - ((eq (elt string start) ?{) - (if (string-match "}" string start) - (error - "Subsituting non-existent environment variable %s" - (substring string (1+ start) (match-end 0))) - (error - "Missing \"}\" in environment-variable substitution"))) - ((eq (string-match "[A-Za-z0-9]+" string start) start) - (error - "Subsituting non-existent environment variable %s" - (substring string start (match-end 0)))) - (t - (error - "Bad format environment-variable substitution"))))) - - (if root - (concat root - (efs-unquote-dollars - (if (zerop start) - string - (substring string start)))) - (efs-unquote-dollars - (if (zerop start) - string - (substring string start))))))) - -(defun efs-expand-file-name (name &optional default) - "Documented as original." - (let (s-c-res path host user host-type) - (efs-save-match-data - (or (file-name-absolute-p name) - (setq name (concat - (file-name-as-directory - (or default default-directory)) - name))) - (setq s-c-res (efs-short-circuit-file-name name) - path (car s-c-res) - host-type (nth 1 s-c-res) - host (nth 2 s-c-res) - user (nth 3 s-c-res)) - (cond ((string-match "^~[^/]*" path) - (let ((start (match-end 0))) - (setq path (concat - (efs-expand-tilde - (substring path 0 start) - host-type host user) - (substring path start))))) - ((and host-type (not (file-name-absolute-p path))) - ;; We expand the empty string to a directory. - ;; This can be more efficient for filename - ;; completion. It's also consistent with non-unix. - (let ((tilde (efs-expand-tilde - "~" host-type host user))) - (if (string-equal tilde "/") - (setq path (concat "/" path)) - (setq path (concat tilde "/" path)))))) - - (setq path (efs-de-dot-file-name path)) - (if host-type - (format efs-path-format-string user host path) - path)))) - -;;;; ------------------------------------------------------------ -;;;; Other functions for manipulating file names. -;;;; ------------------------------------------------------------ - -(defun efs-internal-file-name-extension (filename) - ;; Returns the extension for file name FN. - (save-match-data - (let ((file (file-name-sans-versions (file-name-nondirectory filename)))) - (if (string-match "\\.[^.]*\\'" file) - (substring file (match-beginning 0)) - "")))) - -(defun efs-file-name-as-directory (name) - ;; version of file-name-as-directory for remote files. - ;; Usually just appends a / if there isn't one already. - ;; For some systems, it may also remove .DIR like extensions. - (let* ((parsed (efs-ftp-path name)) - (file (nth 2 parsed))) - (if (string-equal file "") - name - (efs-internal-file-name-as-directory - (efs-host-type (car parsed) (nth 1 parsed)) name)))) - -(efs-defun efs-internal-file-name-as-directory nil (name) - ;; By default, simply adds a trailing /, if there isn't one. - ;; Note that for expanded filenames, it pays to call this rather - ;; than efs-file-name-as-directory. - (let (file-name-handler-alist) - (file-name-as-directory name))) - -(defun efs-file-name-directory (name) - ;; file-name-directory for remote files. Takes care not to - ;; turn /user@host: into /. - (let ((path (nth 2 (efs-ftp-path name))) - file-name-handler-alist) - (if (or (string-equal path "") - (and (= (string-to-char path) ?~) - (not - (efs-save-match-data - (string-match "/" path 1))))) - name - (if (efs-save-match-data - (not (string-match "/" path))) - (efs-replace-path-component name "") - (file-name-directory name))))) - -(defun efs-file-name-nondirectory (name) - ;; Computes file-name-nondirectory for remote files. - ;; For expanded filenames, can just call efs-internal-file-name-nondirectory. - (let ((file (nth 2 (efs-ftp-path name)))) - (if (or (string-equal file "") - (and (= (string-to-char file) ?~) - (not - (efs-save-match-data - (string-match "/" file 1))))) - "" - (if (efs-save-match-data - (not (string-match "/" file))) - file - (efs-internal-file-name-nondirectory name))))) - -(defun efs-internal-file-name-nondirectory (name) - ;; Version of file-name-nondirectory, without the efs-file-handler-function. - ;; Useful to call this, if we have already decomposed the filename. - (let (file-name-handler-alist) - (file-name-nondirectory name))) - -(defun efs-directory-file-name (dir) - ;; Computes directory-file-name for remote files. - ;; Needs to be careful not to turn /foo@bar:/ into /foo@bar: - (let ((parsed (efs-ftp-path dir))) - (if (string-equal "/" (nth 2 parsed)) - dir - (efs-internal-directory-file-name dir)))) - -(defun efs-internal-directory-file-name (dir) - ;; Call this if you want to apply directory-file-name to the remote - ;; part of a efs-style path. Don't call for non-efs-style paths, - ;; as this short-circuits the file-name-handler-alist completely. - (let (file-name-handler-alist) - (directory-file-name dir))) - -(efs-defun efs-remote-directory-file-name nil (dir) - "Returns the file name on the remote system of directory DIR. -If the remote system is not unix, this may not be the same as the file name -of the directory in efs's internal cache." - (directory-file-name dir)) - -(defun efs-file-name-sans-versions (filename &optional keep-backup-versions) - ;; Version of file-name-sans-versions for remote files. - (or (file-name-absolute-p filename) - (setq filename (expand-file-name filename))) - (let ((parsed (efs-ftp-path filename))) - (efs-internal-file-name-sans-versions - (efs-host-type (car parsed) (nth 1 parsed)) - filename keep-backup-versions))) - -(efs-defun efs-internal-file-name-sans-versions nil - (filename &optional keep-backup-versions) - (let (file-name-handler-alist) - (file-name-sans-versions filename keep-backup-versions))) - -(defun efs-diff-latest-backup-file (fn) - ;; Version of diff latest backup file for remote files. - ;; Accomodates non-unix. - ;; Returns the latest backup for fn, according to the numbering - ;; of the backups. Does not check file-newer-than-file-p. - (let ((parsed (efs-ftp-path fn))) - (efs-internal-diff-latest-backup-file - (efs-host-type (car parsed) (nth 1 parsed)) fn))) - -(efs-defun efs-internal-diff-latest-backup-file nil (fn) - ;; Default behaviour is the behaviour in diff.el - (let (file-name-handler-alist) - (diff-latest-backup-file fn))) - -(defun efs-unhandled-file-name-directory (filename) - ;; Calculate a default unhandled directory for an efs buffer. - ;; This is used to compute directories in which to execute - ;; processes. This is relevant to V19 only. Doesn't do any harm for - ;; older versions though. It would be nice if this wasn't such a - ;; kludge. - (file-name-directory efs-tmp-name-template)) - -(defun efs-file-truename (filename) - ;; Calculates a remote file's truename, if this isn't inhibited. - (let ((filename (expand-file-name filename))) - (if (and efs-compute-remote-buffer-file-truename - (memq (efs-host-type (car (efs-ftp-path filename))) - efs-unix-host-types)) - (efs-internal-file-truename filename) - filename))) - -(defun efs-internal-file-truename (filename) - ;; Internal function so that we don't keep checking - ;; efs-compute-remote-buffer-file-truename, etc, as we recurse. - (let ((dir (efs-file-name-directory filename)) - target dirfile) - ;; Get the truename of the directory. - (setq dirfile (efs-directory-file-name dir)) - ;; If these are equal, we have the (or a) root directory. - (or (string= dir dirfile) - (setq dir (efs-file-name-as-directory - (efs-internal-file-truename dirfile)))) - (if (equal ".." (efs-file-name-nondirectory filename)) - (efs-directory-file-name (efs-file-name-directory - (efs-directory-file-name dir))) - (if (equal "." (efs-file-name-nondirectory filename)) - (efs-directory-file-name dir) - ;; Put it back on the file name. - (setq filename (concat dir (efs-file-name-nondirectory filename))) - ;; Is the file name the name of a link? - (setq target (efs-file-symlink-p filename)) - (if target - ;; Yes => chase that link, then start all over - ;; since the link may point to a directory name that uses links. - ;; We can't safely use expand-file-name here - ;; since target might look like foo/../bar where foo - ;; is itself a link. Instead, we handle . and .. above. - (if (file-name-absolute-p target) - (efs-internal-file-truename target) - (efs-internal-file-truename (concat dir target))) - ;; No, we are done! - filename))))) - - -;;;; ---------------------------------------------------------------- -;;;; I/O functions -;;;; ---------------------------------------------------------------- - -(efs-define-fun efs-set-buffer-file-name (filename) - ;; Sets the buffer local variables for filename appropriately. - ;; A special function because Lucid and FSF do this differently. - ;; This default behaviour is the lowest common denominator. - (setq buffer-file-name filename)) - -(defun efs-write-region (start end filename &optional append visit &rest args) - ;; write-region for remote files. - ;; This version accepts the V19 interpretation for the arg VISIT. - ;; However, making use of this within V18 may cause errors to crop up. - ;; ARGS should catch the MULE coding-system argument. - (if (stringp visit) (setq visit (expand-file-name visit))) - (setq filename (expand-file-name filename)) - (let ((parsed (efs-ftp-path filename)) - ;; Make sure that the after-write-region-hook isn't called inside - ;; the file-handler-alist - (after-write-region-hook nil)) - (if parsed - (let* ((host (car parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - (temp (car (efs-make-tmp-name nil host))) - (type (efs-xfer-type nil nil host-type filename)) - (abbr (and (or (stringp visit) (eq t visit) (null visit)) - (efs-relativize-filename - (if (stringp visit) visit filename)))) - (buffer (current-buffer)) - (b-file-name buffer-file-name) - (mod-p (buffer-modified-p))) - (unwind-protect - (progn - (condition-case err - (progn - (unwind-protect - (let ((executing-macro t)) - ;; let-bind executing-macro to inhibit messaging. - ;; Setting VISIT to 'quiet is more elegant. - ;; But in Emacs 18, doing it this way allows - ;; us to modify the visited file modtime, so - ;; that undo's show the buffer modified. - (apply 'write-region start end - temp nil visit args)) - ;; buffer-modified-p is now correctly set - (setq buffer-file-name b-file-name) - ;; File modtime is bogus, so clear. - (clear-visited-file-modtime)) - (efs-copy-file-internal - temp nil filename parsed (if append 'append t) - nil (and abbr (format "Writing %s" abbr)) - ;; cont - (efs-cont (result line cont-lines) (filename buffer - visit) - (if result - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\"" line) - filename))) - ;; The new file entry will be added by - ;; efs-copy-file-internal. - (cond - ((eq visit t) - ;; This will run asynch. - (efs-save-buffer-excursion - (set-buffer buffer) - (efs-set-buffer-file-name filename) - (efs-set-visited-file-modtime))) - ((stringp visit) - (efs-save-buffer-excursion - (set-buffer buffer) - (efs-set-buffer-file-name visit) - (set-visited-file-modtime))))) - nil type)) - (error - ;; restore buffer-modified-p - (let (file-name-handler-alist) - (set-buffer-modified-p mod-p)) - (signal (car err) (cdr err)))) - (if (or (eq visit t) - (and (stringp visit) - (efs-ftp-path visit))) - (efs-set-buffer-mode))) - (efs-del-tmp-name temp)) - (and abbr (efs-message "Wrote %s" abbr))) - (if (and (stringp visit) (efs-ftp-path visit)) - (progn - (apply 'write-region start end filename append visit args) - (efs-set-buffer-file-name visit) - (efs-set-visited-file-modtime) - (efs-set-buffer-mode)) - (error "efs-write-region called for a local file"))))) - -(defun efs-insert-file-contents (filename &optional visit &rest args) - ;; Inserts file contents for remote files. - ;; The additional ARGS covers V19 BEG and END. Should also handle the - ;; CODING-SYSTEM arg for mule. Hope the two don't trip over each other. - (barf-if-buffer-read-only) - (unwind-protect - (let* ((filename (expand-file-name filename)) - (parsed (efs-ftp-path filename)) - (host (car parsed)) - (host-type (efs-host-type host)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (buffer (current-buffer))) - - (if (or (file-exists-p filename) - (let* ((res (and - (not (efs-get-host-property host 'rnfr-failed)) - (efs-send-cmd - host user (list 'quote 'rnfr path)))) - (line (nth 1 res))) - ;; RNFR returns a 550 if the file doesn't exist. - (if (and line (>= (length line) 4) - (string-equal "550 " (substring line 0 4))) - nil - (if (car res) (efs-set-host-property host 'rnfr-failed t)) - (efs-del-from-ls-cache filename t nil) - (efs-del-hash-entry - (efs-canonize-file-name (file-name-directory filename)) - efs-files-hashtable) - (file-exists-p filename)))) - - (let ((temp (concat - (car (efs-make-tmp-name nil host)) - (efs-internal-file-name-extension filename))) - (type (efs-xfer-type host-type filename nil nil)) - (abbr (efs-relativize-filename filename)) - (i-f-c-size 0)) - - (unwind-protect - (efs-copy-file-internal - filename parsed temp nil t nil - (format "Retrieving %s" abbr) - (efs-cont (result line cont-lines) (filename visit buffer - host-type - temp args) - (if result - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\"" - line) - filename)) - (if (eq host-type 'coke) - (efs-coke-insert-beverage-contents buffer filename - line) - (efs-save-buffer-excursion - (set-buffer buffer) - (if (or (file-readable-p temp) - (sleep-for efs-retry-time) - ;; Wait for file to hopefully appear. - (file-readable-p temp)) - - (setq i-f-c-size - (nth 1 (apply 'insert-file-contents - temp visit args))) - (signal 'ftp-error - (list - "Opening input file:" - (format - "FTP Error: %s not arrived or readable" - filename)))) - ;; This is done asynch - (if visit - (let ((buffer-file-name filename)) - (efs-set-visited-file-modtime))))))) - nil type) - (efs-del-tmp-name temp)) - ;; Return (FILENAME SIZE) - (list filename i-f-c-size)) - (signal 'file-error (list "Opening input file" filename)))) - ;; Set buffer-file-name at the very last, so if anything bombs, we're - ;; not visiting. - (if visit - (efs-set-buffer-file-name filename)))) - -(defun efs-revert-buffer (arg noconfirm) - "Revert this buffer from a remote file using ftp." - (let ((opoint (point))) - (cond ((null buffer-file-name) - (error "Buffer does not seem to be associated with any file")) - ((or noconfirm - (yes-or-no-p (format "Revert buffer from file %s? " - buffer-file-name))) - (let ((buffer-read-only nil)) - ;; Set buffer-file-name to nil - ;; so that we don't try to lock the file. - (let ((buffer-file-name nil)) - (unlock-buffer) - (erase-buffer)) - (insert-file-contents buffer-file-name t)) - (goto-char (min opoint (point-max))) - (after-find-file nil) - t)))) - -(defun efs-recover-file (file) - ;; Version of recover file for remote files, and remote autosave files too. - (if (auto-save-file-name-p file) (error "%s is an auto-save file" file)) - (let* ((file-name (let ((buffer-file-name file)) (make-auto-save-file-name))) - (file-name-parsed (efs-ftp-path file-name)) - (file-parsed (efs-ftp-path file)) - (efs-ls-uncache t)) - (cond ((not (file-newer-than-file-p file-name file)) - (error "Auto-save file %s not current" file-name)) - ((save-window-excursion - (or (eq system-type 'vax-vms) - (progn - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (if file-parsed - (progn - (princ (format "On the host %s:\n" - (car file-parsed))) - (princ - (let ((default-directory exec-directory)) - (efs-ls file (if (file-symlink-p file) - "-lL" "-l") - t t)))) - (princ "On the local host:\n") - (let ((default-directory exec-directory)) - (call-process "ls" nil standard-output nil - (if (file-symlink-p file) "-lL" "-l") - file))) - (princ "\nAUTO SAVE FILE on the ") - (if file-name-parsed - (progn - (princ (format "host %s:\n" - (car file-name-parsed))) - (princ - (efs-ls file-name - (if (file-symlink-p file-name) "-lL" "-l") - t t))) - (princ "local host:\n") - (let ((default-directory exec-directory)) - (call-process "ls" nil standard-output nil - "-l" file-name))) - (princ "\nFile modification times are given in ") - (princ "the local time of each host.\n")) - (save-excursion - (set-buffer "*Directory*") - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (if (> (current-column) (window-width)) - (progn - (skip-chars-backward " \t") - (skip-chars-backward "^ \t\n") - (if (> (current-column) 12) - (progn - (delete-horizontal-space) - (insert "\n "))))) - (forward-line 1)) - (set-buffer-modified-p nil) - (goto-char (point-min))))) - (yes-or-no-p (format "Recover using this auto save file? "))) - (switch-to-buffer (find-file-noselect file t)) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents file-name nil)) - (after-find-file nil)) - (t (error "Recover-file cancelled.")))) - ;; This is no longer done in V19. However, I like the caution for - ;; remote files, where file-newer-than-file-p may lie. - (setq buffer-auto-save-file-name nil) - (message "Auto-save off in this buffer till you do M-x auto-save-mode.")) - -;;;; ------------------------------------------------------------------ -;;;; Attributes of files. -;;;; ------------------------------------------------------------------ - -(defun efs-file-symlink-p (file) - ;; Version of file-symlink-p for remote files. - ;; Call efs-expand-file-name rather than the normal - ;; expand-file-name to stop loops when using a package that - ;; redefines both file-symlink-p and expand-file-name. - ;; Do not use efs-get-file-entry, because a child-lookup won't do. - (let* ((file (efs-expand-file-name file)) - (ignore-case (memq (efs-host-type (car (efs-ftp-path file))) - efs-case-insensitive-host-types)) - (file-type (car (efs-get-hash-entry - (efs-get-file-part file) - (efs-get-files (file-name-directory file)) - ignore-case)))) - (and (stringp file-type) - (if (file-name-absolute-p file-type) - (efs-replace-path-component file file-type) - file-type)))) - -(defun efs-file-exists-p (path) - ;; file-exists-p for remote file. Uses the cache if possible. - (let* ((path (expand-file-name path)) - (parsed (efs-ftp-path path))) - (efs-internal-file-exists-p (efs-host-type (car parsed) (nth 1 parsed)) - path))) - -(efs-defun efs-internal-file-exists-p nil (path) - (and (efs-get-file-entry path) t)) - -(defun efs-file-directory-p (file) - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file))) - (efs-internal-file-directory-p (efs-host-type (car parsed) (nth 1 parsed)) - file))) - -(efs-defun efs-internal-file-directory-p nil (path) - ;; Version of file-directory-p for remote files. - (let ((parsed (efs-ftp-path path))) - (or (string-equal (nth 2 parsed) "/") ; root is always a directory - (let ((file-ent (car (efs-get-file-entry - (efs-internal-file-name-as-directory - (efs-host-type (car parsed) (nth 1 parsed)) - path))))) - ;; We do a file-name-as-directory on path here because some - ;; machines (VMS) use a .DIR to indicate the filename associated - ;; with a directory. This needs to be canonicalized. - (if (stringp file-ent) - (efs-internal-file-directory-p - nil - (efs-chase-symlinks - ;; efs-internal-directory-file-name - ;; only loses for paths where the remote file - ;; is /. This has been eliminated. - (efs-internal-directory-file-name path))) - file-ent))))) - -(defun efs-file-attributes (file) - ;; Returns file-file-attributes for a remote file. - ;; For the file modtime does not return efs's cached value, as that - ;; corresponds to buffer-file-modtime (i.e. the modtime of the file - ;; the last time the buffer was vsisted or saved). Caching modtimes - ;; does not make much sense, as they are usually used to determine - ;; if a cache is stale. The modtime if a remote file can be obtained with - ;; efs-get-file-mdtm. This is _not_ returned for the 5th entry here, - ;; because it requires an FTP transaction, and a priori we don't know - ;; if the caller actually cares about this info. Having file-attributes - ;; return such a long list of info is not well suited to remote files, - ;; as some of this info may be costly to obtain. - (let* ((file (expand-file-name file)) - (ent (efs-get-file-entry file))) - (if ent - (let* ((parsed (efs-ftp-path file)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (type (car ent)) - (size (or (nth 1 ent) -1)) - (owner (nth 2 ent)) - (modes (nth 3 ent)) - ;; Hack to give remote files a "unique" "inode number". - ;; It's actually the sum of the characters in its name. - ;; It's not even really unique. - (inode (apply '+ - (nconc (mapcar 'identity host) - (mapcar 'identity user) - (mapcar 'identity - (efs-internal-directory-file-name - path))))) - (nlinks (or (nth 4 ent) -1))) ; return -1 if we don't know - (list - (if (and (stringp type) (file-name-absolute-p type)) - (efs-replace-path-component file type) - type) ;0 file type - nlinks ;1 link count - (if owner ;2 uid - ;; Not really a unique integer, - ;; just a half-hearted attempt - (apply '+ (mapcar 'identity owner)) - -1) - -1 ;3 gid - '(0 0) ;4 atime - '(0 0) ;5 mtime - '(0 0) ;6 ctime - size ;7 size - (or modes ;8 mode - (concat - (cond ((stringp type) "l") - (type "d") - (t "-")) - "?????????")) - nil ;9 gid weird (Who knows if the gid - ; would be changed?) - inode ;10 inode - -1 ;11 device number [v19 only] - ))))) - -(defun efs-file-writable-p (file) - ;; file-writable-p for remote files. - ;; Does not attempt to open the file, but just looks at the cached file - ;; modes. - (let* ((file (expand-file-name file)) - (ent (efs-get-file-entry file))) - (if (and ent (or (not (stringp (car ent))) - (setq file (efs-chase-symlinks file) - ent (efs-get-file-entry file)))) - (let* ((owner (nth 2 ent)) - (modes (nth 3 ent)) - (parsed (efs-ftp-path file)) - (host-type (efs-host-type (car parsed))) - (user (nth 1 parsed))) - (if (memq host-type efs-unix-host-types) - (setq host-type 'unix)) - (efs-internal-file-writable-p host-type user owner modes)) - (let ((dir (file-name-directory file))) - (and - (not (string-equal dir file)) - (file-directory-p dir) - (file-writable-p dir)))))) - -(efs-defun efs-internal-file-writable-p nil (user owner modes) - ;; By default, we'll just guess yes. - t) - -(efs-defun efs-internal-file-writable-p unix (user owner modes) - (if (and modes - (not (string-equal user "root"))) - (null - (null - (if (string-equal user owner) - (memq ?w (list (aref modes 2) (aref modes 5) - (aref modes 8))) - (memq ?w (list (aref modes 5) (aref modes 8)))))) - t)) ; guess - -(defun efs-file-readable-p (file) - ;; Version of file-readable-p that works for remote files. - ;; Works by checking efs's cache of the file modes. - (let* ((file (expand-file-name file)) - (ent (efs-get-file-entry file))) - (and ent - (or (not (stringp (car ent))) - (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) - ;; file exists - (let* ((parsed (efs-ftp-path file)) - (owner (nth 2 ent)) - (modes (nth 3 ent)) - (host-type (efs-host-type (car parsed))) - (user (nth 1 parsed))) - (if (memq host-type efs-unix-host-types) - (setq host-type 'unix)) - (efs-internal-file-readable-p host-type user owner modes))))) - -(efs-defun efs-internal-file-readable-p nil (user owner modes) - ;; Guess t by default - t) - -(efs-defun efs-internal-file-readable-p unix (user owner modes) - (if (and modes - (not (string-equal user "root"))) - (null - (null - (if (string-equal user owner) - (memq ?r (list (aref modes 1) (aref modes 4) - (aref modes 7))) - (memq ?r (list (aref modes 4) (aref modes 7)))))) - t)) ; guess - -(defun efs-file-executable-p (file) - ;; Version of file-executable-p for remote files. - (let ((ent (efs-get-file-entry file))) - (and ent - (or (not (stringp (car ent))) - (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) - ;; file exists - (let* ((parsed (efs-ftp-path file)) - (owner (nth 2 ent)) - (modes (nth 3 ent)) - (host-type (efs-host-type (car parsed))) - (user (nth 1 parsed))) - (if (memq host-type efs-unix-host-types) - (setq host-type 'unix)) - (efs-internal-file-executable-p host-type user owner modes))))) - -(efs-defun efs-internal-file-executable-p nil (user owner modes) - ;; Guess t by default - t) - -(efs-defun efs-internal-file-executable-p unix (user owner modes) - (if (and modes - (not (string-equal user "root"))) - (null - (null - (if (string-equal user owner) - (memq ?x (list (aref modes 3) (aref modes 6) - (aref modes 9))) - (memq ?x (list (aref modes 6) (aref modes 9)))))) - t)) ; guess - -(defun efs-file-accessible-directory-p (dir) - ;; Version of file-accessible-directory-p for remote directories. - (let ((file (directory-file-name dir))) - (and (efs-file-directory-p file) (efs-file-executable-p file)))) - -;;;; -------------------------------------------------------------- -;;;; Listing directories. -;;;; -------------------------------------------------------------- - -(defun efs-shell-regexp-to-regexp (regexp) - ;; Converts a shell regexp to an emacs regexp. - ;; Probably full of bugs. Tries to follow csh globbing. - (let ((curly 0) - backslash) - (concat "^" - (mapconcat - (function - (lambda (char) - (cond - (backslash - (setq backslash nil) - (regexp-quote (char-to-string char))) - ((and (> curly 0) (eq char ?,)) - "\\|") - ((memq char '(?[ ?])) - (char-to-string char)) - ((eq char ??) - ".") - ((eq char ?\\) - (setq backslash t) - "") - ((eq char ?*) - ".*") - ((eq char ?{) - (setq curly (1+ curly)) - "\\(") - ((and (eq char ?}) (> curly 0)) - (setq curly (1- curly)) - "\\)") - (t (regexp-quote (char-to-string char)))))) - regexp nil) - "$"))) - - -;;; Getting directory listings. - -(defun efs-directory-files (directory &optional full match nosort &rest ignored-for-now) - ;; Returns directory-files for remote directories. - ;; NOSORT is a V19 arg. - (let* ((directory (expand-file-name directory)) - (parsed (efs-ftp-path directory)) - (directory (efs-internal-file-name-as-directory - (efs-host-type (car parsed) (nth 1 parsed)) directory)) - files) - (efs-barf-if-not-directory directory) - (setq files (efs-hash-table-keys (efs-get-files directory) nosort)) - (cond - ((null (or full match)) - files) - (match ; this is slow case - (let (res f) - (efs-save-match-data - (while files - (setq f (if full (concat directory (car files)) (car files)) - files (cdr files)) - (if (string-match match f) - (setq res (nconc res (list f)))))) - res)) - (full - (mapcar (function - (lambda (fn) - (concat directory fn))) - files))))) - -(defun efs-list-directory (dirname &optional verbose) - ;; Version of list-directory for remote directories. - ;; If verbose is nil, it gets its information from efs's - ;; internal cache. - (let* ((dirname (expand-file-name (or dirname default-directory))) - header) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (setq header dirname) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (princ "Directory ") - (princ header) - (terpri) - (princ - (efs-ls dirname (if verbose - list-directory-verbose-switches - list-directory-brief-switches) - t))))) - -;;;; ------------------------------------------------------------------- -;;;; Manipulating buffers. -;;;; ------------------------------------------------------------------- - -(defun efs-get-file-buffer (file) - ;; Version of get-file-buffer for remote files. Needs to fuss over things - ;; like OS's which are case-insens. for file names. - (let ((file (efs-canonize-file-name (expand-file-name file))) - (buff-list (buffer-list)) - buff-name) - (catch 'match - (while buff-list - (and (setq buff-name (buffer-file-name (car buff-list))) - (= (length buff-name) (length file)) ; efficiency hack - (string-equal (efs-canonize-file-name buff-name) file) - (throw 'match (car buff-list))) - (setq buff-list (cdr buff-list)))))) - -(defun efs-create-file-buffer (filename) - ;; Version of create-file-buffer for remote file names. - (let* ((parsed (efs-ftp-path (expand-file-name filename))) - (file (nth 2 parsed)) - (host (car parsed)) - (host-type (efs-host-type host)) - (buff (cond - ((null efs-fancy-buffer-names) - (if (string-equal file "/") - "/" - (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name file)))) - ((stringp efs-fancy-buffer-names) - (format efs-fancy-buffer-names - (if (string-equal file "/") - "/" - (efs-internal-file-name-nondirectory - (efs-internal-directory-file-name file))) - (substring host 0 (string-match "\\." host 1)))) - (t ; efs-fancy-buffer-names had better be a function - (funcall efs-fancy-buffer-names host - (nth 1 parsed) file))))) - (if (memq host-type efs-case-insensitive-host-types) - (cond ((eq efs-buffer-name-case 'down) - (setq buff (downcase buff))) - ((eq efs-buffer-name-case 'up) - (setq buff (upcase buff))))) - (get-buffer-create (generate-new-buffer-name buff)))) - -(defun efs-set-buffer-mode () - "Set correct modes for the current buffer if it is visiting a remote file." - (if (and (stringp buffer-file-name) - (efs-ftp-path buffer-file-name)) - (progn - (auto-save-mode efs-auto-save) - (set (make-local-variable 'revert-buffer-function) - 'efs-revert-buffer) - (set (make-local-variable 'default-directory-function) - 'efs-default-dir-function)))) - -;;;; --------------------------------------------------------- -;;;; Functions for doing backups. -;;;; --------------------------------------------------------- - -(defun efs-backup-buffer () - ;; Version of backup-buffer for buffers visiting remote files. - (if efs-make-backup-files - (let* ((parsed (efs-ftp-path buffer-file-name)) - (host (car parsed)) - (host-type (efs-host-type (car parsed)))) - (if (or (not (listp efs-make-backup-files)) - (memq host-type efs-make-backup-files)) - (efs-internal-backup-buffer - host host-type (nth 1 parsed) (nth 2 parsed)))))) - -(defun efs-internal-backup-buffer (host host-type user remote-path) - ;; This is almost a copy of the function in files.el, modified - ;; to check to see if the backup file exists, before deleting it. - ;; It also supports efs-backup-by-copying, and tries to do the - ;; right thing about backup-by-copying-when-mismatch. Only called - ;; for remote files. - ;; Set the umask now, so that `setmodes' knows about it. - (efs-set-umask host user) - (let ((ent (efs-get-file-entry (expand-file-name buffer-file-name))) - ;; Never do version-control if the remote operating system is doing it. - (version-control (if (memq host-type efs-version-host-types) - 'never - version-control)) - modstring) - (and make-backup-files - (not buffer-backed-up) - ent ; i.e. file-exists-p - (not (eq t (car ent))) - (or (null (setq modstring (nth 3 ent))) - (not (memq host-type efs-unix-host-types)) - (memq (aref modstring 0) '(?- ?l))) - (or (< (length remote-path) 5) - (not (string-equal "/tmp/" (substring remote-path 0 5)))) - (condition-case () - (let* ((backup-info (find-backup-file-name buffer-file-name)) - (backupname (car backup-info)) - (targets (cdr backup-info)) - (links (nth 4 ent)) - setmodes) - (condition-case () - (if (or file-precious-flag - (stringp (car ent)) ; symlinkp - efs-backup-by-copying - (and backup-by-copying-when-linked - links (> links 1)) - (and backup-by-copying-when-mismatch - (not - (if (memq - host-type - efs-case-insensitive-host-types) - (string-equal - (downcase user) (downcase (nth 2 ent))) - (string-equal user (nth 2 ent)))))) - (copy-file buffer-file-name backupname t t) - (condition-case () - (if (file-exists-p backupname) - (delete-file backupname)) - (file-error nil)) - (rename-file buffer-file-name backupname t) - (setq setmodes (file-modes backupname))) - (file-error - ;; If trouble writing the backup, write it in ~. - (setq backupname (expand-file-name "~/%backup%~")) - (message - "Cannot write backup file; backing up in ~/%%backup%%~") - (sleep-for 1) - (copy-file buffer-file-name backupname t t))) - (setq buffer-backed-up t) - ;; Starting with 19.26, trim-versions-without-asking - ;; has been renamed to delete-old-verions. - (if (and targets - (or (if (boundp 'trim-versions-without-asking) - trim-versions-without-asking - (and - (boundp 'delete-old-versions) - delete-old-versions)) - (y-or-n-p (format - "Delete excess backup versions of %s? " - buffer-file-name)))) - (while targets - (condition-case () - (delete-file (car targets)) - (file-error nil)) - (setq targets (cdr targets)))) - ;; If the file was already written with the right modes, - ;; don't return set-modes. - (and setmodes - (null - (let ((buff (get-buffer - (efs-ftp-process-buffer host user)))) - (and buff - (save-excursion - (set-buffer buff) - (and (integerp efs-process-umask) - (= (efs-modes-from-umask efs-process-umask) - setmodes)))))) - setmodes)) - (file-error nil))))) - -;;;; ------------------------------------------------------------ -;;;; Redefinition for Emacs file mode support -;;;; ------------------------------------------------------------ - -(defmacro efs-build-mode-string-element (int suid-p sticky-p) - ;; INT is between 0 and 7. - ;; If SUID-P is non-nil, we are building the 3-char string for either - ;; the owner or group, and the s[ug]id bit is set. - ;; If STICKY-P is non-nil, we are building the string for other perms, - ;; and the sticky bit is set. - ;; It doesn't make sense for both SUID-P and STICKY-P be non-nil! - (` (let* ((int (, int)) - (suid-p (, suid-p)) - (sticky-p (, sticky-p)) - (read-bit (if (memq int '(4 5 6 7)) "r" "-")) - (write-bit (if (memq int '(2 3 6 7)) "w" "-")) - (x-bit (if (memq int '(1 3 5 7)) - (cond (suid-p "s") (sticky-p "t") ("x")) - (cond (suid-p "S") (sticky-p "T") ("-"))))) - (concat read-bit write-bit x-bit)))) - -(defun efs-mode-string (int) - ;; Takes an octal integer between 0 and 7777, and returns the 9 character - ;; mode string. - (let* ((other-int (% int 10)) - (int (/ int 10)) - (group-int (% int 10)) - (int (/ int 10)) - (owner-int (% int 10)) - (int (/ int 10)) - (suid (memq int '(4 5 6 7))) - (sgid (memq int '(2 3 6 7))) - (sticky (memq int '(1 3 5 7)))) - (concat (efs-build-mode-string-element owner-int suid nil) - (efs-build-mode-string-element group-int sgid nil) - (efs-build-mode-string-element other-int nil sticky)))) - -(defun efs-shell-call-process (command dir &optional in-background) - ;; Runs shell process on remote hosts. - (let* ((parsed (efs-ftp-path dir)) - (host (car parsed)) - (user (nth 1 parsed)) - (rdir (nth 2 parsed)) - (file-name-handler-alist nil)) - (or (string-equal (efs-internal-directory-file-name dir) - (efs-expand-tilde "~" (efs-host-type host) host user)) - (string-match "^cd " command) - (setq command (concat "cd " rdir "; " command))) - (setq command - (format "%s %s%s \"%s\"" ; remsh -l USER does not work well - ; on a hp-ux machine I tried - efs-remote-shell-file-name host - (if efs-remote-shell-takes-user - (concat " -l " user) - "") - command)) - (message "Doing shell command on %s..." host) - ;; do it - (let ((process-connection-type ; don't waste pty's - (null (null in-background)))) - (setq default-directory (file-name-directory efs-tmp-name-template)) - (if in-background - (progn - (setq mode-line-process '(": %s")) - (start-process "Shell" (current-buffer) - shell-file-name "-c" command)) - (call-process shell-file-name nil t nil "-c" command))))) - -(defun efs-set-file-modes (file mode) - ;; set-file-modes for remote files. - ;; For remote files, if mode is nil, does nothing. - ;; This is because efs-file-modes returns nil if the modes - ;; of a remote file couldn't be determined, even if the file exists. - (and mode - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (r-file (nth 2 parsed)) - ;; convert to octal, and keep only 12 lowest order bits. - (omode (format "%o" (- mode (lsh (lsh mode -12) 12))))) - (if (or (efs-get-host-property host 'chmod-failed) - (null (memq (efs-host-type host user) efs-unix-host-types))) - (message "Unable to set file modes for %s to %s." file omode) - (efs-send-cmd - host user - (list 'quote 'site 'chmod omode r-file) - nil nil - (efs-cont (result line cont-lines) (host file r-file omode) - (if result - (let ((exit-code - (efs-shell-call-process - (concat "chmod " omode " " (file-name-nondirectory file)) - (file-name-directory file)))) - (if (not (equal 0 exit-code)) - (progn - (efs-set-host-property host 'chmod-failed t) - (message "CHMOD %s failed for %s on %s." omode r-file host) - (if efs-ding-on-chmod-failure - (progn (ding) (sit-for 1)))))) - (let ((ent (efs-get-file-entry file))) - (if ent - (let* ((type - (cond - ((null (car ent)) "-") - ((eq (car ent) t) "d") - ((stringp (car ent)) "s") - (t - (error - "Weird error in efs-set-file-modes")))) - (mode-string (concat - type - (efs-mode-string - (string-to-int omode)))) - (tail (nthcdr 3 ent))) - (if (consp tail) - (setcar tail mode-string) - (efs-add-file-entry nil file (car ent) (nth 1 ent) - (nth 2 ent) mode-string))))))) - 0)))) ; It should be safe to do this NOWAIT = 0 - ;; set-file-modes returns nil - nil) - -(defmacro efs-parse-mode-element (modes) - ;; Parses MODES, a string of three chars, and returns an integer - ;; between 0 and 7 according to how unix file modes are represented - ;; for chmod. - (` (if (= (length (, modes)) 3) - (let ((list (mapcar - (function (lambda (char) - (if (memq char '( ?- ?S ?T)) 0 1))) - (, modes)))) - ;; Convert to octal - (+ (* (car list) 4) (* (nth 1 list) 2) (nth 2 list))) - (error "Can't parse modes %s" (, modes))))) - -(defun efs-parse-mode-string (string) - ;; Parse a 9-character mode string, and return what it represents - ;; as a decimal integer. - (let ((owner (efs-parse-mode-element (substring string 0 3))) - (group (efs-parse-mode-element (substring string 3 6))) - (other (efs-parse-mode-element (substring string 6 9))) - (owner-x (elt string 2)) - (group-x (elt string 5)) - (other-x (elt string 8))) - (+ (* (+ (if (memq owner-x '(?s ?S)) 4 0) - (if (memq group-x '(?s ?S)) 2 0) - (if (memq other-x '(?t ?T)) 1 0)) - 512) - (* owner 64) - (* group 8) - other))) - -(defun efs-file-modes (file) - ;; Version of file-modes for remote files. - ;; Returns nil if the file modes can't be determined, either because - ;; the file doesn't exist, or for any other reason. - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file))) - (and (memq (efs-host-type (car parsed)) efs-unix-host-types) - ;; Someday we should cache mode strings for non-unix, but they - ;; won't be in unix format. Also, CHMOD doesn't work for non-unix - ;; hosts, so returning this info to emacs is a waste. - (let* ((ent (efs-get-file-entry file)) - (modes (nth 3 ent))) - (and modes - (efs-parse-mode-string (substring modes 1))))))) - -;;;; ------------------------------------------------------------ -;;;; Redefinition of Emacs file modtime support. -;;;; ------------------------------------------------------------ - -(defun efs-day-number (year month day) - ;; Returns the day number within year of date. Taken from calendar.el, - ;; by Edward Reingold. Thanks. - ;; An explanation of the calculation can be found in PascAlgorithms by - ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. - (let ((day-of-year (+ day (* 31 (1- month))))) - (if (> month 2) - (progn - (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) - (if (zerop (% year 4)) - (setq day-of-year (1+ day-of-year))))) - day-of-year)) - -(defun efs-days-elapsed (year month day) - ;; Number of days elapsed since Jan 1, `efs-time-zero' - (+ (efs-day-number year month day) ; days this year - (* 365 (- year efs-time-zero)) ; days in prior years - (- (/ (max (1- year) efs-time-zero) 4) - (/ efs-time-zero 4)) ; leap years - -1 )) ; don't count today - -;; 2^16 = 65536 -;; Use this to avoid overflows - -(defun efs-seconds-elapsed (year month day hours minutes seconds) - ;; Computes the seconds elapsed from `efs-time-zero', in emacs' - ;; format of a list of two integers, the first the higher 16-bits, - ;; the second the lower 16-bits. - (let* ((days (efs-days-elapsed year month day)) - ;; compute hours - (hours (+ (* 24 days) hours)) - (high (lsh hours -16)) - (low (- hours (lsh high 16))) - ;; compute minutes - (low (+ (* low 60) minutes)) - (carry (lsh low -16)) - (high (+ (* high 60) carry)) - (low (- low (lsh carry 16))) - ;; compute seconds - (low (+ (* low 60) seconds)) - (carry (lsh low -16)) - (high (+ (* high 60) carry)) - (low (- low (lsh carry 16)))) - (list high low))) - -(defun efs-parse-mdtime (string) - ;; Parse a string, which is assumed to be the result of an ftp MDTM command. - (efs-save-match-data - (if (string-match efs-mdtm-msgs string) - (efs-seconds-elapsed - (string-to-int (substring string 4 8)) - (string-to-int (substring string 8 10)) - (string-to-int (substring string 10 12)) - (string-to-int (substring string 12 14)) - (string-to-int (substring string 14 16)) - (string-to-int (substring string 16 18)))))) - -(defun efs-parse-ctime (string) - ;; Parse STRING which is assumed to be the result of a query over port 37. - ;; Returns the number of seconds since the turn of the century, as a - ;; list of two 16-bit integers. - (and (= (length string) 4) - (list (+ (lsh (aref string 0) 8) (aref string 1)) - (+ (lsh (aref string 2) 8) (aref string 3))))) - -(defun efs-time-minus (time1 time2) - ;; Subtract 32-bit integers, represented as two 16-bit integers. - (let ((high (- (car time1) (car time2))) - (low (- (nth 1 time1) (nth 1 time2)))) - (cond - ((and (< high 0) (> low 0)) - (setq high (1+ high) - low (- low 65536))) - ((and (> high 0) (< low 0)) - (setq high (1- high) - low (+ 65536 low)))) - (list high low))) - -(defun efs-time-greater (time1 time2) - ;; Compare two 32-bit integers, each represented as a list of two 16-bit - ;; integers. - (or (> (car time1) (car time2)) - (and (= (car time1) (car time2)) - (> (nth 1 time1) (nth 1 time2))))) - -(defun efs-century-time (host &optional nowait cont) - ;; Treat nil as the local host. - ;; Returns the # of seconds since the turn of the century, according - ;; to the system clock on host. - ;; CONT is called with first arg HOST and second the # of seconds. - (or host (setq host (system-name))) - (efs-set-host-property host 'last-ctime nil) - (efs-set-host-property host 'ctime-cont cont) - (let ((name (format efs-ctime-process-name-format host)) - proc) - (condition-case nil (delete-process name) (error nil)) - (if (and - (or (efs-save-match-data (string-match efs-local-host-regexp host)) - (string-equal host (system-name))) - (setq proc (condition-case nil - (open-network-stream name nil host 37) - (error nil)))) - (progn - (set (intern name) "") - (set-process-filter - proc - (function - (lambda (proc string) - (let ((name (process-name proc)) - result) - (set (intern name) (concat (symbol-value (intern name)) - string)) - (setq result (efs-parse-ctime - (symbol-value (intern name)))) - (if result - (let* ((host (substring name 11 -1)) - (cont (efs-get-host-property host 'ctime-cont))) - (efs-set-host-property host 'last-ctime result) - (condition-case nil (delete-process proc) (error nil)) - (if cont - (progn - (efs-set-host-property host 'ctime-cont nil) - (efs-call-cont cont host result))))))))) - (set-process-sentinel - proc - (function - (lambda (proc state) - (let* ((name (process-name proc)) - (host (substring name 11 -1)) - (cont (efs-get-host-property host 'ctime-cont))) - (makunbound (intern name)) - (or (efs-get-host-property host 'last-ctime) - (if cont - (progn - (efs-set-host-property host 'ctime-cont nil) - (efs-call-cont cont host 'failed)))))))) - (if nowait - nil - (let ((quit-flag nil) - (inhibit-quit nil)) - (while (memq (process-status proc) '(run open)) - (accept-process-output))) - (accept-process-output) - (or (efs-get-host-property host 'last-ctime) - 'failed))) - (if cont - (progn - (efs-set-host-property host 'ctime-cont nil) - (efs-call-cont cont host 'failed))) - (if nowait nil 'failed)))) - -(defun efs-clock-difference (host &optional nowait) - ;; clock difference with the local host - (let ((result (efs-get-host-property host 'clock-diff))) - (or - result - (progn - (efs-century-time - host nowait - (efs-cont (host result) (nowait) - (if (eq result 'failed) - (efs-set-host-property host 'clock-diff 'failed) - (efs-century-time - nil nowait - (efs-cont (lhost lresult) (host result) - (if (eq lresult 'failed) - (efs-set-host-property host 'clock-diff 'failed) - (efs-set-host-property host 'clock-diff - (efs-time-minus result lresult)))))))) - (and (null nowait) - (or (efs-get-host-property host 'clock-diff) - 'failed)))))) - -(defun efs-get-file-mdtm (host user file path) - "For HOST and USER, return FILE's last modification time. -PATH is the file name in full efs syntax. -Returns a list of two six-digit integers which represent the 16 high order -bits, and 16 low order bits of the number of elapsed seconds since -`efs-time-zero'" - (and (null (efs-get-host-property host 'mdtm-failed)) - (let ((result (efs-send-cmd host user (list 'quote 'mdtm file) - (and (eq efs-verbose t) - "Getting modtime"))) - parsed) - (if (and (null (car result)) - (setq parsed (efs-parse-mdtime (nth 1 result)))) - (let ((ent (efs-get-file-entry path))) - (if ent - (setcdr ent (list (nth 1 ent) (nth 2 ent) - (nth 3 ent) (nth 4 ent) - parsed))) - parsed) - (efs-save-match-data - ;; The 550 error is for a nonexistent file. Actually implies - ;; that MDTM works. - (if (string-match "^550 " (nth 1 result)) - '(0 0) - (efs-set-host-property host 'mdtm-failed t) - nil)))))) - -(efs-define-fun efs-set-emacs-bvf-mdtm (buffer mdtm) - ;; Sets cached value for the buffer visited file modtime. - (if (get-buffer buffer) - (save-excursion - (set-buffer buffer) - (let (file-name-handler-alist) - (set-visited-file-modtime mdtm))))) - -;; (defun efs-set-visited-file-modtime (&optional time) -;; ;; For remote files sets the modtime for a buffer to be that of the -;; ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list -;; ;; of two 16-bit integers. -;; ;; The function set-visited-file-modtime is for emacs-19. It doesn't -;; ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for -;; ;; remote files only. -;; (if time -;; (efs-set-emacs-bvf-mdtm (current-buffer) time) -;; (let* ((path buffer-file-name) -;; (parsed (efs-ftp-path path)) -;; (host (car parsed)) -;; (user (nth 1 parsed)) -;; (file (nth 2 parsed)) -;; (buffer (current-buffer))) -;; (if (efs-save-match-data -;; (and efs-verify-modtime-host-regexp -;; (string-match efs-verify-modtime-host-regexp host) -;; (or efs-verify-anonymous-modtime -;; (not (efs-anonymous-p user))) -;; (not (efs-get-host-property host 'mdtm-failed)))) -;; (efs-send-cmd -;; host user (list 'quote 'mdtm file) -;; nil nil -;; (efs-cont (result line cont-lines) (host user path buffer) -;; (let (modtime) -;; (if (and (null result) -;; (setq modtime (efs-parse-mdtime line))) -;; (let ((ent (efs-get-file-entry path))) -;; (if ent -;; (setcdr ent (list (nth 1 ent) (nth 2 ent) -;; (nth 3 ent) (nth 4 ent) -;; modtime))) -;; (setq buffer (and (setq buffer (get-buffer buffer)) -;; (buffer-name buffer))) -;; ;; Beware that since this is happening asynch, the buffer -;; ;; may have disappeared. -;; (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) -;; (efs-save-match-data -;; (or (string-match "^550 " line) -;; (efs-set-host-property host 'mdtm-failed t))) -;; (efs-set-emacs-bvf-mdtm buffer 0)))) ; store dummy values -;; 0) ; Always do this NOWAIT = 0 -;; (efs-set-emacs-bvf-mdtm buffer 0)) -;; nil) ; return NIL -;; )) - -(defvar efs-set-modtimes-synchronously nil - "*Whether efs uses a synchronous FTP command to set the visited file modtime. -Setting this variable to non-nil means that efs will set visited file modtimes -synchronously. - -Asynchronous setting of visited file modtimes leaves a very small -window where Emacs may fail to detect a super session. However, it gives -faster user access to newly visited files.") - - -(defun efs-set-visited-file-modtime (&optional time) - ;; For remote files sets the modtime for a buffer to be that of the - ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list - ;; of two 16-bit integers. - ;; The function set-visited-file-modtime is for emacs-19. It doesn't - ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for - ;; remote files only. - (if time - (efs-set-emacs-bvf-mdtm (current-buffer) time) - (let* ((path buffer-file-name) - (parsed (efs-ftp-path path)) - (host (car parsed)) - (user (nth 1 parsed)) - (file (nth 2 parsed)) - (buffer (current-buffer))) - (if (efs-save-match-data - (and efs-verify-modtime-host-regexp - (string-match efs-verify-modtime-host-regexp host) - (or efs-verify-anonymous-modtime - (not (efs-anonymous-p user))) - (not (efs-get-host-property host 'mdtm-failed)))) - (progn - (or efs-set-modtimes-synchronously (clear-visited-file-modtime)) - (efs-send-cmd - host user (list 'quote 'mdtm file) - nil nil - (efs-cont (result line cont-lines) (host user path buffer) - (let (modtime) - (if (and (null result) - (setq modtime (efs-parse-mdtime line))) - (let ((ent (efs-get-file-entry path))) - (if ent - (setcdr ent (list (nth 1 ent) (nth 2 ent) - (nth 3 ent) (nth 4 ent) - modtime))) - (setq buffer (and (setq buffer (get-buffer buffer)) - (buffer-name buffer))) - ;; Beware that since might be happening asynch, - ;; the buffer may have disappeared. - (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) - (efs-save-match-data - (or (string-match "^550 " line) - (efs-set-host-property host 'mdtm-failed t))) - (efs-set-emacs-bvf-mdtm buffer '(0 0))))) ; store dummy values - (and (null efs-set-modtimes-synchronously) 0))) - (efs-set-emacs-bvf-mdtm buffer '(0 0))) - nil))) ; return NIL - -(defun efs-file-newer-than-file-p (file1 file2) - ;; Version of file-newer-than-file-p for remote files. - (let* ((file1 (expand-file-name file1)) - (file2 (expand-file-name file2)) - (parsed1 (efs-ftp-path file1)) - (parsed2 (efs-ftp-path file2)) - (host1 (car parsed1)) - (host2 (car parsed2)) - (user1 (nth 1 parsed1)) - (user2 (nth 1 parsed2))) - (cond - ;; If the first file doedn't exist, or is remote but - ;; we're not supposed to check modtimes on it, return nil. - ((or (null (file-exists-p file1)) - (and parsed1 - (or - (null efs-verify-modtime-host-regexp) - (efs-get-host-property host1 'mdtm-failed) - (not (string-match efs-verify-modtime-host-regexp host1)) - (and (null efs-verify-anonymous-modtime) - (efs-anonymous-p user1))))) - nil) - ;; If the same is true for the second file, return t. - ((or (null (file-exists-p file2)) - (and parsed2 - (or - (null efs-verify-modtime-host-regexp) - (efs-get-host-property host2 'mdtm-failed) - (not (string-match efs-verify-modtime-host-regexp host2)) - (and (null efs-verify-anonymous-modtime) - (efs-anonymous-p user2))))) - t) - ;; Calculate modtimes. If we get here, any remote files should - ;; have a file entry. - (t - (let (mod1 mod2 shift1 shift2) - (if parsed1 - (let ((ent (efs-get-file-entry file1))) - (setq mod1 (nth 5 ent) - shift1 (efs-clock-difference host1)) - (or mod1 - (setq mod1 (efs-get-file-mdtm - host1 user1 (nth 2 parsed1) file1)))) - (setq mod1 (nth 5 (file-attributes file1)))) - (if parsed2 - (let ((ent (efs-get-file-entry file2))) - (setq mod2 (nth 5 ent) - shift2 (efs-clock-difference host2)) - (or mod2 - (setq mod2 (efs-get-file-mdtm - host2 user2 (nth 2 parsed2) file2)))) - (setq mod2 (nth 5 (file-attributes file2)))) - ;; If we can't compute clock shifts, we act as if we don't - ;; even know the modtime. Should we have more faith in ntp? - (cond - ((or (null mod1) (eq shift1 'failed)) - nil) - ((or (null mod2) (eq shift2 'failed)) - t) - ;; We get to compute something! - (t - (efs-time-greater - (if shift1 (efs-time-minus mod1 shift1) mod1) - (if shift2 (efs-time-minus mod2 shift2) mod2))))))))) - -(defun efs-verify-visited-file-modtime (buff) - ;; Verifies the modtime for buffers visiting remote files. - ;; Won't get called for buffer not visiting any file. - (let ((buff (get-buffer buff))) - (null - (and buff ; return t if no buffer? Need to beware of multi-threading. - (buffer-file-name buff) ; t if no file - (let ((mdtm (save-excursion - (set-buffer buff) - (visited-file-modtime)))) - (and - (not (eq mdtm 0)) - (not (equal mdtm '(0 0))) - efs-verify-modtime-host-regexp - (let* ((path (buffer-file-name buff)) - (parsed (efs-ftp-path path)) - (host (car parsed)) - (user (nth 1 parsed)) - nmdtm) - (and - (null (efs-get-host-property host 'mdtm-failed)) - (efs-save-match-data - (string-match - efs-verify-modtime-host-regexp host)) - (or efs-verify-anonymous-modtime - (not (efs-anonymous-p user))) - (setq nmdtm (efs-get-file-mdtm host user (nth 2 parsed) path)) - (progn - (or (equal nmdtm '(0 0)) - (file-exists-p path) ; Make sure that there is an entry. - (null - (efs-get-files - (file-name-directory - (efs-internal-directory-file-name path)))) - (efs-add-file-entry - (efs-host-type host) path nil nil nil nil nil nmdtm)) - (null (and (eq (cdr mdtm) (nth 1 nmdtm)) - (eq (car mdtm) (car nmdtm))))))))))))) - -;;;; ----------------------------------------------------------- -;;;; Redefinition of Emacs file name completion -;;;; ----------------------------------------------------------- - -(defmacro efs-set-completion-ignored-pattern () - ;; Set regexp efs-completion-ignored-pattern - ;; to use for filename completion. - (` - (or (equal efs-completion-ignored-extensions - completion-ignored-extensions) - (setq efs-completion-ignored-extensions - completion-ignored-extensions - efs-completion-ignored-pattern - (mapconcat (function - (lambda (s) (if (stringp s) - (concat (regexp-quote s) "$") - "/"))) ; / never in filename - efs-completion-ignored-extensions - "\\|"))))) - -(defun efs-file-entry-active-p (sym) - ;; If the file entry is a symlink, returns whether the file pointed to - ;; exists. - ;; Note that DIR is dynamically bound. - (let ((file-type (car (get sym 'val)))) - (or (not (stringp file-type)) - (file-exists-p (efs-chase-symlinks - (expand-file-name file-type efs-completion-dir)))))) - -(defun efs-file-entry-not-ignored-p (sym) - ;; If the file entry is not a directory (nor a symlink pointing to a - ;; directory) returns whether the file (or file pointed to by the symlink) - ;; is ignored by completion-ignored-extensions. - (let ((file-type (car (get sym 'val))) - (symname (symbol-name sym))) - (if (stringp file-type) - ;; Maybe file-truename would be better here, but it is very costly - ;; to chase symlinks at every level over FTP. - (let ((file (efs-chase-symlinks (expand-file-name - file-type efs-completion-dir)))) - (or (file-directory-p file) - (and (file-exists-p file) - (not (string-match efs-completion-ignored-pattern - symname))))) - (or file-type ; is a directory name - (not (string-match efs-completion-ignored-pattern symname)))))) - -(defun efs-file-name-all-completions (file dir) - ;; Does file-name-all-completions in remote directories. - (efs-barf-if-not-directory dir) - (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) - (completion-ignore-case - (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) - efs-case-insensitive-host-types)) - (tbl (efs-get-files efs-completion-dir)) - (completions - (all-completions file tbl - (function efs-file-entry-active-p)))) - ;; see whether each matching file is a directory or not... - (mapcar - ;; Since the entries in completions will match the case - ;; of the entries in tbl, don't need to case-fold - ;; in efs-get-hash-entry below. - (function - (lambda (file) - (let ((ent (car (efs-get-hash-entry file tbl)))) - (if (or (eq ent t) - (and (stringp ent) - (file-directory-p (efs-chase-symlinks - (expand-file-name - ent efs-completion-dir))))) - (concat file "/") - file)))) - completions))) - -(defun efs-file-name-completion (file dir) - ;; Does file name expansion in remote directories. - (efs-barf-if-not-directory dir) - (if (equal file "") - "" - (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) - (completion-ignore-case - (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) - efs-case-insensitive-host-types)) - (tbl (efs-get-files efs-completion-dir))) - (efs-set-completion-ignored-pattern) - (efs-save-match-data - (or (efs-file-name-completion-1 - file tbl efs-completion-dir - (function efs-file-entry-not-ignored-p)) - (efs-file-name-completion-1 - file tbl efs-completion-dir - (function efs-file-entry-active-p))))))) - -(defun efs-file-name-completion-1 (file tbl dir predicate) - ;; Internal subroutine for efs-file-name-completion. Do not call this. - (let ((bestmatch (try-completion file tbl predicate))) - (if bestmatch - (if (eq bestmatch t) - (if (file-directory-p (expand-file-name file dir)) - (concat file "/") - t) - (if (and (eq (try-completion bestmatch tbl predicate) t) - (file-directory-p - (expand-file-name bestmatch dir))) - (concat bestmatch "/") - bestmatch))))) - -;;;; ---------------------------------------------------------- -;;;; Functions for loading lisp. -;;;; ---------------------------------------------------------- - -;;; jka-load provided ideas here. Thanks, Jay. - -(defun efs-load-openp (str suffixes) - ;; Given STR, searches load-path and efs-load-lisp-extensions - ;; for the name of a file to load. Returns the full path, or nil - ;; if none found. - (let ((path-list (if (file-name-absolute-p str) t load-path)) - root result) - ;; If there is no load-path, at least try the default directory. - (or path-list - (setq path-list (list default-directory))) - (while (and path-list (null result)) - (if (eq path-list t) - (setq path-list nil - root str) - (setq root (expand-file-name str (car path-list)) - path-list (cdr path-list)) - (or (file-name-absolute-p root) - (setq root (expand-file-name root default-directory)))) - (let ((suff-list suffixes)) - (while (and suff-list (null result)) - (let ((try (concat root (car suff-list)))) - (if (or (not (file-readable-p try)) - (file-directory-p try)) - (setq suff-list (cdr suff-list)) - (setq result try)))))) - result)) - -(defun efs-load (file &optional noerror nomessage nosuffix) - "Documented as original." - (let ((filename (efs-load-openp - file - (if nosuffix '("") efs-load-lisp-extensions)))) - (if (not filename) - (and (null noerror) (error "Cannot open load file %s" file)) - (let ((parsed (efs-ftp-path filename)) - (after-load (and (boundp 'after-load-alist) - (assoc file after-load-alist)))) - (if parsed - (let ((temp (car (efs-make-tmp-name nil (car parsed))))) - (unwind-protect - (progn - (efs-copy-file-internal - filename parsed temp nil t nil - (format "Getting %s" filename)) - (or (file-readable-p temp) - (error - "efs-load: temp file %s is unreadable" temp)) - (or nomessage - (message "Loading %s..." file)) - ;; temp is an absolute filename, so load path - ;; won't be searched. - (let (after-load-alist) - (efs-real-load temp t t t)) - (or nomessage - (message "Loading %s...done" file)) - (if after-load (mapcar 'eval (cdr after-load))) - t) ; return t if everything worked - (efs-del-tmp-name temp))) - (prog2 - (or nomessage - (message "Loading %s..." file)) - (let (after-load-alist) - (or (efs-real-load filename noerror t t) - (setq after-load nil))) - (or nomessage - (message "Loading %s...done" file)) - (if after-load (mapcar 'eval (cdr after-load))))))))) - -(defun efs-require (feature &optional filename) - "Documented as original." - (if (eq feature 'ange-ftp) (efs-require-scream-and-yell)) - (if (featurep feature) - feature - (or filename (setq filename (symbol-name feature))) - (let ((fullpath (efs-load-openp filename - efs-load-lisp-extensions))) - (if (not fullpath) - (error "Cannot open load file: %s" filename) - (let ((parsed (efs-ftp-path fullpath))) - (if parsed - (let ((temp (car (efs-make-tmp-name nil (car parsed))))) - (unwind-protect - (progn - (efs-copy-file-internal - fullpath parsed temp nil t nil - (format "Getting %s" fullpath)) - (or (file-readable-p temp) - (error - "efs-require: temp file %s is unreadable" temp)) - (efs-real-require feature temp)) - (efs-del-tmp-name temp))) - (efs-real-require feature fullpath))))))) - -(defun efs-require-scream-and-yell () - ;; Complain if something attempts to load ange-ftp. - (with-output-to-temp-buffer "*Help*" - (princ - "Something tried to load ange-ftp. -EFS AND ANGE-FTP DO NOT WORK TOGETHER. - -If the culprit package does need to access ange-ftp internal functions, -then it should be adequate to simply remove the \(require 'ange-ftp\) -line and let efs handle remote file access. Otherwise, it will need to -be ported to efs. This may already have been done, and you can find out -by sending an enquiry to efs-help@cuckoo.hpl.hp.com. - -Signalling an error with backtrace will allow you to determine which -package was requiring ange-ftp.\n")) - (select-window (get-buffer-window "*Help*")) - (enlarge-window (- (count-lines (point-min) (point-max)) - (window-height) -1)) - (if (y-or-n-p "Signal error with backtrace? ") - (let ((stack-trace-on-error t)) - (error "Attempt to require ange-ftp")))) - -;;;; ----------------------------------------------------------- -;;;; Redefinition of Emacs functions for reading file names. -;;;; ----------------------------------------------------------- - -(defun efs-unexpand-parsed-filename (host user path) - ;; Replaces the home directory in path with "~". Returns the unexpanded - ;; full-path. - (let* ((path-len (length path)) - (def-user (efs-get-user host)) - (host-type (efs-host-type host user)) - (ignore-case (memq host-type efs-case-insensitive-host-types))) - (if (> path-len 1) - (let* ((home (efs-expand-tilde "~" host-type host user)) - (home-len (length home))) - (if (and (> path-len home-len) - (if ignore-case (string-equal (downcase home) - (downcase - (substring path - 0 home-len))) - (string-equal home (substring path 0 home-len))) - (= (aref path home-len) ?/)) - (setq path (concat "~" (substring path home-len)))))) - (if (if ignore-case (string-equal (downcase user) - (downcase def-user)) - (string-equal user def-user)) - (format efs-path-format-without-user host path) - (format efs-path-format-string user host path)))) - -(efs-define-fun efs-abbreviate-file-name (filename &optional ignored-for-now) - ;; Version of abbreviate-file-name for remote files. - (efs-save-match-data - (let ((tail directory-abbrev-alist)) - (while tail - (if (string-match (car (car tail)) filename) - (setq filename - (concat (cdr (car tail)) - (substring filename (match-end 0))))) - (setq tail (cdr tail))) - (apply 'efs-unexpand-parsed-filename (efs-ftp-path filename))))) - -(defun efs-default-dir-function () - (let ((parsed (efs-ftp-path default-directory)) - (dd default-directory)) - (if parsed - (efs-save-match-data - (let ((tail directory-abbrev-alist)) - (while tail - (if (string-match (car (car tail)) dd) - (setq dd (concat (cdr (car tail)) - (substring dd (match-end 0))) - parsed nil)) - (setq tail (cdr tail))) - (apply 'efs-unexpand-parsed-filename - (or parsed (efs-ftp-path dd))))) - default-directory))) - -(defun efs-re-read-dir (&optional dir) - "Forces a re-read of the directory DIR. -If DIR is omitted then it defaults to the directory part of the contents -of the current buffer. This is so this function can be caled from the -minibuffer." - (interactive) - (if dir - (setq dir (expand-file-name dir)) - (setq dir (file-name-directory (expand-file-name (buffer-string))))) - (let ((parsed (efs-ftp-path dir))) - (if parsed - (let ((efs-ls-uncache t)) - (efs-del-hash-entry (efs-canonize-file-name dir) - efs-files-hashtable) - (efs-get-files dir t))))) - -;;;; --------------------------------------------------------------- -;;;; Creation and deletion of files and directories. -;;;; --------------------------------------------------------------- - -(defun efs-delete-file (file) - ;; Deletes remote files. - (let* ((file (expand-file-name file)) - (parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - (path (nth 2 parsed)) - (abbr (efs-relativize-filename file)) - (result (efs-send-cmd host user (list 'delete path) - (format "Deleting %s" abbr)))) - (if (car result) - (signal 'ftp-error - (list "Removing old name" - (format "FTP Error: \"%s\"" (nth 1 result)) - file))) - (efs-delete-file-entry host-type file))) - -(defun efs-make-directory-internal (dir) - ;; version of make-directory-internal for remote directories. - (if (file-exists-p dir) - (error "Cannot make directory %s: file already exists" dir) - (let* ((parsed (efs-ftp-path dir)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that mkdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that mkdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path (if (or (memq host-type efs-unix-host-types) - (memq host-type '(os2 dos))) - (efs-internal-directory-file-name (nth 2 parsed)) - (efs-internal-file-name-as-directory - host-type (nth 2 parsed)))) - (abbr (efs-relativize-filename dir)) - (result (efs-send-cmd host user - (list 'mkdir path) - (format "Making directory %s" - abbr)))) - (if (car result) - (efs-error host user - (format "Could not make directory %s: %s" dir - (nth 1 result)))) - (efs-add-file-entry host-type dir t nil user)))) - -;; V19 calls this function delete-directory. It used to be called -;; remove-directory. - -(defun efs-delete-directory (dir) - ;; Version of delete-directory for remote directories. - (if (file-directory-p dir) - (let* ((parsed (efs-ftp-path dir)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (host-type (efs-host-type host user)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that rmdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that rmdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path - (if (or (memq host-type efs-unix-host-types) - (memq host-type '(os2 dos))) - (efs-internal-directory-file-name (nth 2 parsed)) - (efs-internal-file-name-as-directory - host-type (nth 2 parsed)))) - (abbr (efs-relativize-filename dir)) - (result (efs-send-cmd host user - (list 'rmdir path) - (format "Deleting directory %s" abbr)))) - (if (car result) - (efs-error host user - (format "Could not delete directory %s: %s" - dir (nth 1 result)))) - (efs-delete-file-entry host-type dir t)) - (error "Not a directory: %s" dir))) - -(defun efs-file-local-copy (file) - ;; internal function for diff.el (dired 6.3 or later) - ;; Makes a temp file containing the contents of file. - ;; returns the name of the tmp file created, or nil if none is. - ;; This function should have optional cont and nowait args. - (let* ((file (expand-file-name file)) - (tmp (car (efs-make-tmp-name nil (car (efs-ftp-path file)))))) - (efs-copy-file-internal file (efs-ftp-path file) - tmp nil t nil (format "Getting %s" file)) - tmp)) - -(defun efs-diff/grep-del-temp-file (temp) - ;; internal function for diff.el and grep.el - ;; if TEMP is non-nil, deletes the temp file TEMP. - ;; if TEMP is nil, does nothing. - (and temp - (efs-del-tmp-name temp))) - -;;;; ------------------------------------------------------------ -;;;; File copying support... -;;;; ------------------------------------------------------------ - -;;; - totally re-written 6/24/92. -;;; - re-written again 9/3/93 -;;; - and again 14/4/93 -;;; - and again 17/8/93 - -(defun efs-barf-or-query-if-file-exists (absname querystring interactive) - (if (file-exists-p absname) - (if (not interactive) - (signal 'file-already-exists (list absname)) - (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " - absname querystring))) - (signal 'file-already-exists (list absname)))))) - -(defun efs-concatenate-files (file1 file2) - ;; Concatenates file1 to file2. Both must be local files. - ;; Needed because the efs version of copy-file understands - ;; ok-if-already-exists = 'append - (or (file-readable-p file1) - (signal 'file-error - (list (format "Input file %s not readable." file1)))) - (or (file-writable-p file2) - (signal 'file-error - (list (format "Output file %s not writable." file2)))) - (let ((default-directory exec-directory)) - (call-process "sh" nil nil nil "-c" (format "cat %s >> %s" file1 file2)))) - -(defun efs-copy-add-file-entry (newname host-type user size append) - ;; Add an entry in `efs-files-hashtable' for a file newly created via a copy. - (if (eq size -1) (setq size nil)) - (if append - (let ((ent (efs-get-file-entry newname))) - (if (and ent (null (car ent))) - (if (and size (numberp (nth 1 ent))) - (setcar (cdr ent) (+ size (nth 1 ent))) - (setcar (cdr ent) nil)) - ;; If the ent is a symlink or directory, don't overwrite that entry. - (if (null ent) - (efs-add-file-entry host-type newname nil nil nil)))) - (efs-add-file-entry host-type newname nil size user))) - -(defun efs-copy-remote-to-remote (f-host-type f-host f-user f-path filename - t-host-type t-host t-user - t-path newname append msg cont - nowait xfer-type) -;; Use a 3rd data connection to copy from F-HOST for F-USER to T-HOST -;; for T-USER. - (if (efs-get-host-property t-host 'pasv-failed) - ;; PASV didn't work before, don't try again. - (if cont (efs-call-cont cont 'failed "" "")) - (or xfer-type - (setq xfer-type (efs-xfer-type f-host-type filename - t-host-type newname))) - (efs-send-cmd - t-host t-user '(quote pasv) nil nil - (efs-cont (pasv-result pasv-line pasv-cont-lines) - (cont nowait f-host-type f-host f-user f-path filename - t-host-type t-host t-user t-path newname xfer-type msg append) - (efs-save-match-data - (if (or pasv-result - (not (string-match efs-pasv-msgs pasv-line))) - (progn - (efs-set-host-property t-host 'pasv-failed t) - (if cont - (efs-call-cont - cont (or pasv-result 'failed) pasv-line pasv-cont-lines))) - (let ((address (substring pasv-line (match-beginning 1) - (match-end 1)))) - (efs-send-cmd - f-host f-user - (list 'quote 'port address) nil nil - (efs-cont (port-result port-line port-cont-lines) - (cont f-host f-user f-host-type f-path filename - xfer-type msg) - (if port-result - (if cont - (efs-call-cont - cont port-result port-line port-cont-lines) - (efs-error f-host f-user - (format "PORT failed for %s: %s" - filename port-line))) - (efs-send-cmd - f-host f-user - (list 'quote 'retr f-path xfer-type) - msg nil - (efs-cont (retr-result retr-line retr-cont-lines) - (cont f-host f-user f-path) - (and retr-result - (null cont) - (efs-error - f-host f-user - (format "RETR failed for %s: %s" - f-path retr-line))) - (if cont (efs-call-cont - cont retr-result retr-line retr-cont-lines))) - (if (eq nowait t) 1 nowait)))) - 1) ; can't ever wait on this command. - (efs-send-cmd - t-host t-user - (list 'quote (if append 'appe 'stor) t-path xfer-type) - nil nil - (efs-cont (stor-result stor-line stor-cont-lines) - (t-host t-user t-path t-host-type newname filename - append) - (if stor-result - (efs-error - t-host t-user (format "%s failed for %s: %s" - (if append "APPE" "STOR") - t-path stor-line)) - (efs-copy-add-file-entry - newname t-host-type t-user - (nth 1 (efs-get-file-entry filename)) append))) - (if (eq nowait t) 1 nowait)))))) - nowait))) - -(defun efs-copy-on-remote (host user host-type filename newname filename-parsed - newname-parsed keep-date append-p msg cont - nowait xfer-type) - ;; Uses site exec to copy the file on a remote host - (let ((exec-cp (efs-get-host-property host 'exec-cp))) - (if (or append-p - (not (memq host-type efs-unix-host-types)) - (efs-get-host-property host 'exec-failed) - (eq exec-cp 'failed)) - (efs-copy-via-temp filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type) - (if (eq exec-cp 'works) - (efs-send-cmd - host user - (list 'quote 'site 'exec - (format "cp %s%s %s" (if keep-date "-p " "") - (nth 2 filename-parsed) (nth 2 newname-parsed))) - msg nil - (efs-cont (result line cont-lines) (host user filename newname - host-type filename-parsed - newname-parsed - keep-date append-p msg cont - xfer-type nowait) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-copy-via-temp filename filename-parsed newname - newname-parsed append-p keep-date - nil cont nowait xfer-type)) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user err))) - (efs-copy-add-file-entry - newname host-type user - (nth 7 (efs-file-attributes filename)) nil) - (if cont (efs-call-cont cont nil line cont-lines)))))) - nowait) - (message "Checking for cp executable on %s..." host) - (efs-send-cmd - host user (list 'quote 'site 'exec "cp / /") nil nil - (efs-cont (result line cont-lines) (host user filename newname - host-type filename-parsed - newname-parsed - keep-date append-p msg cont - xfer-type nowait) - (efs-save-match-data - (if (string-match "\n200-" cont-lines) - (efs-set-host-property host 'exec-cp 'works) - (efs-set-host-property host 'exec-cp 'failed))) - (efs-copy-on-remote host user host-type filename newname - filename-parsed newname-parsed keep-date - append-p msg cont nowait xfer-type)) - nowait))))) - -(defun efs-copy-via-temp (filename filename-parsed newname newname-parsed - append keep-date msg cont nowait xfer-type) - ;; Copies from FILENAME to NEWNAME via a temp file. - (let* ((temp (car (if (efs-use-gateway-p (car filename-parsed) t) - (efs-make-tmp-name (car filename-parsed) - (car newname-parsed)) - (efs-make-tmp-name (car newname-parsed) - (car filename-parsed))))) - (temp-parsed (efs-ftp-path temp))) - (or xfer-type (setq xfer-type - (efs-xfer-type - (efs-host-type (car filename-parsed)) filename - (efs-host-type (car newname-parsed)) newname - t))) - (efs-copy-file-internal - filename filename-parsed temp temp-parsed t nil (if (eq 0 msg) 2 msg) - (efs-cont (result line cont-lines) (newname newname-parsed temp - temp-parsed append msg cont - nowait xfer-type) - (if result - (progn - (efs-del-tmp-name temp) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\" " line) filename)))) - (efs-copy-file-internal - temp temp-parsed newname newname-parsed (if append 'append t) nil - (if (eq msg 0) 1 msg) - (efs-cont (result line cont-lines) (temp newname cont) - (efs-del-tmp-name temp) - (if cont - (efs-call-cont cont result line cont-lines) - (if result - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\" " line) newname))))) - nowait xfer-type))) - nowait xfer-type))) - -(defun efs-copy-file-internal (filename filename-parsed newname newname-parsed - ok-if-already-exists keep-date - &optional msg cont nowait xfer-type) - ;; Internal function for copying a file from FILENAME to NEWNAME. - ;; FILENAME-PARSED and NEWNAME-PARSED are the lists obtained by parsing - ;; FILENAME and NEWNAME with efs-ftp-path. - ;; If OK-IF-ALREADY-EXISTS is nil, then existing files will not be - ;; overwritten. - ;; If it is a number, then the user will be prompted about overwriting. - ;; If it eq 'append, then an existing file will be appended to. - ;; If it has anyother value, then existing files will be silently - ;; overwritten. - ;; If KEEP-DATE is t then we will attempt to reatin the date of the - ;; original copy of the file. If this is a string, the modtime of the - ;; NEWNAME will be set to this date. Must be in touch -t format. - ;; If MSG is nil, then the copying will be done silently. - ;; If it is a string, then that will be the massage displayed while copying. - ;; If it is 0, then a suitable default message will be computed. - ;; If it is 1, then a suitable default will be computed, assuming - ;; that FILENAME is a temporary file, whose name is not suitable to use - ;; in a status message. - ;; If it is 2, then a suitable default will be used, assuming that - ;; NEWNAME is a temporary file. - ;; CONT is a continuation to call after completing the copy. - ;; The first two args are RESULT and LINE, the result symbol and status - ;; line of the FTP command. If more than one ftp command has been used, - ;; then these values for the last FTP command are given. - ;; NOWAIT can be either nil, 0, 1, t. See `efs-send-cmd' for an explanation. - ;; XFER-TYPE is the transfer type to use for transferring the files. - ;; If this is nil, than a suitable transfer type is computed. - ;; Does not call expand-file-name. Do that yourself. - - ;; check to see if we can overwrite - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname "copy to it" (numberp ok-if-already-exists))) - (if (null (or filename-parsed newname-parsed)) - ;; local to local copy - (progn - (if (eq ok-if-already-exists 'append) - (efs-concatenate-files filename newname) - (copy-file filename newname ok-if-already-exists keep-date)) - (if cont - (efs-call-cont cont nil "Copied locally" ""))) - (let* ((f-host (car filename-parsed)) - (f-user (nth 1 filename-parsed)) - (f-path (nth 2 filename-parsed)) - (f-host-type (efs-host-type f-host f-user)) - (f-gate-p (efs-use-gateway-p f-host t)) - (t-host (car newname-parsed)) - (t-user (nth 1 newname-parsed)) - (t-path (nth 2 newname-parsed)) - (t-host-type (efs-host-type t-host t-user)) - (t-gate-p (efs-use-gateway-p t-host t)) - (append-p (eq ok-if-already-exists 'append)) - gatename) - - (if (and (eq keep-date t) (null newname-parsed)) - ;; f-host must be remote now. - (setq keep-date filename)) - - (cond - - ;; Check to see if we can do a PUT - ((or - (and (null f-host) - (or (null t-gate-p) - (setq gatename (efs-local-to-gateway-filename filename)))) - (and t-gate-p - f-host - (string-equal (downcase f-host) (downcase efs-gateway-host)) - (if (memq f-host-type efs-case-insensitive-host-types) - (string-equal (downcase f-user) - (downcase (efs-get-user efs-gateway-host))) - (string-equal f-user (efs-get-user efs-gateway-host))))) - (or f-host (let (file-name-handler-alist) - (if (file-exists-p filename) - (cond - ((file-directory-p filename) - (signal 'file-error - (list "Non-regular file" - "is a directory" filename))) - ((not (file-readable-p filename)) - (signal 'file-error - (list "Opening input file" - "permission denied" filename)))) - (signal 'file-error - (list "Opening input file" - "no such file or directory" filename))))) - (or xfer-type - (setq xfer-type - (efs-xfer-type f-host-type filename t-host-type newname))) - (let ((size (and (or (null f-host-type) - (efs-file-entry-p filename)) - (nth 7 (file-attributes filename))))) - ;; -1 is a bogus size for remote files - (if (eq size -1) (setq size nil)) - (efs-send-cmd - t-host t-user - (list (if append-p 'append 'put) - (if f-host - f-path - (or gatename filename)) - t-path - xfer-type) - (cond ((eq msg 2) - (concat (if append-p "Appending " "Putting ") - (efs-relativize-filename filename))) - ((eq msg 1) - (concat (if append-p "Appending " "Putting ") - (efs-relativize-filename newname))) - ((eq msg 0) - (concat (if append-p "Appending " "Copying ") - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - (t msg)) - (and size (list 'efs-set-xfer-size t-host t-user size)) - (efs-cont (result line cont-lines) (newname t-host-type t-user size - append-p cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\" " line) newname))) - ;; add file entry - (efs-copy-add-file-entry newname t-host-type t-user - size append-p) - (if cont - (efs-call-cont cont result line cont-lines)))) - nowait))) - - ;; Check to see if we can do a GET - ((and - ;; I think that giving the append arg, will cause this function - ;; to make a temp file, recursively call itself, and append the temp - ;; file to the local file. Hope it works out... - (null append-p) - (or - (and (null t-host) - (or (null f-gate-p) - (setq gatename (efs-local-to-gateway-filename newname)))) - (and f-gate-p - t-host - (string-equal (downcase t-host) (downcase efs-gateway-host)) - (if (memq t-host-type efs-case-insensitive-host-types) - (string-equal (downcase t-user) - (downcase (efs-get-user efs-gateway-host))) - (string-equal t-user (efs-get-user efs-gateway-host)))))) - (or t-host (let (file-name-handler-alist) - (cond ((not (file-writable-p newname)) - (signal 'file-error - (list "Opening output file" - "permission denied" newname))) - ((file-directory-p newname) - (signal 'file-error - (list "Opening output file" - "is a directory" newname)))))) - (or xfer-type - (setq xfer-type - (efs-xfer-type f-host-type filename t-host-type newname))) - (let ((size (and (or (null f-host-type) - (efs-file-entry-p filename)) - (nth 7 (file-attributes filename))))) - ;; -1 is a bogus size for remote files. - (if (eq size -1) (setq size nil)) - (efs-send-cmd - f-host f-user - (list 'get - f-path - (if t-host - t-path - (or gatename newname)) - xfer-type) - (cond ((eq msg 0) - (concat "Copying " - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - ((eq msg 2) - (concat "Getting " (efs-relativize-filename filename))) - ((eq msg 1) - (concat "Getting " (efs-relativize-filename newname))) - (t msg)) - ;; If the server emits a efs-xfer-size-msgs, it will over-ride this. - ;; With no xfer msg, this is will do the job. - (and size (list 'efs-set-xfer-size f-host f-user size)) - (efs-cont (result line cont-lines) (filename newname size - t-host-type t-user - cont keep-date) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Opening input file" - (format "FTP Error: \"%s\" " line) filename))) - ;; Add a new file entry, if relevant. - (if t-host-type - ;; t-host will be equal to efs-gateway-host, if t-host-type - ;; is non-nil. - (efs-copy-add-file-entry newname t-host-type - t-user size nil)) - (if (and (null t-host-type) (stringp keep-date)) - (efs-set-mdtm-of - filename newname - (and cont - (efs-cont (result1 line1 cont-lines1) (result - line cont-lines - cont) - (efs-call-cont cont result line cont-lines)))) - (if cont - (efs-call-cont cont result line cont-lines))))) - nowait))) - - ;; Can we do a EXEC cp? - ((and t-host f-host - (string-equal (downcase t-host) (downcase f-host)) - (if (memq t-host-type efs-case-insensitive-host-types) - (string-equal (downcase t-user) (downcase f-user)) - (string-equal t-user f-user))) - (efs-copy-on-remote - t-host t-user t-host-type filename newname filename-parsed - newname-parsed keep-date append-p - (cond ((eq msg 0) - (concat "Copying " - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - ((eq msg 1) - (concat "Copying " (efs-relativize-filename newname))) - ((eq msg 2) - (concat "Copying " (efs-relativize-filename filename))) - (t msg)) - cont nowait xfer-type)) - - ;; Try for a copy with PASV - ((and t-host f-host - (not (and (string-equal (downcase t-host) (downcase f-host)) - (if (memq t-host-type efs-case-insensitive-host-types) - (string-equal (downcase t-user) (downcase f-user)) - (string-equal t-user f-user)))) - (or - (and efs-gateway-host - ;; The gateway should be able to talk to anything. - (let ((gh (downcase efs-gateway-host))) - (or (string-equal (downcase t-host) gh) - (string-equal (downcase f-host) gh)))) - (efs-save-match-data - (eq (null (string-match efs-local-host-regexp t-host)) - (null (string-match efs-local-host-regexp f-host)))))) - (efs-copy-remote-to-remote - f-host-type f-host f-user f-path filename - t-host-type t-host t-user t-path newname - append-p - (cond ((eq msg 0) - (concat "Copying " - (efs-relativize-filename filename) - " to " - (efs-relativize-filename - newname (file-name-directory filename) filename))) - ((eq msg 1) - (concat "Copying " (efs-relativize-filename newname))) - ((eq msg 2) - (concat "Copying " (efs-relativize-filename filename))) - (t msg)) - (efs-cont (result line cont-lines) - (filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type) - (if result - ;; PASV didn't work. Do things the old-fashioned - ;; way. - (efs-copy-via-temp - filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type) - (if cont - (efs-call-cont cont result line cont-lines)))) - nowait xfer-type)) - - ;; Can't do anything direct. Divide and conquer. - (t - (efs-copy-via-temp filename filename-parsed newname newname-parsed - append-p keep-date msg cont nowait xfer-type)))))) - -(defun efs-copy-file (filename newname &optional ok-if-already-exists - keep-date nowait) - ;; Version of copy file for remote files. Actually, will also work - ;; for local files too, since efs-copy-file-internal can copy anything. - ;; If called interactively, copies asynchronously. - (setq filename (expand-file-name filename) - newname (expand-file-name newname)) - (if (eq ok-if-already-exists 'append) - (setq ok-if-already-exists t)) - (efs-copy-file-internal filename (efs-ftp-path filename) - newname (efs-ftp-path newname) - ok-if-already-exists keep-date 0 nil nowait)) - -;;;; ------------------------------------------------------------ -;;;; File renaming support. -;;;; ------------------------------------------------------------ - -(defun efs-rename-get-file-list (dir ent) - ;; From hashtable ENT for DIR returns a list of all files except "." - ;; and "..". - (let (list) - (efs-map-hashtable - (function - (lambda (key val) - (or (string-equal "." key) (string-equal ".." key) - (setq list - (cons (expand-file-name key dir) list))))) - ent) - list)) - -(defun efs-rename-get-files (dir cont nowait) - ;; Obtains a list of files in directory DIR (except . and ..), and applies - ;; CONT to the list. Doesn't return anything useful. - (let* ((dir (file-name-as-directory dir)) - (ent (efs-get-files-hashtable-entry dir))) - (if ent - (efs-call-cont cont (efs-rename-get-file-list dir ent)) - (efs-ls - dir (efs-ls-guess-switches) t nil t nowait - (efs-cont (listing) (dir cont) - (efs-call-cont - cont (and listing - (efs-rename-get-file-list - dir (efs-get-files-hashtable-entry dir))))))))) - -(defun efs-rename-get-local-file-tree (dir) - ;; Returns a list of the full directory tree under DIR, for DIR on the - ;; local host. The list is in tree order. - (let ((res (list dir))) - (mapcar - (function - (lambda (file) - (if (file-directory-p file) - (nconc res (delq nil (mapcar - (function - (lambda (f) - (and (not (string-equal "." f)) - (not (string-equal ".." f)) - (expand-file-name f file)))) - (directory-files file))))))) - res) - res)) - -(defun efs-rename-get-remote-file-tree (next curr total cont nowait) - ;; Builds a hierarchy of files. - ;; NEXT is the next level so far. - ;; CURR are unprocessed files in the current level. - ;; TOTAL is the processed files so far. - ;; CONT is a cont. function called on the total list after all files - ;; are processed. - ;; NOWAIT non-nil means run asynch. - (or curr (setq curr next - next nil)) - (if curr - (let ((file (car curr))) - (setq curr (cdr curr) - total (cons file total)) - (if (file-directory-p file) - (efs-rename-get-files - file - (efs-cont (list) (next curr total cont nowait) - (efs-rename-get-remote-file-tree (nconc next list) - curr total cont nowait)) - nowait) - (efs-rename-get-remote-file-tree next curr total cont nowait))) - (efs-call-cont cont (nreverse total)))) - -(defun efs-rename-make-targets (files from-dir-len to-dir host user host-type - cont nowait) - ;; Make targets (copy a file or make a subdir) on local or host - ;; for the files in list. Afterwhich, call CONT. - (if files - (let* ((from (car files)) - (files (cdr files)) - (to (concat to-dir (substring from from-dir-len)))) - (if (file-directory-p from) - (if host-type - (let ((dir (nth 2 (efs-ftp-path to)))) - (or (memq host-type efs-unix-host-types) - (memq host-type '(dos os2)) - (setq dir (efs-internal-file-name-as-directory nil dir))) - (efs-send-cmd - host user (list 'mkdir dir) - (format "Making directory %s" (efs-relativize-filename to)) - nil - (efs-cont (res line cont-lines) (to files from-dir-len - to-dir host user - host-type cont nowait) - (if res - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Making directory" - (format "FTP Error: \"%s\"" line) - to))) - (efs-rename-make-targets - files from-dir-len to-dir host user - host-type cont nowait))) - nowait)) - (condition-case nil - (make-directory-internal to) - (error (efs-call-cont - cont 'failed (format "Failed to mkdir %s" to) ""))) - (efs-rename-make-targets - files from-dir-len to-dir host user host-type cont nowait)) - (efs-copy-file-internal - from (efs-ftp-path from) to (and host-type (efs-ftp-path to)) nil t - (format "Renaming %s to %s" (efs-relativize-filename from) - (efs-relativize-filename to)) - (efs-cont (res line cont-lines) (from to files from-dir-len to-dir - host user host-type cont - nowait) - (if res - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) from to))) - (efs-rename-make-targets - files from-dir-len to-dir host user host-type cont nowait))) - nowait))) - (if cont (efs-call-cont cont nil "" "")))) - -(defun efs-rename-delete-on-local (files) - ;; Delete the files FILES, and then run CONT. - ;; FILES are assumed to be in inverse tree order. - (message "Deleting files...") - (mapcar - (function - (lambda (f) - (condition-case nil - (if (file-directory-p f) - (delete-directory f) - (delete-file f)) - (file-error nil)))) ; don't complain if the file is already gone. - files) - (message "Deleting files...done")) - -(defun efs-rename-delete-on-remote (files host user host-type cont nowait) - ;; Deletes the list FILES on a remote host. When done calls CONT. - ;; FILES is assumed to be in reverse tree order. - (if files - (let* ((f (car files)) - (rf (nth 2 (efs-ftp-path f)))) - (progn - (setq files (cdr files)) - (if (file-directory-p f) - (let ((rf (if (memq host-type (append efs-unix-host-types - '(dos os2))) - (efs-internal-directory-file-name f) - (efs-internal-file-name-as-directory nil f)))) - - (efs-send-cmd - host user (list 'rmdir rf) - (concat "Deleting directory " (efs-relativize-filename f)) - nil - (efs-cont (res line cont-lines) (f files host user host-type - cont nowait) - (if (and res - (efs-save-match-data - (not (string-match "^550 " line)))) - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Deleting directory" - (format "FTP Error: \"%s\"" line) - f))) - (efs-rename-delete-on-remote - files host user host-type cont nowait))) - nowait)) - (efs-send-cmd - host user (list 'delete rf) - (concat "Deleting " rf) - nil - (efs-cont (res line cont-lines) (f files host user host-type - cont nowait) - (if (and res - (efs-save-match-data - (not (string-match "^550 " line)))) - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Deleting" - (format "FTP Error: \"%s\"" line) - f))) - (efs-rename-delete-on-remote - files host user host-type cont nowait))) - nowait)))) - (if cont (efs-call-cont cont nil "" "")))) - -(defun efs-rename-on-remote (host user old-path new-path old-file new-file - msg nowait cont) - ;; Run a rename command on the remote server. - ;; OLD-PATH and NEW-PATH are in full efs syntax. - ;; OLD-FILE and NEW-FILE are the remote full pathnames, not in efs syntax. - (efs-send-cmd - host user (list 'rename old-file new-file) msg nil - (efs-cont (result line cont-lines) (cont old-path new-path host) - (if result - (progn - (or (and (>= (length line) 4) - (string-equal "550 " (substring line 0 4))) - (efs-set-host-property host 'rnfr-failed t)) - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - old-path new-path)))) - (let ((entry (efs-get-file-entry old-path)) - (host-type (efs-host-type host)) - ;; If no file entry, do extra work on the hashtable, - ;; rather than force a listing. - (dir-p (or (not (efs-file-entry-p old-path)) - (file-directory-p old-path)))) - (apply 'efs-add-file-entry host-type new-path - (eq (car entry) t) (cdr entry)) - (efs-delete-file-entry host-type old-path) - (if dir-p - (let* ((old (efs-canonize-file-name - (file-name-as-directory old-path))) - (new (efs-canonize-file-name - (file-name-as-directory new-path))) - (old-len (length old)) - (new-tbl (efs-make-hashtable - (length efs-files-hashtable)))) - (efs-map-hashtable - (function - (lambda (key val) - (if (and (>= (length key) old-len) - (string-equal (substring key 0 old-len) - old)) - (efs-put-hash-entry - (concat new (substring key old-len)) val new-tbl) - (efs-put-hash-entry key val new-tbl)))) - efs-files-hashtable) - (setq efs-files-hashtable new-tbl))) - (if cont (efs-call-cont cont result line cont-lines))))) - nowait)) - -(defun efs-rename-local-to-remote (filename newname newname-parsed - msg cont nowait) - ;; Renames a file from the local host to a remote host. - (if (file-directory-p filename) - (let* ((files (efs-rename-get-local-file-tree filename)) - (to-dir (directory-file-name newname)) - (filename (directory-file-name filename)) - (len (length filename)) - (t-parsed (efs-ftp-path to-dir)) - (host (car t-parsed)) - (user (nth 1 t-parsed)) - (host-type (efs-host-type host))) - ;; MSG is never passed here, instead messages are constructed - ;; internally. I don't know how to use a single message - ;; in a function which sends so many FTP commands. - (efs-rename-make-targets - files len to-dir host user host-type - (efs-cont (result line cont-lines) (files filename newname cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" (format "FTP Error: \"%s\"" line) - filename newname))) - (efs-rename-delete-on-local (nreverse files)) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait)) - (efs-copy-file-internal - filename nil newname newname-parsed t t msg - (efs-cont (result line cont-lines) (filename cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - filename newname))) - (condition-case nil - (delete-file filename) - (error nil)) - (if cont (efs-call-cont cont result line cont-lines)))) - nowait))) - -(defun efs-rename-from-remote (filename filename-parsed newname newname-parsed - msg cont nowait) - (let ((f-host (car filename-parsed)) - (f-user (nth 1 filename-parsed)) - (fast-nowait (if (eq nowait t) 1 nowait))) - (if (file-directory-p filename) - (let* ((t-host (car newname-parsed)) - (t-user (nth 1 newname-parsed)) - (t-host-type (and t-host (efs-host-type t-host))) - (f-host-type (efs-host-type f-host))) - (efs-rename-get-remote-file-tree - nil (list filename) nil - (efs-cont (list) (filename filename-parsed newname t-host t-user - t-host-type f-host f-user f-host-type - cont fast-nowait) - (efs-rename-make-targets - list (length filename) newname t-host t-user t-host-type - (efs-cont (res line cont-lines) (filename newname f-host f-user - f-host-type list cont - fast-nowait) - (if res - (if cont - (efs-call-cont cont res line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - filename newname))) - (efs-rename-delete-on-remote - (nreverse list) f-host f-user f-host-type cont - fast-nowait))) - fast-nowait)) nowait)) - ;; Do things the simple way. - (let ((f-path (nth 2 filename-parsed)) - (f-abbr (efs-relativize-filename filename))) - (efs-copy-file-internal - filename filename-parsed newname newname-parsed t t msg - (efs-cont (result line cont-lines) (filename newname f-host f-user - f-path f-abbr - cont fast-nowait) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "FTP Error: \"%s\"" line) - filename newname))) - (efs-send-cmd - f-host f-user (list 'delete f-path) - (format "Removing %s" f-abbr) nil - (efs-cont (result line cont-lines) (filename f-host cont) - (if result - (if cont - (efs-call-cont cont result line cont-lines) - (signal 'ftp-error - (list "Renaming" - (format "Failed to remove %s" - filename) - "FTP Error: \"%s\"" line))) - (efs-delete-file-entry (efs-host-type f-host) - filename) - (if cont - (efs-call-cont cont result line cont-lines)))) - fast-nowait))) nowait))))) - -(defun efs-rename-file-internal (filename newname ok-if-already-exists - &optional msg cont nowait) - ;; Internal version of rename-file for remote files. - ;; Takes CONT and NOWAIT args. - (let ((filename (expand-file-name filename)) - (newname (expand-file-name newname))) - (let ((f-parsed (efs-ftp-path filename)) - (t-parsed (efs-ftp-path newname))) - (if (null (or f-parsed t-parsed)) - (progn - ;; local rename - (rename-file filename newname ok-if-already-exists) - (if cont - (efs-call-cont cont nil "Renamed locally" ""))) - - ;; check to see if we can overwrite - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname "rename to it" (numberp ok-if-already-exists))) - - (let ((f-abbr (efs-relativize-filename filename)) - (t-abbr (efs-relativize-filename newname - (file-name-directory filename) - filename))) - (or msg (setq msg (format "Renaming %s to %s" f-abbr t-abbr))) - (if f-parsed - (let* ((f-host (car f-parsed)) - (f-user (nth 1 f-parsed)) - (f-path (nth 2 f-parsed)) - (f-host-type (efs-host-type f-host))) - (if (and t-parsed - (string-equal (downcase f-host) - (downcase (car t-parsed))) - (not (efs-get-host-property f-host 'rnfr-failed)) - (if (memq f-host-type efs-case-insensitive-host-types) - (string-equal (downcase f-user) - (downcase (nth 1 t-parsed))) - (string-equal f-user (nth 1 t-parsed)))) - ;; Can run a RENAME command on the server. - (efs-rename-on-remote - f-host f-user filename newname f-path (nth 2 t-parsed) - msg nowait - (efs-cont (result line cont-lines) (f-host - filename - newname - ok-if-already-exists - msg cont nowait) - (if result - (progn - (efs-set-host-property f-host 'rnfr-failed t) - (efs-rename-file-internal - filename newname ok-if-already-exists msg cont - (if (eq nowait t) 1 nowait))) - (if cont - (efs-call-cont cont result line cont-lines))))) - ;; remote to remote - (efs-rename-from-remote filename f-parsed newname t-parsed - msg cont nowait))) - ;; local to remote - (efs-rename-local-to-remote - filename newname t-parsed msg cont nowait))))))) - -(defun efs-rename-file (filename newname &optional ok-if-already-exists nowait) - ;; Does file renaming for remote files. - (efs-rename-file-internal filename newname ok-if-already-exists - nil nil nowait)) - -;;;; ------------------------------------------------------------ -;;;; Making symbolic and hard links. -;;;; ------------------------------------------------------------ - -;;; These functions require that the remote FTP server understand -;;; SITE EXEC and that ln is in its the ftp-exec path. - -(defun efs-try-ln (host user cont nowait) - ;; Do some preemptive testing to see if exec ln works - (if (efs-get-host-property host 'exec-failed) - (signal 'ftp-error (list "Unable to exec ln on host" host))) - (let ((exec-ln (efs-get-host-property host 'exec-ln))) - (cond - ((eq exec-ln 'failed) - (signal 'ftp-error (list "ln is not in FTP exec path on host" host))) - ((eq exec-ln 'works) - (efs-call-cont cont)) - (t - (message "Checking for ln executable on %s..." host) - (efs-send-cmd - host user '(quote site exec "ln / /") - nil nil - (efs-cont (result line cont-lines) (host user cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (format "exec: %s" line))) - ;; Look for an error message - (if (efs-save-match-data - (string-match "\n200-" cont-lines)) - (progn - (efs-set-host-property host 'exec-ln 'works) - (efs-call-cont cont)) - (efs-set-host-property host 'exec-ln 'failed) - (efs-error host user - (format "ln not in FTP exec path on host %s" host))))) - nowait))))) - -(defun efs-make-symbolic-link-internal - (target linkname &optional ok-if-already-exists cont nowait) - ;; Makes remote symbolic links. Assumes that linkname is already expanded. - (let* ((parsed (efs-ftp-path linkname)) - (host (car parsed)) - (user (nth 1 parsed)) - (linkpath (nth 2 parsed)) - (abbr (efs-relativize-filename linkname - (file-name-directory target) target)) - (tparsed (efs-ftp-path target)) - (com-target target) - cmd-string) - (if (null (file-directory-p - (file-name-directory linkname))) - (if cont - (efs-call-cont cont 'failed - (format "no such file or directory, %s" linkname) - "") - (signal 'file-error (list "no such file or directory" linkname))) - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - linkname "make symbolic link" (numberp ok-if-already-exists))) - ;; Do this after above, so that hopefully the host type is sorted out - ;; by now. - (let ((host-type (efs-host-type host))) - (if (or (not (memq host-type efs-unix-host-types)) - (memq host-type efs-dumb-host-types) - (efs-get-host-property host 'exec-failed)) - (error "Unable to make symbolic links on %s." host))) - ;; Be careful not to spoil relative links, or symlinks to other - ;; machines, which maybe symlink-fix.el can sort out. - (if (and tparsed - (string-equal (downcase (car tparsed)) (downcase host)) - (string-equal (nth 1 tparsed) user)) - (setq com-target (nth 2 tparsed))) - ;; symlinks only work for unix, so don't need to - ;; convert pathnames. What about VOS? - (setq cmd-string (concat "ln -sf " com-target " " linkpath)) - (efs-try-ln - host user - (efs-cont () (host user cmd-string target linkname com-target - abbr cont nowait) - (efs-send-cmd - host user (list 'quote 'site 'exec cmd-string) - (format "Symlinking %s to %s" target abbr) - nil - (efs-cont (result line cont-lines) (host user com-target linkname - cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (format "exec: %s" line))) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user err))) - (efs-add-file-entry nil linkname com-target nil user) - (if cont (efs-call-cont cont nil line cont-lines)))))) - nowait)) - nowait)))) - -(defun efs-make-symbolic-link (target linkname &optional ok-if-already-exists) - ;; efs version of make-symbolic-link - (let* ((linkname (expand-file-name linkname)) - (parsed (efs-ftp-path linkname))) - (if parsed - (efs-make-symbolic-link-internal target linkname ok-if-already-exists) - ;; Handler will match on either target or linkname. We are only - ;; interested in the linkname. - (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn - 'efs-file-handler-function))) - (make-symbolic-link target linkname ok-if-already-exists))))) - -(defun efs-add-name-to-file-internal - (file newname &optional ok-if-already-exists cont nowait) - ;; Makes remote symbolic links. Assumes that linkname is already expanded. - (let* ((parsed (efs-ftp-path file)) - (host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (nparsed (efs-ftp-path newname)) - (nhost (car nparsed)) - (nuser (nth 1 nparsed)) - (npath (nth 2 nparsed)) - (abbr (efs-relativize-filename newname - (file-name-directory file))) - (ent (efs-get-file-entry file)) - cmd-string) - (or (and (string-equal (downcase host) (downcase nhost)) - (string-equal user nuser)) - (error "Cannot create hard links between different host user pairs.")) - (if (or (null ent) (stringp (car ent)) - (not (file-directory-p - (file-name-directory newname)))) - (if cont - (efs-call-cont cont 'failed - (format "no such file or directory, %s %s" - file newname) "") - (signal 'file-error - (list "no such file or directory" - file newname))) - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (efs-barf-or-query-if-file-exists - newname "make hard link" (numberp ok-if-already-exists))) - ;; Do this last, so that hopefully the host type is known. - (let ((host-type (efs-host-type host))) - (if (or (not (memq host-type efs-unix-host-types)) - (memq host-type efs-dumb-host-types) - (efs-get-host-property host 'exec-failed)) - (error "Unable to make hard links on %s." host))) - (setq cmd-string (concat "ln -f " path " " npath)) - (efs-try-ln - host user - (efs-cont () (host user cmd-string file newname abbr cont nowait) - (efs-send-cmd - host user (list 'quote 'site 'exec cmd-string) - (format "Adding to %s name %s" file abbr) - nil - (efs-cont (result line cont-lines) (host user file newname cont) - (if result - (progn - (efs-set-host-property host 'exec-failed t) - (efs-error host user (format "exec: %s" line))) - (efs-save-match-data - (if (string-match "\n200-\\([^\n]*\\)" cont-lines) - (let ((err (substring cont-lines (match-beginning 1) - (match-end 1)))) - (if cont - (efs-call-cont cont 'failed err cont-lines) - (efs-error host user err))) - (let ((ent (efs-get-file-entry file))) - (if ent - (let ((nlinks (nthcdr 4 ent)) - new-nlinks) - (and (integerp (car nlinks)) - (setq new-nlinks (1+ (car nlinks))) - (setcar nlinks new-nlinks)) - (apply 'efs-add-file-entry nil newname ent) - (if cont (efs-call-cont cont nil line cont-lines))) - (let ((tbl (efs-get-files-hashtable-entry - (file-name-directory - (directory-file-name newname))))) - (if tbl - (efs-ls - newname - (concat (efs-ls-guess-switches) "d") t t nil - nowait - (efs-cont (listing) (newname cont line cont-lines) - (efs-update-file-info - newname efs-data-buffer-name) - (if cont - (efs-call-cont cont nil line cont-lines)))) - (if cont - (efs-call-cont cont nil line cont-lines)))))))))) - nowait)) - nowait)))) - -(defun efs-add-name-to-file (file newname &optional ok-if-already-exists) - ;; efs version of add-name-to-file - (efs-add-name-to-file-internal file newname ok-if-already-exists)) - - -;;;; ============================================================== -;;;; >9 -;;;; Multiple Host Type Support. -;;;; The initial host type guessing is done in the PWD code below. -;;;; If necessary, further guessing is done in the listing parser. -;;;; ============================================================== - - -;;;; -------------------------------------------------------------- -;;;; Functions for setting and retrieving host types. -;;;; -------------------------------------------------------------- - -(defun efs-add-host (type host) - "Sets the TYPE of the remote host HOST. -The host type is read with completion so this can be used to obtain a -list of supported host types. HOST must be a string, giving the name of -the host, exactly as given in file names. Setting the host type with -this function is preferable to setting the efs-TYPE-host-regexp, as look up -will be faster. Returns TYPE." - ;; Since internet host names are always case-insensitive, we will cache - ;; them in lower case. - (interactive - (list - (intern - (completing-read "Host type: " - (mapcar - (function (lambda (elt) - (list (symbol-name (car elt))))) - efs-host-type-alist) - nil t)) - (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (efs-ftp-path name))))))) - (setq host (downcase host)) - (efs-set-host-property host 'host-type type) - (prog1 - (setq efs-host-cache host - efs-host-type-cache type) - (efs-set-process-host-type host))) - -(defun efs-set-process-host-type (host &optional user) - ;; Sets the value of efs-process-host-type so that it is shown - ;; on the mode-line. - (let ((buff-list (buffer-list))) - (save-excursion - (while buff-list - (set-buffer (car buff-list)) - (if (equal efs-process-host host) - (setq efs-process-host-type (concat " " (symbol-name - (efs-host-type host)))) - (and efs-show-host-type-in-dired - (eq major-mode 'dired-mode) - efs-dired-host-type - (string-equal (downcase - (car (efs-ftp-path default-directory))) - (downcase host)) - (if user - (setq efs-dired-listing-type-string - (concat - " " - (symbol-name (efs-listing-type host user)))) - (or efs-dired-listing-type-string - (setq efs-dired-listing-type-string - (concat " " (symbol-name (efs-host-type host)))))))) - (setq buff-list (cdr buff-list)))))) - -;;;; ---------------------------------------------------------------- -;;;; Functions for setting and retrieving listings types. -;;;; ---------------------------------------------------------------- - -;;; listing types?? -;;; These are distinguished from host types, in case some OS's have two -;;; breeds of listings. e.g. Unix descriptive listings. -;;; We also use this to support the myriad of DOS ftp servers. - - -(defun efs-listing-type (host user) - "Returns the type of listing used on HOST by USER. -If there is no entry for a specialized listing, returns the host type." - (or - (efs-get-host-user-property host user 'listing-type) - (efs-host-type host user))) - -(defun efs-add-listing-type (type host user) - "Interactively adds the specialized listing type TYPE for HOST and USER -to the listing type cache." - (interactive - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (list - (intern - (completing-read "Listing type: " - (mapcar - (function (lambda (elt) - (list (symbol-name elt)))) - efs-listing-types) - nil t)) - (read-string "Host: " - (and name (car (efs-ftp-path name)))) - (read-string "User: " - (and name (nth 1 (efs-ftp-path name))))))) - (efs-set-host-user-property host user 'listing-type type) - (efs-set-process-host-type host user)) - -;;;; -------------------------------------------------------------- -;;;; Auotomagic bug reporting for unrecognized host types. -;;;; -------------------------------------------------------------- - -(defun efs-scream-and-yell-1 (host user) - ;; Internal for efs-scream-and-yell. - (with-output-to-temp-buffer "*Help*" - (princ - (format - "efs is unable to identify the remote host type of %s. - -Please report this as a bug. It would be very helpful -if your bug report contained at least the PWD command -within the *ftp %s@%s* buffer. -If you know them, also send the operating system -and ftp server types of the remote host." host user host))) - (if (y-or-n-p "Would you like to submit a bug report now? ") - (efs-report-bug host user - "Bug occurred during efs-guess-host-type." t))) - -(defun efs-scream-and-yell (host user) - ;; Advertises that something has gone wrong in identifying the host type. - (if (eq (selected-window) (minibuffer-window)) - (efs-abort-recursive-edit-and-then 'efs-scream-and-yell-1 host user) - (efs-scream-and-yell-1 host user) - (error "Unable to identify remote host type"))) - -;;;; -------------------------------------------------------- -;;;; Guess at the host type using PWD syntax. -;;;; -------------------------------------------------------- - -;; host-type path templates. These should match a pwd performed -;; as the first command after connecting. They should be as tight -;; as possible - -(defconst efs-unix-path-template "^/") -(defconst efs-apollo-unix-path-template "^//") -(defconst efs-cms-path-template - (concat - "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" - "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$\\|" - ;; For the SFS version of CMS - "^[-A-Z0-9]+:[-A-Z0-9$*]+\\.$")) - -(defconst efs-mvs-path-template "^'?[A-Z][0-9][0-9]?[0-9]?[0-9]?[0-9]?\\.'?") - -(defconst efs-guardian-path-template - (concat - "^\\(" - "\\\\[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." - "\\)?" - "\\$[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." - "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?$")) -;; guardian and cms are very close to overlapping (they don't). Be careful. -(defconst efs-vms-path-template - "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") -(defconst efs-mts-path-template - "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") -(defconst efs-ms-unix-path-template "^[A-Za-z0-9]:/") - -;; Following two are for TI lisp machines. Note that lisp machines -;; do not have a default directory, but only a default pathname against -;; which relative pathnames are merged (Jamie tells me). -(defconst efs-ti-explorer-pwd-line-template - (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") - (token (concat "[^" excluded-chars "]+"))) - (concat "^250 " - token ": " ; host name - token "\\(\\." token "\\)*; " ; directory - "\\(\\*.\\*\\|\\*\\)#\\(\\*\\|>\\)" ; name, ext, version - "$"))) ; "*.*#*" or "*.*#>" or "*#*" or "*#>" or "#*" ... -(defconst efs-ti-twenex-path-template - (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") - (token (concat "[^" excluded-chars "]+"))) - (concat "^" - token ":" ; host name - "<\\(" token "\\)?\\(\\." token "\\)*>" ; directory - "\\(\\*.\\*\\|\\*\\)" ; name and extension - "$"))) - -(defconst efs-tops-20-path-template - "^[-A-Z0-9_$]+:<[-A-Z0-9_$]\\(.[-A-Z0-9_$]+\\)*>$") -(defconst efs-pc-path-template - "^[a-zA-Z0-9]:\\\\\\([-_+=a-zA-Z0-9.]+\\\\\\)*[-_+=a-zA-Z0-9.]*$") -(defconst efs-mpe-path-template - (let ((token (concat "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?" - "[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?"))) - (concat - ;; optional session name - "^\\(" token "\\)?," - ;; username - token "." - ;; account - token "," - ;; group - token "$"))) -(defconst efs-vos-path-template - (let ((token "[][@\\^`{}|~\"$+,---./:_a-zA-Z0-9]+")) - (concat - "%" token ; host - "#" token ; disk - "\\(>" token "\\)+" ; directories - ))) -(defconst efs-netware-path-template "^[-A-Z0-9_][-A-Z0-9_/]*:/") -;; Sometimes netware doesn't return a device to a PWD. Then it will be -;; recognized by the listing parser. - -(defconst efs-nos-ve-path-template "^:[A-Z0-9]") -;; Matches the path for NOS/VE - -(defconst efs-mvs-pwd-line-template - ;; Not sure how the PWD parser will do with empty strings, so treate - ;; this as a line regexp. - "^257 \\([Nn]o prefix defined\\|\"\" is working directory\\)") -(defconst efs-cms-pwd-line-template - "^450 No current working directory defined$") -(defconst efs-tops-20-pwd-line-template - "^500 I never heard of the \\(XPWD\\|PWD\\) command\\. Try HELP\\.$") -(defconst efs-dos:ftp-pwd-line-template - "^250 Current working directory is +") -(defconst efs-coke-pwd-line-template "^257 Current balance \\$[0-9]") - -(defconst efs-super-dumb-unix-tilde-regexp - "^550 /.*: No such file or directory\\.?$") -(defconst efs-cms-knet-tilde-regexp - "^501 Invalid CMS fileid: ~$") - - -;; It might be nice to message users about the host type identified, -;; but there is so much other messaging going on, it would not be -;; seen. No point in slowing things down just so users can read -;; a host type message. - -(defun efs-guess-host-type (host user) - "Guess the host type of HOST. -Does a PWD and examines the directory syntax. The PWD is then cached for use -in file name expansion." - (let ((host-type (efs-host-type host)) - (key (concat host "/" user "/~")) - syst) - (efs-save-match-data - (if (eq host-type 'unknown) - ;; Note that efs-host-type returns unknown as the default. - ;; Since we don't yet know the host-type, we use the default - ;; version of efs-send-pwd. We compensate if necessary - ;; by looking at the entire line of output. - (let* ((result (efs-send-pwd nil host user)) - (dir (car result)) - (line (cdr result))) - (cond - - ;; First sift through process lines to see if we recognize - ;; any pwd errors, or full line messages. - - ;; CMS - ((string-match efs-cms-pwd-line-template line) - (setq host-type (efs-add-host 'cms host) - dir (concat "/" (if (> (length user) 8) - (substring user 0 8) - user) - ".191")) - (message - "Unable to determine a \"home\" CMS minidisk. Assuming %s" - dir) - (sit-for 1)) - - ;; TOPS-20 - ((string-match efs-tops-20-pwd-line-template line) - (setq host-type (efs-add-host 'tops-20 host) - dir (car (efs-send-pwd 'tops-20 host user)))) - - ;; TI-EXPLORER lisp machine. pwd works here, but the output - ;; needs to be specially parsed since spaces separate - ;; hostnames from dirs from filenames. - ((string-match efs-ti-explorer-pwd-line-template line) - (setq host-type (efs-add-host 'ti-explorer host) - dir (substring line 4))) - - ;; FTP Software's DOS Server - ((string-match efs-dos:ftp-pwd-line-template line) - (setq host-type (efs-add-host 'dos host) - dir (substring line (match-end 0))) - (efs-add-listing-type 'dos:ftp host user)) - - ;; MVS - ((string-match efs-mvs-pwd-line-template line) - (setq host-type (efs-add-host 'mvs host) - dir "")) ; "" will convert to /, which is always - ; the mvs home dir. - - ;; COKE - ((string-match efs-coke-pwd-line-template line) - (setq host-type (efs-add-host 'coke host) - dir "/")) - - ;; Try to get tilde. - ((null dir) - (let ((tilde (nth 1 (efs-send-cmd - host user (list 'get "~" "/dev/null"))))) - (cond - ;; super dumb unix - ((string-match efs-super-dumb-unix-tilde-regexp tilde) - (setq dir (car (efs-send-pwd 'super-dumb-unix host user)) - host-type (efs-add-host 'super-dumb-unix host))) - - ;; Try for cms-knet - ((string-match efs-cms-knet-tilde-regexp tilde) - (setq dir (car (efs-send-pwd 'cms-knet host user)) - host-type (efs-add-host 'cms-knet host))) - - ;; We don't know. Scream and yell. - (efs-scream-and-yell host user)))) - - ;; Now look at dir to determine host type - - ;; try for UN*X-y type stuff - ((string-match efs-unix-path-template dir) - (if - ;; Check for apollo, so we know not to short-circuit //. - (string-match efs-apollo-unix-path-template dir) - (progn - (setq host-type (efs-add-host 'apollo-unix host)) - (efs-add-listing-type 'unix:unknown host user)) - ;; could be ka9q, dos-distinct, plus any of the unix breeds, - ;; except apollo. - (if (setq syst (efs-get-syst host user)) - (let ((case-fold-search t)) - (cond - ((string-match "\\bNetware\\b" syst) - (setq host-type (efs-add-host 'netware host))) - ((string-match "^Plan 9" syst) - (setq host-type (efs-add-host 'plan9 host))) - ((string-match "^UNIX" syst) - (setq host-type (efs-add-host 'unix host)) - (efs-add-listing-type 'unix:unknown host user))))))) - - ;; try for VMS - ((string-match efs-vms-path-template dir) - (setq host-type (efs-add-host 'vms host))) - - ;; try for MTS - ((string-match efs-mts-path-template dir) - (setq host-type (efs-add-host 'mts host))) - - ;; try for CMS - ((string-match efs-cms-path-template dir) - (setq host-type (efs-add-host 'cms host))) - - ;; try for Tandem's guardian OS - ((string-match efs-guardian-path-template dir) - (setq host-type (efs-add-host 'guardian host))) - - ;; Try for TOPS-20. pwd doesn't usually work for tops-20 - ;; But who knows??? - ((string-match efs-tops-20-path-template dir) - (setq host-type (efs-add-host 'tops-20 host))) - - ;; Try for DOS or OS/2. - ((string-match efs-pc-path-template dir) - (let ((syst (efs-get-syst host user)) - (case-fold-search t)) - (if (and syst (string-match "^OS/2 " syst)) - (setq host-type (efs-add-host 'os2 host)) - (setq host-type (efs-add-host 'dos host))))) - - ;; try for TI-TWENEX lisp machine - ((string-match efs-ti-twenex-path-template dir) - (setq host-type (efs-add-host 'ti-twenex host))) - - ;; try for MPE - ((string-match efs-mpe-path-template dir) - (setq host-type (efs-add-host 'mpe host))) - - ;; try for VOS - ((string-match efs-vos-path-template dir) - (setq host-type (efs-add-host 'vos host))) - - ;; try for the microsoft server in unix mode - ((string-match efs-ms-unix-path-template dir) - (setq host-type (efs-add-host 'ms-unix host))) - - ;; Netware? - ((string-match efs-netware-path-template dir) - (setq host-type (efs-add-host 'netware host))) - - ;; Try for MVS - ((string-match efs-mvs-path-template dir) - (if (string-match "^'.+'$" dir) - ;; broken MVS PWD quoting - (setq dir (substring dir 1 -1))) - (setq host-type (efs-add-host 'mvs host))) - - ;; Try for NOS/VE - ((string-match efs-nos-ve-path-template dir) - (setq host-type (efs-add-host 'nos-ve host))) - - ;; We don't know. Scream and yell. - (t - (efs-scream-and-yell host user))) - - ;; Now that we have done a pwd, might as well put it in - ;; the expand-dir hashtable. - (if dir - (efs-put-hash-entry - key - (efs-internal-directory-file-name - (efs-fix-path host-type dir 'reverse)) - efs-expand-dir-hashtable - (memq host-type efs-case-insensitive-host-types)))) - - ;; host-type has been identified by regexp, set the mode-line. - (efs-set-process-host-type host user) - - ;; Some special cases, where we need to store the cwd on login. - (if (not (efs-hash-entry-exists-p - key efs-expand-dir-hashtable)) - (cond - ;; CMS: We will be doing cd's, so we'd better make sure that - ;; we know where home is. - ((eq host-type 'cms) - (let* ((res (efs-send-pwd 'cms host user)) - (dir (car res)) - (line (cdr res))) - (if (and dir (not (string-match - efs-cms-pwd-line-template line))) - (setq dir (concat "/" dir)) - (setq dir (concat "/" (if (> (length user) 8) - (substring user 0 8) - user) - ".191")) - (message - "Unable to determine a \"home\" CMS minidisk. Assuming %s" - dir)) - (efs-put-hash-entry - key dir efs-expand-dir-hashtable - (memq 'cms efs-case-insensitive-host-types)))) - ;; MVS: pwd doesn't work in the root directory, so we stuff this - ;; into the hashtable manually. - ((eq host-type 'mvs) - (efs-put-hash-entry key "/" efs-expand-dir-hashtable)) - )))))) - - -;;;; ----------------------------------------------------------- -;;;; efs-autoloads -;;;; These provide the entry points for the non-unix packages. -;;;; ----------------------------------------------------------- - -(efs-autoload 'efs-fix-path vms "efs-vms") -(efs-autoload 'efs-fix-path mts "efs-mts") -(efs-autoload 'efs-fix-path cms "efs-cms") -(efs-autoload 'efs-fix-path ti-explorer "efs-ti-explorer") -(efs-autoload 'efs-fix-path ti-twenex "efs-ti-twenex") -(efs-autoload 'efs-fix-path dos "efs-pc") -(efs-autoload 'efs-fix-path mvs "efs-mvs") -(efs-autoload 'efs-fix-path tops-20 "efs-tops-20") -(efs-autoload 'efs-fix-path mpe "efs-mpe") -(efs-autoload 'efs-fix-path os2 "efs-pc") -(efs-autoload 'efs-fix-path vos "efs-vos") -(efs-autoload 'efs-fix-path ms-unix "efs-ms-unix") -(efs-autoload 'efs-fix-path netware "efs-netware") -(efs-autoload 'efs-fix-path cms-knet "efs-cms-knet") -(efs-autoload 'efs-fix-path guardian "efs-guardian") -(efs-autoload 'efs-fix-path nos-ve "efs-nos-ve") - -(efs-autoload 'efs-fix-dir-path vms "efs-vms") -(efs-autoload 'efs-fix-dir-path mts "efs-mts") -(efs-autoload 'efs-fix-dir-path cms "efs-cms") -(efs-autoload 'efs-fix-dir-path ti-explorer "efs-ti-explorer") -(efs-autoload 'efs-fix-dir-path ti-twenex "efs-ti-twenex") -(efs-autoload 'efs-fix-dir-path dos "efs-pc") -(efs-autoload 'efs-fix-dir-path mvs "efs-mvs") -(efs-autoload 'efs-fix-dir-path tops-20 "efs-tops-20") -(efs-autoload 'efs-fix-dir-path mpe "efs-mpe") -(efs-autoload 'efs-fix-dir-path os2 "efs-pc") -(efs-autoload 'efs-fix-dir-path vos "efs-vos") -(efs-autoload 'efs-fix-dir-path hell "efs-hell") -(efs-autoload 'efs-fix-dir-path ms-unix "efs-ms-unix") -(efs-autoload 'efs-fix-dir-path netware "efs-netware") -(efs-autoload 'efs-fix-dir-path plan9 "efs-plan9") -(efs-autoload 'efs-fix-dir-path cms-knet "efs-cms-knet") -(efs-autoload 'efs-fix-dir-path guardian "efs-guardian") -(efs-autoload 'efs-fix-dir-path nos-ve "efs-nos-ve") -(efs-autoload 'efs-fix-dir-path coke "efs-coke") - -;; A few need to autoload a pwd function -(efs-autoload 'efs-send-pwd tops-20 "efs-tops-20") -(efs-autoload 'efs-send-pwd cms-knet "efs-cms-knet") -(efs-autoload 'efs-send-pwd ti-explorer "efs-ti-explorer") -(efs-autoload 'efs-send-pwd hell "efs-hell") -(efs-autoload 'efs-send-pwd mvs "efs-mvs") -(efs-autoload 'efs-send-pwd coke "efs-coke") - -;; A few packages are loaded by the listing parser. -(efs-autoload 'efs-parse-listing ka9q "efs-ka9q") -(efs-autoload 'efs-parse-listing unix:dl "efs-dl") -(efs-autoload 'efs-parse-listing dos-distinct "efs-dos-distinct") -(efs-autoload 'efs-parse-listing hell "efs-hell") -(efs-autoload 'efs-parse-listing netware "efs-netware") - -;; Packages that need to autoload for child-lookup -(efs-autoload 'efs-allow-child-lookup plan9 "efs-plan9") -(efs-autoload 'efs-allow-child-lookup coke "efs-coke") - -;; Packages that need to autoload for file-exists-p and file-directory-p -(efs-autoload 'efs-internal-file-exists-p guardian "efs-guardian") -(efs-autoload 'efs-internal-file-directory-p guardian "efs-guardian") - - - -;;;; ============================================================ -;;;; >10 -;;;; Attaching onto the appropriate Emacs version -;;;; ============================================================ - -;;;; ------------------------------------------------------------------- -;;;; Connect to various hooks. -;;;; ------------------------------------------------------------------- - -(or (memq 'efs-set-buffer-mode find-file-hooks) - (setq find-file-hooks - (cons 'efs-set-buffer-mode find-file-hooks))) - -;;; We are using our own dired.el, so this doesn't depend on Emacs flavour. - -(if (featurep 'dired) - (require 'efs-dired) - (add-hook 'dired-load-hook (function - (lambda () - (require 'efs-dired))))) - -;;;; ------------------------------------------------------------ -;;;; Add to minor-mode-alist. -;;;; ------------------------------------------------------------ - -(or (assq 'efs-process-host-type minor-mode-alist) - (if (assq 'dired-sort-mode minor-mode-alist) - (let ((our-list - (nconc - (delq nil - (list (assq 'dired-sort-mode minor-mode-alist) - (assq 'dired-subdir-omit minor-mode-alist) - (assq 'dired-marker-stack minor-mode-alist))) - (list '(efs-process-host-type efs-process-host-type) - '(efs-dired-listing-type - efs-dired-listing-type-string)))) - (old-list (delq - (assq 'efs-process-host-type minor-mode-alist) - (delq - (assq 'efs-dired-listing-type minor-mode-alist) - minor-mode-alist)))) - (setq minor-mode-alist nil) - (while old-list - (or (assq (car (car old-list)) our-list) - (setq minor-mode-alist (nconc minor-mode-alist - (list (car old-list))))) - (setq old-list (cdr old-list))) - (setq minor-mode-alist (nconc our-list minor-mode-alist))) - (setq minor-mode-alist - (nconc - (list '(efs-process-host-type efs-process-host-type) - '(efs-dired-listing-type efs-dired-listing-type-string)) - minor-mode-alist)))) - -;;;; ------------------------------------------------------------ -;;;; File name handlers -;;;; ------------------------------------------------------------ - -;;;###autoload -(defun efs-file-handler-function (operation &rest args) - "Function to call special file handlers for remote files." - (let ((handler (and (if (boundp 'allow-remote-paths) - allow-remote-paths - t) - (get operation 'efs)))) - (if handler - (apply handler args) - (let ((inhibit-file-name-handlers - (cons 'efs-file-handler-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args))))) - -(defun efs-sifn-handler-function (operation &rest args) - ;; Handler function for substitute-in-file-name - (if (and (if (boundp 'allow-remote-paths) - allow-remote-paths - t) - (eq operation 'substitute-in-file-name)) - (apply 'efs-substitute-in-file-name args) - (let ((inhibit-file-name-handlers - (cons 'efs-sifn-handler-function - (and (eq operation inhibit-file-name-operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args)))) - -;; Yes, this is what it looks like. I'm defining the handler to run our -;; version whenever there is an environment variable. - -(defvar efs-path-sifn-regexp "\\(^\\|[^$]\\)\\(\\$\\$\\)*\\$[{a-zA-Z0-9]" - "Regexp to match environment variables in file names.") - -(or (assoc efs-path-sifn-regexp file-name-handler-alist) - (nconc file-name-handler-alist - (list - (cons efs-path-sifn-regexp - 'efs-sifn-handler-function)))) - -;;;; ------------------------------------------------------------ -;;;; Necessary overloads. -;;;; ------------------------------------------------------------ - -;;; The following functions are overloaded, instead of extended via -;;; the file-name-handler-alist. For various reasons, the -;;; file-name-handler-alist doesn't work for them. It would be nice if -;;; this list could be shortened in the future. - -;; File name exansion. It is not until _after_ a file name has been -;; expanded that it is reasonable to test it for a file name handler. -(efs-overwrite-fn "efs" 'expand-file-name) - -;; Loading lisp files. The problem with using the file-name-handler-alist -;; here is that we don't know what is to be handled, until after searching -;; the load-path. The solution is to change the C code for Fload. -;; A patch to do this has been written by Jay Adams <jka@ece.cmu.edu>. -(efs-overwrite-fn "efs" 'load) -(efs-overwrite-fn "efs" 'require) - -;;;; ------------------------------------------------------------ -;;;; Install the file handlers for efs-file-handler-function. -;;;; ------------------------------------------------------------ - -;; I/O -(put 'insert-file-contents 'efs 'efs-insert-file-contents) -(put 'write-region 'efs 'efs-write-region) -(put 'directory-files 'efs 'efs-directory-files) -(put 'list-directory 'efs 'efs-list-directory) -(put 'insert-directory 'efs 'efs-insert-directory) -(put 'recover-file 'efs 'efs-recover-file) -;; file properties -(put 'file-directory-p 'efs 'efs-file-directory-p) -(put 'file-writable-p 'efs 'efs-file-writable-p) -(put 'file-readable-p 'efs 'efs-file-readable-p) -(put 'file-executable-p 'efs 'efs-file-executable-p) -(put 'file-symlink-p 'efs 'efs-file-symlink-p) -(put 'file-attributes 'efs 'efs-file-attributes) -(put 'file-exists-p 'efs 'efs-file-exists-p) -(put 'file-accessible-directory-p 'efs 'efs-file-accessible-directory-p) -;; manipulating file names -(put 'file-name-directory 'efs 'efs-file-name-directory) -(put 'file-name-nondirectory 'efs 'efs-file-name-nondirectory) -(put 'file-name-as-directory 'efs 'efs-file-name-as-directory) -(put 'directory-file-name 'efs 'efs-directory-file-name) -(put 'abbreviate-file-name 'efs 'efs-abbreviate-file-name) -(put 'file-name-sans-versions 'efs 'efs-file-name-sans-versions) -(put 'unhandled-file-name-directory 'efs 'efs-unhandled-file-name-directory) -(put 'diff-latest-backup-file 'efs 'efs-diff-latest-backup-file) -(put 'file-truename 'efs 'efs-file-truename) -;; modtimes -(put 'verify-visited-file-modtime 'efs 'efs-verify-visited-file-modtime) -(put 'file-newer-than-file-p 'efs 'efs-file-newer-than-file-p) -(put 'set-visited-file-modtime 'efs 'efs-set-visited-file-modtime) -;; file modes -(put 'set-file-modes 'efs 'efs-set-file-modes) -(put 'file-modes 'efs 'efs-file-modes) -;; buffers -(put 'backup-buffer 'efs 'efs-backup-buffer) -(put 'get-file-buffer 'efs 'efs-get-file-buffer) -(put 'create-file-buffer 'efs 'efs-create-file-buffer) -;; creating and removing files -(put 'delete-file 'efs 'efs-delete-file) -(put 'copy-file 'efs 'efs-copy-file) -(put 'rename-file 'efs 'efs-rename-file) -(put 'file-local-copy 'efs 'efs-file-local-copy) -(put 'make-directory-internal 'efs 'efs-make-directory-internal) -(put 'delete-directory 'efs 'efs-delete-directory) -(put 'add-name-to-file 'efs 'efs-add-name-to-file) -(put 'make-symbolic-link 'efs 'efs-make-symbolic-link) -;; file name completion -(put 'file-name-completion 'efs 'efs-file-name-completion) -(put 'file-name-all-completions 'efs 'efs-file-name-all-completions) - -;;;; ------------------------------------------------------------ -;;;; Finally run any load-hooks. -;;;; ------------------------------------------------------------ - -(run-hooks 'efs-load-hook) - -;;; end of efs.el
--- a/lisp/efs/fixup.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -;; -*-Emacs-Lisp-*- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: fixup.el -;; Release: $efs release: 1.15 $ -;; Version: #Revision: 1.1 $ -;; RCS: -;; Description: Fix up the load path for batch byte compilation of efs. -;; Author: Andy Norman, Dawn -;; Created: Sat Jan 30 00:21:33 1993 -;; Modified: Fri Sep 16 20:01:50 1994 by sandy on ibm550 -;; Language: Emacs-Lisp -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(setq load-path - (append (list (substitute-in-file-name "$CWD") - (substitute-in-file-name "$BDIR") - (substitute-in-file-name "$VMDIR") - ) - load-path)) - -(setq byte-compile-warnings t) - -;; If the V18 btye-compiler is being used, this won't be around, so don't -;; complain if we can't find it. -(load "bytecomp-runtime" t t) - -(load "bytecomp" nil t) - -;; It seems efs causes the standard byte compiler some grief here. -(setq max-lisp-eval-depth (* 2 max-lisp-eval-depth)) - -;; If the user has the standard dired loaded, having dired -;; featurep will cause efs-dired.el to attempt to do overloads. -(delq 'dired features) - -;;; end of fixup.el
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/egg/egg-leim.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,52 @@ +;;; egg-leim.el --- Egg-related code for LEIM +;; Copyright (C) 1997 Stephen Turnbull <turnbull@sk.tsukuba.ac.jp> +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Shamelessly ripped off from +;; +;; skk-leim.el --- SKK related code for LEIM +;; Copyright (C) 1997 +;; Murata Shuuichirou <mrt@mickey.ai.kyutech.ac.jp> +;; +;; Author: Stephen Turnbull <turnbull@sk.tsukuba.ac.jp> +;; Version: egg-leim.el,v 1.1 1997/10/27 09:59:23 steve Exp steve +;; Keywords: japanese, input method, LEIM +;; Last Modified: 1997/10/27 09:59:23 + +;; This program 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 versions 2, or (at your option) +;; any later version. + +;; This program 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. + +;;; TODO +;; +;; Add pointers to Egg documentation in LEIM format + +(defun egg-activate (&optional name) + (if (featurep 'wnn) + (require 'egg) + (error "Wnn is not built into this XEmacs")) + (setq inactivate-current-input-method-function 'egg-inactivate) + (toggle-egg-mode)) + +(defun egg-inactivate () + (cond (egg:*mode-on* (toggle-egg-mode)))) + +(register-input-method + 'japanese-egg-wnn "Japanese" + 'egg-activate nil + "EGG - an interface to the Wnn kana to kanji conversion program" ) + +(provide 'egg-leim) + +;;; egg-leim.el ends here
--- a/lisp/egg/egg.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/egg/egg.el Mon Aug 13 10:03:52 2007 +0200 @@ -2378,7 +2378,12 @@ ;;; Currently entries C-\ and C-^ at global-map are undefined. ;;; -(define-key global-map "\C-\\" 'toggle-egg-mode) +;; Make this no-op if LEIM interface is used. +(cond ((featurep 'egg-leim) t) + (t (define-key global-map "\C-\\" 'toggle-egg-mode)) ) +;; #### Should hide bindings like this, too? However, `convert-region' +;; probably isn't going to be a LEIM feature, it's really pretty +;; Japanese and Korean specific. (define-key global-map "\C-x " 'henkan-region) ;; 92.3.16 by K.Handa
--- a/lisp/emulators/crisp.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/emulators/crisp.el Mon Aug 13 10:03:52 2007 +0200 @@ -2,7 +2,7 @@ ;; Author: Gary D. Foster <Gary.Foster@corp.sun.com> ;; Created: 01 Mar 1996 -;; Version: 1.20 +;; Version: 1.21 ;; Keywords: emulations brief crisp ;; X-Modified-by: ;; crisp.el,v @@ -111,15 +111,9 @@ (defvar crisp-load-hook nil "Hooks to run after loading the CRiSP emulator package.") -(defconst crisp-version "crisp.el release 1.1/1.20" +(defconst crisp-version "crisp.el release 1.1/1.21" "The release number and RCS version for the CRiSP emulator.") -(if (string-match "XEmacs\\Lucid" emacs-version) - (add-minor-mode 'crisp-mode-enabled crisp-mode-modeline-string) - (or (assq 'crisp-mode-enabled minor-mode-alist) - (setq minor-mode-alist - (cons '(crisp-mode-enabled crisp-mode-modeline-string) minor-mode-alist)))) - ;; and now the keymap defines (define-key crisp-mode-map [(f1)] 'other-window) @@ -256,6 +250,13 @@ ((eq crisp-mode-enabled 'nil) (use-global-map crisp-mode-original-keymap)))) +(if (string-match "\\(XEmacs\\|Lucid\\)" emacs-version) + (add-minor-mode 'crisp-mode-enabled 'crisp-mode-modeline-string + nil nil 'crisp-mode) + (or (assq 'crisp-mode-enabled minor-mode-alist) + (setq minor-mode-alist + (cons '(crisp-mode-enabled crisp-mode-modeline-string) minor-mode-alist)))) + (provide 'crisp) ;;; crisp.el ends here
--- a/lisp/emulators/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/emulators/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,10 +1,9 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Oct 4 18:11:29 1997 ;;; Code: -(custom-put 'emulations 'custom-loads '("crisp")) -(custom-put 'emulations-crisp 'custom-loads '("crisp")) +(custom-add-loads 'emulations '("crisp")) +(custom-add-loads 'emulations-crisp '("crisp")) ;;; custom-load.el ends here
--- a/lisp/emulators/edt-mapper.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/emulators/edt-mapper.el Mon Aug 13 10:03:52 2007 +0200 @@ -88,8 +88,8 @@ ;;; ;;; Decide whether we're running GNU or Lucid emacs. ;;; -(defconst edt-lucid-emacs19-p (string-match "Lucid" emacs-version) - "Non-NIL if we are running Lucid Emacs version 19.") +(defconst edt-lucid-emacs19-p (string-match "XEmacs" emacs-version) + "Non-NIL if we are running XEmacs.") ;;;
--- a/lisp/eterm/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/eterm/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,12 +1,11 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Sat Oct 4 18:11:31 1997 ;;; Code: -(custom-put 'shell 'custom-loads '("term")) -(custom-put 'term 'custom-loads '("term")) -(custom-put 'processes 'custom-loads '("term")) -(custom-put 'unix 'custom-loads '("term")) +(custom-add-loads 'shell '("term")) +(custom-add-loads 'term '("term")) +(custom-add-loads 'processes '("term")) +(custom-add-loads 'unix '("term")) ;;; custom-load.el ends here
--- a/lisp/games/NeXTify.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -;;; NeXTify.el --- Character insertion variation - -;; Copyright status unknown - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: - -(defun SeLF-insert-command (arg) - "Insert the character you TyPE. -Whichever character you TyPE to run ThIS command is inserted." - (interactive "p") - (let ((p (point)) - (case-fold-search nil)) - (self-insert-command arg) - (save-excursion - (goto-char p) - (skip-chars-backward " \t\r\n") - (if (condition-case () (forward-char -4) (error t)) - nil - (if (looking-at "\\<[A-Za-z][a-z][a-z][a-z][^A-Za-z]") - (progn - (insert (upcase (following-char))) (delete-char 1) - (forward-char 1) - (insert (upcase (following-char))) (delete-char 1) - (insert (upcase (following-char))) (delete-char 1))))))) - -(define-key text-mode-map " " 'SeLF-insert-command) -(define-key text-mode-map "," 'SeLF-insert-command) -(define-key text-mode-map "." 'SeLF-insert-command) -(define-key text-mode-map "!" 'SeLF-insert-command) -(define-key text-mode-map "-" 'SeLF-insert-command) -(define-key text-mode-map "_" 'SeLF-insert-command) -(define-key text-mode-map ";" 'SeLF-insert-command) -(define-key text-mode-map ":" 'SeLF-insert-command) - -;;; NeXTify.el ends here
--- a/lisp/games/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,343 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'games-autoloads) (error "Already loaded")) - -;;;### (autoloads (blackbox) "blackbox" "games/blackbox.el") - -(autoload 'blackbox "blackbox" "\ -Play blackbox. Optional prefix argument is the number of balls; -the default is 4. - -What is blackbox? - -Blackbox is a game of hide and seek played on an 8 by 8 grid (the -Blackbox). Your opponent (Emacs, in this case) has hidden several -balls (usually 4) within this box. By shooting rays into the box and -observing where they emerge it is possible to deduce the positions of -the hidden balls. The fewer rays you use to find the balls, the lower -your score. - -Overview of play: - -\\<blackbox-mode-map>To play blackbox, type \\[blackbox]. An optional prefix argument -specifies the number of balls to be hidden in the box; the default is -four. - -The cursor can be moved around the box with the standard cursor -movement keys. - -To shoot a ray, move the cursor to the edge of the box and press SPC. -The result will be determined and the playfield updated. - -You may place or remove balls in the box by moving the cursor into the -box and pressing \\[bb-romp]. - -When you think the configuration of balls you have placed is correct, -press \\[bb-done]. You will be informed whether you are correct or -not, and be given your score. Your score is the number of letters and -numbers around the outside of the box plus five for each incorrectly -placed ball. If you placed any balls incorrectly, they will be -indicated with `x', and their actual positions indicated with `o'. - -Details: - -There are three possible outcomes for each ray you send into the box: - - Detour: the ray is deflected and emerges somewhere other than - where you sent it in. On the playfield, detours are - denoted by matching pairs of numbers -- one where the - ray went in, and the other where it came out. - - Reflection: the ray is reflected and emerges in the same place - it was sent in. On the playfield, reflections are - denoted by the letter `R'. - - Hit: the ray strikes a ball directly and is absorbed. It does - not emerge from the box. On the playfield, hits are - denoted by the letter `H'. - -The rules for how balls deflect rays are simple and are best shown by -example. - -As a ray approaches a ball it is deflected ninety degrees. Rays can -be deflected multiple times. In the diagrams below, the dashes -represent empty box locations and the letter `O' represents a ball. -The entrance and exit points of each ray are marked with numbers as -described under \"Detour\" above. Note that the entrance and exit -points are always interchangeable. `*' denotes the path taken by the -ray. - -Note carefully the relative positions of the ball and the ninety -degree deflection it causes. - - 1 - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - -1 * * - - - - - - - - - - - - - - - O - - - - O - - - - O - - - - - - - O - - - - - - - * * * * - - - - - - - - - - - - - - * * * * * 2 3 * * * - - * - - - - - - - - - - - - - - * - - - - - - - O - * - - - - - - - - - - - - - - * - - - - - - - - * * - - - - - - - - - - - - - - * - - - - - - - - * - O - - 2 3 - -As mentioned above, a reflection occurs when a ray emerges from the same point -it was sent in. This can happen in several ways: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - O - O - - - - - - - - - - - -R * * * * - - - - - - - * - - - - O - - - - - - - - - - - - O - - - - - - * - - - - R - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - R * * * * - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - -In the first example, the ray is deflected downwards by the upper -ball, then left by the lower ball, and finally retraces its path to -its point of origin. The second example is similar. The third -example is a bit anomalous but can be rationalized by realizing the -ray never gets a chance to get into the box. Alternatively, the ray -can be thought of as being deflected downwards and immediately -emerging from the box. - -A hit occurs when a ray runs straight into a ball: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - - - - - O - - - H * * * * - - - - - - - - - - - - - H * * * * O - - - - - - * - - - - - - - - - - - - - - - - - O - - - - - - O - - - - -H * * * O - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Be sure to compare the second example of a hit with the first example of -a reflection." t nil) - -;;;*** - -;;;### (autoloads (conx-load conx conx-region conx-buffer) "conx" "games/conx.el") - -(autoload 'conx-buffer "conx" "\ -Absorb the text in the current buffer into the tree." t nil) - -(autoload 'conx-region "conx" "\ -Absorb the text in the current region into the tree." t nil) - -(autoload 'conx "conx" "\ -Generate some random sentences in the *conx* buffer." t nil) - -(autoload 'conx-load "conx" "\ -Load in a CONX database written by the \\[conx-save] command. -This clears the database currently in memory." t nil) - -;;;*** - -;;;### (autoloads (shuffle-vector cookie-snarf cookie-insert cookie) "cookie1" "games/cookie1.el") - -(autoload 'cookie "cookie1" "\ -Return a random phrase from PHRASE-FILE. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." nil nil) - -(autoload 'cookie-insert "cookie1" "\ -Insert random phrases from PHRASE-FILE; COUNT of them. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." nil nil) - -(autoload 'cookie-snarf "cookie1" "\ -Reads in the PHRASE-FILE, returns it as a vector of strings. -Emit STARTMSG and ENDMSG before and after. Caches the result; second -and subsequent calls on the same file won't go to disk." nil nil) - -(autoload 'shuffle-vector "cookie1" "\ -Randomly permute the elements of VECTOR (all permutations equally likely)" nil nil) - -;;;*** - -;;;### (autoloads (decipher-mode decipher) "decipher" "games/decipher.el") - -(autoload 'decipher "decipher" "\ -Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." t nil) - -(autoload 'decipher-mode "decipher" "\ -Major mode for decrypting monoalphabetic substitution ciphers. -Lower-case letters enter plaintext. -Upper-case letters are commands. - -The buffer is made read-only so that normal Emacs commands cannot -modify it. - -The most useful commands are: -\\<decipher-mode-map> -\\[decipher-digram-list] Display a list of all digrams & their frequency -\\[decipher-frequency-count] Display the frequency of each ciphertext letter -\\[decipher-adjacency-list] Show adjacency list for current letter (lists letters appearing next to it) -\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) -\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" t nil) - -;;;*** - -;;;### (autoloads (dissociated-press) "dissociate" "games/dissociate.el") - -(autoload 'dissociated-press "dissociate" "\ -Dissociate the text of the current buffer. -Output goes in buffer named *Dissociation*, -which is redisplayed each time text is added to it. -Every so often the user must say whether to continue. -If ARG is positive, require ARG chars of continuity. -If ARG is negative, require -ARG words of continuity. -Default is 2." t nil) - -;;;*** - -;;;### (autoloads (doctor) "doctor" "games/doctor.el") - -(autoload 'doctor "doctor" "\ -Switch to *doctor* buffer and start giving psychotherapy." t nil) - -;;;*** - -;;;### (autoloads (dunnet) "dunnet" "games/dunnet.el") - -(autoload 'dunnet "dunnet" "\ -Switch to *dungeon* buffer and start game." t nil) - -;;;*** - -;;;### (autoloads (flame) "flame" "games/flame.el") - -(autoload 'flame "flame" "\ -Generate ARG (default 1) sentences of half-crazed gibberish." t nil) - -;;;*** - -;;;### (autoloads (gomoku) "gomoku" "games/gomoku.el") - -(autoload 'gomoku "gomoku" "\ -Start a Gomoku game between you and Emacs. -If a game is in progress, this command allow you to resume it. -If optional arguments N and M are given, an N by M board is used. - -You and Emacs play in turn by marking a free square. You mark it with X -and Emacs marks it with O. The winner is the first to get five contiguous -marks horizontally, vertically or in diagonal. -You play by moving the cursor over the square you choose and hitting -\\<gomoku-mode-map>\\[gomoku-human-plays]. -Use \\[describe-mode] for more info." t nil) - -;;;*** - -;;;### (autoloads (hanoi) "hanoi" "games/hanoi.el") - -(autoload 'hanoi "hanoi" "\ -Towers of Hanoi diversion. Argument is number of rings." t nil) - -;;;*** - -;;;### (autoloads (life) "life" "games/life.el") - -(autoload 'life "life" "\ -Run Conway's Life simulation. -The starting pattern is randomly selected. Prefix arg (optional first -arg non-nil from a program) is the number of seconds to sleep between -generations (this defaults to 1)." t nil) - -;;;*** - -;;;### (autoloads (mpuz) "mpuz" "games/mpuz.el") - -(autoload 'mpuz "mpuz" "\ -Multiplication puzzle with GNU Emacs." t nil) - -;;;*** - -;;;### (autoloads (snarf-spooks spook) "spook" "games/spook.el") - -(autoload 'spook "spook" "\ -Adds that special touch of class to your outgoing mail." t nil) - -(autoload 'snarf-spooks "spook" "\ -Return a vector containing the lines from `spook-phrases-file'." nil nil) - -;;;*** - -;;;### (autoloads (tetris) "tetris" "games/tetris.el") - -(autoload 'tetris "tetris" "\ -Tetris - -Shapes drop from the top of the screen, and the user has to move and -rotate the shape to fit in with those at the bottom of the screen so -as to form complete rows. - -tetris-mode keybindings: - \\<tetris-mode-map> -\\[tetris-start-game] Starts a new game of Tetris -\\[tetris-end-game] Terminates the current game -\\[tetris-move-left] Moves the shape one square to the left -\\[tetris-move-right] Moves the shape one square to the right -\\[tetris-rotate-prev] Rotates the shape clockwise -\\[tetris-rotate-next] Rotates the shape anticlockwise -\\[tetris-move-bottom] Drops the shape to the bottom of the playing area - -" t nil) - -;;;*** - -;;;### (autoloads (xmine-mode) "xmine" "games/xmine.el") - -(autoload 'xmine-mode "xmine" "\ -A mode for playing the well known mine searching game. - - `\\<annotation-local-map-default>\\[xmine-activate-function-button1]' or `\\<xmine-keymap>\\[xmine-key-action1]' unhides a tile, - `\\<annotation-local-map-default>\\[xmine-activate-function-button2]' or `\\<xmine-keymap>\\[xmine-key-action2]' unhides all neighbours of a tile, - `\\<annotation-local-map-default>\\[xmine-activate-function-button3]' or `\\<xmine-keymap>\\[xmine-key-action3]' (un)flagges a tile to hold a mine. - - `\\[xmine-key-new]' starts a new game. - `\\[xmine-key-quit]' ends a game. - -All keybindings (with alternatives) currently in effect: - \\{xmine-keymap} - -The rules are quite easy: You start by unhiding (random) tiles. An unhidden -tile showing a number tells you something about the number of mines in it's -neighborhood, where the neighborhood are all 8 tiles (or less if it's -at a border) around the tile. - -E.g. a \"1\" shows you that there is only one mine in the neighborhood of -this tile. Empty tiles have no mines around them, and empty tiles in -the neighborhood of another empty tile are all automatically unhidden -if you unhide one of them. You need to find a strategy to use the -information you have from the numbers to \"flag\" the tiles with mines -under them and unhide all other tiles. If you correctly made this -without accidently unhiding a mine, you've won. - -If you are sure you have correctly flagged all mines around a unhidden tile, -you can use Button-2 or \\[xmine-key-action2] on it to unhide all it's -neighbors. But beware: If you made a mistake by flagging the wrong mines, -you'll blow up! - -Have Fun." t nil) - -(fset 'xmine 'xmine-mode) - -;;;*** - -;;;### (autoloads (psychoanalyze-pinhead apropos-zippy insert-zippyism yow) "yow" "games/yow.el") - -(autoload 'yow "yow" "\ -Return or display a random Zippy quotation. With prefix arg, insert it." t nil) - -(autoload 'insert-zippyism "yow" "\ -Prompt with completion for a known Zippy quotation, and insert it at point." t nil) - -(autoload 'apropos-zippy "yow" "\ -Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." t nil) - -(autoload 'psychoanalyze-pinhead "yow" "\ -Zippy goes to the analyst." t nil) - -;;;*** - -(provide 'games-autoloads)
--- a/lisp/games/blackbox.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,437 +0,0 @@ -;;; blackbox.el --- blackbox game in Emacs Lisp - -;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. - -;; Author: F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu> -;; Adapted-By: ESR -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; by F. Thomas May <uw-nsr!uw-warp!tom@beaver.cs.washington.edu> -;; doc comment by Root Boy Jim <rbj@dsys.icst.nbs.gov>, 27 Apr 89 -;; interface improvements by ESR, Dec 5 1991. - -;; The object of the game is to find four hidden balls by shooting rays -;; into the black box. There are four possibilities: 1) the ray will -;; pass thru the box undisturbed, 2) it will hit a ball and be absorbed, -;; 3) it will be deflected and exit the box, or 4) be deflected immediately, -;; not even being allowed entry into the box. - -;; The strange part is the method of deflection. It seems that rays will -;; not pass next to a ball, and change direction at right angles to avoid it. -;; -;; R 3 -;; 1 - - - - - - - - 1 -;; - - - - - - - - -;; - O - - - - - - 3 -;; 2 - - - - O - O - -;; 4 - - - - - - - - -;; 5 - - - - - - - - 5 -;; - - - - - - - - R -;; H - - - - - - - O -;; 2 H 4 H -;; -;; Rays which enter and exit are numbered. You can see that rays 1 & 5 pass -;; thru the box undisturbed. Ray 2 is deflected by the northwesternmost -;; ball. Likewise rays 3 and 4. Rays which hit balls and are absorbed are -;; marked with H. The bottom of the left and the right of the bottom hit -;; the southeastern ball directly. Rays may also hit balls after being -;; reflected. Consider the H on the bottom next to the 4. It bounces off -;; the NW-ern most ball and hits the central ball. A ray shot from above -;; the right side 5 would hit the SE-ern most ball. The R beneath the 5 -;; is because the ball is returned instantly. It is not allowed into -;; the box if it would reflect immediately. The R on the top is a more -;; leisurely return. Both central balls would tend to deflect it east -;; or west, but it cannot go either way, so it just retreats. - -;; At the end of the game, if you've placed guesses for as many balls as -;; there are in the box, the true board position will be revealed. Each -;; `x' is an incorrect guess of yours;; `o' is the true location of a ball. - -;;; Code: - -(defvar blackbox-mode-map nil "") - -(if blackbox-mode-map - () - (setq blackbox-mode-map (make-keymap)) - (suppress-keymap blackbox-mode-map t) - (define-key blackbox-mode-map "\C-f" 'bb-right) - (define-key blackbox-mode-map [right] 'bb-right) - (define-key blackbox-mode-map "\C-b" 'bb-left) - (define-key blackbox-mode-map [left] 'bb-left) - (define-key blackbox-mode-map "\C-p" 'bb-up) - (define-key blackbox-mode-map [up] 'bb-up) - (define-key blackbox-mode-map "\C-n" 'bb-down) - (define-key blackbox-mode-map [down] 'bb-down) - (define-key blackbox-mode-map "\C-e" 'bb-eol) - (define-key blackbox-mode-map "\C-a" 'bb-bol) - (define-key blackbox-mode-map " " 'bb-romp) - (define-key blackbox-mode-map [insert] 'bb-romp) - (define-key blackbox-mode-map "\C-m" 'bb-done) - (define-key blackbox-mode-map [kp-enter] 'bb-done)) - -;; Blackbox mode is suitable only for specially formatted data. -(put 'blackbox-mode 'mode-class 'special) - -(defvar bb-board) -(defvar bb-balls-placed) -(defvar bb-x) -(defvar bb-y) -(defvar bb-score) -(defvar bb-detour-count) - -(defun blackbox-mode () - "Major mode for playing blackbox. To learn how to play blackbox, -see the documentation for function `blackbox'. - -The usual mnemonic keys move the cursor around the box. -\\<blackbox-mode-map>\\[bb-bol] and \\[bb-eol] move to the beginning and end of line, respectively. - -\\[bb-romp] -- send in a ray from point, or toggle a ball at point -\\[bb-done] -- end game and get score -" - (interactive) - (kill-all-local-variables) - (use-local-map blackbox-mode-map) - (setq truncate-lines t) - (setq major-mode 'blackbox-mode) - (setq mode-name "Blackbox")) - -;;;###autoload -(defun blackbox (num) - "Play blackbox. Optional prefix argument is the number of balls; -the default is 4. - -What is blackbox? - -Blackbox is a game of hide and seek played on an 8 by 8 grid (the -Blackbox). Your opponent (Emacs, in this case) has hidden several -balls (usually 4) within this box. By shooting rays into the box and -observing where they emerge it is possible to deduce the positions of -the hidden balls. The fewer rays you use to find the balls, the lower -your score. - -Overview of play: - -\\<blackbox-mode-map>\ -To play blackbox, type \\[blackbox]. An optional prefix argument -specifies the number of balls to be hidden in the box; the default is -four. - -The cursor can be moved around the box with the standard cursor -movement keys. - -To shoot a ray, move the cursor to the edge of the box and press SPC. -The result will be determined and the playfield updated. - -You may place or remove balls in the box by moving the cursor into the -box and pressing \\[bb-romp]. - -When you think the configuration of balls you have placed is correct, -press \\[bb-done]. You will be informed whether you are correct or -not, and be given your score. Your score is the number of letters and -numbers around the outside of the box plus five for each incorrectly -placed ball. If you placed any balls incorrectly, they will be -indicated with `x', and their actual positions indicated with `o'. - -Details: - -There are three possible outcomes for each ray you send into the box: - - Detour: the ray is deflected and emerges somewhere other than - where you sent it in. On the playfield, detours are - denoted by matching pairs of numbers -- one where the - ray went in, and the other where it came out. - - Reflection: the ray is reflected and emerges in the same place - it was sent in. On the playfield, reflections are - denoted by the letter `R'. - - Hit: the ray strikes a ball directly and is absorbed. It does - not emerge from the box. On the playfield, hits are - denoted by the letter `H'. - -The rules for how balls deflect rays are simple and are best shown by -example. - -As a ray approaches a ball it is deflected ninety degrees. Rays can -be deflected multiple times. In the diagrams below, the dashes -represent empty box locations and the letter `O' represents a ball. -The entrance and exit points of each ray are marked with numbers as -described under \"Detour\" above. Note that the entrance and exit -points are always interchangeable. `*' denotes the path taken by the -ray. - -Note carefully the relative positions of the ball and the ninety -degree deflection it causes. - - 1 - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - -1 * * - - - - - - - - - - - - - - - O - - - - O - - - - O - - - - - - - O - - - - - - - * * * * - - - - - - - - - - - - - - * * * * * 2 3 * * * - - * - - - - - - - - - - - - - - * - - - - - - - O - * - - - - - - - - - - - - - - * - - - - - - - - * * - - - - - - - - - - - - - - * - - - - - - - - * - O - - 2 3 - -As mentioned above, a reflection occurs when a ray emerges from the same point -it was sent in. This can happen in several ways: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - O - O - - - - - - - - - - - -R * * * * - - - - - - - * - - - - O - - - - - - - - - - - - O - - - - - - * - - - - R - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - - - - * - - - - - - - - - - - - - - - - - - - - - R * * * * - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - -In the first example, the ray is deflected downwards by the upper -ball, then left by the lower ball, and finally retraces its path to -its point of origin. The second example is similar. The third -example is a bit anomalous but can be rationalized by realizing the -ray never gets a chance to get into the box. Alternatively, the ray -can be thought of as being deflected downwards and immediately -emerging from the box. - -A hit occurs when a ray runs straight into a ball: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - O - - - - - - - - - - - - - - - - O - - - H * * * * - - - - - - - - - - - - - H * * * * O - - - - - - * - - - - - - - - - - - - - - - - - O - - - - - - O - - - - -H * * * O - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Be sure to compare the second example of a hit with the first example of -a reflection." - (interactive "P") - (switch-to-buffer "*Blackbox*") - (blackbox-mode) - (setq buffer-read-only t) - (buffer-disable-undo (current-buffer)) - ;; XEmacs makes some local variables here and FSF doesn't. - (make-local-variable 'bb-board) - (setq bb-board (bb-init-board (or num 4))) - (make-local-variable 'bb-balls-placed) - (setq bb-balls-placed nil) - (make-local-variable 'bb-x) - (setq bb-x -1) - (make-local-variable 'bb-y) - (setq bb-y -1) - (make-local-variable 'bb-score) - (setq bb-score 0) - (make-local-variable 'bb-detour-count) - (setq bb-detour-count 0) - (bb-insert-board) - (bb-goto (cons bb-x bb-y))) - -(defun bb-init-board (num-balls) - (random t) - (let (board pos) - (while (>= (setq num-balls (1- num-balls)) 0) - (while - (progn - (setq pos (cons (random 8) (random 8))) - (bb-member pos board))) - (setq board (cons pos board))) - board)) - -(defun bb-insert-board () - (let (i (buffer-read-only nil)) - (erase-buffer) - (insert " \n") - (setq i 8) - (while (>= (setq i (1- i)) 0) - (insert " - - - - - - - - \n")) - (insert " \n") - (insert (format "\nThere are %d balls in the box" (length bb-board))) - )) - -(defun bb-right () - (interactive) - (if (= bb-x 8) - () - (forward-char 2) - (setq bb-x (1+ bb-x)))) - -(defun bb-left () - (interactive) - (if (= bb-x -1) - () - (backward-char 2) - (setq bb-x (1- bb-x)))) - -(defun bb-up () - (interactive) - (if (= bb-y -1) - () - (previous-line 1) - (setq bb-y (1- bb-y)))) - -(defun bb-down () - (interactive) - (if (= bb-y 8) - () - (next-line 1) - (setq bb-y (1+ bb-y)))) - -(defun bb-eol () - (interactive) - (setq bb-x 8) - (bb-goto (cons bb-x bb-y))) - -(defun bb-bol () - (interactive) - (setq bb-x -1) - (bb-goto (cons bb-x bb-y))) - -(defun bb-romp () - (interactive) - (cond - ((and - (or (= bb-x -1) (= bb-x 8)) - (or (= bb-y -1) (= bb-y 8)))) - ((bb-outside-box bb-x bb-y) - (bb-trace-ray bb-x bb-y)) - (t - (bb-place-ball bb-x bb-y)))) - -(defun bb-place-ball (x y) - (let ((coord (cons x y))) - (cond - ((bb-member coord bb-balls-placed) - (setq bb-balls-placed (bb-delete coord bb-balls-placed)) - (bb-update-board "-")) - (t - (setq bb-balls-placed (cons coord bb-balls-placed)) - (bb-update-board "O"))))) - -(defun bb-trace-ray (x y) - (let ((result (bb-trace-ray-2 - t - x - (cond - ((= x -1) 1) - ((= x 8) -1) - (t 0)) - y - (cond - ((= y -1) 1) - ((= y 8) -1) - (t 0))))) - (cond - ((eq result 'hit) - (bb-update-board "H") - (setq bb-score (1+ bb-score))) - ((equal result (cons x y)) - (bb-update-board "R") - (setq bb-score (1+ bb-score))) - (t - (setq bb-detour-count (1+ bb-detour-count)) - (bb-update-board (format "%d" bb-detour-count)) - (save-excursion - (bb-goto result) - (bb-update-board (format "%d" bb-detour-count))) - (setq bb-score (+ bb-score 2)))))) - -(defun bb-trace-ray-2 (first x dx y dy) - (cond - ((and (not first) - (bb-outside-box x y)) - (cons x y)) - ((bb-member (cons (+ x dx) (+ y dy)) bb-board) - 'hit) - ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board) - (bb-trace-ray-2 nil x (- dy) y (- dx))) - ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board) - (bb-trace-ray-2 nil x dy y dx)) - (t - (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy)))) - -(defun bb-done () - "Finish the game and report score." - (interactive) - (let (bogus-balls) - (cond - ((not (= (length bb-balls-placed) (length bb-board))) - (message "There %s %d hidden ball%s; you have placed %d." - (if (= (length bb-board) 1) "is" "are") - (length bb-board) - (if (= (length bb-board) 1) "" "s") - (length bb-balls-placed))) - (t - (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board)) - (if (= bogus-balls 0) - (message "Right! Your score is %d." bb-score) - (message "Oops! You missed %d ball%s. Your score is %d." - bogus-balls - (if (= bogus-balls 1) "" "s") - (+ bb-score (* 5 bogus-balls)))) - (bb-goto '(-1 . -1)))))) - -(defun bb-show-bogus-balls (balls-placed board) - (bb-show-bogus-balls-2 balls-placed board "x") - (bb-show-bogus-balls-2 board balls-placed "o")) - -(defun bb-show-bogus-balls-2 (list-1 list-2 c) - (cond - ((null list-1) - 0) - ((bb-member (car list-1) list-2) - (bb-show-bogus-balls-2 (cdr list-1) list-2 c)) - (t - (bb-goto (car list-1)) - (bb-update-board c) - (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c))))) - -(defun bb-outside-box (x y) - (or (= x -1) (= x 8) (= y -1) (= y 8))) - -(defun bb-goto (pos) - (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26))) - -(defun bb-update-board (c) - (let ((buffer-read-only nil)) - (backward-char (1- (length c))) - (delete-char (length c)) - (insert c) - (backward-char 1))) - -(defun bb-member (elt list) - "Returns non-nil if ELT is an element of LIST." - (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list)))) - -(defun bb-delete (item list) - "Deletes ITEM from LIST and returns a copy." - (cond - ((equal item (car list)) (cdr list)) - (t (cons (car list) (bb-delete item (cdr list)))))) - -;;; blackbox.el ends here
--- a/lisp/games/conx.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,806 +0,0 @@ -;;; conx.el --- Yet another dissociater - -;; Copyright status unknown - -;; Author: Jamie Zawinski <jwz@netscape.com> -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: - -;;; conx.el: Yet Another Dissociator. -;;; Original design by Skef Wholey <skef@cs.cmu.edu>; -;;; ported to Emacs-Lisp by Jamie Zawinski <jwz@netscape.com>, 5-mar-91. -;;; Run this compiled. It will be an order of magnitude faster. -;;; -;;; Select a buffer with a lot of text in it. Say M-x conx-buffer -;;; or M-x conx-region. Repeat on as many other bodies of text as -;;; you like. -;;; -;;; M-x conx will use the word-frequency tree the above generated -;;; to produce random sentences in a popped-up buffer. It will pause -;;; at the end of each paragraph for two seconds; type ^G to stop it. -;;; -;;; M-x conx-init will clear the data structures so you can start -;;; over. Note that if you run it twice consecutively on the same -;;; body of text, word sequences in that buffer will be twice as -;;; likely to be generated. -;;; -;;; Once you have sucked in a lot of text and like the kinds of -;;; sentences conx is giving you, you can save the internal data -;;; structures to a file with the M-x conx-save command. Loading -;;; this file with M-x conx-load will be a lot faster and easier -;;; than re-absorbing all of the text files. Beware that loading a -;;; saved conx-file clears the conx database in memory. -;;; -;;; M-x conx-emit-c will write out C source code which, when compiled, -;;; will produce a standalone program which generates sentences from -;;; a copy of the database currently loaded. -;;; -;;; Ideas for future improvement: -;;; -;;; o It would be nice if we could load in more than one saved -;;; file at a time. -;;; -;;; o use it to collect statistics on newsgroup conversations by -;;; examining the tree for the most common words and phrases -;;; -;;; o when replying to mail, insert an X-CONX: header field which -;;; contains a sentence randomly generated from the body of the -;;; message being replied to. -;;; -;;; o It could stand to be faster... - -;;; Code: -(defconst conx-version "1.6, 6-may-94.") - -(defvar conx-bounce 10) ; 1/x -(defvar conx-hashtable-size 9923) ; 9923 is prime -(defconst conx-words-hashtable nil) -(defconst conx-words-vector nil) -(defconst conx-words-vector-fp 0) - -(defconst conx-last-word nil) -p -(defvar conx-files nil "FYI") - -(defun conx-init () - "Forget the current word-frequency tree." - (interactive) - (if (and conx-words-hashtable - (>= (length conx-words-hashtable) conx-hashtable-size)) - (fillarray conx-words-hashtable 0) - (setq conx-words-hashtable (make-vector conx-hashtable-size 0))) - (if conx-words-vector - (fillarray conx-words-vector nil) - (setq conx-words-vector (make-vector 1000 nil))) ; this grows - (setq conx-words-vector-fp 0) - (setq conx-last-word nil - conx-files nil)) - -(defun conx-rehash () - ;; misnomer; this just grows the linear vector, growing the hash table - ;; is too hard. - (message "Rehashing...") - (let* ((L (length conx-words-vector)) - (v2 (make-vector (+ L L) nil))) - (while (< 0 L) - (aset v2 (1- L) (aref conx-words-vector (setq L (1- L))))) - (setq conx-words-vector v2) - ) - (message "Rehashing...done")) - -(defmacro conx-count (word) (list 'aref word 0)) -(defmacro conx-cap (word) (list 'aref word 1)) -(defmacro conx-comma (word) (list 'aref word 2)) -(defmacro conx-period (word) (list 'aref word 3)) -(defmacro conx-quem (word) (list 'aref word 4)) -(defmacro conx-bang (word) (list 'aref word 5)) -(defmacro conx-succ (word) (list 'aref word 6)) -(defmacro conx-pred (word) (list 'aref word 7)) -(defmacro conx-succ-c (word) (list 'aref word 8)) -(defmacro conx-pred-c (word) (list 'aref word 9)) -(defconst conx-length 10) - -(defmacro conx-make-word () - '(copy-sequence '[1 0 0 0 0 0 nil nil 0 0])) - -(defmacro conx-setf (form val) ; mind-numbingly simple - (setq form (macroexpand form (and (boundp 'byte-compile-macro-environment) - byte-compile-macro-environment))) - (cond ((symbolp form) (list 'setq form val)) - ((eq (car form) 'aref) (cons 'aset (append (cdr form) (list val)))) - ((eq (car form) 'cdr) (list 'setcdr (nth 1 form) val)) - ((eq (car form) 'car) (list 'setcar (nth 1 form) val)) - (t (error "can't setf %s" form)))) - -(defmacro conx-push (thing list) - (list 'conx-setf list (list 'cons thing list))) - -(defconst conx-most-positive-fixnum (lsh -1 -1) - "The largest positive integer that can be represented in this emacs.") - -(defmacro conx-rand (n) - (list '% (list 'logand 'conx-most-positive-fixnum '(random)) n)) - -(defmacro conx-relate-succ (word related) - (` (let ((vec (symbol-value (, word)))) - (conx-setf (conx-succ-c vec) (1+ (conx-succ-c vec))) - (let ((rel (assq (, related) (conx-succ vec)))) - (if rel - (setcdr rel (1+ (cdr rel))) - (conx-push (cons (, related) 1) (conx-succ vec))))))) - -(defmacro conx-relate-pred (word related) - (` (let ((vec (symbol-value (, word)))) - (conx-setf (conx-pred-c vec) (1+ (conx-pred-c vec))) - (let ((rel (assq (, related) (conx-pred vec)))) - (if rel - (setcdr rel (1+ (cdr rel))) - (conx-push (cons (, related) 1) (conx-pred vec))))))) - -(defmacro conx-add-word (word) - (` (let* ((word (, word)) - (fc (aref word 0))) - (setq word (intern (downcase word) conx-words-hashtable)) - (let ((vec (and (boundp word) (symbol-value word)))) - (if vec - (conx-setf (conx-count vec) (1+ (conx-count vec))) - (if (= conx-words-vector-fp (length conx-words-vector)) - (conx-rehash)) - (set word (setq vec (conx-make-word))) - (aset conx-words-vector conx-words-vector-fp word) - (setq conx-words-vector-fp (1+ conx-words-vector-fp))) - (or (< fc ?A) (> fc ?Z) - (conx-setf (conx-cap vec) (1+ (conx-cap vec))))) - (if conx-last-word - (progn - (conx-relate-succ conx-last-word word) - (conx-relate-pred word conx-last-word))) - (setq conx-last-word word)))) - -(defmacro conx-punx (char) - (` (if conx-last-word - (let ((char (, char)) - (vec (symbol-value conx-last-word))) - (cond ((eq char ?\,) - (conx-setf (conx-comma vec) (1+ (conx-comma vec)))) - ((or (eq char ?\.) - (eq char ?\;)) - (conx-setf (conx-period vec) (1+ (conx-period vec))) - (setq conx-last-word nil)) - ((eq char ?\?) - (conx-setf (conx-quem vec) (1+ (conx-quem vec))) - (setq conx-last-word nil)) - ((eq char ?\!) - (conx-setf (conx-bang vec) (1+ (conx-bang vec))) - (setq conx-last-word nil))))))) - -(defun conxify-internal () - (let (p w) - (while (not (eobp)) - (skip-chars-forward "^A-Za-z0-9'") - (while (memq (following-char) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?\')) - ;; ignore words beginning with digits - (skip-chars-forward "A-Za-z0-9'") - (skip-chars-forward "^A-Za-z0-9'")) - (setq p (point)) - (skip-chars-forward "A-Za-z0-9'") - (if (= ?\' (preceding-char)) (forward-char -1)) - (if (eq p (point)) - nil - (setq w (buffer-substring p (point))) - (if (equal "nil" w) ; hey, nil is totally magic, this doesn't work! - nil - (conx-add-word w) - (setq n (1+ n)) - (skip-chars-forward " \t\n\r") - (if (memq (setq p (following-char)) '(?\, ?\. ?\! ?\? ?\;)) - (conx-punx p))))))) - -;;;###autoload -(defun conx-buffer () - "Absorb the text in the current buffer into the tree." - (interactive) - (or conx-words-vector (conx-init)) - (let ((i conx-words-vector-fp) - (n 0) - (pm (point-max))) - (save-excursion - (goto-char (point-min)) - (save-restriction - (widen) - (while (< (setq p (point)) pm) - (search-forward "\n\n" pm 0) - (narrow-to-region p (point)) - (goto-char (prog1 p (setq p (point)))) - (conxify-internal) - (widen) - (message "%d%%..." (/ (* p 100) (point-max)))))) - (if buffer-file-name - (setq conx-files (nconc conx-files (list buffer-file-name)))) - (message "%s words, %d unique" n (- conx-words-vector-fp i)))) - -;;;###autoload -(defun conx-region (p m) - "Absorb the text in the current region into the tree." - (interactive "r") - (save-restriction - (widen) - (narrow-to-region p m) - (conx-buffer))) - -(defun conx-mail-buffer () - "Conxify a buffer in /bin/mail format." - (interactive) - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\n \t") - (let ((case-fold-search nil) - (buffer-file-name nil) - p p2 p3) - (or (looking-at "^From ") (error "not in /bin/mail format")) - (while (not (eobp)) - (search-forward "\n\n" nil 0) - (setq p (point)) - (search-forward "\nFrom " nil 0) - (setq p3 (setq p2 (point))) - ;; don't count ".signature" sections. - (and (re-search-backward "\n--+\n" nil t) - (< (count-lines (point) p2) 9) - (setq p2 (point))) - (conx-region p (point)) - (goto-char p3))) - (if buffer-file-name - (setq conx-files (nconc conx-files (list buffer-file-name)))) - )) - -;;; output - -(defun conx-random-related (count list) - (let ((foll (if (= 0 count) 0 (conx-rand count))) - ans) - (while list - (if (<= foll (cdr (car list))) - (setq ans (car (car list)) - list nil) - (setq foll (- foll (cdr (car list))) - list (cdr list)))) - ans)) - -(defun conx-random-succ (word) - (if (= 0 (conx-succ-c (symbol-value word))) - word - (let ((next (conx-random-related - (conx-succ-c (symbol-value word)) - (conx-succ (symbol-value word))))) - (if (= 0 (conx-rand conx-bounce)) - (conx-random-succ - (conx-random-related - (conx-pred-c (symbol-value next)) - (conx-pred (symbol-value next)))) - next)))) - - -(defun conx-sentence () - (or (> conx-words-vector-fp 0) - (error "no conx data is loaded; see `conx-buffer'.")) - (let* ((word (aref conx-words-vector (conx-rand conx-words-vector-fp))) - (first-p t) - (p (point)) - vec punc str) - (while word - (setq punc (conx-rand (conx-count (setq vec (symbol-value word))))) - (if (or first-p - ;; (< (conx-rand (conx-count vec)) (conx-cap vec)) - (= (conx-count vec) (conx-cap vec)) - ) - (progn - (setq first-p nil) - (setq str (symbol-name word)) - (insert (+ (- ?A ?a) (aref str 0))) - (insert (substring str 1))) - (insert (symbol-name word))) - (cond ((< punc (conx-comma vec)) - (insert ", ")) - ((< (setq punc (- punc (conx-comma vec))) (conx-period vec)) - (setq word nil) - (if (= 0 (conx-rand 5)) - (if (= 0 (conx-rand 4)) - (insert ": ") - (insert "; ")) - (insert ". "))) - ((< (setq punc (- punc (conx-period vec))) (conx-quem vec)) - (setq word nil) - (insert "? ")) - ((< (setq punc (- punc (conx-quem vec))) (conx-bang vec)) - (setq word nil) - (insert "! ")) - (t - (insert " ") - (if (= 0 (conx-succ-c vec)) (setq word nil)))) - (if word - (setq word (conx-random-succ word)))) - (fill-region-as-paragraph (save-excursion - (goto-char p) - (beginning-of-line) - (point)) - (point)) - (if (= (preceding-char) ?\n) - (if (= 0 (conx-rand 4)) - (insert "\n") - (delete-char -1) - (insert " ")))) - nil) - -;;;###autoload -(defun conx () - "Generate some random sentences in the *conx* buffer." - (interactive) - (display-buffer (set-buffer (get-buffer-create "*conx*"))) - (select-window (get-buffer-window "*conx*")) - (message "type ^G to stop.") - (while t - (goto-char (point-max)) - (sit-for (if (= (preceding-char) ?\n) 2 0)) - (conx-sentence))) - - -;;; GNUS interface; grab words from the current message. - -(defun conx-gnus-snarf () - "For use as a gnus-select-article-hook." - (set-buffer gnus-article-buffer) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (conx-region (point) (point-max))))) - -;;(add-hook 'gnus-select-article-hook 'conx-gnus-snarf) - -(defun psychoanalyze-conx () - "Mr. Random goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (conx-sentence) - (if (= (random 2) 0) - (conx-sentence)) - (sit-for 0) - (doctor-ret-or-read 1))) - - -;;; Saving the database - -(defun conx-save (file) - "Save the current CONX database to a file for future retrieval. -You can re-load this database with the \\[conx-load] command." - (interactive "FSave CONX corpus to file: ") - (save-excursion - (let (b) - (unwind-protect - (progn - (set-buffer (setq b (get-buffer-create "*conx-save-tmp*"))) - (delete-region (point-min) (point-max)) - (insert ";;; -*- Mode:Emacs-Lisp -*-\n") - (insert ";;; This is a CONX database file. Load it with `conx-load'.\n") - (if conx-files - (insert ";;; Corpus: " (mapconcat 'identity conx-files ", ") "\n")) - (insert ";;; Date: " (current-time-string) "\n\n") - ;; The file format used here is such a cute hack that I'm going to - ;; leave it as an excercise to the reader to figure it out. - (let ((p (point)) - (fill-column 78) - (fill-prefix "\t") - (i 0)) - (insert "(!! [\t") - (while (< i conx-words-vector-fp) - (prin1 (aref conx-words-vector i) (current-buffer)) - (insert " ") - (setq i (1+ i))) - (insert "])\n") - (fill-region-as-paragraph p (point)) - (insert "\n")) - (mapatoms (function (lambda (sym) - (if (not (boundp sym)) - nil - (insert "\(! ") - (prin1 sym (current-buffer)) - (insert " ") - (prin1 (symbol-value sym) (current-buffer)) - (insert "\)\n")))) - conx-words-hashtable) - (goto-char (point-min)) - (while (re-search-forward "\\bnil\\b" nil t) - (replace-match "()")) - (set-visited-file-name file) - (save-buffer))) - (and b (kill-buffer b))))) - -;;;###autoload -(defun conx-load (file) - "Load in a CONX database written by the \\[conx-save] command. -This clears the database currently in memory." - (interactive "fLoad CONX corpus from file: ") - (conx-init) - (fset (intern "!!" conx-words-hashtable) - (function (lambda (vec) - (setq conx-words-vector vec - conx-words-vector-fp (length vec))))) - (fset (intern "!" conx-words-hashtable) - (symbol-function 'setq)) - (let ((obarray conx-words-hashtable)) - (load file))) - - -;;; Emitting C code - -(defun conx-emit-c-data (&optional ansi-p) - (let ((all '()) - (standard-output (current-buffer)) - (after-change-functions nil) ; turning off font-lock speeds it up x2 - (before-change-functions nil) - (after-change-function nil) - (before-change-function nil) - (float-output-format "%.2f") - count total total100) - (or conx-words-hashtable (error "no words")) - (let ((i 0)) - (mapatoms (function (lambda (x) - (if (boundp x) - (setq all (cons (cons i x) all) - i (1+ i))))) - conx-words-hashtable)) - (setq all (nreverse all)) - (setq total (* 4 (length all)) - total100 (max 1 (if (featurep 'lisp-float-type) - (/ (float total) 100) - (/ total 100))) - count 0) - (let ((rest all) - (i 5) - rest2 - word) - (insert "static unsigned short D[] = {") - (while rest - (setq word (symbol-value (cdr (car rest)))) - (setq rest2 (conx-pred word)) - (setq count (1+ count)) - (while rest2 - (princ (cdr (car rest2))) (insert ",") - (princ (car (rassq (car (car rest2)) all))) - (insert ",") - (setq i (1+ i)) - (cond ((> i 10) - (insert "\n") - (setq i 0))) - (setq rest2 (cdr rest2))) - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest2 (conx-succ word)) - (while rest2 - (princ (cdr (car rest2))) - (insert ",") - (princ (car (rassq (car (car rest2)) all))) - (insert ",") - (setq i (1+ i)) - (cond ((> i 10) - (insert "\n") - (setq i 0))) - (setq rest2 (cdr rest2))) - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest (cdr rest)))) - (insert "0};\nstatic char T[] = \"") - (let ((rest all) - (i 0) (j 20) - k word) - (while rest - (setq word (symbol-name (cdr (car rest)))) - (setq k (1+ (length word)) - i (+ i k) - j (+ j k 3)) - (cond ((> j 77) - (insert (if ansi-p "\"\n\"" "\\\n")) - (setq j (+ k 3)))) - (insert word) ; assumes word has no chars needing backslashes - (insert "\\000") - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest (cdr rest)))) - (insert "\";\nstatic struct conx_word words [] = {") - (let ((rest all) - (i 0) (j 0) - cons name word) - (while rest - (setq cons (car rest) - name (symbol-name (cdr cons)) - word (symbol-value (cdr cons))) - (insert "{") (princ (conx-count word)) - (insert ",") (princ (conx-cap word)) - (insert ",") (princ (conx-comma word)) - (insert ",") (princ (conx-period word)) - (insert ",") (princ (conx-quem word)) - (insert ",") (princ (conx-bang word)) - (if (null (conx-pred word)) - (insert ",0") - (insert ",") - (princ i) - (setq i (+ i (* 2 (length (conx-pred word)))))) - (if (null (conx-succ word)) - (insert ",0,") - (insert ",") - (princ i) - (insert ",") - (setq i (+ i (* 2 (length (conx-succ word)))))) - (princ (conx-pred-c word)) (insert ",") - (princ (conx-succ-c word)) (insert ",") - (princ j) - (setq j (+ j (length name) 1)) - (insert (if (cdr rest) (if (= 0 (% (car cons) 2)) "},\n" "},") "}")) - (message "Writing C code... %s%%" (/ count total100)) - (setq count (1+ count)) - (setq rest (cdr rest)) - )) - (insert "};\n#define conx_bounce ") - (princ conx-bounce) - (insert "\n") - (message "Writing C code... done.") - )) - -(defvar conx-c-prolog "\ -#if __STDC__ -#include <stddef.h> -#include <unistd.h> -extern long random (void); -extern void srandom (int); -extern void abort (void); -#endif -#include <stdio.h> -#include <time.h> - -struct conx_word { - unsigned short count; - unsigned short cap; - unsigned short comma; - unsigned short period; - unsigned short quem; - unsigned short bang; - unsigned short pred; - unsigned short succ; - unsigned short npred; - unsigned short nsucc; - unsigned short text; -}; -") - -(defvar conx-c-code "\ -#define countof(x) (sizeof((x)) / sizeof(*(x))) -#define conx_rand(n) (random()%(n)) - -static struct conx_word * -conx_random_related (count, which_list) - unsigned short count, which_list; -{ - unsigned short *list = D + which_list; - int i = 0; - unsigned short foll = (count == 0 ? 0 : conx_rand (count)); - while (1) - { - if (foll <= list [i * 2]) - { - if ((list [i * 2 + 1]) > countof (words)) - abort (); - return &words [list [i * 2 + 1]]; - } - foll -= list [i * 2]; - i++; - } -} - -static struct conx_word * -conx_random_succ (word) - struct conx_word *word; -{ - if (word->nsucc == 0) - return word; - else - { - struct conx_word *next = conx_random_related (word->nsucc, word->succ); - if (conx_rand (conx_bounce) != 0) - return next; - return conx_random_succ (conx_random_related (next->npred, next->pred)); - } -} - -static void -conx_sentence () -{ - static int x = 0; - struct conx_word *word = 0; - int first_p = 1; - int done = 0; - int count = 0; - while (!done) - { - int punc; - char *text; - int L; - if (word) - word = conx_random_succ (word); - else - word = &words [conx_rand (countof (words))]; - count++; - punc = conx_rand (word->count); - text = T + word->text; - L = strlen (text); - if (x + L > 70) - { - putchar ('\\n'); - x = 0; - } - x += L+1; - - if (first_p || (word->count == word->cap)) - { - putchar ((*text >= 'a' && *text <= 'z') ? *text + ('A'-'a') : *text); - fputs (text+1, stdout); - first_p = 0; - } - else - fputs (text, stdout); - - if (punc < word->comma) - { - fputs (\", \", stdout); - x++; - } - else if ((punc -= word->comma) < word->period) - { - x++; - if (count > 120 || conx_rand (5) != 0) - { - done = 1; - fputs (\". \", stdout); - x++; - } - else - { - word = 0; - if (conx_rand (4) == 0) - fputs (\": \", stdout); - else - fputs (\"; \", stdout); - } - } - else if ((punc -= word->period) < word->quem) - { - done = 1; - fputs (\"? \", stdout); - x += 2; - } - else if ((punc -= word->quem) < word->bang) - { - done = 1; - fputs (\"! \", stdout); - x += 2; - } - else - { - if (word->nsucc == 0) - { - fputs (\". \", stdout); - x += 2; - done = 1; - } - else - putchar (' '); - } - } - if (conx_rand (3) == 0) - { - fputs (\"\\n\\n\", stdout); - x = 0; - } -} - -main (argc, argv) - int argc; - char **argv; -{ - unsigned int howmany, delay; - char dummy; - if (argc == 1) - { - howmany = 1; - delay = 0; - } - else if (argc == 2 && - 1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy)) - delay = 0; - else if (argc == 3 && - 1 == sscanf (argv[1], \"%ud%c\", &howmany, &dummy) && - 1 == sscanf (argv[2], \"%ud%c\", &delay, &dummy)) - ; - else - { - fprintf (stderr, \"usage: %s [count [delay]]\\n\", argv [0]); - exit (1); - } - - srandom (time (0)); - if (howmany == 0) - howmany = ~0; - while (howmany > 0) - { - conx_sentence (); - fflush (stdout); - howmany--; - if (delay) sleep (delay); - } - putchar ('\\n'); - exit (0); -} -") - -(defun conx-emit-c (file &optional non-ansi-p) - "Write the current CONX database to a file as C source code. -The generated program will have the same effect as M-x conx, -except that it runs without emacs. - -With a prefix argument, write K&R C instead of ANSI C. ANSI is -the default because, without a certain ANSI feature, large databases -will overflow static limits in most K&R preprocessors." - (interactive "FWrite C file: \nP") - (find-file file) - (erase-buffer) - (let ((buffer-undo-list t)) - (insert conx-c-prolog) - (if (not non-ansi-p) - (insert "\n#if !__STDC__\n" - "error! this file requires an ANSI C compiler\n" - "#endif\n\n")) - (conx-emit-c-data (not non-ansi-p)) - (insert conx-c-code)) - (goto-char (point-min))) - - -;;; Reporting stats - -(defun conx-stats () - (set-buffer (get-buffer-create "*conx-stats*")) - (delete-region (point-min) (point-max)) - (mapatoms (function (lambda (x) - (or (not (boundp x)) - (progn - (insert (format "%s" (conx-count (symbol-value x)))) - (insert "\t\t") - (insert (symbol-name x)) - (insert "\n"))))) - conx-words-hashtable) - (sort-numeric-fields -1 (point-min) (point-max))) - -;;; conx.el ends here
--- a/lisp/games/cookie1.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,173 +0,0 @@ -;;; cookie1.el --- retrieve random phrases from fortune cookie files - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond <esr@snark.thyrsus.com> -;; Maintainer: FSF -;; Keywords: games -;; Created: Mon Mar 22 17:06:26 1993 - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; Support for random cookie fetches from phrase files, used for such -;; critical applications as emulating Zippy the Pinhead and confounding -;; the NSA Trunk Trawler. -;; -;; The two entry points are `cookie' and `cookie-insert'. The helper -;; function `shuffle-vector' may be of interest to programmers. -;; -;; The code expects phrase files to be in one of two formats: -;; -;; * ITS-style LINS format (strings terminated by ASCII 0 characters, -;; leading whitespace ignored). -;; -;; * UNIX fortune file format (quotes terminated by %% on a line by itself). -;; -;; Everything up to the first delimiter is treated as a comment. Other -;; formats could be supported by adding alternates to the regexp -;; `cookie-delimiter'. -;; -;; This code derives from Steve Strassman's 1987 spook.el package, but -;; has been generalized so that it supports multiple simultaneous -;; cookie databases and fortune files. It is intended to be called -;; from other packages such as yow.el and spook.el. -;; -;; TO DO: teach cookie-snarf to auto-detect ITS PINS or UNIX fortune(6) -;; format and do the right thing. - -;;; Code: - -; Randomize the seed in the random number generator. -(random t) - -(defconst cookie-delimiter "\n%%\n\\|\0" - "Delimiter used to separate cookie file entries.") - -(defvar cookie-cache (make-vector 511 0) - "Cache of cookie files that have already been snarfed.") - -;;;###autoload -(defun cookie (phrase-file startmsg endmsg) - "Return a random phrase from PHRASE-FILE. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." - (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))) - (shuffle-vector cookie-vector) - (aref cookie-vector 1))) - -;;;###autoload -(defun cookie-insert (phrase-file &optional count startmsg endmsg) - "Insert random phrases from PHRASE-FILE; COUNT of them. When the phrase file -is read in, display STARTMSG at beginning of load, ENDMSG at end." - (let ((cookie-vector (cookie-snarf phrase-file startmsg endmsg))) - (shuffle-vector cookie-vector) - (let ((start (point))) - (insert ?\n) - (cookie1 (min (- (length cookie-vector) 1) (or count 1)) cookie-vector) - (insert ?\n) - (fill-region-as-paragraph start (point) nil)))) - -(defun cookie1 (arg cookie-vec) - "Inserts a cookie phrase ARG times." - (cond ((zerop arg) t) - (t (insert (aref cookie-vec arg)) - (insert " ") - (cookie1 (1- arg) cookie-vec)))) - -;;;###autoload -(defun cookie-snarf (phrase-file startmsg endmsg) - "Reads in the PHRASE-FILE, returns it as a vector of strings. -Emit STARTMSG and ENDMSG before and after. Caches the result; second -and subsequent calls on the same file won't go to disk." - (let ((sym (intern-soft phrase-file cookie-cache))) - (and sym (not (equal (symbol-function sym) - (nth 5 (file-attributes phrase-file)))) - (yes-or-no-p (concat phrase-file - " has changed. Read new contents? ")) - (setq sym nil)) - (if sym - (symbol-value sym) - (setq sym (intern phrase-file cookie-cache)) - (message "%s" startmsg) - (save-excursion - (let ((buf (generate-new-buffer "*cookie*")) - (result nil)) - (set-buffer buf) - (fset sym (nth 5 (file-attributes phrase-file))) - (insert-file-contents (expand-file-name phrase-file)) - (re-search-forward cookie-delimiter) - (while (progn (skip-chars-forward " \t\n\r\f") (not (eobp))) - (let ((beg (point))) - (re-search-forward cookie-delimiter) - ;; XEmacs change - ;; DBC --- here's the change - ;; This used to be (buffer-substring beg (1- (point))), - ;; which only worked if the regexp matched was one - ;; character long - (setq result (cons (buffer-substring beg - (match-beginning 0)) - result)))) - (kill-buffer buf) - (message "%s" endmsg) - (set sym (apply 'vector result))))))) - -(defun read-cookie (prompt phrase-file startmsg endmsg &optional require-match) - "Prompt with PROMPT and read with completion among cookies in PHRASE-FILE. -STARTMSG and ENDMSG are passed along to `cookie-snarf'. -Optional fifth arg REQUIRE-MATCH non-nil forces a matching cookie." - ;; Make sure the cookies are in the cache. - (or (intern-soft phrase-file cookie-cache) - (cookie-snarf phrase-file startmsg endmsg)) - (completing-read prompt - (let ((sym (intern phrase-file cookie-cache))) - ;; We cache the alist form of the cookie in a property. - (or (get sym 'completion-alist) - (let* ((alist nil) - (vec (cookie-snarf phrase-file - startmsg endmsg)) - (i (length vec))) - (while (> (setq i (1- i)) 0) - (setq alist (cons (list (aref vec i)) alist))) - (put sym 'completion-alist alist)))) - nil require-match nil nil)) - -; Thanks to Ian G Batten <BattenIG@CS.BHAM.AC.UK> -; [of the University of Birmingham Computer Science Department] -; for the iterative version of this shuffle. -; -;;;###autoload -(defun shuffle-vector (vector) - "Randomly permute the elements of VECTOR (all permutations equally likely)" - (let ((i 0) - j - temp - (len (length vector))) - (while (< i len) - (setq j (+ i (random (- len i)))) - (setq temp (aref vector i)) - (aset vector i (aref vector j)) - (aset vector j temp) - (setq i (1+ i)))) - vector) - -(provide 'cookie1) - -;;; cookie1.el ends here
--- a/lisp/games/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Oct 4 18:11:32 1997 - -;;; Code: - -(custom-put 'games 'custom-loads '("xmine")) -(custom-put 'xmine 'custom-loads '("xmine")) - -;;; custom-load.el ends here
--- a/lisp/games/decipher.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1051 +0,0 @@ -;;; decipher.el --- Cryptanalyze monoalphabetic substitution ciphers -;; -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. -;; -;; Author: Christopher J. Madsen <ac608@yfn.ysu.edu> -;; Keywords: games -;; -;; This file is part of GNU Emacs. -;; -;; GNU Emacs 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. -;; -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Quick Start: -;; -;; To decipher a message, type or load it into a buffer and type -;; `M-x decipher'. This will format the buffer and place it into -;; Decipher mode. You can save your work to a file with the normal -;; Emacs save commands; when you reload the file it will automatically -;; enter Decipher mode. -;; -;; I'm not going to discuss how to go about breaking a cipher; try -;; your local library for a book on cryptanalysis. One book you might -;; find is: -;; Cryptanalysis: A study of ciphers and their solution -;; Helen Fouche Gaines -;; ISBN 0-486-20097-3 - -;;; Commentary: -;; -;; This package is designed to help you crack simple substitution -;; ciphers where one letter stands for another. It works for ciphers -;; with or without word divisions. (You must set the variable -;; decipher-ignore-spaces for ciphers without word divisions.) -;; -;; First, some quick definitions: -;; ciphertext The encrypted message (what you start with) -;; plaintext The decrypted message (what you are trying to get) -;; -;; Decipher mode displays ciphertext in uppercase and plaintext in -;; lowercase. You must enter the plaintext in lowercase; uppercase -;; letters are interpreted as commands. The ciphertext may be entered -;; in mixed case; `M-x decipher' will convert it to uppercase. -;; -;; Decipher mode depends on special characters in the first column of -;; each line. The command `M-x decipher' inserts these characters for -;; you. The characters and their meanings are: -;; ( The plaintext & ciphertext alphabets on the first line -;; ) The ciphertext & plaintext alphabets on the second line -;; : A line of ciphertext (with plaintext below) -;; > A line of plaintext (with ciphertext above) -;; % A comment -;; Each line in the buffer MUST begin with one of these characters (or -;; be left blank). In addition, comments beginning with `%!' are reserved -;; for checkpoints; see decipher-make-checkpoint & decipher-restore-checkpoint -;; for more information. -;; -;; While the cipher message may contain digits or punctuation, Decipher -;; mode will ignore these characters. -;; -;; The buffer is made read-only so it can't be modified by normal -;; Emacs commands. -;; -;; Decipher supports Font Lock mode. To use it, you can also add -;; (add-hook 'decipher-mode-hook 'turn-on-font-lock) -;; See the variable `decipher-font-lock-keywords' if you want to customize -;; the faces used. I'd like to thank Simon Marshall for his help in making -;; Decipher work well with Font Lock. - -;;; Things To Do: -;; -;; Email me if you have any suggestions or would like to help. -;; But be aware that I work on Decipher only sporadically. -;; -;; 1. The consonant-line shortcut -;; 2. More functions for analyzing ciphertext - -;;;=================================================================== -;;; Variables: -;;;=================================================================== - -(eval-when-compile - (require 'cl)) - -(defvar decipher-force-uppercase t - "*Non-nil means to convert ciphertext to uppercase. -Nil means the case of the ciphertext is preserved. -This variable must be set before typing `\\[decipher]'.") - -(defvar decipher-ignore-spaces nil - "*Non-nil means to ignore spaces and punctuation when counting digrams. -You should set this to `nil' if the cipher message is divided into words, -or `t' if it is not. -This variable is buffer-local.") -(make-variable-buffer-local 'decipher-ignore-spaces) - -(defvar decipher-undo-limit 5000 - "The maximum number of entries in the undo list. -When the undo list exceeds this number, 100 entries are deleted from -the tail of the list.") - -;; End of user modifiable variables -;;-------------------------------------------------------------------- - -(defvar decipher-font-lock-keywords - '(("^:.*" . font-lock-keyword-face) - ("^>.*" . font-lock-string-face) - ("^%!.*" . font-lock-reference-face) - ("^%.*" . font-lock-comment-face) - ("\\`(\\([a-z]+\\) +\\([A-Z]+\\)" - (1 font-lock-string-face) - (2 font-lock-keyword-face)) - ("^)\\([A-Z ]+\\)\\([a-z ]+\\)" - (1 font-lock-keyword-face) - (2 font-lock-string-face))) - "Expressions to fontify in Decipher mode. -Ciphertext uses `font-lock-keyword-face', plaintext uses -`font-lock-string-face', comments use `font-lock-comment-face', and -checkpoints use `font-lock-reference-face'. You can customize the -display by changing these variables. For best results, I recommend -that all faces use the same background color. -For example, to display ciphertext in the `bold' face, use - (add-hook 'decipher-mode-hook - (lambda () (set (make-local-variable 'font-lock-keyword-face) - 'bold))) -in your `.emacs' file.") - -(defvar decipher-mode-map nil - "Keymap for Decipher mode.") -(if (not decipher-mode-map) - (progn - (setq decipher-mode-map (make-keymap)) - (suppress-keymap decipher-mode-map) - (define-key decipher-mode-map "A" 'decipher-show-alphabet) - (define-key decipher-mode-map "C" 'decipher-complete-alphabet) - (define-key decipher-mode-map "D" 'decipher-digram-list) - (define-key decipher-mode-map "F" 'decipher-frequency-count) - (define-key decipher-mode-map "M" 'decipher-make-checkpoint) - (define-key decipher-mode-map "N" 'decipher-adjacency-list) - (define-key decipher-mode-map "R" 'decipher-restore-checkpoint) - (define-key decipher-mode-map "U" 'decipher-undo) - (define-key decipher-mode-map " " 'decipher-keypress) - (substitute-key-definition 'undo 'decipher-undo - decipher-mode-map global-map) - (substitute-key-definition 'advertised-undo 'decipher-undo - decipher-mode-map global-map) - (let ((key ?a)) - (while (<= key ?z) - (define-key decipher-mode-map (vector key) 'decipher-keypress) - (incf key))))) - -(defvar decipher-stats-mode-map nil - "Keymap for Decipher-Stats mode.") -(if (not decipher-stats-mode-map) - (progn - (setq decipher-stats-mode-map (make-keymap)) - (suppress-keymap decipher-stats-mode-map) - (define-key decipher-stats-mode-map "D" 'decipher-digram-list) - (define-key decipher-stats-mode-map "F" 'decipher-frequency-count) - (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list) - )) - -(defvar decipher-mode-syntax-table nil - "Decipher mode syntax table") - -(if decipher-mode-syntax-table - () - (let ((table (make-syntax-table)) - (c ?0)) - (while (<= c ?9) - (modify-syntax-entry c "_" table) ;Digits are not part of words - (incf c)) - (setq decipher-mode-syntax-table table))) - -(defvar decipher-alphabet nil) -;; This is an alist containing entries (PLAIN-CHAR . CIPHER-CHAR), -;; where PLAIN-CHAR runs from ?a to ?z and CIPHER-CHAR is an uppercase -;; letter or space (which means no mapping is known for that letter). -;; This *must* contain entries for all lowercase characters. -(make-variable-buffer-local 'decipher-alphabet) - -(defvar decipher-stats-buffer nil - "The buffer which displays statistics for this ciphertext. -Do not access this variable directly, use the function -`decipher-stats-buffer' instead.") -(make-variable-buffer-local 'decipher-stats-buffer) - -(defvar decipher-undo-list-size 0 - "The number of entries in the undo list.") -(make-variable-buffer-local 'decipher-undo-list-size) - -(defvar decipher-undo-list nil - "The undo list for this buffer. -Each element is either a cons cell (PLAIN-CHAR . CIPHER-CHAR) or a -list of such cons cells.") -(make-variable-buffer-local 'decipher-undo-list) - -(defvar decipher-pending-undo-list nil) - -;; The following variables are used by the analysis functions -;; and are defined here to avoid byte-compiler warnings. -;; Don't mess with them unless you know what you're doing. -(defvar decipher-char nil - "See the functions decipher-loop-with-breaks and decipher-loop-no-breaks.") -(defvar decipher--prev-char) -(defvar decipher--digram) -(defvar decipher--digram-list) -(defvar decipher--before) -(defvar decipher--after) -(defvar decipher--freqs) - -;;;=================================================================== -;;; Code: -;;;=================================================================== -;; Main entry points: -;;-------------------------------------------------------------------- - -;;;###autoload -(defun decipher () - "Format a buffer of ciphertext for cryptanalysis and enter Decipher mode." - (interactive) - ;; Make sure the buffer ends in a newline: - (goto-char (point-max)) - (or (bolp) - (insert "\n")) - ;; See if it's already in decipher format: - (goto-char (point-min)) - (if (looking-at "^(abcdefghijklmnopqrstuvwxyz \ -ABCDEFGHIJKLMNOPQRSTUVWXYZ -\\*-decipher-\\*-\n)") - (message "Buffer is already formatted, entering Decipher mode...") - ;; Add the alphabet at the beginning of the file - (insert "(abcdefghijklmnopqrstuvwxyz \ -ABCDEFGHIJKLMNOPQRSTUVWXYZ -*-decipher-*-\n)\n\n") - ;; Add lines for the solution: - (let (begin) - (while (not (eobp)) - (if (looking-at "^%") - (forward-line) ;Leave comments alone - (delete-horizontal-space) - (if (eolp) - (forward-line) ;Just leave blank lines alone - (insert ":") ;Mark ciphertext line - (setq begin (point)) - (forward-line) - (if decipher-force-uppercase - (upcase-region begin (point))) ;Convert ciphertext to uppercase - (insert ">\n"))))) ;Mark plaintext line - (delete-blank-lines) ;Remove any blank lines - (delete-blank-lines)) ; at end of buffer - (goto-line 4) - (decipher-mode)) - -;;;###autoload -(defun decipher-mode () - "Major mode for decrypting monoalphabetic substitution ciphers. -Lower-case letters enter plaintext. -Upper-case letters are commands. - -The buffer is made read-only so that normal Emacs commands cannot -modify it. - -The most useful commands are: -\\<decipher-mode-map> -\\[decipher-digram-list] Display a list of all digrams & their frequency -\\[decipher-frequency-count] Display the frequency of each ciphertext letter -\\[decipher-adjacency-list]\ - Show adjacency list for current letter (lists letters appearing next to it) -\\[decipher-make-checkpoint] Save the current cipher alphabet (checkpoint) -\\[decipher-restore-checkpoint] Restore a saved cipher alphabet (checkpoint)" - (interactive) - (kill-all-local-variables) - (setq buffer-undo-list t ;Disable undo - indent-tabs-mode nil ;Do not use tab characters - major-mode 'decipher-mode - mode-name "Decipher") - (if decipher-force-uppercase - (setq case-fold-search nil)) ;Case is significant when searching - (use-local-map decipher-mode-map) - (set-syntax-table decipher-mode-syntax-table) - (decipher-read-alphabet) - (set (make-local-variable 'font-lock-defaults) - '(decipher-font-lock-keywords t)) - ;; Make the buffer writable when we exit Decipher mode: - (make-local-hook 'change-major-mode-hook) - (add-hook 'change-major-mode-hook - (lambda () (setq buffer-read-only nil - buffer-undo-list nil)) - nil t) - (run-hooks 'decipher-mode-hook) - (setq buffer-read-only t)) -(put 'decipher-mode 'mode-class 'special) - -;;-------------------------------------------------------------------- -;; Normal key handling: -;;-------------------------------------------------------------------- - -(defmacro decipher-last-command-char () - ;; Return the char which ran this command (for compatibility with XEmacs) - (if (fboundp 'event-to-character) - '(event-to-character last-command-event) - 'last-command-event)) - -(defun decipher-keypress () - "Enter a plaintext or ciphertext character." - (interactive) - (let ((decipher-function 'decipher-set-map) - buffer-read-only) ;Make buffer writable - (save-excursion - (or (save-excursion - (beginning-of-line) - (let ((first-char (following-char))) - (cond - ((= ?: first-char) - t) - ((= ?> first-char) - nil) - ((= ?\( first-char) - (setq decipher-function 'decipher-alphabet-keypress) - t) - ((= ?\) first-char) - (setq decipher-function 'decipher-alphabet-keypress) - nil) - (t - (error "Bad location"))))) - (let (goal-column) - (previous-line 1))) - (let ((char-a (following-char)) - (char-b (decipher-last-command-char))) - (or (and (not (= ?w (char-syntax char-a))) - (= char-b ?\ )) ;Spacebar just advances on non-letters - (funcall decipher-function char-a char-b))))) - (forward-char)) - -(defun decipher-alphabet-keypress (a b) - ;; Handle keypresses in the alphabet lines. - ;; A is the character in the alphabet row (which starts with '(') - ;; B is the character pressed - (cond ((and (>= a ?A) (<= a ?Z)) - ;; If A is uppercase, then it is in the ciphertext alphabet: - (decipher-set-map a b)) - ((and (>= a ?a) (<= a ?z)) - ;; If A is lowercase, then it is in the plaintext alphabet: - (if (= b ?\ ) - ;; We are clearing the association (if any): - (if (/= ?\ (setq b (cdr (assoc a decipher-alphabet)))) - (decipher-set-map b ?\ )) - ;; Associate the plaintext char with the char pressed: - (decipher-set-map b a))) - (t - ;; If A is not a letter, that's a problem: - (error "Bad character")))) - -;;-------------------------------------------------------------------- -;; Undo: -;;-------------------------------------------------------------------- - -(defun decipher-undo () - "Undo a change in Decipher mode." - (interactive) - ;; If we don't get all the way thru, make last-command indicate that - ;; for the following command. - (setq this-command t) - (or (eq major-mode 'decipher-mode) - (error "This buffer is not in Decipher mode")) - (or (eq last-command 'decipher-undo) - (setq decipher-pending-undo-list decipher-undo-list)) - (or decipher-pending-undo-list - (error "No further undo information")) - (let ((undo-rec (pop decipher-pending-undo-list)) - buffer-read-only ;Make buffer writable - redo-map redo-rec undo-map) - (or (consp (car undo-rec)) - (setq undo-rec (list undo-rec))) - (while (setq undo-map (pop undo-rec)) - (setq redo-map (decipher-get-undo (cdr undo-map) (car undo-map))) - (if redo-map - (setq redo-rec - (if (consp (car redo-map)) - (append redo-map redo-rec) - (cons redo-map redo-rec)))) - (decipher-set-map (cdr undo-map) (car undo-map) t)) - (decipher-add-undo redo-rec)) - (setq this-command 'decipher-undo) - (message "Undo!")) - -(defun decipher-add-undo (undo-rec) - "Add UNDO-REC to the undo list." - (if undo-rec - (progn - (push undo-rec decipher-undo-list) - (incf decipher-undo-list-size) - (if (> decipher-undo-list-size decipher-undo-limit) - (let ((new-size (- decipher-undo-limit 100))) - ;; Truncate undo list to NEW-SIZE elements: - (setcdr (nthcdr (1- new-size) decipher-undo-list) nil) - (setq decipher-undo-list-size new-size)))))) - -(defun decipher-get-undo (cipher-char plain-char) - ;; Return an undo record that will undo the result of - ;; (decipher-set-map CIPHER-CHAR PLAIN-CHAR) - ;; We must use copy-list because the original cons cells will be - ;; modified using setcdr. - (let ((cipher-map (copy-list (rassoc cipher-char decipher-alphabet))) - (plain-map (copy-list (assoc plain-char decipher-alphabet)))) - (cond ((equal ?\ plain-char) - cipher-map) - ((equal cipher-char (cdr plain-map)) - nil) ;We aren't changing anything - ((equal ?\ (cdr plain-map)) - (or cipher-map (cons ?\ cipher-char))) - (cipher-map - (list plain-map cipher-map)) - (t - plain-map)))) - -;;-------------------------------------------------------------------- -;; Mapping ciphertext and plaintext: -;;-------------------------------------------------------------------- - -(defun decipher-set-map (cipher-char plain-char &optional no-undo) - ;; Associate a ciphertext letter with a plaintext letter - ;; CIPHER-CHAR must be an uppercase or lowercase letter - ;; PLAIN-CHAR must be a lowercase letter (or a space) - ;; NO-UNDO if non-nil means do not record undo information - ;; Any existing associations for CIPHER-CHAR or PLAIN-CHAR will be erased. - (setq cipher-char (upcase cipher-char)) - (or (and (>= cipher-char ?A) (<= cipher-char ?Z)) - (error "Bad character")) ;Cipher char must be uppercase letter - (or no-undo - (decipher-add-undo (decipher-get-undo cipher-char plain-char))) - (let ((cipher-string (char-to-string cipher-char)) - (plain-string (char-to-string plain-char)) - case-fold-search ;Case is significant - mapping bound) - (save-excursion - (goto-char (point-min)) - (if (setq mapping (rassoc cipher-char decipher-alphabet)) - (progn - (setcdr mapping ?\ ) - (search-forward-regexp (concat "^([a-z]*" - (char-to-string (car mapping)))) - (decipher-insert ?\ ) - (beginning-of-line))) - (if (setq mapping (assoc plain-char decipher-alphabet)) - (progn - (if (/= ?\ (cdr mapping)) - (decipher-set-map (cdr mapping) ?\ t)) - (setcdr mapping cipher-char) - (search-forward-regexp (concat "^([a-z]*" plain-string)) - (decipher-insert cipher-char) - (beginning-of-line))) - (search-forward-regexp (concat "^([a-z]+ [A-Z]*" cipher-string)) - (decipher-insert plain-char) - (setq case-fold-search t ;Case is not significant - cipher-string (downcase cipher-string)) - (let ((font-lock-fontify-region-function 'ignore)) - ;; insert-and-inherit will pick the right face automatically - (while (search-forward-regexp "^:" nil t) - (setq bound (save-excursion (end-of-line) (point))) - (while (search-forward cipher-string bound 'end) - (decipher-insert plain-char))))))) - -(defun decipher-insert (char) - ;; Insert CHAR in the row below point. It replaces any existing - ;; character in that position. - (let ((col (1- (current-column)))) - (save-excursion - (forward-line) - (or (= ?\> (following-char)) - (= ?\) (following-char)) - (error "Bad location")) - (move-to-column col t) - (or (eolp) - (delete-char 1)) - (insert-and-inherit char)))) - -;;-------------------------------------------------------------------- -;; Checkpoints: -;;-------------------------------------------------------------------- -;; A checkpoint is a comment of the form: -;; %!ABCDEFGHIJKLMNOPQRSTUVWXYZ! Description -;; Such comments are usually placed at the end of the buffer following -;; this header (which is inserted by decipher-make-checkpoint): -;; %--------------------------- -;; % Checkpoints: -;; % abcdefghijklmnopqrstuvwxyz -;; but this is not required; checkpoints can be placed anywhere. -;; -;; The description is optional; all that is required is the alphabet. - -(defun decipher-make-checkpoint (desc) - "Checkpoint the current cipher alphabet. -This records the current alphabet so you can return to it later. -You may have any number of checkpoints. -Type `\\[decipher-restore-checkpoint]' to restore a checkpoint." - (interactive "sCheckpoint description: ") - (or (stringp desc) - (setq desc "")) - (let (alphabet - buffer-read-only ;Make buffer writable - mapping) - (goto-char (point-min)) - (re-search-forward "^)") - (move-to-column 27 t) - (setq alphabet (buffer-substring-no-properties (- (point) 26) (point))) - (if (re-search-forward "^%![A-Z ]+!" nil 'end) - nil ; Add new checkpoint with others - (if (re-search-backward "^% *Local Variables:" nil t) - ;; Add checkpoints before local variables list: - (progn (forward-line -1) - (or (looking-at "^ *$") - (progn (forward-line) (insert ?\n) (forward-line -1))))) - (insert "\n%" (make-string 69 ?\-) - "\n% Checkpoints:\n% abcdefghijklmnopqrstuvwxyz\n")) - (beginning-of-line) - (insert "%!" alphabet "! " desc ?\n))) - -(defun decipher-restore-checkpoint () - "Restore the cipher alphabet from a checkpoint. -If point is not on a checkpoint line, moves to the first checkpoint line. -If point is on a checkpoint, restores that checkpoint. - -Type `\\[decipher-make-checkpoint]' to make a checkpoint." - (interactive) - (beginning-of-line) - (if (looking-at "%!\\([A-Z ]+\\)!") - ;; Restore this checkpoint: - (let ((alphabet (match-string 1)) - buffer-read-only) ;Make buffer writable - (goto-char (point-min)) - (re-search-forward "^)") - (or (eolp) - (delete-region (point) (progn (end-of-line) (point)))) - (insert alphabet) - (decipher-resync)) - ;; Move to the first checkpoint: - (goto-char (point-min)) - (if (re-search-forward "^%![A-Z ]+!" nil t) - (message "Select the checkpoint to restore and type `%s'" - (substitute-command-keys "\\[decipher-restore-checkpoint]")) - (error "No checkpoints in this buffer")))) - -;;-------------------------------------------------------------------- -;; Miscellaneous commands: -;;-------------------------------------------------------------------- - -(defun decipher-complete-alphabet () - "Complete the cipher alphabet. -This fills any blanks in the cipher alphabet with the unused letters -in alphabetical order. Use this when you have a keyword cipher and -you have determined the keyword." - (interactive) - (let ((cipher-char ?A) - (ptr decipher-alphabet) - buffer-read-only ;Make buffer writable - plain-map undo-rec) - (while (setq plain-map (pop ptr)) - (if (equal ?\ (cdr plain-map)) - (progn - (while (rassoc cipher-char decipher-alphabet) - ;; Find the next unused letter - (incf cipher-char)) - (push (cons ?\ cipher-char) undo-rec) - (decipher-set-map cipher-char (car plain-map) t)))) - (decipher-add-undo undo-rec))) - -(defun decipher-show-alphabet () - "Display the current cipher alphabet in the message line." - (interactive) - (message - (mapconcat (lambda (a) - (concat - (char-to-string (car a)) - (char-to-string (cdr a)))) - decipher-alphabet - ""))) - -(defun decipher-resync () - "Reprocess the buffer using the alphabet from the top. -This regenerates all deciphered plaintext and clears the undo list. -You should use this if you edit the ciphertext." - (interactive) - (message "Reprocessing buffer...") - (let (alphabet - buffer-read-only ;Make buffer writable - mapping) - (save-excursion - (decipher-read-alphabet) - (setq alphabet decipher-alphabet) - (goto-char (point-min)) - (and (re-search-forward "^).+" nil t) - (replace-match ")" nil nil)) - (while (re-search-forward "^>.+" nil t) - (replace-match ">" nil nil)) - (decipher-read-alphabet) - (while (setq mapping (pop alphabet)) - (or (equal ?\ (cdr mapping)) - (decipher-set-map (cdr mapping) (car mapping)))))) - (setq decipher-undo-list nil - decipher-undo-list-size 0) - (message "Reprocessing buffer...done")) - -;;-------------------------------------------------------------------- -;; Miscellaneous functions: -;;-------------------------------------------------------------------- - -(defun decipher-read-alphabet () - "Build the decipher-alphabet from the alphabet line in the buffer." - (save-excursion - (goto-char (point-min)) - (search-forward-regexp "^)") - (move-to-column 27 t) - (setq decipher-alphabet nil) - (let ((plain-char ?z)) - (while (>= plain-char ?a) - (backward-char) - (push (cons plain-char (following-char)) decipher-alphabet) - (decf plain-char))))) - -;;;=================================================================== -;;; Analyzing ciphertext: -;;;=================================================================== - -(defun decipher-frequency-count () - "Display the frequency count in the statistics buffer." - (interactive) - (decipher-analyze) - (decipher-display-regexp "^A" "^[A-Z][A-Z]")) - -(defun decipher-digram-list () - "Display the list of digrams in the statistics buffer." - (interactive) - (decipher-analyze) - (decipher-display-regexp "[A-Z][A-Z] +[0-9]" "^$")) - -(defun decipher-adjacency-list (cipher-char) - "Display the adjacency list for the letter at point. -The adjacency list shows all letters which come next to CIPHER-CHAR. - -An adjacency list (for the letter X) looks like this: - 1 1 1 1 1 3 2 1 3 8 -X: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z * 11 14 9% - 1 1 1 2 1 1 2 5 7 -This says that X comes before D once, and after B once. X begins 5 -words, and ends 3 words (`*' represents a space). X comes before 8 -different letters, after 7 differerent letters, and is next to a total -of 11 different letters. It occurs 14 times, making up 9% of the -ciphertext." - (interactive (list (upcase (following-char)))) - (decipher-analyze) - (let (start end) - (save-excursion - (set-buffer (decipher-stats-buffer)) - (goto-char (point-min)) - (or (re-search-forward (format "^%c: " cipher-char) nil t) - (error "Character `%c' is not used in ciphertext." cipher-char)) - (forward-line -1) - (setq start (point)) - (forward-line 3) - (setq end (point))) - (decipher-display-range start end))) - -;;-------------------------------------------------------------------- -(defun decipher-analyze () - "Perform frequency analysis on the current buffer if necessary." - (cond - ;; If this is the statistics buffer, do nothing: - ((eq major-mode 'decipher-stats-mode)) - ;; If this is the Decipher buffer, see if the stats buffer exists: - ((eq major-mode 'decipher-mode) - (or (and (bufferp decipher-stats-buffer) - (buffer-name decipher-stats-buffer)) - (decipher-analyze-buffer))) - ;; Otherwise: - (t (error "This buffer is not in Decipher mode")))) - -;;-------------------------------------------------------------------- -(defun decipher-display-range (start end) - "Display text between START and END in the statistics buffer. -START and END are positions in the statistics buffer. Makes the -statistics buffer visible and sizes the window to just fit the -displayed text, but leaves the current window selected." - (let ((stats-buffer (decipher-stats-buffer)) - (current-window (selected-window)) - (pop-up-windows t)) - (or (eq (current-buffer) stats-buffer) - (pop-to-buffer stats-buffer)) - (goto-char start) - (or (one-window-p t) - (enlarge-window (- (1+ (count-lines start end)) (window-height)))) - (recenter 0) - (select-window current-window))) - -(defun decipher-display-regexp (start-regexp end-regexp) - "Display text between two regexps in the statistics buffer. - -START-REGEXP matches the first line to display. -END-REGEXP matches the line after that which ends the display. -The ending line is included in the display unless it is blank." - (let (start end) - (save-excursion - (set-buffer (decipher-stats-buffer)) - (goto-char (point-min)) - (re-search-forward start-regexp) - (beginning-of-line) - (setq start (point)) - (re-search-forward end-regexp) - (beginning-of-line) - (or (looking-at "^ *$") - (forward-line 1)) - (setq end (point))) - (decipher-display-range start end))) - -;;-------------------------------------------------------------------- -(defun decipher-loop-with-breaks (func) - "Loop through ciphertext, calling FUNC once for each letter & word division. - -FUNC is called with no arguments, and its return value is unimportant. -It may examine `decipher-char' to see the current ciphertext -character. `decipher-char' contains either an uppercase letter or a space. - -FUNC is called exactly once between words, with `decipher-char' set to -a space. - -See `decipher-loop-no-breaks' if you do not care about word divisions." - (let ((decipher-char ?\ ) - (decipher--loop-prev-char ?\ )) - (save-excursion - (goto-char (point-min)) - (funcall func) ;Space marks beginning of first word - (while (search-forward-regexp "^:" nil t) - (while (not (eolp)) - (setq decipher-char (upcase (following-char))) - (or (and (>= decipher-char ?A) (<= decipher-char ?Z)) - (setq decipher-char ?\ )) - (or (and (equal decipher-char ?\ ) - (equal decipher--loop-prev-char ?\ )) - (funcall func)) - (setq decipher--loop-prev-char decipher-char) - (forward-char)) - (or (equal decipher-char ?\ ) - (progn - (setq decipher-char ?\ ; - decipher--loop-prev-char ?\ ) - (funcall func))))))) - -(defun decipher-loop-no-breaks (func) - "Loop through ciphertext, calling FUNC once for each letter. - -FUNC is called with no arguments, and its return value is unimportant. -It may examine `decipher-char' to see the current ciphertext letter. -`decipher-char' contains an uppercase letter. - -Punctuation and spacing in the ciphertext are ignored. -See `decipher-loop-with-breaks' if you care about word divisions." - (let (decipher-char) - (save-excursion - (goto-char (point-min)) - (while (search-forward-regexp "^:" nil t) - (while (not (eolp)) - (setq decipher-char (upcase (following-char))) - (and (>= decipher-char ?A) - (<= decipher-char ?Z) - (funcall func)) - (forward-char)))))) - -;;-------------------------------------------------------------------- -;; Perform the analysis: -;;-------------------------------------------------------------------- - -(defun decipher-insert-frequency-counts (freq-list total) - "Insert frequency counts in current buffer. -Each element of FREQ-LIST is a list (LETTER FREQ ...). -TOTAL is the total number of letters in the ciphertext." - (let ((i 4) temp-list) - (while (> i 0) - (setq temp-list freq-list) - (while temp-list - (insert (caar temp-list) - (format "%4d%3d%% " - (cadar temp-list) - (/ (* 100 (cadar temp-list)) total))) - (setq temp-list (nthcdr 4 temp-list))) - (insert ?\n) - (setq freq-list (cdr freq-list) - i (1- i))))) - -(defun decipher--analyze () - ;; Perform frequency analysis on ciphertext. - ;; - ;; This function is called repeatedly with decipher-char set to each - ;; character of ciphertext. It uses decipher--prev-char to remember - ;; the previous ciphertext character. - ;; - ;; It builds several data structures, which must be initialized - ;; before the first call to decipher--analyze. The arrays are - ;; indexed with A = 0, B = 1, ..., Z = 25, SPC = 26 (if used). - ;; decipher--after: (initialize to zeros) - ;; A vector of 26 vectors of 27 integers. The first vector - ;; represents the number of times A follows each character, the - ;; second vector represents B, and so on. - ;; decipher--before: (initialize to zeros) - ;; The same as decipher--after, but representing the number of - ;; times the character precedes each other character. - ;; decipher--digram-list: (initialize to nil) - ;; An alist with an entry for each digram (2-character sequence) - ;; encountered. Each element is a cons cell (DIGRAM . FREQ), - ;; where DIGRAM is a 2 character string and FREQ is the number - ;; of times it occurs. - ;; decipher--freqs: (initialize to zeros) - ;; A vector of 26 integers, counting the number of occurrences - ;; of the corresponding characters. - (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char)) - (incf (cdr (or (assoc decipher--digram decipher--digram-list) - (car (push (cons decipher--digram 0) - decipher--digram-list))))) - (and (>= decipher--prev-char ?A) - (incf (aref (aref decipher--before (- decipher--prev-char ?A)) - (if (equal decipher-char ?\ ) - 26 - (- decipher-char ?A))))) - (and (>= decipher-char ?A) - (incf (aref decipher--freqs (- decipher-char ?A))) - (incf (aref (aref decipher--after (- decipher-char ?A)) - (if (equal decipher--prev-char ?\ ) - 26 - (- decipher--prev-char ?A))))) - (setq decipher--prev-char decipher-char)) - -(defun decipher--digram-counts (counts) - "Generate the counts for an adjacency list." - (let ((total 0)) - (concat - (mapconcat (lambda (x) - (cond ((> x 99) (incf total) "XX") - ((> x 0) (incf total) (format "%2d" x)) - (t " "))) - counts - "") - (format "%4d" (if (> (aref counts 26) 0) - (1- total) ;Don't count space - total))))) - -(defun decipher--digram-total (before-count after-count) - "Count the number of different letters a letter appears next to." - ;; We do not include spaces (word divisions) in this count. - (let ((total 0) - (i 26)) - (while (>= (decf i) 0) - (if (or (> (aref before-count i) 0) - (> (aref after-count i) 0)) - (incf total))) - total)) - -(defun decipher-analyze-buffer () - "Perform frequency analysis and store results in statistics buffer. -Creates the statistics buffer if it doesn't exist." - (let ((decipher--prev-char (if decipher-ignore-spaces ?\ ?\*)) - (decipher--before (make-vector 26 nil)) - (decipher--after (make-vector 26 nil)) - (decipher--freqs (make-vector 26 0)) - (total-chars 0) - decipher--digram decipher--digram-list freq-list) - (message "Scanning buffer...") - (let ((i 26)) - (while (>= (decf i) 0) - (aset decipher--before i (make-vector 27 0)) - (aset decipher--after i (make-vector 27 0)))) - (if decipher-ignore-spaces - (progn - (decipher-loop-no-breaks 'decipher--analyze) - ;; The first character of ciphertext was marked as following a space: - (let ((i 26)) - (while (>= (decf i) 0) - (aset (aref decipher--after i) 26 0)))) - (decipher-loop-with-breaks 'decipher--analyze)) - (message "Processing results...") - (setcdr (last decipher--digram-list 2) nil) ;Delete the phony "* " digram - ;; Sort the digram list by frequency and alphabetical order: - (setq decipher--digram-list (sort (sort decipher--digram-list - (lambda (a b) (string< (car a) (car b)))) - (lambda (a b) (> (cdr a) (cdr b))))) - ;; Generate the frequency list: - ;; Each element is a list of 3 elements (LETTER FREQ DIFFERENT), - ;; where LETTER is the ciphertext character, FREQ is the number - ;; of times it occurs, and DIFFERENT is the number of different - ;; letters it appears next to. - (let ((i 26)) - (while (>= (decf i) 0) - (setq freq-list - (cons (list (+ i ?A) - (aref decipher--freqs i) - (decipher--digram-total (aref decipher--before i) - (aref decipher--after i))) - freq-list) - total-chars (+ total-chars (aref decipher--freqs i))))) - (save-excursion - ;; Switch to statistics buffer, creating it if necessary: - (set-buffer (decipher-stats-buffer t)) - ;; This can't happen, but it never hurts to double-check: - (or (eq major-mode 'decipher-stats-mode) - (error "Buffer %s is not in Decipher-Stats mode" (buffer-name))) - (setq buffer-read-only nil) - (erase-buffer) - ;; Display frequency counts for letters A-Z: - (decipher-insert-frequency-counts freq-list total-chars) - (insert ?\n) - ;; Display frequency counts for letters in order of frequency: - (setq freq-list (sort freq-list - (lambda (a b) (> (second a) (second b))))) - (decipher-insert-frequency-counts freq-list total-chars) - ;; Display letters in order of frequency: - (insert ?\n (mapconcat (lambda (a) (char-to-string (car a))) - freq-list nil) - "\n\n") - ;; Display list of digrams in order of frequency: - (let* ((rows (floor (+ (length decipher--digram-list) 9) 10)) - (i rows) - temp-list) - (while (> i 0) - (setq temp-list decipher--digram-list) - (while temp-list - (insert (caar temp-list) - (format "%3d " - (cdar temp-list))) - (setq temp-list (nthcdr rows temp-list))) - (delete-horizontal-space) - (insert ?\n) - (setq decipher--digram-list (cdr decipher--digram-list) - i (1- i)))) - ;; Display adjacency list for each letter, sorted in descending - ;; order of the number of adjacent letters: - (setq freq-list (sort freq-list - (lambda (a b) (> (third a) (third b))))) - (let ((temp-list freq-list) - entry i) - (while (setq entry (pop temp-list)) - (if (equal 0 (second entry)) - nil ;This letter was not used - (setq i (- (car entry) ?A)) - (insert ?\n " " - (decipher--digram-counts (aref decipher--before i)) ?\n - (car entry) - ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *" - (format "%4d %4d %3d%%\n " - (third entry) (second entry) - (/ (* 100 (second entry)) total-chars)) - (decipher--digram-counts (aref decipher--after i)) ?\n)))) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - )) - (message nil)) - -;;==================================================================== -;; Statistics Buffer: -;;==================================================================== - -(defun decipher-stats-mode () - "Major mode for displaying ciphertext statistics." - (interactive) - (kill-all-local-variables) - (setq buffer-read-only t - buffer-undo-list t ;Disable undo - case-fold-search nil ;Case is significant when searching - indent-tabs-mode nil ;Do not use tab characters - major-mode 'decipher-stats-mode - mode-name "Decipher-Stats") - (use-local-map decipher-stats-mode-map) - (run-hooks 'decipher-stats-mode-hook)) -(put 'decipher-stats-mode 'mode-class 'special) - -;;-------------------------------------------------------------------- - -(defun decipher-display-stats-buffer () - "Make the statistics buffer visible, but do not select it." - (let ((stats-buffer (decipher-stats-buffer)) - (current-window (selected-window))) - (or (eq (current-buffer) stats-buffer) - (progn - (pop-to-buffer stats-buffer) - (select-window current-window))))) - -(defun decipher-stats-buffer (&optional create) - "Return the buffer used for decipher statistics. -If CREATE is non-nil, create the buffer if it doesn't exist. -This is guaranteed to return a buffer in Decipher-Stats mode; -if it can't, it signals an error." - (cond - ;; We may already be in the statistics buffer: - ((eq major-mode 'decipher-stats-mode) - (current-buffer)) - ;; See if decipher-stats-buffer exists: - ((and (bufferp decipher-stats-buffer) - (buffer-name decipher-stats-buffer)) - (or (save-excursion - (set-buffer decipher-stats-buffer) - (eq major-mode 'decipher-stats-mode)) - (error "Buffer %s is not in Decipher-Stats mode" - (buffer-name decipher-stats-buffer))) - decipher-stats-buffer) - ;; Create a new buffer if requested: - (create - (let ((stats-name (concat "*" (buffer-name) "*"))) - (setq decipher-stats-buffer - (if (eq 'decipher-stats-mode - (cdr-safe (assoc 'major-mode - (buffer-local-variables - (get-buffer stats-name))))) - ;; We just lost track of the statistics buffer: - (get-buffer stats-name) - (generate-new-buffer stats-name)))) - (save-excursion - (set-buffer decipher-stats-buffer) - (decipher-stats-mode)) - decipher-stats-buffer) - ;; Give up: - (t (error "No statistics buffer")))) - -;;==================================================================== - -(provide 'decipher) - -;;;(defun decipher-show-undo-list () -;;; "Display the undo list (for debugging purposes)." -;;; (interactive) -;;; (with-output-to-temp-buffer "*Decipher Undo*" -;;; (let ((undo-list decipher-undo-list) -;;; undo-rec undo-map) -;;; (save-excursion -;;; (set-buffer "*Decipher Undo*") -;;; (while (setq undo-rec (pop undo-list)) -;;; (or (consp (car undo-rec)) -;;; (setq undo-rec (list undo-rec))) -;;; (insert ?\() -;;; (while (setq undo-map (pop undo-rec)) -;;; (insert (cdr undo-map) (car undo-map) ?\ )) -;;; (delete-backward-char 1) -;;; (insert ")\n")))))) - -;;; decipher.el ends here
--- a/lisp/games/dissociate.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -;;; dissociate.el --- scramble text amusingly for Emacs. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; The single entry point, `dissociated-press', applies a travesty -;; generator to the current buffer. The results can be quite amusing. - -;;; Code: - -;;;###autoload -(defun dissociated-press (&optional arg) - "Dissociate the text of the current buffer. -Output goes in buffer named *Dissociation*, -which is redisplayed each time text is added to it. -Every so often the user must say whether to continue. -If ARG is positive, require ARG chars of continuity. -If ARG is negative, require -ARG words of continuity. -Default is 2." - (interactive "P") - (setq arg (if arg (prefix-numeric-value arg) 2)) - (let* ((inbuf (current-buffer)) - (outbuf (get-buffer-create "*Dissociation*")) - (move-function (if (> arg 0) 'forward-char 'forward-word)) - (move-amount (if (> arg 0) arg (- arg))) - (search-function (if (> arg 0) 'search-forward 'word-search-forward)) - (last-query-point 0)) - (if (= (point-max) (point-min)) - (error "The buffer contains no text to start from")) - (switch-to-buffer outbuf) - (erase-buffer) - (while - (save-excursion - (goto-char last-query-point) - (vertical-motion (- (window-height) 4)) - (or (= (point) (point-max)) - (and (progn (goto-char (point-max)) - (y-or-n-p "Continue dissociation? ")) - (progn - (message "") - (recenter 1) - (setq last-query-point (point-max)) - t)))) - (let (start end) - (save-excursion - (set-buffer inbuf) - (setq start (point)) - (if (eq move-function 'forward-char) - (progn - (setq end (+ start (+ move-amount (random 16)))) - (if (> end (point-max)) - (setq end (+ 1 move-amount (random 16)))) - (goto-char end)) - (funcall move-function - (+ move-amount (random 16)))) - (setq end (point))) - (let ((opoint (point))) - (insert-buffer-substring inbuf start end) - (save-excursion - (goto-char opoint) - (end-of-line) - (and (> (current-column) fill-column) - (do-auto-fill))))) - (save-excursion - (set-buffer inbuf) - (if (eobp) - (goto-char (point-min)) - (let ((overlap - (buffer-substring (prog1 (point) - (funcall move-function - (- move-amount))) - (point)))) - (goto-char (1+ (random (1- (point-max))))) - (or (funcall search-function overlap nil t) - (let ((opoint (point))) - (goto-char 1) - (funcall search-function overlap opoint t)))))) - (sit-for 0)))) - -;;; dissociate.el ends here
--- a/lisp/games/doctor.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1641 +0,0 @@ -;;; doctor.el --- psychological help for frustrated users. -;;; (uncensored version--see below) - -;; Copyright (C) 1985, 1987, 1994, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; The single entry point `doctor', simulates a Rogerian analyst using -;; phrase-production techniques similar to the classic ELIZA demonstration -;; of pseudo-AI. - -;; Original Censorship message: -;; This file has been censored by the Communications Decency Act. -;; Some of its features were removed. The law was promoted as a ban -;; on pornography, but it bans far more than that. The doctor program -;; did not contain pornography, but part of it was prohibited -;; nonetheless. - -;; For information on US government censorship of the Internet, and -;; what you can do to bring back freedom of the press, see the web -;; site http://www.vtw.org/ - -;;; Code: - -(defun doctor-cadr (x) (car (cdr x))) -(defun doctor-caddr (x) (car (cdr (cdr x)))) -(defun doctor-cddr (x) (cdr (cdr x))) - -(defun // (x) x) - -(defmacro $ (what) - "quoted arg form of doctor-$" - (list 'doctor-$ (list 'quote what))) - -(defun doctor-$ (what) - "Return the car of a list, rotating the list each time" - (let* ((vv (symbol-value what)) - (first (car vv)) - (ww (append (cdr vv) (list first)))) - (set what ww) - first)) - -(defvar doctor-mode-map nil) -(if doctor-mode-map - nil - (setq doctor-mode-map (make-sparse-keymap)) - (define-key doctor-mode-map "\n" 'doctor-read-print) - (define-key doctor-mode-map "\r" 'doctor-ret-or-read)) - -(defun doctor-mode () - "Major mode for running the Doctor (Eliza) program. -Like Text mode with Auto Fill mode -except that RET when point is after a newline, or LFD at any time, -reads the sentence before point, and prints the Doctor's answer." - (interactive) - (text-mode) - (make-doctor-variables) - (use-local-map doctor-mode-map) - (setq major-mode 'doctor-mode) - (setq mode-name "Doctor") - (turn-on-auto-fill) - (doctor-type '(i am the psychotherapist \. - ($ please) ($ describe) your ($ problems) \. - each time you are finished talking, type \R\E\T twice \.)) - (insert "\n")) - -(defun make-doctor-variables () - (make-local-variable 'monosyllables) - (setq monosyllables - " - Your attitude at the end of the session was wholly unacceptable. - Please try to come back next time with a willingness to speak more - freely. If you continue to refuse to talk openly, there is little - I can do to help! -") - (make-local-variable 'typos) - (setq typos - (mapcar (function (lambda (x) - (put (car x) 'doctor-correction (doctor-cadr x)) - (put (doctor-cadr x) 'doctor-expansion (doctor-caddr x)) - (car x))) - '((theyll they\'ll (they will)) - (theyre they\'re (they are)) - (hes he\'s (he is)) - (he7s he\'s (he is)) - (im i\'m (you are)) - (i7m i\'m (you are)) - (isa is\ a (is a)) - (thier their (their)) - (dont don\'t (do not)) - (don7t don\'t (do not)) - (you7re you\'re (i am)) - (you7ve you\'ve (i have)) - (you7ll you\'ll (i will))))) - (make-local-variable 'found) - (setq found nil) - (make-local-variable 'owner) - (setq owner nil) - (make-local-variable 'history) - (setq history nil) - (make-local-variable '*debug*) - (setq *debug* nil) - (make-local-variable 'inter) - (setq inter - '((well\,) - (hmmm \.\.\.\ so\,) - (so) - (\.\.\.and) - (then))) - (make-local-variable 'continue) - (setq continue - '((continue) - (proceed) - (go on) - (keep going) )) - (make-local-variable 'relation) - (setq relation - '((your relationship with) - (something you remember about) - (your feelings toward) - (some experiences you have had with) - (how you feel about))) - (make-local-variable 'fears) - (setq fears '( (($ whysay) you are ($ afraidof) (// feared) \?) - (you seem terrified by (// feared) \.) - (when did you first feel ($ afraidof) (// feared) \?) )) - (make-local-variable 'sure) - (setq sure '((sure)(positive)(certain)(absolutely sure))) - (make-local-variable 'afraidof) - (setq afraidof '( (afraid of) (frightened by) (scared of) )) - (make-local-variable 'areyou) - (setq areyou '( (are you)(have you been)(have you been) )) - (make-local-variable 'isrelated) - (setq isrelated '( (has something to do with)(is related to) - (could be the reason for) (is caused by)(is because of))) - (make-local-variable 'arerelated) - (setq arerelated '((have something to do with)(are related to) - (could have caused)(could be the reason for) (are caused by) - (are because of))) - (make-local-variable 'moods) - (setq moods '( (($ areyou)(// found) often \?) - (what causes you to be (// found) \?) - (($ whysay) you are (// found) \?) )) - (make-local-variable 'maybe) - (setq maybe - '((maybe) - (perhaps) - (possibly))) - (make-local-variable 'whatwhen) - (setq whatwhen - '((what happened when) - (what would happen if))) - (make-local-variable 'hello) - (setq hello - '((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.))) - (make-local-variable 'drnk) - (setq drnk - '((do you drink a lot of (// found) \?) - (do you get drunk often \?) - (($ describe) your drinking habits \.) )) - (make-local-variable 'drugs) - (setq drugs '( (do you use (// found) often \?)(($ areyou) - addicted to (// found) \?)(do you realize that drugs can - be very harmful \?)(($ maybe) you should try to quit using (// found) - \.))) - (make-local-variable 'whywant) - (setq whywant '( (($ whysay) (// subj) might ($ want) (// obj) \?) - (how does it feel to want \?) - (why should (// subj) get (// obj) \?) - (when did (// subj) first ($ want) (// obj) \?) - (($ areyou) obsessed with (// obj) \?) - (why should i give (// obj) to (// subj) \?) - (have you ever gotten (// obj) \?) )) - (make-local-variable 'canyou) - (setq canyou '((of course i can \.) - (why should i \?) - (what makes you think i would even want to \?) - (i am the doctor\, i can do anything i damn please \.) - (not really\, it\'s not up to me \.) - (depends\, how important is it \?) - (i could\, but i don\'t think it would be a wise thing to do \.) - (can you \?) - (maybe i can\, maybe i can\'t \.\.\.) - (i don\'t think i should do that \.))) - (make-local-variable 'want) - (setq want '( (want) (desire) (wish) (want) (hope) )) - (make-local-variable 'shortlst) - (setq shortlst - '((can you elaborate on that \?) - (($ please) continue \.) - (go on\, don\'t be afraid \.) - (i need a little more detail please \.) - (you\'re being a bit brief\, ($ please) go into detail \.) - (can you be more explicit \?) - (and \?) - (($ please) go into more detail \?) - (you aren\'t being very talkative today\!) - (is that all there is to it \?) - (why must you respond so briefly \?))) - - (make-local-variable 'famlst) - (setq famlst - '((tell me ($ something) about (// owner) family \.) - (you seem to dwell on (// owner) family \.) - (($ areyou) hung up on (// owner) family \?))) - (make-local-variable 'huhlst) - (setq huhlst - '((($ whysay)(// sent) \?) - (is it because of ($ things) that you say (// sent) \?) )) - (make-local-variable 'longhuhlst) - (setq longhuhlst - '((($ whysay) that \?) - (i don\'t understand \.) - (($ thlst)) - (($ areyou) ($ afraidof) that \?))) - (make-local-variable 'feelings-about) - (setq feelings-about - '((feelings about) - (apprehensions toward) - (thoughts on) - (emotions toward))) - (make-local-variable 'random-adjective) - (setq random-adjective - '((vivid) - (emotionally stimulating) - (exciting) - (boring) - (interesting) - (recent) - (random) ;How can we omit this? - (unusual) - (shocking) - (embarrassing))) - (make-local-variable 'whysay) - (setq whysay - '((why do you say) - (what makes you believe) - (are you sure that) - (do you really think) - (what makes you think) )) - (make-local-variable 'isee) - (setq isee - '((i see \.\.\.) - (yes\,) - (i understand \.) - (oh \.) )) - (make-local-variable 'please) - (setq please - '((please\,) - (i would appreciate it if you would) - (perhaps you could) - (please\,) - (would you please) - (why don\'t you) - (could you))) - (make-local-variable 'bye) - (setq bye - '((my secretary will send you a bill \.) - (bye bye \.) - (see ya \.) - (ok\, talk to you some other time \.) - (talk to you later \.) - (ok\, have fun \.) - (ciao \.))) - (make-local-variable 'something) - (setq something - '((something) - (more) - (how you feel))) - (make-local-variable 'things) - (setq things - '(;(your interests in computers) ;; let's make this less computer oriented - ;(the machines you use) - (your plans) - ;(your use of computers) - (your life) - ;(other machines you use) - (the people you hang around with) - ;(computers you like) - (problems at school) - (any hobbies you have) - ;(other computers you use) - (your sex life) - (hangups you have) - (your inhibitions) - (some problems in your childhood) - ;(knowledge of computers) - (some problems at home))) - (make-local-variable 'describe) - (setq describe - '((describe) - (tell me about) - (talk about) - (discuss) - (tell me more about) - (elaborate on))) - (make-local-variable 'ibelieve) - (setq ibelieve - '((i believe) (i think) (i have a feeling) (it seems to me that) - (it looks like))) - (make-local-variable 'problems) - (setq problems '( (problems) - (inhibitions) - (hangups) - (difficulties) - (anxieties) - (frustrations) )) - (make-local-variable 'bother) - (setq bother - '((does it bother you that) - (are you annoyed that) - (did you ever regret) - (are you sorry) - (are you satisfied with the fact that))) - (make-local-variable 'machlst) - (setq machlst - '((you have your mind on (// found) \, it seems \.) - (you think too much about (// found) \.) - (you should try taking your mind off of (// found)\.) - (are you a computer hacker \?))) - (make-local-variable 'qlist) - (setq qlist - '((what do you think \?) - (i\'ll ask the questions\, if you don\'t mind!) - (i could ask the same thing myself \.) - (($ please) allow me to do the questioning \.) - (i have asked myself that question many times \.) - (($ please) try to answer that question yourself \.))) - (make-local-variable 'elist) - (setq elist - '((($ please) try to calm yourself \.) - (you seem very excited \. relax \. ($ please) ($ describe) ($ things) - \.) - (you\'re being very emotional \. calm down \.))) - (make-local-variable 'foullst) - (setq foullst - '((($ please) watch your tongue!) - (($ please) avoid such unwholesome thoughts \.) - (($ please) get your mind out of the gutter \.) - (such lewdness is not appreciated \.))) - (make-local-variable 'deathlst) - (setq deathlst - '((this is not a healthy way of thinking \.) - (($ bother) you\, too\, may die someday \?) - (i am worried by your obsession with this topic!) - (did you watch a lot of crime and violence on television as a child \?)) - ) - (make-local-variable 'sexlst) - (setq sexlst - '((($ areyou) ($ afraidof) sex \?) - (($ describe)($ something) about your sexual history \.) - (($ please)($ describe) your sex life \.\.\.) - (($ describe) your ($ feelings-about) your sexual partner \.) - (($ describe) your most ($ random-adjective) sexual experience \.) - (($ areyou) satisfied with (// lover) \.\.\. \?))) - (make-local-variable 'neglst) - (setq neglst - '((why not \?) - (($ bother) i ask that \?) - (why not \?) - (why not \?) - (how come \?) - (($ bother) i ask that \?))) - (make-local-variable 'beclst) - (setq beclst '( - (is it because (// sent) that you came to me \?) - (($ bother)(// sent) \?) - (when did you first know that (// sent) \?) - (is the fact that (// sent) the real reason \?) - (does the fact that (// sent) explain anything else \?) - (($ areyou)($ sure)(// sent) \? ) )) - (make-local-variable 'shortbeclst) - (setq shortbeclst '( - (($ bother) i ask you that \?) - (that\'s not much of an answer!) - (($ inter) why won\'t you talk about it \?) - (speak up!) - (($ areyou) ($ afraidof) talking about it \?) - (don\'t be ($ afraidof) elaborating \.) - (($ please) go into more detail \.))) - (make-local-variable 'thlst) - (setq thlst '( - (($ maybe)($ things)($ arerelated) this \.) - (is it because of ($ things) that you are going through all this \?) - (how do you reconcile ($ things) \? ) - (($ maybe) this ($ isrelated)($ things) \?) )) - (make-local-variable 'remlst) - (setq remlst '( (earlier you said ($ history) \?) - (you mentioned that ($ history) \?) - (($ whysay)($ history) \? ) )) - (make-local-variable 'toklst) - (setq toklst - '((is this how you relax \?) - (how long have you been smoking grass \?) - (($ areyou) ($ afraidof) of being drawn to using harder stuff \?))) - (make-local-variable 'states) - (setq states - '((do you get (// found) often \?) - (do you enjoy being (// found) \?) - (what makes you (// found) \?) - (how often ($ areyou)(// found) \?) - (when were you last (// found) \?))) - (make-local-variable 'replist) - (setq replist - '((i . (you)) - (my . (your)) - (me . (you)) - (you . (me)) - (your . (my)) - (mine . (yours)) - (yours . (mine)) - (our . (your)) - (ours . (yours)) - (we . (you)) - (dunno . (do not know)) -;; (yes . ()) - (no\, . ()) - (yes\, . ()) - (ya . (i)) - (aint . (am not)) - (wanna . (want to)) - (gimme . (give me)) - (gotta . (have to)) - (gonna . (going to)) - (never . (not ever)) - (doesn\'t . (does not)) - (don\'t . (do not)) - (aren\'t . (are not)) - (isn\'t . (is not)) - (won\'t . (will not)) - (can\'t . (cannot)) - (haven\'t . (have not)) - (i\'m . (you are)) - (ourselves . (yourselves)) - (myself . (yourself)) - (yourself . (myself)) - (you\'re . (i am)) - (you\'ve . (i have)) - (i\'ve . (you have)) - (i\'ll . (you will)) - (you\'ll . (i shall)) - (i\'d . (you would)) - (you\'d . (i would)) - (here . (there)) - (please . ()) - (eh\, . ()) - (eh . ()) - (oh\, . ()) - (oh . ()) - (shouldn\'t . (should not)) - (wouldn\'t . (would not)) - (won\'t . (will not)) - (hasn\'t . (has not)))) - (make-local-variable 'stallmanlst) - (setq stallmanlst '( - (($ describe) your ($ feelings-about) him \.) - (($ areyou) a friend of Stallman \?) - (($ bother) Stallman is ($ random-adjective) \?) - (($ ibelieve) you are ($ afraidof) him \.))) - (make-local-variable 'schoollst) - (setq schoollst '( - (($ describe) your (// found) \.) - (($ bother) your grades could ($ improve) \?) - (($ areyou) ($ afraidof) (// found) \?) - (($ maybe) this ($ isrelated) to your attitude \.) - (($ areyou) absent often \?) - (($ maybe) you should study ($ something) \.))) - (make-local-variable 'improve) - (setq improve '((improve) (be better) (be improved) (be higher))) - (make-local-variable 'elizalst) - (setq elizalst '( - (($ areyou) ($ sure) \?) - (($ ibelieve) you have ($ problems) with (// found) \.) - (($ whysay) (// sent) \?))) - (make-local-variable 'sportslst) - (setq sportslst '( - (tell me ($ something) about (// found) \.) - (($ describe) ($ relation) (// found) \.) - (do you find (// found) ($ random-adjective) \?))) - (make-local-variable 'mathlst) - (setq mathlst '( - (($ describe) ($ something) about math \.) - (($ maybe) your ($ problems) ($ arerelated) (// found) \.) - (i do\'nt know much (// found) \, but ($ continue) - anyway \.))) - (make-local-variable 'zippylst) - (setq zippylst '( - (($ areyou) Zippy \?) - (($ ibelieve) you have some serious ($ problems) \.) - (($ bother) you are a pinhead \?))) - (make-local-variable 'chatlst) - (setq chatlst '( - (($ maybe) we could chat \.) - (($ please) ($ describe) ($ something) about chat mode \.) - (($ bother) our discussion is so ($ random-adjective) \?))) - (make-local-variable 'abuselst) - (setq abuselst '( - (($ please) try to be less abusive \.) - (($ describe) why you call me (// found) \.) - (i\'ve had enough of you!))) - (make-local-variable 'abusewords) - (setq abusewords '(boring bozo clown clumsy cretin dumb dummy - fool foolish gnerd gnurd idiot jerk - lose loser louse lousy luse luser - moron nerd nurd oaf oafish reek - stink stupid tool toolish twit)) - (make-local-variable 'howareyoulst) - (setq howareyoulst '((how are you) (hows it going) (hows it going eh) - (how\'s it going) (how\'s it going eh) (how goes it) - (whats up) (whats new) (what\'s up) (what\'s new) - (howre you) (how\'re you) (how\'s everything) - (how is everything) (how do you do) - (how\'s it hanging) (que pasa) - (how are you doing) (what do you say))) - (make-local-variable 'whereoutp) - (setq whereoutp '( huh remem rthing ) ) - (make-local-variable 'subj) - (setq subj nil) - (make-local-variable 'verb) - (setq verb nil) - (make-local-variable 'obj) - (setq obj nil) - (make-local-variable 'feared) - (setq feared nil) - (make-local-variable 'observation-list) - (setq observation-list nil) - (make-local-variable 'repetitive-shortness) - (setq repetitive-shortness '(0 . 0)) - (make-local-variable '**mad**) - (setq **mad** nil) - (make-local-variable 'rms-flag) - (setq rms-flag nil) - (make-local-variable 'eliza-flag) - (setq eliza-flag nil) - (make-local-variable 'zippy-flag) - (setq zippy-flag nil) - (make-local-variable 'lover) - (setq lover '(your partner)) - (make-local-variable 'bak) - (setq bak nil) - (make-local-variable 'lincount) - (setq lincount 0) - (make-local-variable '*print-upcase*) - (setq *print-upcase* nil) - (make-local-variable '*print-space*) - (setq *print-space* nil) - (make-local-variable 'howdyflag) - (setq howdyflag nil) - (make-local-variable 'object) - (setq object nil)) - -;; Define equivalence classes of words that get treated alike. - -(defun doctor-meaning (x) (get x 'doctor-meaning)) - -(defmacro doctor-put-meaning (symb val) - "Store the base meaning of a word on the property list." - (list 'put (list 'quote symb) ''doctor-meaning val)) - -(doctor-put-meaning howdy 'howdy) -(doctor-put-meaning hi 'howdy) -(doctor-put-meaning greetings 'howdy) -(doctor-put-meaning hello 'howdy) -(doctor-put-meaning tops20 'mach) -(doctor-put-meaning tops-20 'mach) -(doctor-put-meaning tops 'mach) -(doctor-put-meaning pdp11 'mach) -(doctor-put-meaning computer 'mach) -(doctor-put-meaning unix 'mach) -(doctor-put-meaning machine 'mach) -(doctor-put-meaning computers 'mach) -(doctor-put-meaning machines 'mach) -(doctor-put-meaning pdp11s 'mach) -(doctor-put-meaning foo 'mach) -(doctor-put-meaning foobar 'mach) -(doctor-put-meaning multics 'mach) -(doctor-put-meaning macsyma 'mach) -(doctor-put-meaning teletype 'mach) -(doctor-put-meaning la36 'mach) -(doctor-put-meaning vt52 'mach) -(doctor-put-meaning zork 'mach) -(doctor-put-meaning trek 'mach) -(doctor-put-meaning startrek 'mach) -(doctor-put-meaning advent 'mach) -(doctor-put-meaning pdp 'mach) -(doctor-put-meaning dec 'mach) -(doctor-put-meaning commodore 'mach) -(doctor-put-meaning vic 'mach) -(doctor-put-meaning bbs 'mach) -(doctor-put-meaning modem 'mach) -(doctor-put-meaning baud 'mach) -(doctor-put-meaning macintosh 'mach) -(doctor-put-meaning vax 'mach) -(doctor-put-meaning vms 'mach) -(doctor-put-meaning ibm 'mach) -(doctor-put-meaning pc 'mach) -(doctor-put-meaning bitching 'foul) -(doctor-put-meaning shit 'foul) ; Censored -(doctor-put-meaning bastard 'foul) -(doctor-put-meaning damn 'foul) -(doctor-put-meaning damned 'foul) -(doctor-put-meaning hell 'foul) -(doctor-put-meaning suck 'foul) -(doctor-put-meaning sucking 'foul) -(doctor-put-meaning sux 'foul) -(doctor-put-meaning ass 'foul) -(doctor-put-meaning whore 'foul) -(doctor-put-meaning bitch 'foul) -(doctor-put-meaning asshole 'foul) -(doctor-put-meaning shrink 'foul) -(doctor-put-meaning pot 'toke) -(doctor-put-meaning grass 'toke) -(doctor-put-meaning weed 'toke) -(doctor-put-meaning marijuana 'toke) -(doctor-put-meaning acapulco 'toke) -(doctor-put-meaning columbian 'toke) -(doctor-put-meaning tokin 'toke) -(doctor-put-meaning joint 'toke) -(doctor-put-meaning toke 'toke) -(doctor-put-meaning toking 'toke) -(doctor-put-meaning tokin\' 'toke) -(doctor-put-meaning toked 'toke) -(doctor-put-meaning roach 'toke) -(doctor-put-meaning pills 'drug) -(doctor-put-meaning dope 'drug) -(doctor-put-meaning acid 'drug) -(doctor-put-meaning lsd 'drug) -(doctor-put-meaning speed 'drug) -(doctor-put-meaning heroin 'drug) -(doctor-put-meaning hash 'drug) -(doctor-put-meaning cocaine 'drug) -(doctor-put-meaning uppers 'drug) -(doctor-put-meaning downers 'drug) -(doctor-put-meaning loves 'loves) -(doctor-put-meaning love 'love) -(doctor-put-meaning loved 'love) -(doctor-put-meaning hates 'hates) -(doctor-put-meaning dislikes 'hates) -(doctor-put-meaning hate 'hate) -(doctor-put-meaning hated 'hate) -(doctor-put-meaning dislike 'hate) -(doctor-put-meaning stoned 'state) -(doctor-put-meaning drunk 'state) -(doctor-put-meaning drunken 'state) -(doctor-put-meaning high 'state) -(doctor-put-meaning horny 'state) -(doctor-put-meaning blasted 'state) -(doctor-put-meaning happy 'state) -(doctor-put-meaning paranoid 'state) -(doctor-put-meaning wish 'desire) -(doctor-put-meaning wishes 'desire) -(doctor-put-meaning want 'desire) -(doctor-put-meaning desire 'desire) -(doctor-put-meaning like 'desire) -(doctor-put-meaning hope 'desire) -(doctor-put-meaning hopes 'desire) -(doctor-put-meaning desires 'desire) -(doctor-put-meaning wants 'desire) -(doctor-put-meaning desires 'desire) -(doctor-put-meaning likes 'desire) -(doctor-put-meaning needs 'desire) -(doctor-put-meaning need 'desire) -(doctor-put-meaning frustrated 'mood) -(doctor-put-meaning depressed 'mood) -(doctor-put-meaning annoyed 'mood) -(doctor-put-meaning upset 'mood) -(doctor-put-meaning unhappy 'mood) -(doctor-put-meaning excited 'mood) -(doctor-put-meaning worried 'mood) -(doctor-put-meaning lonely 'mood) -(doctor-put-meaning angry 'mood) -(doctor-put-meaning mad 'mood) -(doctor-put-meaning pissed 'mood) ; censored -(doctor-put-meaning jealous 'mood) -(doctor-put-meaning afraid 'fear) -(doctor-put-meaning terrified 'fear) -(doctor-put-meaning fear 'fear) -(doctor-put-meaning scared 'fear) -(doctor-put-meaning frightened 'fear) -(doctor-put-meaning virginity 'sexnoun) -(doctor-put-meaning virgins 'sexnoun) -(doctor-put-meaning virgin 'sexnoun) -(doctor-put-meaning cock 'sexnoun) -(doctor-put-meaning cocks 'sexnoun) -(doctor-put-meaning dick 'sexnoun) -(doctor-put-meaning dicks 'sexnoun) -(doctor-put-meaning cunt 'sexnoun) ; censored -(doctor-put-meaning cunts 'sexnoun) ; censored -(doctor-put-meaning prostitute 'sexnoun) -(doctor-put-meaning condom 'sexnoun) -(doctor-put-meaning sex 'sexnoun) -(doctor-put-meaning rapes 'sexnoun) -(doctor-put-meaning wife 'family) -(doctor-put-meaning family 'family) -(doctor-put-meaning brothers 'family) -(doctor-put-meaning sisters 'family) -(doctor-put-meaning parent 'family) -(doctor-put-meaning parents 'family) -(doctor-put-meaning brother 'family) -(doctor-put-meaning sister 'family) -(doctor-put-meaning father 'family) -(doctor-put-meaning mother 'family) -(doctor-put-meaning husband 'family) -(doctor-put-meaning siblings 'family) -(doctor-put-meaning grandmother 'family) -(doctor-put-meaning grandfather 'family) -(doctor-put-meaning maternal 'family) -(doctor-put-meaning paternal 'family) -(doctor-put-meaning stab 'death) -(doctor-put-meaning murder 'death) -(doctor-put-meaning murders 'death) -(doctor-put-meaning suicide 'death) -(doctor-put-meaning suicides 'death) -(doctor-put-meaning kill 'death) -(doctor-put-meaning kills 'death) -(doctor-put-meaning die 'death) -(doctor-put-meaning dies 'death) -(doctor-put-meaning died 'death) -(doctor-put-meaning dead 'death) -(doctor-put-meaning death 'death) -(doctor-put-meaning deaths 'death) -(doctor-put-meaning pain 'symptoms) -(doctor-put-meaning ache 'symptoms) -(doctor-put-meaning fever 'symptoms) -(doctor-put-meaning sore 'symptoms) -(doctor-put-meaning aching 'symptoms) -(doctor-put-meaning stomachache 'symptoms) -(doctor-put-meaning headache 'symptoms) -(doctor-put-meaning hurts 'symptoms) -(doctor-put-meaning disease 'symptoms) -(doctor-put-meaning virus 'symptoms) -(doctor-put-meaning vomit 'symptoms) -(doctor-put-meaning vomiting 'symptoms) -(doctor-put-meaning barf 'symptoms) -(doctor-put-meaning toothache 'symptoms) -(doctor-put-meaning hurt 'symptoms) -(doctor-put-meaning rum 'alcohol) -(doctor-put-meaning gin 'alcohol) -(doctor-put-meaning vodka 'alcohol) -(doctor-put-meaning alcohol 'alcohol) -(doctor-put-meaning bourbon 'alcohol) -(doctor-put-meaning beer 'alcohol) -(doctor-put-meaning wine 'alcohol) -(doctor-put-meaning whiskey 'alcohol) -(doctor-put-meaning scotch 'alcohol) -(doctor-put-meaning fuck 'sexverb) ; censored -(doctor-put-meaning fucked 'sexverb) ; censored -(doctor-put-meaning screw 'sexverb) -(doctor-put-meaning screwing 'sexverb) -(doctor-put-meaning fucking 'sexverb) ; censored -(doctor-put-meaning rape 'sexverb) -(doctor-put-meaning raped 'sexverb) -(doctor-put-meaning kiss 'sexverb) -(doctor-put-meaning kissing 'sexverb) -(doctor-put-meaning kisses 'sexverb) -(doctor-put-meaning screws 'sexverb) -(doctor-put-meaning fucks 'sexverb) ; censored -(doctor-put-meaning because 'conj) -(doctor-put-meaning but 'conj) -(doctor-put-meaning however 'conj) -(doctor-put-meaning besides 'conj) -(doctor-put-meaning anyway 'conj) -(doctor-put-meaning that 'conj) -(doctor-put-meaning except 'conj) -(doctor-put-meaning why 'conj) -(doctor-put-meaning how 'conj) -(doctor-put-meaning until 'when) -(doctor-put-meaning when 'when) -(doctor-put-meaning whenever 'when) -(doctor-put-meaning while 'when) -(doctor-put-meaning since 'when) -(doctor-put-meaning rms 'rms) -(doctor-put-meaning stallman 'rms) -(doctor-put-meaning school 'school) -(doctor-put-meaning schools 'school) -(doctor-put-meaning skool 'school) -(doctor-put-meaning grade 'school) -(doctor-put-meaning grades 'school) -(doctor-put-meaning teacher 'school) -(doctor-put-meaning teachers 'school) -(doctor-put-meaning classes 'school) -(doctor-put-meaning professor 'school) -(doctor-put-meaning prof 'school) -(doctor-put-meaning profs 'school) -(doctor-put-meaning professors 'school) -(doctor-put-meaning mit 'school) -(doctor-put-meaning emacs 'eliza) -(doctor-put-meaning eliza 'eliza) -(doctor-put-meaning liza 'eliza) -(doctor-put-meaning elisa 'eliza) -(doctor-put-meaning weizenbaum 'eliza) -(doctor-put-meaning doktor 'eliza) -(doctor-put-meaning athletics 'sports) -(doctor-put-meaning baseball 'sports) -(doctor-put-meaning basketball 'sports) -(doctor-put-meaning football 'sports) -(doctor-put-meaning frisbee 'sports) -(doctor-put-meaning gym 'sports) -(doctor-put-meaning gymnastics 'sports) -(doctor-put-meaning hockey 'sports) -(doctor-put-meaning lacrosse 'sports) -(doctor-put-meaning soccer 'sports) -(doctor-put-meaning softball 'sports) -(doctor-put-meaning sports 'sports) -(doctor-put-meaning swimming 'sports) -(doctor-put-meaning swim 'sports) -(doctor-put-meaning tennis 'sports) -(doctor-put-meaning volleyball 'sports) -(doctor-put-meaning math 'math) -(doctor-put-meaning mathematics 'math) -(doctor-put-meaning mathematical 'math) -(doctor-put-meaning theorem 'math) -(doctor-put-meaning axiom 'math) -(doctor-put-meaning lemma 'math) -(doctor-put-meaning algebra 'math) -(doctor-put-meaning algebraic 'math) -(doctor-put-meaning trig 'math) -(doctor-put-meaning trigonometry 'math) -(doctor-put-meaning trigonometric 'math) -(doctor-put-meaning geometry 'math) -(doctor-put-meaning geometric 'math) -(doctor-put-meaning calculus 'math) -(doctor-put-meaning arithmetic 'math) -(doctor-put-meaning zippy 'zippy) -(doctor-put-meaning zippy 'zippy) -(doctor-put-meaning pinhead 'zippy) -(doctor-put-meaning chat 'chat) - -;;;###autoload -(defun doctor () - "Switch to *doctor* buffer and start giving psychotherapy." - (interactive) - (switch-to-buffer "*doctor*") - (doctor-mode)) - -(defun doctor-ret-or-read (arg) - "Insert a newline if preceding character is not a newline. -Otherwise call the Doctor to parse preceding sentence." - (interactive "*p") - (if (= (preceding-char) ?\n) - (doctor-read-print) - (newline arg))) - -(defun doctor-read-print nil - "top level loop" - (interactive) - (let ((sent (doctor-readin))) - (insert "\n") - (setq lincount (1+ lincount)) - (doctor-doc sent) - (insert "\n") - (setq bak sent))) - -(defun doctor-readin nil - "Read a sentence. Return it as a list of words." - (let (sentence) - (backward-sentence 1) - (while (not (eobp)) - (setq sentence (append sentence (list (doctor-read-token))))) - sentence)) - -(defun doctor-read-token () - "read one word from buffer" - (prog1 (intern (downcase (buffer-substring (point) - (progn - (forward-word 1) - (point))))) - (re-search-forward "\\Sw*"))) - -;; Main processing function for sentences that have been read. - -(defun doctor-doc (sent) - (cond - ((equal sent '(foo)) - (doctor-type '(bar! ($ please)($ continue) \.))) - ((member sent howareyoulst) - (doctor-type '(i\'m ok \. ($ describe) yourself \.))) - ((or (member sent '((good bye) (see you later) (i quit) (so long) - (go away) (get lost))) - (memq (car sent) - '(bye halt break quit done exit goodbye - bye\, stop pause goodbye\, stop pause))) - (doctor-type ($ bye))) - ((and (eq (car sent) 'you) - (memq (doctor-cadr sent) abusewords)) - (setq found (doctor-cadr sent)) - (doctor-type ($ abuselst))) - ((eq (car sent) 'whatmeans) - (doctor-def (doctor-cadr sent))) - ((equal sent '(parse)) - (doctor-type (list 'subj '= subj ", " - 'verb '= verb "\n" - 'object 'phrase '= obj "," - 'noun 'form '= object "\n" - 'current 'keyword 'is found - ", " - 'most 'recent 'possessive - 'is owner "\n" - 'sentence 'used 'was - "..." - '(// bak)))) - ;; ((eq (car sent) 'forget) - ;; (set (doctor-cadr sent) nil) - ;; (doctor-type '(($ isee)($ please) - ;; ($ continue)\.))) - (t - (if (doctor-defq sent) (doctor-define sent found)) - (if (> (length sent) 12)(doctor-shorten sent)) - (setq sent (doctor-correct-spelling (doctor-replace sent replist))) - (cond ((and (not (memq 'me sent))(not (memq 'i sent)) - (memq 'am sent)) - (setq sent (doctor-replace sent '((am . (are))))))) - (cond ((equal (car sent) 'yow) (doctor-zippy)) - ((< (length sent) 2) - (cond ((eq (doctor-meaning (car sent)) 'howdy) - (doctor-howdy)) - (t (doctor-short)))) - (t - (if (memq 'am sent) - (setq sent (doctor-replace sent '((me . (i)))))) - (setq sent (doctor-fixup sent)) - (if (and (eq (car sent) 'do) (eq (doctor-cadr sent) 'not)) - (cond ((zerop (random 3)) - (doctor-type '(are you ($ afraidof) that \?))) - ((zerop (random 2)) - (doctor-type '(don\'t tell me what to do \. i am the - psychiatrist here!)) - (doctor-rthing)) - (t - (doctor-type '(($ whysay) that i shouldn\'t - (doctor-cddr sent) - \?)))) - (doctor-go (doctor-wherego sent)))))))) - -;; Things done to process sentences once read. - -(defun doctor-correct-spelling (sent) - "Correct the spelling and expand each word in sentence." - (if sent - (apply 'append (mapcar '(lambda (word) - (if (memq word typos) - (get (get word 'doctor-correction) 'doctor-expansion) - (list word))) - sent)))) - -(defun doctor-shorten (sent) - "Make a sentence manageably short using a few hacks." - (let (foo - retval - (temp '(because but however besides anyway until - while that except why how))) - (while temp - (setq foo (memq (car temp) sent)) - (if (and foo - (> (length foo) 3)) - (setq sent foo - sent (doctor-fixup sent) - temp nil - retval t) - (setq temp (cdr temp)))) - retval)) - -(defun doctor-define (sent found) - (doctor-svo sent found 1 nil) - (and - (doctor-nounp subj) - (not (doctor-pronounp subj)) - subj - (doctor-meaning object) - (put subj 'doctor-meaning (doctor-meaning object)) - t)) - -(defun doctor-defq (sent) - "Set global var FOUND to first keyword found in sentence SENT." - (setq found nil) - (let ((temp '(means applies mean refers refer related - similar defined associated linked like same))) - (while temp - (if (memq (car temp) sent) - (setq found (car temp) - temp nil) - (setq temp (cdr temp))))) - found) - -(defun doctor-def (x) - (progn - (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me)) - nil)) - -(defun doctor-forget () - "Delete the last element of the history list." - (setq history (reverse (cdr (reverse history))))) - -(defun doctor-query (x) - "Prompt for a line of input from the minibuffer until a noun or verb is seen. -Put dialogue in buffer." - (let (a - (prompt (concat (doctor-make-string x) - " what \? ")) - retval) - (while (not retval) - (while (not a) - (insert ?\n - prompt - (read-string prompt) - ?\n) - (setq a (doctor-readin))) - (while (and a (not retval)) - (cond ((doctor-nounp (car a)) - (setq retval (car a))) - ((doctor-verbp (car a)) - (setq retval (doctor-build - (doctor-build x " ") - (car a)))) - ((setq a (cdr a)))))) - retval)) - -(defun doctor-subjsearch (sent key type) - "Search for the subject of a sentence SENT, looking for the noun closest -to and preceding KEY by at least TYPE words. Set global variable subj to -the subject noun, and return the portion of the sentence following it." - (let ((i (- (length sent) (length (memq key sent)) type))) - (while (and (> i -1) (not (doctor-nounp (nth i sent)))) - (setq i (1- i))) - (cond ((> i -1) - (setq subj (nth i sent)) - (nthcdr (1+ i) sent)) - (t - (setq subj 'you) - nil)))) - -(defun doctor-nounp (x) - "Returns t if the symbol argument is a noun." - (or (doctor-pronounp x) - (not (or (doctor-verbp x) - (equal x 'not) - (doctor-prepp x) - (doctor-modifierp x) )) )) - -(defun doctor-pronounp (x) - "Returns t if the symbol argument is a pronoun." - (memq x '( - i me mine myself - we us ours ourselves ourself - you yours yourself yourselves - he him himself she hers herself - it that those this these things thing - they them themselves theirs - anybody everybody somebody - anyone everyone someone - anything something everything))) - -(mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb))) - '(abort aborted aborts ask asked asks am - applied applies apply are associate - associated ate - be became become becomes becoming - been being believe believed believes - bit bite bites bore bored bores boring bought buy buys buying - call called calling calls came can caught catch come - contract contracted contracts control controlled controls - could croak croaks croaked cut cuts - dare dared define defines dial dialed dials did die died dies - dislike disliked - dislikes do does drank drink drinks drinking - drive drives driving drove dying - eat eating eats expand expanded expands - expect expected expects expel expels expelled - explain explained explains - fart farts feel feels felt fight fights find finds finding - forget forgets forgot fought found fuck fucked ; censored - fucking fucks ; censored - gave get gets getting give gives go goes going gone got gotten - had harm harms has hate hated hates have having - hear heard hears hearing help helped helping helps - hit hits hope hoped hopes hurt hurts - implies imply is - join joined joins jump jumped jumps - keep keeping keeps kept - kill killed killing kills kiss kissed kisses kissing - knew know knows - laid lay lays let lets lie lied lies like liked likes - liking listen listens - login look looked looking looks - lose losing lost - love loved loves loving - luse lusing lust lusts - made make makes making may mean means meant might - move moved moves moving must - need needed needs - order ordered orders ought - paid pay pays pick picked picking picks - placed placing prefer prefers put puts - ran rape raped rapes - read reading reads recall receive received receives - refer refered referred refers - relate related relates remember remembered remembers - romp romped romps run running runs - said sang sat saw say says - screw screwed screwing screws scrod see sees seem seemed - seems seen sell selling sells - send sendind sends sent shall shoot shot should - sing sings sit sits sitting sold studied study - take takes taking talk talked talking talks tell tells telling - think thinks - thought told took tooled touch touched touches touching - transfer transferred transfers transmit transmits transmitted - type types types typing - walk walked walking walks want wanted wants was watch - watched watching went were will wish would work worked works - write writes writing wrote use used uses using)) - -(defun doctor-verbp (x) (if (symbolp x) - (eq (get x 'doctor-sentence-type) 'verb))) - -(defun doctor-plural (x) - "Form the plural of the word argument." - (let ((foo (doctor-make-string x))) - (cond ((string-equal (substring foo -1) "s") - (cond ((string-equal (substring foo -2 -1) "s") - (intern (concat foo "es"))) - (t x))) - ((string-equal (substring foo -1) "y") - (intern (concat (substring foo 0 -1) - "ies"))) - (t (intern (concat foo "s")))))) - -(defun doctor-setprep (sent key) - (let ((val) - (foo (memq key sent))) - (cond ((doctor-prepp (doctor-cadr foo)) - (setq val (doctor-getnoun (doctor-cddr foo))) - (cond (val val) - (t 'something))) - ((doctor-articlep (doctor-cadr foo)) - (setq val (doctor-getnoun (doctor-cddr foo))) - (cond (val (doctor-build (doctor-build (doctor-cadr foo) " ") val)) - (t 'something))) - (t 'something)))) - -(defun doctor-getnoun (x) - (cond ((null x)(setq object 'something)) - ((atom x)(setq object x)) - ((eq (length x) 1) - (setq object (cond - ((doctor-nounp (setq object (car x))) object) - (t (doctor-query object))))) - ((eq (car x) 'to) - (doctor-build 'to\ (doctor-getnoun (cdr x)))) - ((doctor-prepp (car x)) - (doctor-getnoun (cdr x))) - ((not (doctor-nounp (car x))) - (doctor-build (doctor-build (cdr (assq (car x) - (append - '((a . this) - (some . this) - (one . that)) - (list - (cons - (car x) (car x)))))) - " ") - (doctor-getnoun (cdr x)))) - (t (setq object (car x))) )) - -(defun doctor-modifierp (x) - (or (doctor-adjectivep x) - (doctor-adverbp x) - (doctor-othermodifierp x))) - -(defun doctor-adjectivep (x) - (or (numberp x) - (doctor-nmbrp x) - (doctor-articlep x) - (doctor-colorp x) - (doctor-sizep x) - (doctor-possessivepronounp x))) - -(defun doctor-adverbp (xx) - (let ((xxstr (doctor-make-string xx))) - (and (>= (length xxstr) 2) - (string-equal (substring (doctor-make-string xx) -2) "ly")))) - -(defun doctor-articlep (x) - (memq x '(the a an))) - -(defun doctor-nmbrp (x) - (memq x '(one two three four five six seven eight nine ten - eleven twelve thirteen fourteen fifteen - sixteen seventeen eighteen nineteen - twenty thirty forty fifty sixty seventy eighty ninety - hundred thousand million billion - half quarter - first second third fourth fifth - sixth seventh eighth ninth tenth))) - -(defun doctor-colorp (x) - (memq x '(beige black blue brown crimson - gray grey green - orange pink purple red tan tawny - violet white yellow))) - -(defun doctor-sizep (x) - (memq x '(big large tall fat wide thick - small petite short thin skinny))) - -(defun doctor-possessivepronounp (x) - (memq x '(my your his her our their))) - -(defun doctor-othermodifierp (x) - (memq x '(all also always amusing any anyway associated awesome - bad beautiful best better but certain clear - ever every fantastic fun funny - good great grody gross however if ignorant - less linked losing lusing many more much - never nice obnoxious often poor pretty real related rich - similar some stupid super superb - terrible terrific too total tubular ugly very))) - -(defun doctor-prepp (x) - (memq x '(about above after around as at - before beneath behind beside between by - for from in inside into - like near next of on onto over - same through thru to toward towards - under underneath with without))) - -(defun doctor-remember (thing) - (cond ((null history) - (setq history (list thing))) - (t (setq history (append history (list thing)))))) - -(defun doctor-type (x) - (setq x (doctor-fix-2 x)) - (doctor-txtype (doctor-assm x))) - -(defun doctor-fixup (sent) - (setq sent (append - (cdr - (assq (car sent) - (append - '((me i) - (him he) - (her she) - (them they) - (okay) - (well) - (sigh) - (hmm) - (hmmm) - (hmmmm) - (hmmmmm) - (gee) - (sure) - (great) - (oh) - (fine) - (ok) - (no)) - (list (list (car sent) - (car sent)))))) - (cdr sent))) - (doctor-fix-2 sent)) - -(defun doctor-fix-2 (sent) - (let ((foo sent)) - (while foo - (if (and (eq (car foo) 'me) - (doctor-verbp (doctor-cadr foo))) - (rplaca foo 'i) - (cond ((eq (car foo) 'you) - (cond ((memq (doctor-cadr foo) '(am be been is)) - (rplaca (cdr foo) 'are)) - ((memq (doctor-cadr foo) '(has)) - (rplaca (cdr foo) 'have)) - ((memq (doctor-cadr foo) '(was)) - (rplaca (cdr foo) 'were)))) - ((equal (car foo) 'i) - (cond ((memq (doctor-cadr foo) '(are is be been)) - (rplaca (cdr foo) 'am)) - ((memq (doctor-cadr foo) '(were)) - (rplaca (cdr foo) 'was)) - ((memq (doctor-cadr foo) '(has)) - (rplaca (cdr foo) 'have)))) - ((and (doctor-verbp (car foo)) - (eq (doctor-cadr foo) 'i) - (not (doctor-verbp (car (doctor-cddr foo))))) - (rplaca (cdr foo) 'me)) - ((and (eq (car foo) 'a) - (doctor-vowelp (string-to-char - (doctor-make-string (doctor-cadr foo))))) - (rplaca foo 'an)) - ((and (eq (car foo) 'an) - (not (doctor-vowelp (string-to-char - (doctor-make-string (doctor-cadr foo)))))) - (rplaca foo 'a))) - (setq foo (cdr foo)))) - sent)) - -(defun doctor-vowelp (x) - (memq x '(?a ?e ?i ?o ?u))) - -(defun doctor-replace (sent rlist) - "Replace any element of SENT that is the car of a replacement -element pair in RLIST." - (apply 'append - (mapcar - (function - (lambda (x) - (cdr (or (assq x rlist) ; either find a replacement - (list x x))))) ; or fake an identity mapping - sent))) - -(defun doctor-wherego (sent) - (cond ((null sent)($ whereoutp)) - ((null (doctor-meaning (car sent))) - (doctor-wherego (cond ((zerop (random 2)) - (reverse (cdr sent))) - (t (cdr sent))))) - (t - (setq found (car sent)) - (doctor-meaning (car sent))))) - -(defun doctor-svo (sent key type mem) - "Find subject, verb and object in sentence SENT with focus on word KEY. -TYPE is number of words preceding KEY to start looking for subject. -MEM is t if results are to be put on Doctor's memory stack. -Return in the global variables SUBJ, VERB and OBJECT." - (let ((foo (doctor-subjsearch sent key type))) - (or foo - (setq foo sent - mem nil)) - (while (and (null (doctor-verbp (car foo))) (cdr foo)) - (setq foo (cdr foo))) - (setq verb (car foo)) - (setq obj (doctor-getnoun (cdr foo))) - (cond ((eq object 'i)(setq object 'me)) - ((eq subj 'me)(setq subj 'i))) - (cond (mem (doctor-remember (list subj verb obj)))))) - -(defun doctor-possess (sent key) - "Set possessive in SENT for keyword KEY. -Hack on previous word, setting global variable OWNER to correct result." - (let* ((i (- (length sent) (length (memq key sent)) 1)) - (prev (if (< i 0) 'your - (nth i sent)))) - (setq owner (if (or (doctor-possessivepronounp prev) - (string-equal "s" - (substring (doctor-make-string prev) - -1))) - prev - 'your)))) - -;; Output of replies. - -(defun doctor-txtype (ans) - "Output to buffer a list of symbols or strings as a sentence." - (setq *print-upcase* t *print-space* nil) - (mapcar 'doctor-type-symbol ans) - (insert "\n")) - -(defun doctor-type-symbol (word) - "Output a symbol to the buffer with some fancy case and spacing hacks." - (setq word (doctor-make-string word)) - (if (string-equal word "i") (setq word "I")) - (if *print-upcase* - (progn - (setq word (capitalize word)) - (if *print-space* - (insert " ")))) - (cond ((or (string-match "^[.,;:?! ]" word) - (not *print-space*)) - (insert word)) - (t (insert ?\ word))) - (and auto-fill-function - (> (current-column) fill-column) - (apply auto-fill-function nil)) - (setq *print-upcase* (string-match "[.?!]$" word) - *print-space* t)) - -(defun doctor-build (str1 str2) - "Make a symbol out of the concatenation of the two non-list arguments." - (cond ((null str1) str2) - ((null str2) str1) - ((and (atom str1) - (atom str2)) - (intern (concat (doctor-make-string str1) - (doctor-make-string str2)))) - (t nil))) - -(defun doctor-make-string (obj) - (cond ((stringp obj) obj) - ((symbolp obj) (symbol-name obj)) - ((numberp obj) (int-to-string obj)) - (t ""))) - -(defun doctor-concat (x y) - "Like append, but force atomic arguments to be lists." - (append - (if (and x (atom x)) (list x) x) - (if (and y (atom y)) (list y) y))) - -(defun doctor-assm (proto) - (cond ((null proto) nil) - ((atom proto) (list proto)) - ((atom (car proto)) - (cons (car proto) (doctor-assm (cdr proto)))) - (t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto)))))) - -;; Functions that handle specific words or meanings when found. - -(defun doctor-go (destination) - "Call a `doctor-*' function." - (funcall (intern (concat "doctor-" (doctor-make-string destination))))) - -(defun doctor-desire1 () - (doctor-go ($ whereoutp))) - -(defun doctor-huh () - (cond ((< (length sent) 9) (doctor-type ($ huhlst))) - (t (doctor-type ($ longhuhlst))))) - -(defun doctor-rthing () (doctor-type ($ thlst))) - -(defun doctor-remem () (cond ((null history)(doctor-huh)) - ((doctor-type ($ remlst))))) - -(defun doctor-howdy () - (cond ((not howdyflag) - (doctor-type '(($ hello) what brings you to see me \?)) - (setq howdyflag t)) - (t - (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.)) - (doctor-type '(($ please) ($ describe) ($ things) \.))))) - -(defun doctor-when () - (cond ((< (length (memq found sent)) 3)(doctor-short)) - (t - (setq sent (cdr (memq found sent))) - (setq sent (doctor-fixup sent)) - (doctor-type '(($ whatwhen)(// sent) \?))))) - -(defun doctor-conj () - (cond ((< (length (memq found sent)) 4)(doctor-short)) - (t - (setq sent (cdr (memq found sent))) - (setq sent (doctor-fixup sent)) - (cond ((eq (car sent) 'of) - (doctor-type '(are you ($ sure) that is the real reason \?)) - (setq things (cons (cdr sent) things))) - (t - (doctor-remember sent) - (doctor-type ($ beclst))))))) - -(defun doctor-short () - (cond ((= (car repetitive-shortness) (1- lincount)) - (rplacd repetitive-shortness - (1+ (cdr repetitive-shortness)))) - (t - (rplacd repetitive-shortness 1))) - (rplaca repetitive-shortness lincount) - (cond ((> (cdr repetitive-shortness) 6) - (cond ((not **mad**) - (doctor-type '(($ areyou) - just trying to see what kind of things - i have in my vocabulary \? please try to - carry on a reasonable conversation!)) - (setq **mad** t)) - (t - (doctor-type '(i give up \. you need a lesson in creative - writing \.\.\.)) - ;;(push monosyllables observation-list) - ))) - (t - (cond ((equal sent (doctor-assm '(yes))) - (doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?))) - ((equal sent (doctor-assm '(because))) - (doctor-type ($ shortbeclst))) - ((equal sent (doctor-assm '(no))) - (doctor-type ($ neglst))) - (t (doctor-type ($ shortlst))))))) - -(defun doctor-alcohol () (doctor-type ($ drnk))) - -(defun doctor-desire () - (let ((foo (memq found sent))) - (cond ((< (length foo) 2) - (doctor-go (doctor-build (doctor-meaning found) 1))) - ((memq (doctor-cadr foo) '(a an)) - (rplacd foo (append '(to have) (cdr foo))) - (doctor-svo sent found 1 nil) - (doctor-remember (list subj 'would 'like obj)) - (doctor-type ($ whywant))) - ((not (eq (doctor-cadr foo) 'to)) - (doctor-go (doctor-build (doctor-meaning found) 1))) - (t - (doctor-svo sent found 1 nil) - (doctor-remember (list subj 'would 'like obj)) - (doctor-type ($ whywant)))))) - -(defun doctor-drug () - (doctor-type ($ drugs)) - (doctor-remember (list 'you 'used found))) - -(defun doctor-toke () - (doctor-type ($ toklst))) - -(defun doctor-state () - (doctor-type ($ states))(doctor-remember (list 'you 'were found))) - -(defun doctor-mood () - (doctor-type ($ moods))(doctor-remember (list 'you 'felt found))) - -(defun doctor-fear () - (setq feared (doctor-setprep sent found)) - (doctor-type ($ fears)) - (doctor-remember (list 'you 'were 'afraid 'of feared))) - -(defun doctor-hate () - (doctor-svo sent found 1 t) - (cond ((memq 'not sent) (doctor-forget) (doctor-huh)) - ((equal subj 'you) - (doctor-type '(why do you (// verb)(// obj) \?))) - (t (doctor-type '(($ whysay)(list subj verb obj)))))) - -(defun doctor-symptoms () - (doctor-type '(($ maybe) you should consult a doctor of medicine\, - i am a psychiatrist \.))) - -(defun doctor-hates () - (doctor-svo sent found 1 t) - (doctor-hates1)) - -(defun doctor-hates1 () - (doctor-type '(($ whysay)(list subj verb obj)))) - -(defun doctor-loves () - (doctor-svo sent found 1 t) - (doctor-qloves)) - -(defun doctor-qloves () - (doctor-type '(($ bother)(list subj verb obj) \?))) - -(defun doctor-love () - (doctor-svo sent found 1 t) - (cond ((memq 'not sent) (doctor-forget) (doctor-huh)) - ((memq 'to sent) (doctor-hates1)) - (t - (cond ((equal object 'something) - (setq object '(this person you love)))) - (cond ((equal subj 'you) - (setq lover obj) - (cond ((equal lover '(this person you love)) - (setq lover '(your partner)) - (doctor-forget) - (doctor-type '(with whom are you in love \?))) - ((doctor-type '(($ please) - ($ describe) - ($ relation) - (// lover) - \.))))) - ((equal subj 'i) - (doctor-txtype '(we were discussing you!))) - (t (doctor-forget) - (setq obj 'someone) - (setq verb (doctor-build verb 's)) - (doctor-qloves)))))) - -(defun doctor-mach () - (setq found (doctor-plural found)) - (doctor-type ($ machlst))) - -(defun doctor-sexnoun () (doctor-sexverb)) - -(defun doctor-sexverb () - (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent)) - (doctor-foul) - (doctor-type ($ sexlst)))) - -(defun doctor-death () (doctor-type ($ deathlst))) - -(defun doctor-foul () - (doctor-type ($ foullst))) - -(defun doctor-family () - (doctor-possess sent found) - (doctor-type ($ famlst))) - -;; I did not add this -- rms. -;; But he might have removed it. I put it back. --roland -(defun doctor-rms () - (cond (rms-flag (doctor-type ($ stallmanlst))) - (t (setq rms-flag t) (doctor-type '(do you know Stallman \?))))) - -(defun doctor-school nil (doctor-type ($ schoollst))) - -(defun doctor-eliza () - (cond (eliza-flag (doctor-type ($ elizalst))) - (t (setq eliza-flag t) - (doctor-type '((// found) \? hah ! - ($ please) ($ continue) \.))))) - -(defun doctor-sports () (doctor-type ($ sportslst))) - -(defun doctor-math () (doctor-type ($ mathlst))) - -(defun doctor-zippy () - (cond (zippy-flag (doctor-type ($ zippylst))) - (t (setq zippy-flag t) - (doctor-type '(yow! are we interactive yet \?))))) - - -(defun doctor-chat () (doctor-type ($ chatlst))) - -(defun doctor-strangelove () - (interactive) - (insert "Mein fuehrer!!\n") - (doctor-read-print)) - -;;; doctor.el ends here
--- a/lisp/games/dunnet.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3340 +0,0 @@ -;;; dunnet.el --- Text adventure for Emacs - -;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. - -;; Author: Ron Schnell <ronnie@media.mit.edu> -;; Created: 25 Jul 1992 -;; Version: 2.0 -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; This game can be run in batch mode. To do this, use: -;; emacs -batch -l dunnet - -;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -;;; The log file should be set for your system, and it must -;;; be writable by all. - - -(defvar dun-log-file "/usr/local/dunnet.score" - "Name of file to store score information for dunnet.") - -(if nil - (eval-and-compile (setq byte-compile-warnings nil))) - -(eval-when-compile - (require 'cl)) - -;;;; Mode definitions for interactive mode - -(defun dun-mode () - "Major mode for running dunnet." - (interactive) - (text-mode) - (make-local-variable 'scroll-step) - (setq scroll-step 2) - (use-local-map dungeon-mode-map) - (setq major-mode 'dungeon-mode) - (setq mode-name "Dungeon")) - -(defun dun-parse (arg) - "Function called when return is pressed in interactive mode to parse line." - (interactive "*p") - (beginning-of-line) - (setq beg (+ (point) 1)) - (end-of-line) - (if (and (not (= beg (point))) (not (< (point) beg)) - (string= ">" (buffer-substring (- beg 1) beg))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n"))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (dun-messages)) - -(defun dun-messages () - (if dun-dead - (text-mode) - (if (eq dungeon-mode 'dungeon) - (progn - (if (not (= room dun-current-room)) - (progn - (dun-describe-room dun-current-room) - (setq room dun-current-room))) - (dun-fix-screen) - (dun-mprinc ">"))))) - - -;;;###autoload -(defun dunnet () - "Switch to *dungeon* buffer and start game." - (interactive) - (switch-to-buffer "*dungeon*") - (dun-mode) - (setq dun-dead nil) - (setq room 0) - (dun-messages)) - -;;;; -;;;; This section contains all of the verbs and commands. -;;;; - -;;; Give long description of room if haven't been there yet. Otherwise -;;; short. Also give long if we were called with negative room number. - -(defun dun-describe-room (room) - (if (and (not (member (abs room) dun-light-rooms)) - (not (member obj-lamp dun-inventory))) - (dun-mprincl "It is pitch dark. You are likely to be eaten by a grue.") - (dun-mprincl (cadr (nth (abs room) dun-rooms))) - (if (and (and (or (member room dun-visited) - (string= dun-mode "dun-superb")) (> room 0)) - (not (string= dun-mode "long"))) - nil - (dun-mprinc (car (nth (abs room) dun-rooms))) - (dun-mprinc "\n")) - (if (not (string= dun-mode "long")) - (if (not (member (abs room) dun-visited)) - (setq dun-visited (append (list (abs room)) dun-visited)))) - (dolist (xobjs (nth dun-current-room dun-room-objects)) - (if (= xobjs obj-special) - (dun-special-object) - (if (>= xobjs 0) - (dun-mprincl (car (nth xobjs dun-objects))) - (if (not (and (= xobjs obj-bus) dun-inbus)) - (progn - (dun-mprincl (car (nth (abs xobjs) dun-perm-objects))))))) - (if (and (= xobjs obj-jar) dun-jar) - (progn - (dun-mprincl "The jar contains:") - (dolist (x dun-jar) - (dun-mprinc " ") - (dun-mprincl (car (nth x dun-objects))))))) - (if (and (member obj-bus (nth dun-current-room dun-room-objects)) dun-inbus) - (dun-mprincl "You are on the bus.")))) - -;;; There is a special object in the room. This object's description, -;;; or lack thereof, depends on certain conditions. - -(defun dun-special-object () - (if (= dun-current-room computer-room) - (if dun-computer - (dun-mprincl -"The panel lights are flashing in a seemingly organized pattern.") - (dun-mprincl "The panel lights are steady and motionless."))) - - (if (and (= dun-current-room red-room) - (not (member obj-towel (nth red-room dun-room-objects)))) - (dun-mprincl "There is a hole in the floor here.")) - - (if (and (= dun-current-room marine-life-area) dun-black) - (dun-mprincl -"The room is lit by a black light, causing the fish, and some of -your objects, to give off an eerie glow.")) - (if (and (= dun-current-room fourth-vermont-intersection) dun-hole) - (progn - (if (not dun-inbus) - (progn - (dun-mprincl"You fall into a hole in the ground.") - (setq dun-current-room vermont-station) - (dun-describe-room vermont-station)) - (progn - (dun-mprincl -"The bus falls down a hole in the ground and explodes.") - (dun-die "burning"))))) - - (if (> dun-current-room endgame-computer-room) - (progn - (if (not dun-correct-answer) - (dun-endgame-question) - (dun-mprincl "Your question is:") - (dun-mprincl dun-endgame-question)))) - - (if (= dun-current-room sauna) - (progn - (dun-mprincl (nth dun-sauna-level '( -"It is normal room temperature in here." -"It is luke warm in here." -"It is comfortably hot in here." -"It is refreshingly hot in here." -"You are dead now."))) - (if (and (= dun-sauna-level 3) - (or (member obj-rms dun-inventory) - (member obj-rms (nth dun-current-room dun-room-objects)))) - (progn - (dun-mprincl -"You notice the wax on your statuette beginning to melt, until it completely -melts off. You are left with a beautiful diamond!") - (if (member obj-rms dun-inventory) - (progn - (dun-remove-obj-from-inven obj-rms) - (setq dun-inventory (append dun-inventory - (list obj-diamond)))) - (dun-remove-obj-from-room dun-current-room obj-rms) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-diamond)))) - (if (member obj-floppy dun-inventory) - (progn - (dun-mprincl -"You notice your floppy disk beginning to melt. As you grab for it, the -disk bursts into flames, and disintegrates.") - (dun-remove-obj-from-inven obj-floppy) - (dun-remove-obj-from-room dun-current-room obj-floppy))))) - ))) - -(defun dun-die (murderer) - (dun-mprinc "\n") - (if murderer - (dun-mprincl "You are dead.")) - (dun-do-logfile 'dun-die murderer) - (dun-score nil) - (setq dun-dead t)) - -(defun dun-quit (args) - (dun-die nil)) - -;;; Print every object in player's inventory. Special case for the jar, -;;; as we must also print what is in it. - -(defun dun-inven (args) - (dun-mprinc "You currently have:") - (dun-mprinc "\n") - (dolist (curobj dun-inventory) - (if curobj - (progn - (dun-mprincl (cadr (nth curobj dun-objects))) - (if (and (= curobj obj-jar) dun-jar) - (progn - (dun-mprincl "The jar contains:") - (dolist (x dun-jar) - (dun-mprinc " ") - (dun-mprincl (cadr (nth x dun-objects)))))))))) - -(defun dun-shake (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (member objnum dun-inventory) - (progn -;;; If shaking anything will do anything, put here. - (dun-mprinc "Shaking ") - (dun-mprinc (downcase (cadr (nth objnum dun-objects)))) - (dun-mprinc " seems to have no effect.") - (dun-mprinc "\n") - ) - (if (and (not (member objnum (nth dun-current-room dun-room-silents))) - (not (member objnum (nth dun-current-room dun-room-objects)))) - (dun-mprincl "I don't see that here.") -;;; Shaking trees can be deadly - (if (= objnum obj-tree) - (progn - (dun-mprinc - "You begin to shake a tree, and notice a coconut begin to fall from the air. -As you try to get your hand up to block it, you feel the impact as it lands -on your head.") - (dun-die "a coconut")) - (if (= objnum obj-bear) - (progn - (dun-mprinc -"As you go up to the bear, it removes your head and places it on the ground.") - (dun-die "a bear")) - (if (< objnum 0) - (dun-mprincl "You cannot shake that.") - (dun-mprincl "You don't have that."))))))))) - - -(defun dun-drop (obj) - (if dun-inbus - (dun-mprincl "You can't drop anything while on the bus.") - (let (objnum ptr) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (setq ptr (member objnum dun-inventory))) - (dun-mprincl "You don't have that.") - (progn - (dun-remove-obj-from-inven objnum) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list objnum))) - (dun-mprincl "Done.") - (if (member objnum (list obj-food obj-weight obj-jar)) - (dun-drop-check objnum)))))))) - -;;; Dropping certain things causes things to happen. - -(defun dun-drop-check (objnum) - (if (and (= objnum obj-food) (= room bear-hangout) - (member obj-bear (nth bear-hangout dun-room-objects))) - (progn - (dun-mprincl -"The bear takes the food and runs away with it. He left something behind.") - (dun-remove-obj-from-room dun-current-room obj-bear) - (dun-remove-obj-from-room dun-current-room obj-food) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-key))))) - - (if (and (= objnum obj-jar) (member obj-nitric dun-jar) - (member obj-glycerine dun-jar)) - (progn - (dun-mprincl - "As the jar impacts the ground it explodes into many pieces.") - (setq dun-jar nil) - (dun-remove-obj-from-room dun-current-room obj-jar) - (if (= dun-current-room fourth-vermont-intersection) - (progn - (setq dun-hole t) - (setq dun-current-room vermont-station) - (dun-mprincl -"The explosion causes a hole to open up in the ground, which you fall -through."))))) - - (if (and (= objnum obj-weight) (= dun-current-room maze-button-room)) - (dun-mprincl "A passageway opens."))) - -;;; Give long description of current room, or an object. - -(defun dun-examine (obj) - (let (objnum) - (setq objnum (dun-objnum-from-args obj)) - (if (eq objnum obj-special) - (dun-describe-room (* dun-current-room -1)) - (if (and (eq objnum obj-computer) - (member obj-pc (nth dun-current-room dun-room-silents))) - (dun-examine '("pc")) - (if (eq objnum nil) - (dun-mprincl "I don't know what that is.") - (if (and (not (member objnum - (nth dun-current-room dun-room-objects))) - (not (member objnum - (nth dun-current-room dun-room-silents))) - (not (member objnum dun-inventory))) - (dun-mprincl "I don't see that here.") - (if (>= objnum 0) - (if (and (= objnum obj-bone) - (= dun-current-room marine-life-area) dun-black) - (dun-mprincl -"In this light you can see some writing on the bone. It says: -For an explosive time, go to Fourth St. and Vermont.") - (if (nth objnum dun-physobj-desc) - (dun-mprincl (nth objnum dun-physobj-desc)) - (dun-mprincl "I see nothing special about that."))) - (if (nth (abs objnum) dun-permobj-desc) - (progn - (dun-mprincl (nth (abs objnum) dun-permobj-desc))) - (dun-mprincl "I see nothing special about that."))))))))) - -(defun dun-take (obj) - (if dun-inbus - (dun-mprincl "You can't take anything while on the bus.") - (setq obj (dun-firstword obj)) - (if (not obj) - (dun-mprincl "You must supply an object.") - (if (string= obj "all") - (let (gotsome) - (setq gotsome nil) - (dolist (x (nth dun-current-room dun-room-objects)) - (if (and (>= x 0) (not (= x obj-special))) - (progn - (setq gotsome t) - (dun-mprinc (cadr (nth x dun-objects))) - (dun-mprinc ": ") - (dun-take-object x)))) - (if (not gotsome) - (dun-mprincl "Nothing to take."))) - (let (objnum) - (setq objnum (cdr (assq (intern obj) dun-objnames))) - (if (eq objnum nil) - (progn - (dun-mprinc "I don't know what that is.") - (dun-mprinc "\n")) - (dun-take-object objnum))))))) - -(defun dun-take-object (objnum) - (if (and (member objnum dun-jar) (member obj-jar dun-inventory)) - (let (newjar) - (dun-mprincl "You remove it from the jar.") - (setq newjar nil) - (dolist (x dun-jar) - (if (not (= x objnum)) - (setq newjar (append newjar (list x))))) - (setq dun-jar newjar) - (setq dun-inventory (append dun-inventory (list objnum)))) - (if (not (member objnum (nth dun-current-room dun-room-objects))) - (if (not (member objnum (nth dun-current-room dun-room-silents))) - (dun-mprinc "I do not see that here.") - (dun-try-take objnum)) - (if (>= objnum 0) - (progn - (if (and (car dun-inventory) - (> (+ (dun-inven-weight) (nth objnum dun-object-lbs)) 11)) - (dun-mprinc "Your load would be too heavy.") - (setq dun-inventory (append dun-inventory (list objnum))) - (dun-remove-obj-from-room dun-current-room objnum) - (dun-mprinc "Taken. ") - (if (and (= objnum obj-towel) (= dun-current-room red-room)) - (dun-mprinc - "Taking the towel reveals a hole in the floor.")))) - (dun-try-take objnum))) - (dun-mprinc "\n"))) - -(defun dun-inven-weight () - (let (total) - (setq total 0) - (dolist (x dun-jar) - (setq total (+ total (nth x dun-object-lbs)))) - (dolist (x dun-inventory) - (setq total (+ total (nth x dun-object-lbs)))) total)) - -;;; We try to take an object that is untakable. Print a message -;;; depending on what it is. - -(defun dun-try-take (obj) - (dun-mprinc "You cannot take that.")) - -(defun dun-dig (args) - (if dun-inbus - (dun-mprincl "You can't dig while on the bus.") - (if (not (member 0 dun-inventory)) - (dun-mprincl "You have nothing with which to dig.") - (if (not (nth dun-current-room dun-diggables)) - (dun-mprincl "Digging here reveals nothing.") - (dun-mprincl "I think you found something.") - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (nth dun-current-room dun-diggables))) - (dun-replace dun-diggables dun-current-room nil))))) - -(defun dun-climb (obj) - (let (objnum) - (setq objnum (dun-objnum-from-args obj)) - (cond ((null objnum) - (dun-mprincl "I don't know that name.")) - ((and (not (eq objnum obj-special)) - (not (member objnum (nth dun-current-room dun-room-objects))) - (not (member objnum (nth dun-current-room dun-room-silents))) - (not (member objnum dun-inventory))) - (dun-mprincl "I don't see that here.")) - ((and (eq objnum obj-special) - (not (member obj-tree (nth dun-current-room dun-room-silents)))) - (dun-mprincl "There is nothing here to climb.")) - ((and (not (eq objnum obj-tree)) (not (eq objnum obj-special))) - (dun-mprincl "You can't climb that.")) - (t - (dun-mprincl - "You manage to get about two feet up the tree and fall back down. You -notice that the tree is very unsteady."))))) - -(defun dun-eat (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (member objnum dun-inventory)) - (dun-mprincl "You don't have that.") - (if (not (= objnum obj-food)) - (progn - (dun-mprinc "You forcefully shove ") - (dun-mprinc (downcase (cadr (nth objnum dun-objects)))) - (dun-mprincl " down your throat, and start choking.") - (dun-die "choking")) - (dun-mprincl "That tasted horrible.") - (dun-remove-obj-from-inven obj-food)))))) - -(defun dun-put (args) - (if dun-inbus - (dun-mprincl "You can't do that while on the bus") - (let (newargs objnum objnum2 obj) - (setq newargs (dun-firstwordl args)) - (if (not newargs) - (dun-mprincl "You must supply an object") - (setq obj (intern (car newargs))) - (setq objnum (cdr (assq obj dun-objnames))) - (if (not objnum) - (dun-mprincl "I don't know what that object is.") - (if (not (member objnum dun-inventory)) - (dun-mprincl "You don't have that.") - (setq newargs (dun-firstwordl (cdr newargs))) - (setq newargs (dun-firstwordl (cdr newargs))) - (if (not newargs) - (dun-mprincl "You must supply an indirect object.") - (setq objnum2 (cdr (assq (intern (car newargs)) dun-objnames))) - (if (and (eq objnum2 obj-computer) (= dun-current-room pc-area)) - (setq objnum2 obj-pc)) - (if (not objnum2) - (dun-mprincl "I don't know what that indirect object is.") - (if (and (not (member objnum2 - (nth dun-current-room dun-room-objects))) - (not (member objnum2 - (nth dun-current-room dun-room-silents))) - (not (member objnum2 dun-inventory))) - (dun-mprincl "That indirect object is not here.") - (dun-put-objs objnum objnum2)))))))))) - -(defun dun-put-objs (obj1 obj2) - (if (and (= obj2 obj-drop) (not dun-nomail)) - (setq obj2 obj-chute)) - - (if (= obj2 obj-disposal) (setq obj2 obj-chute)) - - (if (and (= obj1 obj-cpu) (= obj2 obj-computer)) - (progn - (dun-remove-obj-from-inven obj-cpu) - (setq dun-computer t) - (dun-mprincl -"As you put the CPU board in the computer, it immediately springs to life. -The lights start flashing, and the fans seem to startup.")) - (if (and (= obj1 obj-weight) (= obj2 obj-button)) - (dun-drop '("weight")) - (if (= obj2 obj-jar) ;; Put something in jar - (if (not (member obj1 (list obj-paper obj-diamond obj-emerald - obj-license obj-coins obj-egg - obj-nitric obj-glycerine))) - (dun-mprincl "That will not fit in the jar.") - (dun-remove-obj-from-inven obj1) - (setq dun-jar (append dun-jar (list obj1))) - (dun-mprincl "Done.")) - (if (= obj2 obj-chute) ;; Put something in chute - (progn - (dun-remove-obj-from-inven obj1) - (dun-mprincl -"You hear it slide down the chute and off into the distance.") - (dun-put-objs-in-treas (list obj1))) - (if (= obj2 obj-box) ;; Put key in key box - (if (= obj1 obj-key) - (progn - (dun-mprincl -"As you drop the key, the box begins to shake. Finally it explodes -with a bang. The key seems to have vanished!") - (dun-remove-obj-from-inven obj1) - (dun-replace dun-room-objects computer-room (append - (nth computer-room - dun-room-objects) - (list obj1))) - (dun-remove-obj-from-room dun-current-room obj-box) - (setq dun-key-level (1+ dun-key-level))) - (dun-mprincl "You can't put that in the key box!")) - - (if (and (= obj1 obj-floppy) (= obj2 obj-pc)) - (progn - (setq dun-floppy t) - (dun-remove-obj-from-inven obj1) - (dun-mprincl "Done.")) - - (if (= obj2 obj-urinal) ;; Put object in urinal - (progn - (dun-remove-obj-from-inven obj1) - (dun-replace dun-room-objects urinal (append - (nth urinal dun-room-objects) - (list obj1))) - (dun-mprincl - "You hear it plop down in some water below.")) - (if (= obj2 obj-mail) - (dun-mprincl "The mail chute is locked.") - (if (member obj1 dun-inventory) - (dun-mprincl -"I don't know how to combine those objects. Perhaps you should -just try dropping it.") - (dun-mprincl"You can't put that there."))))))))))) - -(defun dun-type (args) - (if (not (= dun-current-room computer-room)) - (dun-mprincl "There is nothing here on which you could type.") - (if (not dun-computer) - (dun-mprincl -"You type on the keyboard, but your characters do not even echo.") - (dun-unix-interface)))) - -;;; Various movement directions - -(defun dun-n (args) - (dun-move north)) - -(defun dun-s (args) - (dun-move south)) - -(defun dun-e (args) - (dun-move east)) - -(defun dun-w (args) - (dun-move west)) - -(defun dun-ne (args) - (dun-move northeast)) - -(defun dun-se (args) - (dun-move southeast)) - -(defun dun-nw (args) - (dun-move northwest)) - -(defun dun-sw (args) - (dun-move southwest)) - -(defun dun-up (args) - (dun-move up)) - -(defun dun-down (args) - (dun-move down)) - -(defun dun-in (args) - (dun-move in)) - -(defun dun-out (args) - (dun-move out)) - -(defun dun-go (args) - (if (or (not (car args)) - (eq (dun-doverb dun-ignore dun-verblist (car args) - (cdr (cdr args))) -1)) - (dun-mprinc "I don't understand where you want me to go.\n"))) - -;;; Uses the dungeon-map to figure out where we are going. If the -;;; requested direction yields 255, we know something special is -;;; supposed to happen, or perhaps you can't go that way unless -;;; certain conditions are met. - -(defun dun-move (dir) - (if (and (not (member dun-current-room dun-light-rooms)) - (not (member obj-lamp dun-inventory))) - (progn - (dun-mprinc -"You trip over a grue and fall into a pit and break every bone in your -body.") - (dun-die "a grue")) - (let (newroom) - (setq newroom (nth dir (nth dun-current-room dungeon-map))) - (if (eq newroom -1) - (dun-mprinc "You can't go that way.\n") - (if (eq newroom 255) - (dun-special-move dir) - (setq room -1) - (setq dun-lastdir dir) - (if dun-inbus - (progn - (if (or (< newroom 58) (> newroom 83)) - (dun-mprincl "The bus cannot go this way.") - (dun-mprincl - "The bus lurches ahead and comes to a screeching halt.") - (dun-remove-obj-from-room dun-current-room obj-bus) - (setq dun-current-room newroom) - (dun-replace dun-room-objects newroom - (append (nth newroom dun-room-objects) - (list obj-bus))))) - (setq dun-current-room newroom))))))) - -;;; Movement in this direction causes something special to happen if the -;;; right conditions exist. It may be that you can't go this way unless -;;; you have a key, or a passage has been opened. - -;;; coding note: Each check of the current room is on the same 'if' level, -;;; i.e. there aren't else's. If two rooms next to each other have -;;; specials, and they are connected by specials, this could cause -;;; a problem. Be careful when adding them to consider this, and -;;; perhaps use else's. - -(defun dun-special-move (dir) - (if (= dun-current-room building-front) - (if (not (member obj-key dun-inventory)) - (dun-mprincl "You don't have a key that can open this door.") - (setq dun-current-room old-building-hallway)) - (if (= dun-current-room north-end-of-cave-passage) - (let (combo) - (dun-mprincl -"You must type a 3 digit combination code to enter this room.") - (dun-mprinc "Enter it here: ") - (setq combo (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (string= combo dun-combination) - (setq dun-current-room gamma-computing-center) - (dun-mprincl "Sorry, that combination is incorrect.")))) - - (if (= dun-current-room bear-hangout) - (if (member obj-bear (nth bear-hangout dun-room-objects)) - (progn - (dun-mprinc -"The bear is very annoyed that you would be so presumptuous as to try -and walk right by it. He tells you so by tearing your head off. -") - (dun-die "a bear")) - (dun-mprincl "You can't go that way."))) - - (if (= dun-current-room vermont-station) - (progn - (dun-mprincl -"As you board the train it immediately leaves the station. It is a very -bumpy ride. It is shaking from side to side, and up and down. You -sit down in one of the chairs in order to be more comfortable.") - (dun-mprincl -"\nFinally the train comes to a sudden stop, and the doors open, and some -force throws you out. The train speeds away.\n") - (setq dun-current-room museum-station))) - - (if (= dun-current-room old-building-hallway) - (if (and (member obj-key dun-inventory) - (> dun-key-level 0)) - (setq dun-current-room meadow) - (dun-mprincl "You don't have a key that can open this door."))) - - (if (and (= dun-current-room maze-button-room) (= dir northwest)) - (if (member obj-weight (nth maze-button-room dun-room-objects)) - (setq dun-current-room 18) - (dun-mprincl "You can't go that way."))) - - (if (and (= dun-current-room maze-button-room) (= dir up)) - (if (member obj-weight (nth maze-button-room dun-room-objects)) - (dun-mprincl "You can't go that way.") - (setq dun-current-room weight-room))) - - (if (= dun-current-room classroom) - (dun-mprincl "The door is locked.")) - - (if (or (= dun-current-room lakefront-north) - (= dun-current-room lakefront-south)) - (dun-swim nil)) - - (if (= dun-current-room reception-area) - (if (not (= dun-sauna-level 3)) - (setq dun-current-room health-club-front) - (dun-mprincl -"As you exit the building, you notice some flames coming out of one of the -windows. Suddenly, the building explodes in a huge ball of fire. The flames -engulf you, and you burn to death.") - (dun-die "burning"))) - - (if (= dun-current-room red-room) - (if (not (member obj-towel (nth red-room dun-room-objects))) - (setq dun-current-room long-n-s-hallway) - (dun-mprincl "You can't go that way."))) - - (if (and (> dir down) (> dun-current-room gamma-computing-center) - (< dun-current-room museum-lobby)) - (if (not (member obj-bus (nth dun-current-room dun-room-objects))) - (dun-mprincl "You can't go that way.") - (if (= dir in) - (if (member obj-license dun-inventory) - (progn - (dun-mprincl - "You board the bus and get in the driver's seat.") - (setq dun-nomail t) - (setq dun-inbus t)) - (dun-mprincl "You are not licensed for this type of vehicle.")) - (dun-mprincl "You hop off the bus.") - (setq dun-inbus nil))) - (if (= dun-current-room fifth-oaktree-intersection) - (if (not dun-inbus) - (progn - (dun-mprincl "You fall down the cliff and land on your head.") - (dun-die "a cliff")) - (dun-mprincl -"The bus flies off the cliff, and plunges to the bottom, where it explodes.") - (dun-die "a bus accident"))) - (if (= dun-current-room main-maple-intersection) - (progn - (if (not dun-inbus) - (dun-mprincl "The gate will not open.") - (dun-mprincl -"As the bus approaches, the gate opens and you drive through.") - (dun-remove-obj-from-room main-maple-intersection obj-bus) - (dun-replace dun-room-objects museum-entrance - (append (nth museum-entrance dun-room-objects) - (list obj-bus))) - (setq dun-current-room museum-entrance))))) - (if (= dun-current-room cave-entrance) - (progn - (dun-mprincl -"As you enter the room you hear a rumbling noise. You look back to see -huge rocks sliding down from the ceiling, and blocking your way out.\n") - (setq dun-current-room misty-room))))) - -(defun dun-long (args) - (setq dun-mode "long")) - -(defun dun-turn (obj) - (let (objnum direction) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (not (= objnum obj-dial)) - (dun-mprincl "You can't turn that.") - (setq direction (dun-firstword (cdr obj))) - (if (or (not direction) - (not (or (string= direction "clockwise") - (string= direction "counterclockwise")))) - (dun-mprincl "You must indicate clockwise or counterclockwise.") - (if (string= direction "clockwise") - (setq dun-sauna-level (+ dun-sauna-level 1)) - (setq dun-sauna-level (- dun-sauna-level 1))) - - (if (< dun-sauna-level 0) - (progn - (dun-mprincl - "The dial will not turn further in that direction.") - (setq dun-sauna-level 0)) - (dun-sauna-heat)))))))) - -(defun dun-sauna-heat () - (if (= dun-sauna-level 0) - (dun-mprincl - "The temperature has returned to normal room temperature.")) - (if (= dun-sauna-level 1) - (dun-mprincl "It is now luke warm in here. You begin to sweat.")) - (if (= dun-sauna-level 2) - (dun-mprincl "It is pretty hot in here. It is still very comfortable.")) - (if (= dun-sauna-level 3) - (progn - (dun-mprincl -"It is now very hot. There is something very refreshing about this.") - (if (or (member obj-rms dun-inventory) - (member obj-rms (nth dun-current-room dun-room-objects))) - (progn - (dun-mprincl -"You notice the wax on your statuette beginning to melt, until it completely -melts off. You are left with a beautiful diamond!") - (if (member obj-rms dun-inventory) - (progn - (dun-remove-obj-from-inven obj-rms) - (setq dun-inventory (append dun-inventory - (list obj-diamond)))) - (dun-remove-obj-from-room dun-current-room obj-rms) - (dun-replace dun-room-objects dun-current-room - (append (nth dun-current-room dun-room-objects) - (list obj-diamond)))))) - (if (or (member obj-floppy dun-inventory) - (member obj-floppy (nth dun-current-room dun-room-objects))) - (progn - (dun-mprincl -"You notice your floppy disk beginning to melt. As you grab for it, the -disk bursts into flames, and disintegrates.") - (if (member obj-floppy dun-inventory) - (dun-remove-obj-from-inven obj-floppy) - (dun-remove-obj-from-room dun-current-room obj-floppy)))))) - - (if (= dun-sauna-level 4) - (progn - (dun-mprincl -"As the dial clicks into place, you immediately burst into flames.") - (dun-die "burning")))) - -(defun dun-press (obj) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (not (member objnum (list obj-button obj-switch))) - (progn - (dun-mprinc "You can't ") - (dun-mprinc (car line-list)) - (dun-mprincl " that.")) - (if (= objnum obj-button) - (dun-mprincl -"As you press the button, you notice a passageway open up, but -as you release it, the passageway closes.")) - (if (= objnum obj-switch) - (if dun-black - (progn - (dun-mprincl "The button is now in the off position.") - (setq dun-black nil)) - (dun-mprincl "The button is now in the on position.") - (setq dun-black t)))))))) - -(defun dun-swim (args) - (if (not (member dun-current-room (list lakefront-north lakefront-south))) - (dun-mprincl "I see no water!") - (if (not (member obj-life dun-inventory)) - (progn - (dun-mprincl -"You dive in the water, and at first notice it is quite cold. You then -start to get used to it as you realize that you never really learned how -to swim.") - (dun-die "drowning")) - (if (= dun-current-room lakefront-north) - (setq dun-current-room lakefront-south) - (setq dun-current-room lakefront-north))))) - - -(defun dun-score (args) - (if (not dun-endgame) - (let (total) - (setq total (dun-reg-score)) - (dun-mprinc "You have scored ") - (dun-mprinc total) - (dun-mprincl " out of a possible 90 points.") total) - (dun-mprinc "You have scored ") - (dun-mprinc (dun-endgame-score)) - (dun-mprincl " endgame points out of a possible 110.") - (if (= (dun-endgame-score) 110) - (dun-mprincl -"\n\nCongratulations. You have won. The wizard password is 'moby'")))) - -(defun dun-help (args) - (dun-mprincl -"Welcome to dunnet (2.0), by Ron Schnell (ronnie@media.mit.edu). -Here is some useful information (read carefully because there are one -or more clues in here): -- If you have a key that can open a door, you do not need to explicitly - open it. You may just use 'in' or walk in the direction of the door. - -- If you have a lamp, it is always lit. - -- You will not get any points until you manage to get treasures to a certain - place. Simply finding the treasures is not good enough. There is more - than one way to get a treasure to the special place. It is also - important that the objects get to the special place *unharmed* and - *untarnished*. You can tell if you have successfully transported the - object by looking at your score, as it changes immediately. Note that - an object can become harmed even after you have received points for it. - If this happens, your score will decrease, and in many cases you can never - get credit for it again. - -- You can save your game with the 'save' command, and use restore it - with the 'restore' command. - -- There are no limits on lengths of object names. - -- Directions are: north,south,east,west,northeast,southeast,northwest, - southwest,up,down,in,out. - -- These can be abbreviated: n,s,e,w,ne,se,nw,sw,u,d,in,out. - -- If you go down a hole in the floor without an aid such as a ladder, - you probably won't be able to get back up the way you came, if at all. - -- To run this game in batch mode (no emacs window), use: - emacs -batch -l dunnet - -If you have questions or comments, please contact ronnie@media.mit.edu.")) - -(defun dun-flush (args) - (if (not (= dun-current-room bathroom)) - (dun-mprincl "I see nothing to flush.") - (dun-mprincl "Whoooosh!!") - (dun-put-objs-in-treas (nth urinal dun-room-objects)) - (dun-replace dun-room-objects urinal nil))) - -(defun dun-piss (args) - (if (not (= dun-current-room bathroom)) - (dun-mprincl "You can't do that here, don't even bother trying.") - (if (not dun-gottago) - (dun-mprincl "I'm afraid you don't have to go now.") - (dun-mprincl "That was refreshing.") - (setq dun-gottago nil) - (dun-replace dun-room-objects urinal (append - (nth urinal dun-room-objects) - (list obj-URINE)))))) - - -(defun dun-sleep (args) - (if (not (= dun-current-room bedroom)) - (dun-mprincl -"You try to go to sleep while standing up here, but can't seem to do it.") - (setq dun-gottago t) - (dun-mprincl -"As soon as you start to doze off you begin dreaming. You see images of -workers digging caves, slaving in the humid heat. Then you see yourself -as one of these workers. While no one is looking, you leave the group -and walk into a room. The room is bare except for a horseshoe -shaped piece of stone in the center. You see yourself digging a hole in -the ground, then putting some kind of treasure in it, and filling the hole -with dirt again. After this, you immediately wake up."))) - -(defun dun-break (obj) - (let (objnum) - (if (not (member obj-axe dun-inventory)) - (dun-mprincl "You have nothing you can use to break things.") - (when (setq objnum (dun-objnum-from-args-std obj)) - (if (member objnum dun-inventory) - (progn - (dun-mprincl -"You take the object in your hands and swing the axe. Unfortunately, you miss -the object and slice off your hand. You bleed to death.") - (dun-die "an axe")) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum - (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (if (= objnum obj-cable) - (progn - (dun-mprincl -"As you break the ethernet cable, everything starts to blur. You collapse -for a moment, then straighten yourself up. -") - (dun-replace dun-room-objects gamma-computing-center - (append - (nth gamma-computing-center dun-room-objects) - dun-inventory)) - (if (member obj-key dun-inventory) - (progn - (setq dun-inventory (list obj-key)) - (dun-remove-obj-from-room - gamma-computing-center obj-key)) - (setq dun-inventory nil)) - (setq dun-current-room computer-room) - (setq dun-ethernet nil) - (dun-mprincl "Connection closed.") - (dun-unix-interface)) - (if (< objnum 0) - (progn - (dun-mprincl "Your axe shatters into a million pieces.") - (dun-remove-obj-from-inven obj-axe)) - (dun-mprincl "Your axe breaks it into a million pieces.") - (dun-remove-obj-from-room dun-current-room objnum))))))))) - -(defun dun-drive (args) - (if (not dun-inbus) - (dun-mprincl "You cannot drive when you aren't in a vehicle.") - (dun-mprincl "To drive while you are in the bus, just give a direction."))) - -(defun dun-superb (args) - (setq dun-mode 'dun-superb)) - -(defun dun-reg-score () - (let (total) - (setq total 0) - (dolist (x (nth treasure-room dun-room-objects)) - (setq total (+ total (nth x dun-object-pts)))) - (if (member obj-URINE (nth treasure-room dun-room-objects)) - (setq total 0)) total)) - -(defun dun-endgame-score () - (let (total) - (setq total 0) - (dolist (x (nth endgame-treasure-room dun-room-objects)) - (setq total (+ total (nth x dun-object-pts)))) total)) - -(defun dun-answer (args) - (if (not dun-correct-answer) - (dun-mprincl "I don't believe anyone asked you anything.") - (setq args (car args)) - (if (not args) - (dun-mprincl "You must give the answer on the same line.") - (if (dun-members args dun-correct-answer) - (progn - (dun-mprincl "Correct.") - (if (= dun-lastdir 0) - (setq dun-current-room (1+ dun-current-room)) - (setq dun-current-room (- dun-current-room 1))) - (setq dun-correct-answer nil)) - (dun-mprincl "That answer is incorrect."))))) - -(defun dun-endgame-question () -(if (not dun-endgame-questions) - (progn - (dun-mprincl "Your question is:") - (dun-mprincl "No more questions, just do 'answer foo'.") - (setq dun-correct-answer '("foo"))) - (let (which i newques) - (setq i 0) - (setq newques nil) - (setq which (random (length dun-endgame-questions))) - (dun-mprincl "Your question is:") - (dun-mprincl (setq dun-endgame-question (car - (nth which - dun-endgame-questions)))) - (setq dun-correct-answer (cdr (nth which dun-endgame-questions))) - (while (< i which) - (setq newques (append newques (list (nth i dun-endgame-questions)))) - (setq i (1+ i))) - (setq i (1+ which)) - (while (< i (length dun-endgame-questions)) - (setq newques (append newques (list (nth i dun-endgame-questions)))) - (setq i (1+ i))) - (setq dun-endgame-questions newques)))) - -(defun dun-power (args) - (if (not (= dun-current-room pc-area)) - (dun-mprincl "That operation is not applicable here.") - (if (not dun-floppy) - (dun-dos-no-disk) - (dun-dos-interface)))) - -(defun dun-feed (args) - (let (objnum) - (when (setq objnum (dun-objnum-from-args-std args)) - (if (and (= objnum obj-bear) - (member obj-bear (nth dun-current-room dun-room-objects))) - (progn - (if (not (member obj-food dun-inventory)) - (dun-mprincl "You have nothing with which to feed it.") - (dun-drop '("food")))) - (if (not (or (member objnum (nth dun-current-room dun-room-objects)) - (member objnum dun-inventory) - (member objnum (nth dun-current-room dun-room-silents)))) - (dun-mprincl "I don't see that here.") - (dun-mprincl "You cannot feed that.")))))) - - -;;;; -;;;; This section defines various utility functions used -;;;; by dunnet. -;;;; - - -;;; Function which takes a verb and a list of other words. Calls proper -;;; function associated with the verb, and passes along the other words. - -(defun dun-doverb (dun-ignore dun-verblist verb rest) - (if (not verb) - nil - (if (member (intern verb) dun-ignore) - (if (not (car rest)) -1 - (dun-doverb dun-ignore dun-verblist (car rest) (cdr rest))) - (if (not (cdr (assq (intern verb) dun-verblist))) -1 - (setq dun-numcmds (1+ dun-numcmds)) - (eval (list (cdr (assq (intern verb) dun-verblist)) (quote rest))))))) - - -;;; Function to take a string and change it into a list of lowercase words. - -(defun dun-listify-string (strin) - (let (pos ret-list end-pos) - (setq pos 0) - (setq ret-list nil) - (while (setq end-pos (string-match "[ ,:;]" (substring strin pos))) - (setq end-pos (+ end-pos pos)) - (if (not (= end-pos pos)) - (setq ret-list (append ret-list (list - (downcase - (substring strin pos end-pos)))))) - (setq pos (+ end-pos 1))) ret-list)) - -(defun dun-listify-string2 (strin) - (let (pos ret-list end-pos) - (setq pos 0) - (setq ret-list nil) - (while (setq end-pos (string-match " " (substring strin pos))) - (setq end-pos (+ end-pos pos)) - (if (not (= end-pos pos)) - (setq ret-list (append ret-list (list - (downcase - (substring strin pos end-pos)))))) - (setq pos (+ end-pos 1))) ret-list)) - -(defun dun-replace (list n number) - (rplaca (nthcdr n list) number)) - - -;;; Get the first non-ignored word from a list. - -(defun dun-firstword (list) - (if (not (car list)) - nil - (while (and list (member (intern (car list)) dun-ignore)) - (setq list (cdr list))) - (car list))) - -(defun dun-firstwordl (list) - (if (not (car list)) - nil - (while (and list (member (intern (car list)) dun-ignore)) - (setq list (cdr list))) - list)) - -;;; parse a line passed in as a string Call the proper verb with the -;;; rest of the line passed in as a list. - -(defun dun-vparse (dun-ignore dun-verblist line) - (dun-mprinc "\n") - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-parse2 (dun-ignore dun-verblist line) - (dun-mprinc "\n") - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -;;; Read a line, in window mode - -(defun dun-read-line () - (let (line) - (setq line (read-string "")) - (dun-mprinc line) line)) - -;;; Insert something into the window buffer - -(defun dun-minsert (string) - (if (stringp string) - (insert string) - (insert (prin1-to-string string)))) - -;;; Print something out, in window mode - -(defun dun-mprinc (string) - (if (stringp string) - (insert string) - (insert (prin1-to-string string)))) - -;;; In window mode, keep screen from jumping by keeping last line at -;;; the bottom of the screen. - -(defun dun-fix-screen () - (interactive) - (forward-line (- 0 (- (window-height) 2 ))) - (set-window-start (selected-window) (point)) - (end-of-buffer)) - -;;; Insert something into the buffer, followed by newline. - -(defun dun-minsertl (string) - (dun-minsert string) - (dun-minsert "\n")) - -;;; Print something, followed by a newline. - -(defun dun-mprincl (string) - (dun-mprinc string) - (dun-mprinc "\n")) - -;;; Function which will get an object number given the list of -;;; words in the command, except for the verb. - -(defun dun-objnum-from-args (obj) - (let (objnum) - (setq obj (dun-firstword obj)) - (if (not obj) - obj-special - (setq objnum (cdr (assq (intern obj) dun-objnames)))))) - -(defun dun-objnum-from-args-std (obj) - (let (result) - (if (eq (setq result (dun-objnum-from-args obj)) obj-special) - (dun-mprincl "You must supply an object.")) - (if (eq result nil) - (dun-mprincl "I don't know what that is.")) - (if (eq result obj-special) - nil - result))) - -;;; Take a short room description, and change spaces and slashes to dashes. - -(defun dun-space-to-hyphen (string) - (let (space) - (if (setq space (string-match "[ /]" string)) - (progn - (setq string (concat (substring string 0 space) "-" - (substring string (1+ space)))) - (dun-space-to-hyphen string)) - string))) - -;;; Given a unix style pathname, build a list of path components (recursive) - -(defun dun-get-path (dirstring startlist) - (let (slash pos) - (if (= (length dirstring) 0) - startlist - (if (string= (substring dirstring 0 1) "/") - (dun-get-path (substring dirstring 1) (append startlist (list "/"))) - (if (not (setq slash (string-match "/" dirstring))) - (append startlist (list dirstring)) - (dun-get-path (substring dirstring (1+ slash)) - (append startlist - (list (substring dirstring 0 slash))))))))) - - -;;; Is a string a member of a string list? - -(defun dun-members (string string-list) - (let (found) - (setq found nil) - (dolist (x string-list) - (if (string= x string) - (setq found t))) found)) - -;;; Function to put objects in the treasure room. Also prints current -;;; score to let user know he has scored. - -(defun dun-put-objs-in-treas (objlist) - (let (oscore newscore) - (setq oscore (dun-reg-score)) - (dun-replace dun-room-objects 0 (append (nth 0 dun-room-objects) objlist)) - (setq newscore (dun-reg-score)) - (if (not (= oscore newscore)) - (dun-score nil)))) - -;;; Load an encrypted file, and eval it. - -(defun dun-load-d (filename) - (let (old-buffer result) - (setq result t) - (setq old-buffer (current-buffer)) - (switch-to-buffer (get-buffer-create "*loadc*")) - (erase-buffer) - (condition-case nil - (insert-file-contents filename) - (error (setq result nil))) - (unless (not result) - (condition-case nil - (dun-rot13) - (error (yank))) - (eval-current-buffer) - (kill-buffer (current-buffer)) - (switch-to-buffer old-buffer)) - result)) - -;;; Functions to remove an object either from a room, or from inventory. - -(defun dun-remove-obj-from-room (room objnum) - (let (newroom) - (setq newroom nil) - (dolist (x (nth room dun-room-objects)) - (if (not (= x objnum)) - (setq newroom (append newroom (list x))))) - (rplaca (nthcdr room dun-room-objects) newroom))) - -(defun dun-remove-obj-from-inven (objnum) - (let (new-inven) - (setq new-inven nil) - (dolist (x dun-inventory) - (if (not (= x objnum)) - (setq new-inven (append new-inven (list x))))) - (setq dun-inventory new-inven))) - - -(let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (setq dun-translate-table (make-vector 256 0)) - (while (< i 256) - (aset dun-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower)) - (setq upper (upcase lower)) - (setq i 0) - (while (< i 26) - (aset dun-translate-table (+ ?a i) (aref lower (+ i 13))) - (aset dun-translate-table (+ ?A i) (aref upper (+ i 13))) - (setq i (1+ i)))) - -(defun dun-rot13 () - (let (str len (i 0)) - (setq str (buffer-substring (point-min) (point-max))) - (setq len (length str)) - (while (< i len) - (aset str i (aref dun-translate-table (aref str i))) - (setq i (1+ i))) - (erase-buffer) - (insert str))) - -;;;; -;;;; This section defines the globals that are used in dunnet. -;;;; -;;;; IMPORTANT -;;;; All globals which can change must be saved from 'save-game. Add -;;;; all new globals to bottom of file. - -(setq dun-visited '(27)) -(setq dun-current-room 1) -(setq dun-exitf nil) -(setq dun-badcd nil) -(defvar dungeon-mode-map nil) -(setq dungeon-mode-map (make-sparse-keymap)) -(define-key dungeon-mode-map "\r" 'dun-parse) -;; XEmacs -(defvar dungeon-batch-map - (let ((map (make-keymap)) - (n 32)) - (while (< 0 (setq n (- n 1))) - (define-key map (make-string 1 n) 'dungeon-nil)) - (define-key map "\r" 'exit-minibuffer) - (define-key map "\n" 'exit-minibuffer) - map)) -(setq dun-computer nil) -(setq dun-floppy nil) -(setq dun-key-level 0) -(setq dun-hole nil) -(setq dun-correct-answer nil) -(setq dun-lastdir 0) -(setq dun-numsaves 0) -(setq dun-jar nil) -(setq dun-dead nil) -(setq room 0) -(setq dun-numcmds 0) -(setq dun-wizard nil) -(setq dun-endgame-question nil) -(setq dun-logged-in nil) -(setq dungeon-mode 'dungeon) -(setq dun-unix-verbs '((ls . dun-ls) (ftp . dun-ftp) (echo . dun-echo) - (exit . dun-uexit) (cd . dun-cd) (pwd . dun-pwd) - (rlogin . dun-rlogin) (uncompress . dun-uncompress) - (cat . dun-cat) (zippy . dun-zippy))) - -(setq dun-dos-verbs '((dir . dun-dos-dir) (type . dun-dos-type) - (exit . dun-dos-exit) (command . dun-dos-spawn) - (b: . dun-dos-invd) (c: . dun-dos-invd) - (a: . dun-dos-nil))) - - -(setq dun-batch-mode nil) - -(setq dun-cdpath "/usr/toukmond") -(setq dun-cdroom -10) -(setq dun-uncompressed nil) -(setq dun-ethernet t) -(setq dun-restricted - '(dun-room-objects dungeon-map dun-rooms - dun-room-silents dun-combination)) -(setq dun-ftptype 'ascii) -(setq dun-endgame nil) -(setq dun-gottago t) -(setq dun-black nil) - -(setq dun-rooms '( - ( -"You are in the treasure room. A door leads out to the north." - "Treasure room" - ) - ( -"You are at a dead end of a dirt road. The road goes to the east. -In the distance you can see that it will eventually fork off. The -trees here are very tall royal palms, and they are spaced equidistant -from each other." - "Dead end" - ) - ( -"You are on the continuation of a dirt road. There are more trees on -both sides of you. The road continues to the east and west." - "E/W Dirt road" - ) - ( -"You are at a fork of two passages, one to the northeast, and one to the -southeast. The ground here seems very soft. You can also go back west." - "Fork" - ) - ( -"You are on a northeast/southwest road." - "NE/SW road" - ) - ( -"You are at the end of the road. There is a building in front of you -to the northeast, and the road leads back to the southwest." - "Building front" - ) - ( -"You are on a southeast/northwest road." - "SE/NW road" - ) - ( -"You are standing at the end of a road. A passage leads back to the -northwest." - "Bear hangout" - ) - ( -"You are in the hallway of an old building. There are rooms to the east -and west, and doors leading out to the north and south." - "Old Building hallway" - ) - ( -"You are in a mailroom. There are many bins where the mail is usually -kept. The exit is to the west." - "Mailroom" - ) - ( -"You are in a computer room. It seems like most of the equipment has -been removed. There is a VAX 11/780 in front of you, however, with -one of the cabinets wide open. A sign on the front of the machine -says: This VAX is named 'pokey'. To type on the console, use the -'type' command. The exit is to the east." - "Computer room" - ) - ( -"You are in a meadow in the back of an old building. A small path leads -to the west, and a door leads to the south." - "Meadow" - ) - ( -"You are in a round, stone room with a door to the east. There -is a sign on the wall that reads: 'receiving room'." - "Receiving room" - ) - ( -"You are at the south end of a hallway that leads to the north. There -are rooms to the east and west." - "Northbound Hallway" - ) - ( -"You are in a sauna. There is nothing in the room except for a dial -on the wall. A door leads out to west." - "Sauna" - ) - ( -"You are at the end of a north/south hallway. You can go back to the south, -or off to a room to the east." - "End of N/S Hallway" - ) - ( -"You are in an old weight room. All of the equipment is either destroyed -or completely broken. There is a door out to the west, and there is a ladder -leading down a hole in the floor." - "Weight room" ;16 - ) - ( -"You are in a maze of twisty little passages, all alike. -There is a button on the ground here." - "Maze button room" - ) - ( -"You are in a maze of little twisty passages, all alike." - "Maze" - ) - ( -"You are in a maze of thirsty little passages, all alike." - "Maze" ;19 - ) - ( -"You are in a maze of twenty little passages, all alike." - "Maze" - ) - ( -"You are in a daze of twisty little passages, all alike." - "Maze" ;21 - ) - ( -"You are in a maze of twisty little cabbages, all alike." - "Maze" ;22 - ) - ( -"You are in a reception area for a health and fitness center. The place -appears to have been recently ransacked, and nothing is left. There is -a door out to the south, and a crawlspace to the southeast." - "Reception area" - ) - ( -"You are outside a large building to the north which used to be a health -and fitness center. A road leads to the south." - "Health Club front" - ) - ( -"You are at the north side of a lake. On the other side you can see -a road which leads to a cave. The water appears very deep." - "Lakefront North" - ) - ( -"You are at the south side of a lake. A road goes to the south." - "Lakefront South" - ) - ( -"You are in a well-hidden area off to the side of a road. Back to the -northeast through the brush you can see the bear hangout." - "Hidden area" - ) - ( -"The entrance to a cave is to the south. To the north, a road leads -towards a deep lake. On the ground nearby there is a chute, with a sign -that says 'put treasures here for points'." - "Cave Entrance" ;28 - ) - ( -"You are in a misty, humid room carved into a mountain. -To the north is the remains of a rockslide. To the east, a small -passage leads away into the darkness." ;29 - "Misty Room" - ) - ( -"You are in an east/west passageway. The walls here are made of -multicolored rock and are quite beautiful." - "Cave E/W passage" ;30 - ) - ( -"You are at the junction of two passages. One goes north/south, and -the other goes west." - "N/S/W Junction" ;31 - ) - ( -"You are at the north end of a north/south passageway. There are stairs -leading down from here. There is also a door leading west." - "North end of cave passage" ;32 - ) - ( -"You are at the south end of a north/south passageway. There is a hole -in the floor here, into which you could probably fit." - "South end of cave passage" ;33 - ) - ( -"You are in what appears to be a worker's bedroom. There is a queen- -sized bed in the middle of the room, and a painting hanging on the -wall. A door leads to another room to the south, and stairways -lead up and down." - "Bedroom" ;34 - ) - ( -"You are in a bathroom built for workers in the cave. There is a -urinal hanging on the wall, and some exposed pipes on the opposite -wall where a sink used to be. To the north is a bedroom." - "Bathroom" ;35 - ) - ( -"This is a marker for the urinal. User will not see this, but it -is a room that can contain objects." - "Urinal" ;36 - ) - ( -"You are at the northeast end of a northeast/southwest passageway. -Stairs lead up out of sight." - "Ne end of ne/sw cave passage" ;37 - ) - ( -"You are at the junction of northeast/southwest and east/west passages." - "Ne/sw-e/w junction" ;38 - ) - ( -"You are at the southwest end of a northeast/southwest passageway." - "Sw end of ne/sw cave passage" ;39 - ) - ( -"You are at the east end of an e/w passage. There are stairs leading up -to a room above." - "East end of e/w cave passage" ;40 - ) - ( -"You are at the west end of an e/w passage. There is a hole on the ground -which leads down out of sight." - "West end of e/w cave passage" ;41 - ) - ( -"You are in a room which is bare, except for a horseshoe shaped boulder -in the center. Stairs lead down from here." ;42 - "Horseshoe boulder room" - ) - ( -"You are in a room which is completely empty. Doors lead out to the north -and east." - "Empty room" ;43 - ) - ( -"You are in an empty room. Interestingly enough, the stones in this -room are painted blue. Doors lead out to the east and south." ;44 - "Blue room" - ) - ( -"You are in an empty room. Interestingly enough, the stones in this -room are painted yellow. Doors lead out to the south and west." ;45 - "Yellow room" - ) - ( -"You are in an empty room. Interestingly enough, the stones in this room -are painted red. Doors lead out to the west and north." - "Red room" ;46 - ) - ( -"You are in the middle of a long north/south hallway." ;47 - "Long n/s hallway" - ) - ( -"You are 3/4 of the way towards the north end of a long north/south hallway." - "3/4 north" ;48 - ) - ( -"You are at the north end of a long north/south hallway. There are stairs -leading upwards." - "North end of long hallway" ;49 - ) - ( -"You are 3/4 of the way towards the south end of a long north/south hallway." - "3/4 south" ;50 - ) - ( -"You are at the south end of a long north/south hallway. There is a hole -to the south." - "South end of long hallway" ;51 - ) - ( -"You are at a landing in a stairwell which continues up and down." - "Stair landing" ;52 - ) - ( -"You are at the continuation of an up/down staircase." - "Up/down staircase" ;53 - ) - ( -"You are at the top of a staircase leading down. A crawlway leads off -to the northeast." - "Top of staircase." ;54 - ) - ( -"You are in a crawlway that leads northeast or southwest." - "Ne crawlway" ;55 - ) - ( -"You are in a small crawlspace. There is a hole in the ground here, and -a small passage back to the southwest." - "Small crawlspace" ;56 - ) - ( -"You are in the Gamma Computing Center. An IBM 3090/600s is whirring -away in here. There is an ethernet cable coming out of one of the units, -and going through the ceiling. There is no console here on which you -could type." - "Gamma computing center" ;57 - ) - ( -"You are near the remains of a post office. There is a mail drop on the -face of the building, but you cannot see where it leads. A path leads -back to the east, and a road leads to the north." - "Post office" ;58 - ) - ( -"You are at the intersection of Main Street and Maple Ave. Main street -runs north and south, and Maple Ave runs east off into the distance. -If you look north and east you can see many intersections, but all of -the buildings that used to stand here are gone. Nothing remains except -street signs. -There is a road to the northwest leading to a gate that guards a building." - "Main-Maple intersection" ;59 - ) - ( -"You are at the intersection of Main Street and the west end of Oaktree Ave." - "Main-Oaktree intersection" ;60 - ) - ( -"You are at the intersection of Main Street and the west end of Vermont Ave." - "Main-Vermont intersection" ;61 - ) - ( -"You are at the north end of Main Street at the west end of Sycamore Ave." ;62 - "Main-Sycamore intersection" - ) - ( -"You are at the south end of First Street at Maple Ave." ;63 - "First-Maple intersection" - ) - ( -"You are at the intersection of First Street and Oaktree Ave." ;64 - "First-Oaktree intersection" - ) - ( -"You are at the intersection of First Street and Vermont Ave." ;65 - "First-Vermont intersection" - ) - ( -"You are at the north end of First Street at Sycamore Ave." ;66 - "First-Sycamore intersection" - ) - ( -"You are at the south end of Second Street at Maple Ave." ;67 - "Second-Maple intersection" - ) - ( -"You are at the intersection of Second Street and Oaktree Ave." ;68 - "Second-Oaktree intersection" - ) - ( -"You are at the intersection of Second Street and Vermont Ave." ;69 - "Second-Vermont intersection" - ) - ( -"You are at the north end of Second Street at Sycamore Ave." ;70 - "Second-Sycamore intersection" - ) - ( -"You are at the south end of Third Street at Maple Ave." ;71 - "Third-Maple intersection" - ) - ( -"You are at the intersection of Third Street and Oaktree Ave." ;72 - "Third-Oaktree intersection" - ) - ( -"You are at the intersection of Third Street and Vermont Ave." ;73 - "Third-Vermont intersection" - ) - ( -"You are at the north end of Third Street at Sycamore Ave." ;74 - "Third-Sycamore intersection" - ) - ( -"You are at the south end of Fourth Street at Maple Ave." ;75 - "Fourth-Maple intersection" - ) - ( -"You are at the intersection of Fourth Street and Oaktree Ave." ;76 - "Fourth-Oaktree intersection" - ) - ( -"You are at the intersection of Fourth Street and Vermont Ave." ;77 - "Fourth-Vermont intersection" - ) - ( -"You are at the north end of Fourth Street at Sycamore Ave." ;78 - "Fourth-Sycamore intersection" - ) - ( -"You are at the south end of Fifth Street at the east end of Maple Ave." ;79 - "Fifth-Maple intersection" - ) - ( -"You are at the intersection of Fifth Street and the east end of Oaktree Ave. -There is a cliff off to the east." - "Fifth-Oaktree intersection" ;80 - ) - ( -"You are at the intersection of Fifth Street and the east end of Vermont Ave." - "Fifth-Vermont intersection" ;81 - ) - ( -"You are at the north end of Fifth Street and the east end of Sycamore Ave." - "Fifth-Sycamore intersection" ;82 - ) - ( -"You are in front of the Museum of Natural History. A door leads into -the building to the north, and a road leads to the southeast." - "Museum entrance" ;83 - ) - ( -"You are in the main lobby for the Museum of Natural History. In the center -of the room is the huge skeleton of a dinosaur. Doors lead out to the -south and east." - "Museum lobby" ;84 - ) - ( -"You are in the geological display. All of the objects that used to -be on display are missing. There are rooms to the east, west, and -north." - "Geological display" ;85 - ) - ( -"You are in the marine life area. The room is filled with fish tanks, -which are filled with dead fish that have apparently died due to -starvation. Doors lead out to the south and east." - "Marine life area" ;86 - ) - ( -"You are in some sort of maintenance room for the museum. There is a -switch on the wall labeled 'BL'. There are doors to the west and north." - "Maintenance room" ;87 - ) - ( -"You are in a classroom where school children were taught about natural -history. On the blackboard is written, 'No children allowed downstairs.' -There is a door to the east with an 'exit' sign on it. There is another -door to the west." - "Classroom" ;88 - ) - ( -"You are at the Vermont St. subway station. A train is sitting here waiting." - "Vermont station" ;89 - ) - ( -"You are at the Museum subway stop. A passage leads off to the north." - "Museum station" ;90 - ) - ( -"You are in a north/south tunnel." - "N/S tunnel" ;91 - ) - ( -"You are at the north end of a north/south tunnel. Stairs lead up and -down from here. There is a garbage disposal here." - "North end of n/s tunnel" ;92 - ) - ( -"You are at the top of some stairs near the subway station. There is -a door to the west." - "Top of subway stairs" ;93 - ) - ( -"You are at the bottom of some stairs near the subway station. There is -a room to the northeast." - "Bottom of subway stairs" ;94 - ) - ( -"You are in another computer room. There is a computer in here larger -than you have ever seen. It has no manufacturers name on it, but it -does have a sign that says: This machine's name is 'endgame'. The -exit is to the southwest. There is no console here on which you could -type." - "Endgame computer room" ;95 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;96 - ) - ( -"You have reached a question room. You must answer a question correctly in -order to get by. Use the 'answer' command to answer the question." - "Question room 1" ;97 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;98 - ) - ( -"You are in a second question room." - "Question room 2" ;99 - ) - ( -"You are in a north/south hallway." - "Endgame n/s hallway" ;100 - ) - ( -"You are in a third question room." - "Question room 3" ;101 - ) - ( -"You are in the endgame treasure room. A door leads out to the north, and -a hallway leads to the south." - "Endgame treasure room" ;102 - ) - ( -"You are in the winner's room. A door leads back to the south." - "Winner's room" ;103 - ) - ( -"You have reached a dead end. There is a PC on the floor here. Above -it is a sign that reads: - Type the 'reset' command to type on the PC. -A hole leads north." - "PC area" ;104 - ) -)) - -(setq dun-light-rooms '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 24 25 26 27 28 58 59 - 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 - 77 78 79 80 81 82 83)) - -(setq dun-verblist '((die . dun-die) (ne . dun-ne) (north . dun-n) - (south . dun-s) (east . dun-e) (west . dun-w) - (u . dun-up) (d . dun-down) (i . dun-inven) - (inventory . dun-inven) (look . dun-examine) (n . dun-n) - (s . dun-s) (e . dun-e) (w . dun-w) (se . dun-se) - (nw . dun-nw) (sw . dun-sw) (up . dun-up) - (down . dun-down) (in . dun-in) (out . dun-out) - (go . dun-go) (drop . dun-drop) (southeast . dun-se) - (southwest . dun-sw) (northeast . dun-ne) - (northwest . dun-nw) (save . dun-save-game) - (restore . dun-restore) (long . dun-long) (dig . dun-dig) - (shake . dun-shake) (wave . dun-shake) - (examine . dun-examine) (describe . dun-examine) - (climb . dun-climb) (eat . dun-eat) (put . dun-put) - (type . dun-type) (insert . dun-put) - (score . dun-score) (help . dun-help) (quit . dun-quit) - (read . dun-examine) (verbose . dun-long) - (urinate . dun-piss) (piss . dun-piss) ; censored - (flush . dun-flush) (sleep . dun-sleep) (lie . dun-sleep) - (x . dun-examine) (break . dun-break) (drive . dun-drive) - (board . dun-in) (enter . dun-in) (turn . dun-turn) - (press . dun-press) (push . dun-press) (swim . dun-swim) - (on . dun-in) (off . dun-out) (chop . dun-break) - (switch . dun-press) (cut . dun-break) (exit . dun-out) - (leave . dun-out) (reset . dun-power) (flick . dun-press) - (superb . dun-superb) (answer . dun-answer) - (throw . dun-drop) (l . dun-examine) (take . dun-take) - (get . dun-take) (feed . dun-feed))) - -(setq dun-inbus nil) -(setq dun-nomail nil) -(setq dun-ignore '(the to at)) -(setq dun-mode 'moby) -(setq dun-sauna-level 0) - -(defconst north 0) -(defconst south 1) -(defconst east 2) -(defconst west 3) -(defconst northeast 4) -(defconst southeast 5) -(defconst northwest 6) -(defconst southwest 7) -(defconst up 8) -(defconst down 9) -(defconst in 10) -(defconst out 11) - -(setq dungeon-map '( -; no so ea we ne se nw sw up do in ot - ( 96 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;0 - ( -1 -1 2 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;1 - ( -1 -1 3 1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;2 - ( -1 -1 -1 2 4 6 -1 -1 -1 -1 -1 -1 ) ;3 - ( -1 -1 -1 -1 5 -1 -1 3 -1 -1 -1 -1 ) ;4 - ( -1 -1 -1 -1 255 -1 -1 4 -1 -1 255 -1 ) ;5 - ( -1 -1 -1 -1 -1 7 3 -1 -1 -1 -1 -1 ) ;6 - ( -1 -1 -1 -1 -1 255 6 27 -1 -1 -1 -1 ) ;7 - ( 255 5 9 10 -1 -1 -1 5 -1 -1 -1 5 ) ;8 - ( -1 -1 -1 8 -1 -1 -1 -1 -1 -1 -1 -1 ) ;9 - ( -1 -1 8 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;10 - ( -1 8 -1 58 -1 -1 -1 -1 -1 -1 -1 -1 ) ;11 - ( -1 -1 13 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;12 - ( 15 -1 14 12 -1 -1 -1 -1 -1 -1 -1 -1 ) ;13 - ( -1 -1 -1 13 -1 -1 -1 -1 -1 -1 -1 -1 ) ;14 - ( -1 13 16 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;15 - ( -1 -1 -1 15 -1 -1 -1 -1 -1 17 16 -1 ) ;16 - ( -1 -1 17 17 17 17 255 17 255 17 -1 -1 ) ;17 - ( 18 18 18 18 18 -1 18 18 19 18 -1 -1 ) ;18 - ( -1 18 18 19 19 20 19 19 -1 18 -1 -1 ) ;19 - ( -1 -1 -1 18 -1 -1 -1 -1 -1 21 -1 -1 ) ;20 - ( -1 -1 -1 -1 -1 20 22 -1 -1 -1 -1 -1 ) ;21 - ( 18 18 18 18 16 18 23 18 18 18 18 18 ) ;22 - ( -1 255 -1 -1 -1 19 -1 -1 -1 -1 -1 -1 ) ;23 - ( 23 25 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;24 - ( 24 255 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;25 - (255 28 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;26 - ( -1 -1 -1 -1 7 -1 -1 -1 -1 -1 -1 -1 ) ;27 - ( 26 255 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;28 - ( -1 -1 30 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;29 - ( -1 -1 31 29 -1 -1 -1 -1 -1 -1 -1 -1 ) ;30 - ( 32 33 -1 30 -1 -1 -1 -1 -1 -1 -1 -1 ) ;31 - ( -1 31 -1 255 -1 -1 -1 -1 -1 34 -1 -1 ) ;32 - ( 31 -1 -1 -1 -1 -1 -1 -1 -1 35 -1 -1 ) ;33 - ( -1 35 -1 -1 -1 -1 -1 -1 32 37 -1 -1 ) ;34 - ( 34 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;35 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;36 - ( -1 -1 -1 -1 -1 -1 -1 38 34 -1 -1 -1 ) ;37 - ( -1 -1 40 41 37 -1 -1 39 -1 -1 -1 -1 ) ;38 - ( -1 -1 -1 -1 38 -1 -1 -1 -1 -1 -1 -1 ) ;39 - ( -1 -1 -1 38 -1 -1 -1 -1 42 -1 -1 -1 ) ;40 - ( -1 -1 38 -1 -1 -1 -1 -1 -1 43 -1 -1 ) ;41 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 40 -1 -1 ) ;42 - ( 44 -1 46 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;43 - ( -1 43 45 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;44 - ( -1 46 -1 44 -1 -1 -1 -1 -1 -1 -1 -1 ) ;45 - ( 45 -1 -1 43 -1 -1 -1 -1 -1 255 -1 -1 ) ;46 - ( 48 50 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;47 - ( 49 47 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;48 - ( -1 48 -1 -1 -1 -1 -1 -1 52 -1 -1 -1 ) ;49 - ( 47 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;50 - ( 50 104 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;51 - ( -1 -1 -1 -1 -1 -1 -1 -1 53 49 -1 -1 ) ;52 - ( -1 -1 -1 -1 -1 -1 -1 -1 54 52 -1 -1 ) ;53 - ( -1 -1 -1 -1 55 -1 -1 -1 -1 53 -1 -1 ) ;54 - ( -1 -1 -1 -1 56 -1 -1 54 -1 -1 -1 54 ) ;55 - ( -1 -1 -1 -1 -1 -1 -1 55 -1 31 -1 -1 ) ;56 - ( -1 -1 32 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;57 - ( 59 -1 11 -1 -1 -1 -1 -1 -1 -1 255 255) ;58 - ( 60 58 63 -1 -1 -1 255 -1 -1 -1 255 255) ;59 - ( 61 59 64 -1 -1 -1 -1 -1 -1 -1 255 255) ;60 - ( 62 60 65 -1 -1 -1 -1 -1 -1 -1 255 255) ;61 - ( -1 61 66 -1 -1 -1 -1 -1 -1 -1 255 255) ;62 - ( 64 -1 67 59 -1 -1 -1 -1 -1 -1 255 255) ;63 - ( 65 63 68 60 -1 -1 -1 -1 -1 -1 255 255) ;64 - ( 66 64 69 61 -1 -1 -1 -1 -1 -1 255 255) ;65 - ( -1 65 70 62 -1 -1 -1 -1 -1 -1 255 255) ;66 - ( 68 -1 71 63 -1 -1 -1 -1 -1 -1 255 255) ;67 - ( 69 67 72 64 -1 -1 -1 -1 -1 -1 255 255) ;68 - ( 70 68 73 65 -1 -1 -1 -1 -1 -1 255 255) ;69 - ( -1 69 74 66 -1 -1 -1 -1 -1 -1 255 255) ;70 - ( 72 -1 75 67 -1 -1 -1 -1 -1 -1 255 255) ;71 - ( 73 71 76 68 -1 -1 -1 -1 -1 -1 255 255) ;72 - ( 74 72 77 69 -1 -1 -1 -1 -1 -1 255 255) ;73 - ( -1 73 78 70 -1 -1 -1 -1 -1 -1 255 255) ;74 - ( 76 -1 79 71 -1 -1 -1 -1 -1 -1 255 255) ;75 - ( 77 75 80 72 -1 -1 -1 -1 -1 -1 255 255) ;76 - ( 78 76 81 73 -1 -1 -1 -1 -1 -1 255 255) ;77 - ( -1 77 82 74 -1 -1 -1 -1 -1 -1 255 255) ;78 - ( 80 -1 -1 75 -1 -1 -1 -1 -1 -1 255 255) ;79 - ( 81 79 255 76 -1 -1 -1 -1 -1 -1 255 255) ;80 - ( 82 80 -1 77 -1 -1 -1 -1 -1 -1 255 255) ;81 - ( -1 81 -1 78 -1 -1 -1 -1 -1 -1 255 255) ;82 - ( 84 -1 -1 -1 -1 59 -1 -1 -1 -1 255 255) ;83 - ( -1 83 85 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;84 - ( 86 -1 87 84 -1 -1 -1 -1 -1 -1 -1 -1 ) ;85 - ( -1 85 88 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;86 - ( 88 -1 -1 85 -1 -1 -1 -1 -1 -1 -1 -1 ) ;87 - ( -1 87 255 86 -1 -1 -1 -1 -1 -1 -1 -1 ) ;88 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 255 -1 ) ;89 - ( 91 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;90 - ( 92 90 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;91 - ( -1 91 -1 -1 -1 -1 -1 -1 93 94 -1 -1 ) ;92 - ( -1 -1 -1 88 -1 -1 -1 -1 -1 92 -1 -1 ) ;93 - ( -1 -1 -1 -1 95 -1 -1 -1 92 -1 -1 -1 ) ;94 - ( -1 -1 -1 -1 -1 -1 -1 94 -1 -1 -1 -1 ) ;95 - ( 97 0 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;96 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;97 - ( 99 97 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;98 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;99 - ( 101 99 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;100 - ( -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;101 - ( 103 101 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;102 - ( -1 102 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;103 - ( 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 ) ;104 - ) -; no so ea we ne se nw sw up do in ot -) - - -;;; How the user references *all* objects, permanent and regular. -(setq dun-objnames '( - (shovel . 0) - (lamp . 1) - (cpu . 2) (board . 2) (card . 2) - (food . 3) - (key . 4) - (paper . 5) - (rms . 6) (statue . 6) (statuette . 6) (stallman . 6) - (diamond . 7) - (weight . 8) - (life . 9) (preserver . 9) - (bracelet . 10) (emerald . 10) - (gold . 11) - (platinum . 12) - (towel . 13) (beach . 13) - (axe . 14) - (silver . 15) - (license . 16) - (coins . 17) - (egg . 18) - (jar . 19) - (bone . 20) - (acid . 21) (nitric . 21) - (glycerine . 22) - (ruby . 23) - (amethyst . 24) - (mona . 25) - (bill . 26) - (floppy . 27) (disk . 27) - - (boulder . -1) - (tree . -2) (trees . -2) (palm . -2) - (bear . -3) - (bin . -4) (bins . -4) - (cabinet . -5) (computer . -5) (vax . -5) (ibm . -5) - (protoplasm . -6) - (dial . -7) - (button . -8) - (chute . -9) - (painting . -10) - (bed . -11) - (urinal . -12) - (URINE . -13) - (pipes . -14) (pipe . -14) - (box . -15) (slit . -15) - (cable . -16) (ethernet . -16) - (mail . -17) (drop . -17) - (bus . -18) - (gate . -19) - (cliff . -20) - (skeleton . -21) (dinosaur . -21) - (fish . -22) - (tanks . -23) - (switch . -24) - (blackboard . -25) - (disposal . -26) (garbage . -26) - (ladder . -27) - (subway . -28) (train . -28) - (pc . -29) (drive . -29) -)) - -(dolist (x dun-objnames) - (let (name) - (setq name (concat "obj-" (prin1-to-string (car x)))) - (eval (list 'defconst (intern name) (cdr x))))) - -(defconst obj-special 255) - -;;; The initial setup of what objects are in each room. -;;; Regular objects have whole numbers lower than 255. -;;; Objects that cannot be taken but might move and are -;;; described during room description are negative. -;;; Stuff that is described and might change are 255, and are -;;; handled specially by 'dun-describe-room. - -(setq dun-room-objects (list nil - - (list obj-shovel) ;; treasure-room - (list obj-boulder) ;; dead-end - nil nil nil - (list obj-food) ;; se-nw-road - (list obj-bear) ;; bear-hangout - nil nil - (list obj-special) ;; computer-room - (list obj-lamp obj-license obj-silver);; meadow - nil nil - (list obj-special) ;; sauna - nil - (list obj-weight obj-life) ;; weight-room - nil nil - (list obj-rms obj-floppy) ;; thirsty-maze - nil nil nil nil nil nil nil - (list obj-emerald) ;; hidden-area - nil - (list obj-gold) ;; misty-room - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - (list obj-towel obj-special) ;; red-room - nil nil nil nil nil - (list obj-box) ;; stair-landing - nil nil nil - (list obj-axe) ;; smal-crawlspace - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil - (list obj-special) ;; fourth-vermont-intersection - nil nil - (list obj-coins) ;; fifth-oaktree-intersection - nil - (list obj-bus) ;; fifth-sycamore-intersection - nil - (list obj-bone) ;; museum-lobby - nil - (list obj-jar obj-special obj-ruby) ;; marine-life-area - (list obj-nitric) ;; maintenance-room - (list obj-glycerine) ;; classroom - nil nil nil nil nil - (list obj-amethyst) ;; bottom-of-subway-stairs - nil nil - (list obj-special) ;; question-room-1 - nil - (list obj-special) ;; question-room-2 - nil - (list obj-special) ;; question-room-three - nil - (list obj-mona) ;; winner's-room -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -nil)) - -;;; These are objects in a room that are only described in the -;;; room description. They are permanent. - -(setq dun-room-silents (list nil - (list obj-tree) ;; dead-end - (list obj-tree) ;; e-w-dirt-road - nil nil nil nil nil nil - (list obj-bin) ;; mailroom - (list obj-computer) ;; computer-room - nil nil nil - (list obj-dial) ;; sauna - nil - (list obj-ladder) ;; weight-room - (list obj-button obj-ladder) ;; maze-button-room - nil nil nil - nil nil nil nil nil nil nil - (list obj-chute) ;; cave-entrance - nil nil nil nil nil - (list obj-painting obj-bed) ;; bedroom - (list obj-urinal obj-pipes) ;; bathroom - nil nil nil nil nil nil - (list obj-boulder) ;; horseshoe-boulder-room - nil nil nil nil nil nil nil nil nil nil nil nil nil nil - (list obj-computer obj-cable) ;; gamma-computing-center - (list obj-mail) ;; post-office - (list obj-gate) ;; main-maple-intersection - nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil - (list obj-cliff) ;; fifth-oaktree-intersection - nil nil nil - (list obj-dinosaur) ;; museum-lobby - nil - (list obj-fish obj-tanks) ;; marine-life-area - (list obj-switch) ;; maintenance-room - (list obj-blackboard) ;; classroom - (list obj-train) ;; vermont-station - nil nil - (list obj-disposal) ;; north-end-of-n-s-tunnel - nil nil - (list obj-computer) ;; endgame-computer-room - nil nil nil nil nil nil nil nil - (list obj-pc) ;; pc-area - nil nil nil nil nil nil -)) -(setq dun-inventory '(1)) - -;;; Descriptions of objects, as they appear in the room description, and -;;; the inventory. - -(setq dun-objects '( - ("There is a shovel here." "A shovel") ;0 - ("There is a lamp nearby." "A lamp") ;1 - ("There is a CPU card here." "A computer board") ;2 - ("There is some food here." "Some food") ;3 - ("There is a shiny brass key here." "A brass key") ;4 - ("There is a slip of paper here." "A slip of paper") ;5 - ("There is a wax statuette of Richard Stallman here." ;6 - "An RMS statuette") - ("There is a shimmering diamond here." "A diamond") ;7 - ("There is a 10 pound weight here." "A weight") ;8 - ("There is a life preserver here." "A life preserver");9 - ("There is an emerald bracelet here." "A bracelet") ;10 - ("There is a gold bar here." "A gold bar") ;11 - ("There is a platinum bar here." "A platinum bar") ;12 - ("There is a beach towel on the ground here." "A beach towel") - ("There is an axe here." "An axe") ;14 - ("There is a silver bar here." "A silver bar") ;15 - ("There is a bus driver's license here." "A license") ;16 - ("There are some valuable coins here." "Some valuable coins") - ("There is a jewel-encrusted egg here." "A valuable egg") ;18 - ("There is a glass jar here." "A glass jar") ;19 - ("There is a dinosaur bone here." "A bone") ;20 - ("There is a packet of nitric acid here." "Some nitric acid") - ("There is a packet of glycerine here." "Some glycerine") ;22 - ("There is a valuable ruby here." "A ruby") ;23 - ("There is a valuable amethyst here." "An amethyst") ;24 - ("The Mona Lisa is here." "The Mona Lisa") ;25 - ("There is a 100 dollar bill here." "A $100 bill") ;26 - ("There is a floppy disk here." "A floppy disk") ;27 - ) -) - -;;; Weight of objects - -(setq dun-object-lbs - '(2 1 1 1 1 0 2 2 10 3 1 1 1 0 1 1 0 1 1 1 1 0 0 2 2 1 0 0)) -(setq dun-object-pts - '(0 0 0 0 0 0 0 10 0 0 10 10 10 0 0 10 0 10 10 0 0 0 0 10 10 10 10 0)) - - -;;; Unix representation of objects. -(setq dun-objfiles '( - "shovel.o" "lamp.o" "cpu.o" "food.o" "key.o" "paper.o" - "rms.o" "diamond.o" "weight.o" "preserver.o" "bracelet.o" - "gold.o" "platinum.o" "towel.o" "axe.o" "silver.o" "license.o" - "coins.o" "egg.o" "jar.o" "bone.o" "nitric.o" "glycerine.o" - "ruby.o" "amethyst.o" - )) - -;;; These are the descriptions for the negative numbered objects from -;;; dun-room-objects - -(setq dun-perm-objects '( - nil - ("There is a large boulder here.") - nil - ("There is a ferocious bear here!") - nil - nil - ("There is a worthless pile of protoplasm here.") - nil - nil - nil - nil - nil - nil - ("There is a strange smell in this room.") - nil - ( -"There is a box with a slit in it, bolted to the wall here." - ) - nil - nil - ("There is a bus here.") - nil - nil - nil -)) - - -;;; These are the descriptions the user gets when regular objects are -;;; examined. - -(setq dun-physobj-desc '( -"It is a normal shovel with a price tag attached that says $19.99." -"The lamp is hand-crafted by Geppetto." -"The CPU board has a VAX chip on it. It seems to have -2 Megabytes of RAM onboard." -"It looks like some kind of meat. Smells pretty bad." -nil -"The paper says: Don't forget to type 'help' for help. Also, remember -this word: 'worms'" -"The statuette is of the likeness of Richard Stallman, the author of the -famous EMACS editor. You notice that he is not wearing any shoes." -nil -"You observe that the weight is heavy." -"It says S. S. Minnow." -nil -nil -nil -"It has a picture of snoopy on it." -nil -nil -"It has your picture on it!" -"They are old coins from the 19th century." -"It is a valuable Fabrege egg." -"It is a a plain glass jar." -nil -nil -nil -nil -nil - ) -) - -;;; These are the descriptions the user gets when non-regular objects -;;; are examined. - -(setq dun-permobj-desc '( - nil -"It is just a boulder. It cannot be moved." -"They are palm trees with a bountiful supply of coconuts in them." -"It looks like a grizzly to me." -"All of the bins are empty. Looking closely you can see that there -are names written at the bottom of each bin, but most of them are -faded away so that you cannot read them. You can only make out three -names: - Jeffrey Collier - Robert Toukmond - Thomas Stock -" - nil -"It is just a garbled mess." -"The dial points to a temperature scale which has long since faded away." -nil -nil -"It is a velvet painting of Elvis Presly. It seems to be nailed to the -wall, and you cannot move it." -"It is a queen sized bed, with a very firm mattress." -"The urinal is very clean compared with everything else in the cave. There -isn't even any rust. Upon close examination you realize that the drain at the -bottom is missing, and there is just a large hole leading down the -pipes into nowhere. The hole is too small for a person to fit in. The -flush handle is so clean that you can see your reflection in it." -nil -nil -"The box has a slit in the top of it, and on it, in sloppy handwriting, is -written: 'For key upgrade, put key in here.'" -nil -"It says 'express mail' on it." -"It is a 35 passenger bus with the company name 'mobytours' on it." -"It is a large metal gate that is too big to climb over." -"It is a HIGH cliff." -"Unfortunately you do not know enough about dinosaurs to tell very much about -it. It is very big, though." -"The fish look like they were once quite beautiful." -nil -nil -nil -nil -"It is a normal ladder that is permanently attached to the hole." -"It is a passenger train that is ready to go." -"It is a personal computer that has only one floppy disk drive." - ) -) - -(setq dun-diggables - (list nil nil nil (list obj-cpu) nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil ;11-20 - nil nil nil nil nil nil nil nil nil nil ;21-30 - nil nil nil nil nil nil nil nil nil nil ;31-40 - nil (list obj-platinum) nil nil nil nil nil nil nil nil)) - -(setq dun-room-shorts nil) -(dolist (x dun-rooms) - (setq dun-room-shorts - (append dun-room-shorts (list (downcase - (dun-space-to-hyphen - (cadr x))))))) - -(setq dun-endgame-questions '( - ( -"What is your password on the machine called 'pokey'?" "robert") - ( -"What password did you use during anonymous ftp to gamma?" "foo") - ( -"Excluding the endgame, how many places are there where you can put -treasures for points?" "4" "four") - ( -"What is your login name on the 'endgame' machine?" "toukmond" -) - ( -"What is the nearest whole dollar to the price of the shovel?" "20" "twenty") - ( -"What is the name of the bus company serving the town?" "mobytours") - ( -"Give either of the two last names in the mailroom, other than your own." -"collier" "stock") - ( -"What cartoon character is on the towel?" "snoopy") - ( -"What is the last name of the author of EMACS?" "stallman") - ( -"How many megabytes of memory is on the CPU board for the Vax?" "2") - ( -"Which street in town is named after a U.S. state?" "vermont") - ( -"How many pounds did the weight weigh?" "ten" "10") - ( -"Name the STREET which runs right over the subway stop." "fourth" "4" "4th") - ( -"How many corners are there in town (excluding the one with the Post Office)?" - "24" "twentyfour" "twenty-four") - ( -"What type of bear was hiding your key?" "grizzly") - ( -"Name either of the two objects you found by digging." "cpu" "card" "vax" -"board" "platinum") - ( -"What network protocol is used between pokey and gamma?" "tcp/ip" "ip" "tcp") -)) - -(let (a) - (setq a 0) - (dolist (x dun-room-shorts) - (eval (list 'defconst (intern x) a)) - (setq a (+ a 1)))) - - - -;;;; -;;;; This section defines the UNIX emulation functions for dunnet. -;;;; - -(defun dun-unix-parse (args) - (interactive "*p") - (beginning-of-line) - (let (beg esign) - (setq beg (+ (point) 2)) - (end-of-line) - (if (and (not (= beg (point))) - (string= "$" (buffer-substring (- beg 2) (- beg 1)))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) - (progn - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) - (dun-mprincl ": not found."))))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (if (eq dungeon-mode 'unix) - (progn - (dun-fix-screen) - (dun-mprinc "$ "))))) - -(defun dun-doassign (line esign) - (if (not dun-wizard) - (let (passwd) - (dun-mprinc "Enter wizard password: ") - (setq passwd (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (string= passwd "moby") - (progn - (setq dun-wizard t) - (dun-doassign line esign)) - (dun-mprincl "Incorrect."))) - - (let (varname epoint afterq i value) - (setq varname (substring line 0 esign)) - (if (not (setq epoint (string-match ")" line))) - (if (string= (substring line (1+ esign) (+ esign 2)) - "\"") - (progn - (setq afterq (substring line (+ esign 2))) - (setq epoint (+ - (string-match "\"" afterq) - (+ esign 3)))) - - (if (not (setq epoint (string-match " " line))) - (setq epoint (length line)))) - (setq epoint (1+ epoint)) - (while (and - (not (= epoint (length line))) - (setq i (string-match ")" (substring line epoint)))) - (setq epoint (+ epoint i 1)))) - (setq value (substring line (1+ esign) epoint)) - (dun-eval varname value)))) - -(defun dun-eval (varname value) - (let (eval-error) - (switch-to-buffer (get-buffer-create "*dungeon-eval*")) - (erase-buffer) - (insert "(setq ") - (insert varname) - (insert " ") - (insert value) - (insert ")") - (setq eval-error nil) - (condition-case nil - (eval-current-buffer) - (error (setq eval-error t))) - (kill-buffer (current-buffer)) - (switch-to-buffer "*dungeon*") - (if eval-error - (dun-mprincl "Invalid syntax.")))) - - -(defun dun-unix-interface () - (dun-login) - (if dun-logged-in - (progn - (setq dungeon-mode 'unix) - (define-key dungeon-mode-map "\r" 'dun-unix-parse) - (dun-mprinc "$ ")))) - -(defun dun-login () - (let (tries username password) - (setq tries 4) - (while (and (not dun-logged-in) (> (setq tries (- tries 1)) 0)) - (dun-mprinc "\n\nUNIX System V, Release 2.2 (pokey)\n\nlogin: ") - (setq username (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (dun-mprinc "password: ") - (setq password (dun-read-line)) - (if (not dun-batch-mode) - (dun-mprinc "\n")) - (if (or (not (string= username "toukmond")) - (not (string= password "robert"))) - (dun-mprincl "login incorrect") - (setq dun-logged-in t) - (dun-mprincl " -Welcome to Unix\n -Please clean up your directories. The filesystem is getting full. -Our tcp/ip link to gamma is a little flaky, but seems to work. -The current version of ftp can only send files from the current -directory, and deletes them after they are sent! Be careful. - -Note: Restricted bourne shell in use.\n"))) - (setq dungeon-mode 'dungeon))) - -(defun dun-ls (args) - (if (car args) - (let (ocdpath ocdroom) - (setq ocdpath dun-cdpath) - (setq ocdroom dun-cdroom) - (if (not (eq (dun-cd args) -2)) - (dun-ls nil)) - (setq dun-cdpath ocdpath) - (setq dun-cdroom ocdroom)) - (if (= dun-cdroom -10) - (dun-ls-inven)) - (if (= dun-cdroom -2) - (dun-ls-rooms)) - (if (= dun-cdroom -3) - (dun-ls-root)) - (if (= dun-cdroom -4) - (dun-ls-usr)) - (if (> dun-cdroom 0) - (dun-ls-room)))) - -(defun dun-ls-root () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. -drwxr-xr-x 3 root staff 2048 Jan 1 1970 usr -drwxr-xr-x 3 root staff 2048 Jan 1 1970 rooms")) - -(defun dun-ls-usr () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. -drwxr-xr-x 3 toukmond restricted 512 Jan 1 1970 toukmond")) - -(defun dun-ls-rooms () - (dun-mprincl "total 16 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") - (dolist (x dun-visited) - (dun-mprinc -"drwxr-xr-x 3 root staff 512 Jan 1 1970 ") - (dun-mprincl (nth x dun-room-shorts)))) - -(defun dun-ls-room () - (dun-mprincl "total 4 -drwxr-xr-x 3 root staff 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 .. --rwxr-xr-x 3 root staff 2048 Jan 1 1970 description") - (dolist (x (nth dun-cdroom dun-room-objects)) - (if (and (>= x 0) (not (= x 255))) - (progn - (dun-mprinc "-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 ") - (dun-mprincl (nth x dun-objfiles)))))) - -(defun dun-ls-inven () - (dun-mprinc "total 467 -drwxr-xr-x 3 toukmond restricted 512 Jan 1 1970 . -drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") - (dolist (x dun-unix-verbs) - (if (not (eq (car x) 'IMPOSSIBLE)) - (progn - (dun-mprinc" --rwxr-xr-x 1 toukmond restricted 10423 Jan 1 1970 ") - (dun-mprinc (car x))))) - (dun-mprinc "\n") - (if (not dun-uncompressed) - (dun-mprincl -"-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 paper.o.Z")) - (dolist (x dun-inventory) - (dun-mprinc -"-rwxr-xr-x 1 toukmond restricted 0 Jan 1 1970 ") - (dun-mprincl (nth x dun-objfiles)))) - -(defun dun-echo (args) - (let (nomore var) - (setq nomore nil) - (dolist (x args) - (if (not nomore) - (progn - (if (not (string= (substring x 0 1) "$")) - (progn - (dun-mprinc x) - (dun-mprinc " ")) - (setq var (intern (substring x 1))) - (if (not (boundp var)) - (dun-mprinc " ") - (if (member var dun-restricted) - (progn - (dun-mprinc var) - (dun-mprinc ": Permission denied") - (setq nomore t)) - (eval (list 'dun-mprinc var)) - (dun-mprinc " "))))))) - (dun-mprinc "\n"))) - - -(defun dun-ftp (args) - (let (host username passwd ident newlist) - (if (not (car args)) - (dun-mprincl "ftp: hostname required on command line.") - (setq host (intern (car args))) - (if (not (member host '(gamma dun-endgame))) - (dun-mprincl "ftp: Unknown host.") - (if (eq host 'dun-endgame) - (dun-mprincl "ftp: connection to endgame not allowed") - (if (not dun-ethernet) - (dun-mprincl "ftp: host not responding.") - (dun-mprincl "Connected to gamma. FTP ver 0.9 00:00:00 01/01/70") - (dun-mprinc "Username: ") - (setq username (dun-read-line)) - (if (string= username "toukmond") - (if dun-batch-mode - (dun-mprincl "toukmond ftp access not allowed.") - (dun-mprincl "\ntoukmond ftp access not allowed.")) - (if (string= username "anonymous") - (if dun-batch-mode - (dun-mprincl - "Guest login okay, send your user ident as password.") - (dun-mprincl - "\nGuest login okay, send your user ident as password.")) - (if dun-batch-mode - (dun-mprinc "Password required for ") - (dun-mprinc "\nPassword required for ")) - (dun-mprincl username)) - (dun-mprinc "Password: ") - (setq ident (dun-read-line)) - (if (not (string= username "anonymous")) - (if dun-batch-mode - (dun-mprincl "Login failed.") - (dun-mprincl "\nLogin failed.")) - (if dun-batch-mode - (dun-mprincl - "Guest login okay, user access restrictions apply.") - (dun-mprincl - "\nGuest login okay, user access restrictions apply.")) - (dun-ftp-commands) - (setq newlist -'("What password did you use during anonymous ftp to gamma?")) - (setq newlist (append newlist (list ident))) - (rplaca (nthcdr 1 dun-endgame-questions) newlist))))))))) - -(defun dun-ftp-commands () - (setq dun-exitf nil) - (let (line) - (while (not dun-exitf) - (dun-mprinc "ftp> ") - (setq line (dun-read-line)) - (if - (eq - (dun-parse2 nil - '((type . dun-ftptype) (binary . dun-bin) (bin . dun-bin) - (send . dun-send) (put . dun-send) (quit . dun-ftpquit) - (help . dun-ftphelp)(ascii . dun-fascii) - ) line) - -1) - (dun-mprincl "No such command. Try help."))) - (setq dun-ftptype 'ascii))) - -(defun dun-ftptype (args) - (if (not (car args)) - (dun-mprincl "Usage: type [binary | ascii]") - (setq args (intern (car args))) - (if (eq args 'binary) - (dun-bin nil) - (if (eq args 'ascii) - (dun-fascii 'nil) - (dun-mprincl "Unknown type."))))) - -(defun dun-bin (args) - (dun-mprincl "Type set to binary.") - (setq dun-ftptype 'binary)) - -(defun dun-fascii (args) - (dun-mprincl "Type set to ascii.") - (setq dun-ftptype 'ascii)) - -(defun dun-ftpquit (args) - (setq dun-exitf t)) - -(defun dun-send (args) - (if (not (car args)) - (dun-mprincl "Usage: send <filename>") - (setq args (car args)) - (let (counter foo) - (setq foo nil) - (setq counter 0) - -;;; User can send commands! Stupid user. - - - (if (assq (intern args) dun-unix-verbs) - (progn - (rplaca (assq (intern args) dun-unix-verbs) 'IMPOSSIBLE) - (dun-mprinc "Sending ") - (dun-mprinc dun-ftptype) - (dun-mprinc " file for ") - (dun-mprincl args) - (dun-mprincl "Transfer complete.")) - - (dolist (x dun-objfiles) - (if (string= args x) - (progn - (if (not (member counter dun-inventory)) - (progn - (dun-mprincl "No such file.") - (setq foo t)) - (dun-mprinc "Sending ") - (dun-mprinc dun-ftptype) - (dun-mprinc " file for ") - (dun-mprinc (downcase (cadr (nth counter dun-objects)))) - (dun-mprincl ", (0 bytes)") - (if (not (eq dun-ftptype 'binary)) - (progn - (if (not (member obj-protoplasm - (nth receiving-room - dun-room-objects))) - (dun-replace dun-room-objects receiving-room - (append (nth receiving-room - dun-room-objects) - (list obj-protoplasm)))) - (dun-remove-obj-from-inven counter)) - (dun-remove-obj-from-inven counter) - (dun-replace dun-room-objects receiving-room - (append (nth receiving-room dun-room-objects) - (list counter)))) - (setq foo t) - (dun-mprincl "Transfer complete.")))) - (setq counter (+ 1 counter))) - (if (not foo) - (dun-mprincl "No such file.")))))) - -(defun dun-ftphelp (args) - (dun-mprincl - "Possible commands are:\nsend quit type ascii binary help")) - -(defun dun-uexit (args) - (setq dungeon-mode 'dungeon) - (dun-mprincl "\nYou step back from the console.") - (define-key dungeon-mode-map "\r" 'dun-parse) - (if (not dun-batch-mode) - (dun-messages))) - -(defun dun-pwd (args) - (dun-mprincl dun-cdpath)) - -(defun dun-uncompress (args) - (if (not (car args)) - (dun-mprincl "Usage: uncompress <filename>") - (setq args (car args)) - (if (or dun-uncompressed - (and (not (string= args "paper.o")) - (not (string= args "paper.o.z")))) - (dun-mprincl "Uncompress command failed.") - (setq dun-uncompressed t) - (setq dun-inventory (append dun-inventory (list obj-paper)))))) - -(defun dun-rlogin (args) - (let (passwd) - (if (not (car args)) - (dun-mprincl "Usage: rlogin <hostname>") - (setq args (car args)) - (if (string= args "endgame") - (dun-rlogin-endgame) - (if (not (string= args "gamma")) - (dun-mprincl "No such host.") - (if (not dun-ethernet) - (dun-mprincl "Host not responding.") - (dun-mprinc "Password: ") - (setq passwd (dun-read-line)) - (if (not (string= passwd "worms")) - (dun-mprincl "\nlogin incorrect") - (dun-mprinc -"\nYou begin to feel strange for a moment, and you lose your items." -) - (dun-replace dun-room-objects computer-room - (append (nth computer-room dun-room-objects) - dun-inventory)) - (setq dun-inventory nil) - (setq dun-current-room receiving-room) - (dun-uexit nil)))))))) - -(defun dun-cd (args) - (let (tcdpath tcdroom path-elements room-check) - (if (not (car args)) - (dun-mprincl "Usage: cd <path>") - (setq tcdpath dun-cdpath) - (setq tcdroom dun-cdroom) - (setq dun-badcd nil) - (condition-case nil - (setq path-elements (dun-get-path (car args) nil)) - (error (dun-mprincl "Invalid path.") - (setq dun-badcd t))) - (dolist (pe path-elements) - (unless dun-badcd - (if (not (string= pe ".")) - (if (string= pe "..") - (progn - (if (> tcdroom 0) ;In a room - (progn - (setq tcdpath "/rooms") - (setq tcdroom -2)) - ;In /rooms,/usr,root - (if (or - (= tcdroom -2) (= tcdroom -4) - (= tcdroom -3)) - (progn - (setq tcdpath "/") - (setq tcdroom -3)) - (if (= tcdroom -10) ;In /usr/toukmond - (progn - (setq tcdpath "/usr") - (setq tcdroom -4)))))) - (if (string= pe "/") - (progn - (setq tcdpath "/") - (setq tcdroom -3)) - (if (= tcdroom -4) - (if (string= pe "toukmond") - (progn - (setq tcdpath "/usr/toukmond") - (setq tcdroom -10)) - (dun-nosuchdir)) - (if (= tcdroom -10) - (dun-nosuchdir) - (if (> tcdroom 0) - (dun-nosuchdir) - (if (= tcdroom -3) - (progn - (if (string= pe "rooms") - (progn - (setq tcdpath "/rooms") - (setq tcdroom -2)) - (if (string= pe "usr") - (progn - (setq tcdpath "/usr") - (setq tcdroom -4)) - (dun-nosuchdir)))) - (if (= tcdroom -2) - (progn - (dolist (x dun-visited) - (setq room-check - (nth x - dun-room-shorts)) - (if (string= room-check pe) - (progn - (setq tcdpath - (concat "/rooms/" room-check)) - (setq tcdroom x)))) - (if (= tcdroom -2) - (dun-nosuchdir))))))))))))) - (if (not dun-badcd) - (progn - (setq dun-cdpath tcdpath) - (setq dun-cdroom tcdroom) - 0) - -2)))) - -(defun dun-nosuchdir () - (dun-mprincl "No such directory.") - (setq dun-badcd t)) - -(defun dun-cat (args) - (let (doto checklist) - (if (not (setq args (car args))) - (dun-mprincl "Usage: cat <ascii-file-name>") - (if (string-match "/" args) - (dun-mprincl "cat: only files in current directory allowed.") - (if (and (> dun-cdroom 0) (string= args "description")) - (dun-mprincl (car (nth dun-cdroom dun-rooms))) - (if (setq doto (string-match "\\.o" args)) - (progn - (if (= dun-cdroom -10) - (setq checklist dun-inventory) - (setq checklist (nth dun-cdroom dun-room-objects))) - (if (not (member (cdr - (assq (intern - (substring args 0 doto)) - dun-objnames)) - checklist)) - (dun-mprincl "File not found.") - (dun-mprincl "Ascii files only."))) - (if (assq (intern args) dun-unix-verbs) - (dun-mprincl "Ascii files only.") - (dun-mprincl "File not found.")))))))) - -(defun dun-zippy (args) - (dun-mprincl (yow))) - -(defun dun-rlogin-endgame () - (if (not (= (dun-score nil) 90)) - (dun-mprincl - "You have not achieved enough points to connect to endgame.") - (dun-mprincl"\nWelcome to the endgame. You are a truly noble adventurer.") - (setq dun-current-room treasure-room) - (setq dun-endgame t) - (dun-replace dun-room-objects endgame-treasure-room (list obj-bill)) - (dun-uexit nil))) - - -(random t) -(setq tloc (+ 60 (random 18))) -(dun-replace dun-room-objects tloc - (append (nth tloc dun-room-objects) (list 18))) - -(setq tcomb (+ 100 (random 899))) -(setq dun-combination (prin1-to-string tcomb)) - -;;;; -;;;; This section defines the DOS emulation functions for dunnet -;;;; - -(defun dun-dos-parse (args) - (interactive "*p") - (beginning-of-line) - (let (beg) - (setq beg (+ (point) 3)) - (end-of-line) - (if (not (= beg (point))) - (let (line) - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) - (progn - (sleep-for 1) - (dun-mprincl "Bad command or file name")))) - (goto-char (point-max)) - (dun-mprinc "\n")) - (if (eq dungeon-mode 'dos) - (progn - (dun-fix-screen) - (dun-dos-prompt))))) - -(defun dun-dos-interface () - (dun-dos-boot-msg) - (setq dungeon-mode 'dos) - (define-key dungeon-mode-map "\r" 'dun-dos-parse) - (dun-dos-prompt)) - -(defun dun-dos-type (args) - (sleep-for 2) - (if (setq args (car args)) - (if (string= args "foo.txt") - (dun-dos-show-combination) - (if (string= args "command.com") - (dun-mprincl "Cannot type binary files") - (dun-mprinc "File not found - ") - (dun-mprincl (upcase args)))) - (dun-mprincl "Must supply file name"))) - -(defun dun-dos-invd (args) - (sleep-for 1) - (dun-mprincl "Invalid drive specification")) - -(defun dun-dos-dir (args) - (sleep-for 1) - (if (or (not (setq args (car args))) (string= args "\\")) - (dun-mprincl " - Volume in drive A is FOO - Volume Serial Number is 1A16-08C9 - Directory of A:\\ - -COMMAND COM 47845 04-09-91 2:00a -FOO TXT 40 01-20-93 1:01a - 2 file(s) 47845 bytes - 1065280 bytes free -") - (dun-mprincl " - Volume in drive A is FOO - Volume Serial Number is 1A16-08C9 - Directory of A:\\ - -File not found"))) - - -(defun dun-dos-prompt () - (dun-mprinc "A> ")) - -(defun dun-dos-boot-msg () - (sleep-for 3) - (dun-mprinc "Current time is ") - (dun-mprincl (substring (current-time-string) 12 20)) - (dun-mprinc "Enter new time: ") - (dun-read-line) - (if (not dun-batch-mode) - (dun-mprinc "\n"))) - -(defun dun-dos-spawn (args) - (sleep-for 1) - (dun-mprincl "Cannot spawn subshell")) - -(defun dun-dos-exit (args) - (setq dungeon-mode 'dungeon) - (dun-mprincl "\nYou power down the machine and step back.") - (define-key dungeon-mode-map "\r" 'dun-parse) - (if (not dun-batch-mode) - (dun-messages))) - -(defun dun-dos-no-disk () - (sleep-for 3) - (dun-mprincl "Boot sector not found")) - - -(defun dun-dos-show-combination () - (sleep-for 2) - (dun-mprinc "\nThe combination is ") - (dun-mprinc dun-combination) - (dun-mprinc ".\n")) - -(defun dun-dos-nil (args)) - - -;;;; -;;;; This section defines the save and restore game functions for dunnet. -;;;; - -(defun dun-save-game (filename) - (if (not (setq filename (car filename))) - (dun-mprincl "You must supply a filename for the save.") - (if (file-exists-p filename) - (delete-file filename)) - (setq dun-numsaves (1+ dun-numsaves)) - (dun-make-save-buffer) - (dun-save-val "dun-current-room") - (dun-save-val "dun-computer") - (dun-save-val "dun-combination") - (dun-save-val "dun-visited") - (dun-save-val "dun-diggables") - (dun-save-val "dun-key-level") - (dun-save-val "dun-floppy") - (dun-save-val "dun-numsaves") - (dun-save-val "dun-numcmds") - (dun-save-val "dun-logged-in") - (dun-save-val "dungeon-mode") - (dun-save-val "dun-jar") - (dun-save-val "dun-lastdir") - (dun-save-val "dun-black") - (dun-save-val "dun-nomail") - (dun-save-val "dun-unix-verbs") - (dun-save-val "dun-hole") - (dun-save-val "dun-uncompressed") - (dun-save-val "dun-ethernet") - (dun-save-val "dun-sauna-level") - (dun-save-val "dun-room-objects") - (dun-save-val "dun-room-silents") - (dun-save-val "dun-inventory") - (dun-save-val "dun-endgame-questions") - (dun-save-val "dun-endgame") - (dun-save-val "dun-cdroom") - (dun-save-val "dun-cdpath") - (dun-save-val "dun-correct-answer") - (dun-save-val "dun-inbus") - (if (dun-compile-save-out filename) - (dun-mprincl "Error saving to file.") - (dun-do-logfile 'save nil) - (switch-to-buffer "*dungeon*") - (princ "") - (dun-mprincl "Done.")))) - -(defun dun-make-save-buffer () - (switch-to-buffer (get-buffer-create "*save-dungeon*")) - (erase-buffer)) - -(defun dun-compile-save-out (filename) - (let (ferror) - (setq ferror nil) - (condition-case nil - (dun-rot13) - (error (setq ferror t))) - (if (not ferror) - (progn - (goto-char (point-min)))) - (condition-case nil - (write-region 1 (point-max) filename nil 1) - (error (setq ferror t))) - (kill-buffer (current-buffer)) - ferror)) - - -(defun dun-save-val (varname) - (let (value) - (setq varname (intern varname)) - (setq value (eval varname)) - (dun-minsert "(setq ") - (dun-minsert varname) - (dun-minsert " ") - (if (or (listp value) - (symbolp value)) - (dun-minsert "'")) - (if (stringp value) - (dun-minsert "\"")) - (dun-minsert value) - (if (stringp value) - (dun-minsert "\"")) - (dun-minsertl ")"))) - - -(defun dun-restore (args) - (let (file) - (if (not (setq file (car args))) - (dun-mprincl "You must supply a filename.") - (if (not (dun-load-d file)) - (dun-mprincl "Could not load restore file.") - (dun-mprincl "Done.") - (setq room 0))))) - - -(defun dun-do-logfile (type how) - (let (ferror newscore) - (setq ferror nil) - (switch-to-buffer (get-buffer-create "*score*")) - (erase-buffer) - (condition-case nil - (insert-file-contents dun-log-file) - (error (setq ferror t))) - (unless ferror - (goto-char (point-max)) - (dun-minsert (current-time-string)) - (dun-minsert " ") - (dun-minsert (user-login-name)) - (dun-minsert " ") - (if (eq type 'save) - (dun-minsert "saved ") - (if (= (dun-endgame-score) 110) - (dun-minsert "won ") - (if (not how) - (dun-minsert "quit ") - (dun-minsert "killed by ") - (dun-minsert how) - (dun-minsert " ")))) - (dun-minsert "at ") - (dun-minsert (cadr (nth (abs room) dun-rooms))) - (dun-minsert ". score: ") - (if (> (dun-endgame-score) 0) - (dun-minsert (setq newscore (+ 90 (dun-endgame-score)))) - (dun-minsert (setq newscore (dun-reg-score)))) - (dun-minsert " saves: ") - (dun-minsert dun-numsaves) - (dun-minsert " commands: ") - (dun-minsert dun-numcmds) - (dun-minsert "\n") - (write-region 1 (point-max) dun-log-file nil 1)) - (kill-buffer (current-buffer)))) - - -;;;; -;;;; These are functions, and function re-definitions so that dungeon can -;;;; be run in batch mode. - - -(defun dun-batch-mprinc (arg) - (if (stringp arg) - (send-string-to-terminal arg) - (send-string-to-terminal (prin1-to-string arg)))) - - -(defun dun-batch-mprincl (arg) - (if (stringp arg) - (progn - (send-string-to-terminal arg) - (send-string-to-terminal "\n")) - (send-string-to-terminal (prin1-to-string arg)) - (send-string-to-terminal "\n"))) - -(defun dun-batch-parse (dun-ignore dun-verblist line) - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-batch-parse2 (dun-ignore dun-verblist line) - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb dun-ignore dun-verblist (car line-list) (cdr line-list))) - -(defun dun-batch-read-line () - (read-from-minibuffer "" nil dungeon-batch-map)) - - -(defun dun-batch-loop () - (setq dun-dead nil) - (setq room 0) - (while (not dun-dead) - (if (eq dungeon-mode 'dungeon) - (progn - (if (not (= room dun-current-room)) - (progn - (dun-describe-room dun-current-room) - (setq room dun-current-room))) - (dun-mprinc ">") - (setq line (downcase (dun-read-line))) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n")))))) - -(defun dun-batch-dos-interface () - (dun-dos-boot-msg) - (setq dungeon-mode 'dos) - (while (eq dungeon-mode 'dos) - (dun-dos-prompt) - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) - (progn - (sleep-for 1) - (dun-mprincl "Bad command or file name")))) - (goto-char (point-max)) - (dun-mprinc "\n")) - -(defun dun-batch-unix-interface () - (dun-login) - (if dun-logged-in - (progn - (setq dungeon-mode 'unix) - (while (eq dungeon-mode 'unix) - (dun-mprinc "$ ") - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) - (let (esign) - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) - (dun-mprincl ": not found."))))) - (goto-char (point-max)) - (dun-mprinc "\n")))) - -(defun dungeon-nil (arg) - "noop" - (interactive "*p")) - -(defun dun-batch-dungeon () - (load "dun-batch") - (setq dun-visited '(27)) - (dun-mprinc "\n") - (dun-batch-loop)) - -(unless (not noninteractive) - (fset 'dun-mprinc 'dun-batch-mprinc) - (fset 'dun-mprincl 'dun-batch-mprincl) - (fset 'dun-vparse 'dun-batch-parse) - (fset 'dun-parse2 'dun-batch-parse2) - (fset 'dun-read-line 'dun-batch-read-line) - (fset 'dun-dos-interface 'dun-batch-dos-interface) - (fset 'dun-unix-interface 'dun-batch-unix-interface) - (dun-mprinc "\n") - (setq dun-batch-mode t) - (dun-batch-loop)) - -;;; dunnet.el ends here
--- a/lisp/games/flame.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,342 +0,0 @@ -;;; flame.el --- Automated insults - -;; Copyright status Unknown - -;; Author: Unknown -;; Adapted-By: Ian G. Batten, Batten@uk.ac.bham.multics -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: - -;;; "Flame" program. This has a chequered past. -;;; -;;; The original was on a Motorola 286 running Vanilla V.1, -;;; about 2 years ago. It was couched in terms of a yacc (I think) -;;; script. I pulled the data out of it and rewrote it as a piece -;;; of PL/1 on Multics. Now I've moved it into an emacs-lisp -;;; form. If the original author cares to contact me, I'd -;;; be very happy to credit you! -;;; -;;; Ian G. Batten, Batten@uk.ac.bham.multics -;;; - -;;; Code: -(random t) - -(defvar sentence - '((how can you say that (statement) \?) - (I can\'t believe how (adjective) you are\.) - (only a (der-term) like you would say that (statement) \.) - ((statement) \, huh\?) (so\, (statement) \?) - ((statement) \, right\?) (I mean\, (sentence)) - (don\'t you realise that (statement) \?) - (I firmly believe that (statement) \.) - (let me tell you something\, you (der-term) \, (statement) \.) - (furthermore\, you (der-term) \, (statement) \.) - (I couldn\'t care less about your (thing) \.) - (How can you be so (adjective) \?) - (you make me sick\.) - (it\'s well known that (statement) \.) - ((statement) \.) - (it takes a (group-adj) (der-term) like you to say that (statement) \.) - (I don\'t want to hear about your (thing) \.) - (you\'re always totally wrong\.) - (I\'ve never heard anything as ridiculous as the idea that (statement) \.) - (you must be a real (der-term) to think that (statement) \.) - (you (adjective) (group-adj) (der-term) \!) - (you\'re probably (group-adj) yourself\.) - (you sound like a real (der-term) \.) - (why\, (statement) \!) - (I have many (group-adj) friends\.) - (save the (thing) s\!) (no nukes\!) (ban (thing) s\!) - (I\'ll bet you think that (thing) s are (adjective) \.) - (you know\, (statement) \.) - (your (quality) reminds me of a (thing) \.) - (you have the (quality) of a (der-term) \.) - ((der-term) \!) - ((adjective) (group-adj) (der-term) \!) - (you\'re a typical (group-adj) person\, totally (adjective) \.) - (man\, (sentence)))) - -(defvar sentence-loop (nconc sentence sentence)) - - -(defvar quality - '((ignorance) (stupidity) (worthlessness) - (prejudice) (lack of intelligence) (lousiness) - (bad grammar) (lousy spelling) - (lack of common decency) (ugliness) (nastiness) - (subtlety) (dishonesty) ((adjective) (quality)))) - - -(defvar quality-loop (nconc quality quality)) - -(defvar adjective - '((ignorant) (crass) (pathetic) (sick) - (bloated) (malignant) (perverted) (sadistic) - (stupid) (unpleasant) (lousy) (abusive) (bad) - (braindamaged) (selfish) (improper) (nasty) - (disgusting) (foul) (intolerable) (primitive) - (depressing) (dumb) (phoney) - ((adjective) and (adjective)) - (as (adjective) as a (thing)))) - -(defvar adjective-loop (nconc adjective adjective)) - -(defvar der-term - '(((adjective) (der-term)) (sexist) (fascist) - (weakling) (coward) (beast) (peasant) (racist) - (cretin) (fool) (jerk) (ignoramus) (idiot) - (wanker) (rat) (slimebag) (DAF driver) - (Neanderthal) (sadist) (drunk) (capitalist) - (wimp) (dogmatist) (wally) (maniac) - (whimpering scumbag) (pea brain) (arsehole) - (moron) (goof) (incompetent) (lunkhead) (Nazi) - (SysThug) ((der-term) (der-term)))) - -(defvar der-term-loop (nconc der-term der-term)) - - -(defvar thing - '(((adjective) (thing)) (computer) - (Honeywell dps8) (whale) (operation) - (sexist joke) (ten-incher) (dog) (MicroVAX II) - (source license) (real-time clock) - (mental problem) (sexual fantasy) - (venereal disease) (Jewish grandmother) - (cardboard cut-out) (punk haircut) (surfboard) - (system call) (wood-burning stove) - (graphics editor) (right wing death squad) - (disease) (vegetable) (religion) - (cruise missile) (bug fix) (lawyer) (copyright) - (PAD))) - -(defvar thing-loop (nconc thing thing)) - - -(defvar group-adj - '((gay) (old) (lesbian) (young) (black) - (Polish) ((adjective)) (white) - (mentally retarded) (Nicaraguan) (homosexual) - (dead) (underpriviledged) (religious) - ((thing) \-loving) (feminist) (foreign) - (intellectual) (crazy) (working) (unborn) - (Chinese) (short) ((adjective)) (poor) (rich) - (funny-looking) (Puerto Rican) (Mexican) - (Italian) (communist) (fascist) (Iranian) - (Moonie))) - -(defvar group-adj-loop (nconc group-adj group-adj)) - -(defvar statement - '((your (thing) is great) ((thing) s are fun) - ((person) is a (der-term)) - ((group-adj) people are (adjective)) - (every (group-adj) person is a (der-term)) - (most (group-adj) people have (thing) s) - (all (group-adj) dudes should get (thing) s) - ((person) is (group-adj)) (trees are (adjective)) - (if you\'ve seen one (thing) \, you\'ve seen them all) - (you\'re (group-adj)) (you have a (thing)) - (my (thing) is pretty good) - (the Martians are coming) - (the (paper) is always right) - (just because you read it in the (paper) that doesn\'t mean it\'s true) - ((person) was (group-adj)) - ((person) \'s ghost is living in your (thing)) - (you look like a (thing)) - (the oceans are full of dirty fish) - (people are dying every day) - (a (group-adj) man ain\'t got nothing in the world these days) - (women are inherently superior to men) - (the system staff is fascist) - (there is life after death) - (the world is full of (der-term) s) - (you remind me of (person)) (technology is evil) - ((person) killed (person)) - (the Russians are tapping your phone) - (the Earth is flat) - (it\'s OK to run down (group-adj) people) - (Multics is a really (adjective) operating system) - (the CIA killed (person)) - (the sexual revolution is over) - (Lassie was (group-adj)) - (the (group-adj) people have really got it all together) - (I was (person) in a previous life) - (breathing causes cancer) - (it\'s fun to be really (adjective)) - ((quality) is pretty fun) (you\'re a (der-term)) - (the (group-adj) culture is fascinating) - (when ya gotta go ya gotta go) - ((person) is (adjective)) - ((person) \'s (quality) is (adjective)) - (it\'s a wonderful day) - (everything is really a (thing)) - (there\'s a (thing) in (person) \'s brain) - ((person) is a cool dude) - ((person) is just a figment of your imagination) - (the more (thing) s you have, the better) - (life is a (thing)) (life is (quality)) - ((person) is (adjective)) - ((group-adj) people are all (adjective) (der-term) s) - ((statement) \, and (statement)) - ((statement) \, but (statement)) - (I wish I had a (thing)) - (you should have a (thing)) - (you hope that (statement)) - ((person) is secretly (group-adj)) - (you wish you were (group-adj)) - (you wish you were a (thing)) - (I wish I were a (thing)) - (you think that (statement)) - ((statement) \, because (statement)) - ((group-adj) people don\'t get married to (group-adj) people because (reason)) - ((group-adj) people are all (adjective) because (reason)) - ((group-adj) people are (adjective) \, and (reason)) - (you must be a (adjective) (der-term) to think that (person) said (statement)) - ((group-adj) people are inherently superior to (group-adj) people) - (God is Dead))) - -(defvar statement-loop (nconc statement statement)) - - -(defvar paper - '((Daily Mail) (Daily Express) - (Centre Bulletin) (Sun) (Daily Mirror) (Pravda) - (Daily Telegraph) (Beano) (Multics Manual))) - -(defvar paper-loop (nconc paper paper)) - - -(defvar person - '((Reagan) (Ken Thompson) (Dennis Ritchie) - (JFK) (the Pope) (Gadaffi) (Napoleon) - (Karl Marx) (Groucho) (Michael Jackson) - (Caesar) (Nietzsche) (Heidegger) (\"Head-for-the-mountains\" Bush) - (Henry Kissinger) (Nixon) (Castro) (Thatcher) - (Attilla the Hun) (Alaric the Visigoth) (Hitler))) - -(defvar person-loop (nconc person person)) - -(defvar reason - '((they don\'t want their children to grow up to be too lazy to steal) - (they can\'t tell them apart from (group-adj) dudes) - (they\'re too (adjective)) - ((person) wouldn\'t have done it) - (they can\'t spray paint that small) - (they don\'t have (thing) s) (they don\'t know how) - (they can\'t afford (thing) s))) - -(defvar reason-loop (nconc reason reason)) - -(defmacro define-element (name) - (let ((loop-to-use (intern (concat name "-loop")))) - (` (defun (, (intern name)) nil - (let ((step-forward (random 10))) - (if (< step-forward 0) (setq step-forward (- step-forward))) - (prog1 - (nth step-forward (, loop-to-use)) - (setq (, loop-to-use) (nthcdr (1+ step-forward) (, loop-to-use))))))))) - -(define-element "sentence") -(define-element "quality") -(define-element "adjective") -(define-element "der-term") -(define-element "group-adj") -(define-element "statement") -(define-element "thing") -(define-element "paper") -(define-element "person") -(define-element "reason") - -(defun *flame nil - (flame-expand '(sentence))) - -(defun flame-expand (object) - (cond ((atom object) - object) - (t (mapcar 'flame-expand (funcall (car object)))))) - -(defun flatten (list) - (cond ((atom list) - (list list)) - (t (apply 'append (mapcar 'flatten list))))) - -;;;###autoload -(defun flame (arg) - "Generate ARG (default 1) sentences of half-crazed gibberish." - (interactive "p") - (let ((w (selected-window))) - (pop-to-buffer (get-buffer-create "*Flame*")) - (goto-char (point-max)) - (insert ?\n) - (flame2 arg) - (select-window w))) - -(defun flame2 (arg) - (let ((start (point))) - (flame1 arg) - (fill-region-as-paragraph start (point) t))) - -(defun flame1 (arg) - (cond ((zerop arg) t) - (t (insert (concat (sentence-ify (string-ify (append-suffixes-hack (flatten (*flame))))))) - (flame1 (1- arg))))) - -(defun sentence-ify (string) - (concat (upcase (substring string 0 1)) - (substring string 1 (length string)) - " ")) - -(defun string-ify (list) - (mapconcat - 'symbol-name -; '(lambda (x) -; (format "%s" x)) - list - " ")) - -(defun append-suffixes-hack (list) - (cond ((null list) - nil) - ((memq (nth 1 list) - '(\? \. \, s\! \! s \'s \-loving)) - (cons (intern (concat (symbol-name (nth 0 list)) - (symbol-name (nth 1 list)))) - ;;(intern (format "%s%s" (nth 0 list) (nth 1 list))) - (append-suffixes-hack (nthcdr 2 list)))) - (t (cons (nth 0 list) - (append-suffixes-hack (nthcdr 1 list)))))) - -(defun psychoanalyze-flamer () - "Mr. Angry goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (flame2 (if (= (random 2) 0) 2 1)) - (sit-for 0) - (doctor-ret-or-read 1))) - -;;; flame.el ends here
--- a/lisp/games/gomoku.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1136 +0,0 @@ -;;; gomoku.el --- Gomoku game between you and Emacs - -;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. - -;; Author: Philippe Schnoebelen <phs@lifia.imag.fr> -;; Adapted-By: ESR -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.30. - -;;; Commentary: - -;;; Gomoku game between you and GNU Emacs. Last modified on 13 Sep 1988 -;;; -;;; Written by Ph. Schnoebelen (phs@lifia.imag.fr), 1987, 1988 -;;; with precious advices from J.-F. Rit. -;;; This has been tested with GNU Emacs 18.50. - -;; RULES: -;; -;; Gomoku is a game played between two players on a rectangular board. Each -;; player, in turn, marks a free square of its choice. The winner is the first -;; one to mark five contiguous squares in any direction (horizontally, -;; vertically or diagonally). -;; -;; I have been told that, in "The TRUE Gomoku", some restrictions are made -;; about the squares where one may play, or else there is a known forced win -;; for the first player. This program has no such restriction, but it does not -;; know about the forced win, nor do I. Furthermore, you probably do not know -;; it yourself :-). - - -;; There are two main places where you may want to customize the program: key -;; bindings and board display. These features are commented in the code. Go -;; and see. - - -;; HOW TO USE: -;; -;; The command "M-x gomoku" displays a -;; board, the size of which depends on the size of the current window. The -;; size of the board is easily modified by giving numeric arguments to the -;; gomoku command and/or by customizing the displaying parameters. -;; -;; Emacs plays when it is its turn. When it is your turn, just put the cursor -;; on the square where you want to play and hit RET, or X, or whatever key you -;; bind to the command gomoku-human-plays. When it is your turn, Emacs is -;; idle: you may switch buffers, read your mail, ... Just come back to the -;; *Gomoku* buffer and resume play. - - -;; ALGORITHM: -;; -;; The algorithm is briefly described in section "THE SCORE TABLE". Some -;; parameters may be modified if you want to change the style exhibited by the -;; program. - -;;; Code: - -;;; -;;; GOMOKU MODE AND KEYMAP. -;;; -(defvar gomoku-mode-hook nil - "If non-nil, its value is called on entry to Gomoku mode.") - -(defvar gomoku-mode-map nil - "Local keymap to use in Gomoku mode.") - -(if gomoku-mode-map - nil - (setq gomoku-mode-map (make-sparse-keymap)) - (set-keymap-name gomoku-mode-map 'gomoku-mode-map) - - ;; Key bindings for cursor motion. Arrow keys are just "function" - ;; keys, see below. - (define-key gomoku-mode-map "y" 'gomoku-move-nw) ; Y - (define-key gomoku-mode-map "u" 'gomoku-move-ne) ; U - (define-key gomoku-mode-map "b" 'gomoku-move-sw) ; B - (define-key gomoku-mode-map "n" 'gomoku-move-se) ; N - (define-key gomoku-mode-map "h" 'gomoku-move-left) ; H - (define-key gomoku-mode-map "l" 'gomoku-move-right) ; L - (define-key gomoku-mode-map "j" 'gomoku-move-down) ; J - (define-key gomoku-mode-map "k" 'gomoku-move-up) ; K - (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-N - (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-P - (define-key gomoku-mode-map "\C-f" 'gomoku-move-right) ; C-F - (define-key gomoku-mode-map "\C-b" 'gomoku-move-left) ; C-B - - ;; Key bindings for entering Human moves. - ;; If you have a mouse, you may also bind some mouse click ... - (define-key gomoku-mode-map "X" 'gomoku-human-plays) ; X - (define-key gomoku-mode-map "x" 'gomoku-human-plays) ; x - (define-key gomoku-mode-map "\C-m" 'gomoku-human-plays) ; RET - (define-key gomoku-mode-map "\C-c\C-p" 'gomoku-human-plays) ; C-C C-P - (define-key gomoku-mode-map "\C-c\C-b" 'gomoku-human-takes-back) ; C-C C-B - (define-key gomoku-mode-map "\C-c\C-r" 'gomoku-human-resigns) ; C-C C-R - (define-key gomoku-mode-map "\C-c\C-e" 'gomoku-emacs-plays) ; C-C C-E - - (define-key gomoku-mode-map [up] 'gomoku-move-up) - (define-key gomoku-mode-map [down] 'gomoku-move-down) - (define-key gomoku-mode-map [left] 'gomoku-move-left) - (define-key gomoku-mode-map [right] 'gomoku-move-right) - (define-key gomoku-mode-map [kp-enter] 'gomoku-human-plays) - (define-key gomoku-mode-map [button2] 'gomoku-click) - (define-key gomoku-mode-map [insert] 'gomoku-human-plays)) - - -(defun gomoku-mode () - "Major mode for playing Gomoku against Emacs. -You and Emacs play in turn by marking a free square. You mark it with X -and Emacs marks it with O. The winner is the first to get five contiguous -marks horizontally, vertically or in diagonal. -You play by moving the cursor over the square you choose and hitting \\[gomoku-human-plays]. -Other useful commands: -\\{gomoku-mode-map} -Entry to this mode calls the value of `gomoku-mode-hook' if that value -is non-nil." - (interactive) - (setq major-mode 'gomoku-mode - mode-name "Gomoku") - (gomoku-display-statistics) - (use-local-map gomoku-mode-map) - (run-hooks 'gomoku-mode-hook)) - -;;; -;;; THE BOARD. -;;; - -;; The board is a rectangular grid. We code empty squares with 0, X's with 1 -;; and O's with 6. The rectangle is recorded in a one dimensional vector -;; containing padding squares (coded with -1). These squares allow us to -;; detect when we are trying to move out of the board. We denote a square by -;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The -;; leftmost topmost square has coords (1,1) and index gomoku-board-width + 2. -;; Similarly, vectors between squares may be given by two DX, DY coords or by -;; one DEPL (the difference between indexes). - -(defvar gomoku-board-width nil - "Number of columns on the Gomoku board.") - -(defvar gomoku-board-height nil - "Number of lines on the Gomoku board.") - -(defvar gomoku-board nil - "Vector recording the actual state of the Gomoku board.") - -(defvar gomoku-vector-length nil - "Length of gomoku-board vector.") - -(defvar gomoku-draw-limit nil - ;; This is usually set to 70% of the number of squares. - "After how many moves will Emacs offer a draw?") - - -(defun gomoku-xy-to-index (x y) - "Translate X, Y cartesian coords into the corresponding board index." - (+ (* y gomoku-board-width) x y)) - -(defun gomoku-index-to-x (index) - "Return corresponding x-coord of board INDEX." - (% index (1+ gomoku-board-width))) - -(defun gomoku-index-to-y (index) - "Return corresponding y-coord of board INDEX." - (/ index (1+ gomoku-board-width))) - -(defun gomoku-init-board () - "Create the gomoku-board vector and fill it with initial values." - (setq gomoku-board (make-vector gomoku-vector-length 0)) - ;; Every square is 0 (i.e. empty) except padding squares: - (let ((i 0) (ii (1- gomoku-vector-length))) - (while (<= i gomoku-board-width) ; The squares in [0..width] and in - (aset gomoku-board i -1) ; [length - width - 1..length - 1] - (aset gomoku-board ii -1) ; are padding squares. - (setq i (1+ i) - ii (1- ii)))) - (let ((i 0)) - (while (< i gomoku-vector-length) - (aset gomoku-board i -1) ; and also all k*(width+1) - (setq i (+ i gomoku-board-width 1))))) - -;;; -;;; THE SCORE TABLE. -;;; - -;; Every (free) square has a score associated to it, recorded in the -;; GOMOKU-SCORE-TABLE vector. The program always plays in the square having -;; the highest score. - -(defvar gomoku-score-table nil - "Vector recording the actual score of the free squares.") - - -;; The key point point about the algorithm is that, rather than considering -;; the board as just a set of squares, we prefer to see it as a "space" of -;; internested 5-tuples of contiguous squares (called qtuples). -;; -;; The aim of the program is to fill one qtuple with its O's while preventing -;; you from filling another one with your X's. To that effect, it computes a -;; score for every qtuple, with better qtuples having better scores. Of -;; course, the score of a qtuple (taken in isolation) is just determined by -;; its contents as a set, i.e. not considering the order of its elements. The -;; highest score is given to the "OOOO" qtuples because playing in such a -;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because -;; not playing in it is just loosing the game, and so on. Note that a -;; "polluted" qtuple, i.e. one containing at least one X and at least one O, -;; has score zero because there is no more any point in playing in it, from -;; both an attacking and a defending point of view. -;; -;; Given the score of every qtuple, the score of a given free square on the -;; board is just the sum of the scores of all the qtuples to which it belongs, -;; because playing in that square is playing in all its containing qtuples at -;; once. And it is that function which takes into account the internesting of -;; the qtuples. -;; -;; This algorithm is rather simple but anyway it gives a not so dumb level of -;; play. It easily extends to "n-dimensional Gomoku", where a win should not -;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !) -;; should be preferred. - - -;; Here are the scores of the nine "non-polluted" configurations. Tuning -;; these values will change (hopefully improve) the strength of the program -;; and may change its style (rather aggressive here). - -(defconst nil-score 7 "Score of an empty qtuple.") -(defconst Xscore 15 "Score of a qtuple containing one X.") -(defconst XXscore 400 "Score of a qtuple containing two X's.") -(defconst XXXscore 1800 "Score of a qtuple containing three X's.") -(defconst XXXXscore 100000 "Score of a qtuple containing four X's.") -(defconst Oscore 35 "Score of a qtuple containing one O.") -(defconst OOscore 800 "Score of a qtuple containing two O's.") -(defconst OOOscore 15000 "Score of a qtuple containing three O's.") -(defconst OOOOscore 800000 "Score of a qtuple containing four O's.") - -;; These values are not just random: if, given the following situation: -;; -;; . . . . . . . O . -;; . X X a . . . X . -;; . . . X . . . X . -;; . . . X . . . X . -;; . . . . . . . b . -;; -;; you want Emacs to play in "a" and not in "b", then the parameters must -;; satisfy the inequality: -;; -;; 6 * XXscore > XXXscore + XXscore -;; -;; because "a" mainly belongs to six "XX" qtuples (the others are less -;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other -;; conditions are required to obtain sensible moves, but the previous example -;; should illustrate the point. If you manage to improve on these values, -;; please send me a note. Thanks. - - -;; As we choosed values 0, 1 and 6 to denote empty, X and O squares, the -;; contents of a qtuple is uniquely determined by the sum of its elements and -;; we just have to set up a translation table. - -(defconst gomoku-score-trans-table - (vector nil-score Xscore XXscore XXXscore XXXXscore 0 - Oscore 0 0 0 0 0 - OOscore 0 0 0 0 0 - OOOscore 0 0 0 0 0 - OOOOscore 0 0 0 0 0 - 0) - "Vector associating qtuple contents to their score.") - - -;; If you do not modify drastically the previous constants, the only way for a -;; square to have a score higher than OOOOscore is to belong to a "OOOO" -;; qtuple, thus to be a winning move. Similarly, the only way for a square to -;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX" -;; qtuple. We may use these considerations to detect when a given move is -;; winning or loosing. - -(defconst gomoku-winning-threshold OOOOscore - "Threshold score beyond which an Emacs move is winning.") - -(defconst gomoku-loosing-threshold XXXXscore - "Threshold score beyond which a human move is winning.") - - -(defun gomoku-strongest-square () - "Compute index of free square with highest score, or nil if none." - ;; We just have to loop other all squares. However there are two problems: - ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed - ;; up future searches, we set the score of padding or occupied squares - ;; to -1 whenever we meet them. - ;; 2/ We want to choose randomly between equally good moves. - (let ((score-max 0) - (count 0) ; Number of equally good moves - (square (gomoku-xy-to-index 1 1)) ; First square - (end (gomoku-xy-to-index gomoku-board-width gomoku-board-height)) - best-square score) - (while (<= square end) - (cond - ;; If score is lower (i.e. most of the time), skip to next: - ((< (aref gomoku-score-table square) score-max)) - ;; If score is better, beware of non free squares: - ((> (setq score (aref gomoku-score-table square)) score-max) - (if (zerop (aref gomoku-board square)) ; is it free ? - (setq count 1 ; yes: take it ! - best-square square - score-max score) - (aset gomoku-score-table square -1))) ; no: kill it ! - ;; If score is equally good, choose randomly. But first check freeness: - ((not (zerop (aref gomoku-board square))) - (aset gomoku-score-table square -1)) - ((zerop (random (setq count (1+ count)))) - (setq best-square square - score-max score))) - (setq square (1+ square))) ; try next square - best-square)) - -;;; -;;; INITIALIZING THE SCORE TABLE. -;;; - -;; At initialization the board is empty so that every qtuple amounts for -;; nil-score. Therefore, the score of any square is nil-score times the number -;; of qtuples that pass through it. This number is 3 in a corner and 20 if you -;; are sufficiently far from the sides. As computing the number is time -;; consuming, we initialize every square with 20*nil-score and then only -;; consider squares at less than 5 squares from one side. We speed this up by -;; taking symmetry into account. -;; Also, as it is likely that successive games will be played on a board with -;; same size, it is a good idea to save the initial SCORE-TABLE configuration. - -(defvar gomoku-saved-score-table nil - "Recorded initial value of previous score table.") - -(defvar gomoku-saved-board-width nil - "Recorded value of previous board width.") - -(defvar gomoku-saved-board-height nil - "Recorded value of previous board height.") - - -(defun gomoku-init-score-table () - "Create the score table vector and fill it with initial values." - (if (and gomoku-saved-score-table ; Has it been stored last time ? - (= gomoku-board-width gomoku-saved-board-width) - (= gomoku-board-height gomoku-saved-board-height)) - (setq gomoku-score-table (copy-sequence gomoku-saved-score-table)) - ;; No, compute it: - (setq gomoku-score-table - (make-vector gomoku-vector-length (* 20 nil-score))) - (let (i j maxi maxj maxi2 maxj2) - (setq maxi (/ (1+ gomoku-board-width) 2) - maxj (/ (1+ gomoku-board-height) 2) - maxi2 (min 4 maxi) - maxj2 (min 4 maxj)) - ;; We took symmetry into account and could use it more if the board - ;; would have been square and not rectangular ! - ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U - ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the - ;; board may well be less than 8 by 8 ! - (setq i 1) - (while (<= i maxi2) - (setq j 1) - (while (<= j maxj) - (gomoku-init-square-score i j) - (setq j (1+ j))) - (setq i (1+ i))) - (while (<= i maxi) - (setq j 1) - (while (<= j maxj2) - (gomoku-init-square-score i j) - (setq j (1+ j))) - (setq i (1+ i)))) - (setq gomoku-saved-score-table (copy-sequence gomoku-score-table) - gomoku-saved-board-width gomoku-board-width - gomoku-saved-board-height gomoku-board-height))) - -(defun gomoku-nb-qtuples (i j) - "Return the number of qtuples containing square I,J." - ;; This function is complicated because we have to deal - ;; with ugly cases like 3 by 6 boards, but it works. - ;; If you have a simpler (and correct) solution, send it to me. Thanks ! - (let ((left (min 4 (1- i))) - (right (min 4 (- gomoku-board-width i))) - (up (min 4 (1- j))) - (down (min 4 (- gomoku-board-height j)))) - (+ -12 - (min (max (+ left right) 3) 8) - (min (max (+ up down) 3) 8) - (min (max (+ (min left up) (min right down)) 3) 8) - (min (max (+ (min right up) (min left down)) 3) 8)))) - -(defun gomoku-init-square-score (i j) - "Give initial score to square I,J and to its mirror images." - (let ((ii (1+ (- gomoku-board-width i))) - (jj (1+ (- gomoku-board-height j))) - (sc (* (gomoku-nb-qtuples i j) (aref gomoku-score-trans-table 0)))) - (aset gomoku-score-table (gomoku-xy-to-index i j) sc) - (aset gomoku-score-table (gomoku-xy-to-index ii j) sc) - (aset gomoku-score-table (gomoku-xy-to-index i jj) sc) - (aset gomoku-score-table (gomoku-xy-to-index ii jj) sc))) - -;;; -;;; MAINTAINING THE SCORE TABLE. -;;; - -;; We do not provide functions for computing the SCORE-TABLE given the -;; contents of the BOARD. This would involve heavy nested loops, with time -;; proportional to the size of the board. It is better to update the -;; SCORE-TABLE after each move. Updating needs not modify more than 36 -;; squares: it is done in constant time. - -(defun gomoku-update-score-table (square dval) - "Update score table after SQUARE received a DVAL increment." - ;; The board has already been updated when this function is called. - ;; Updating scores is done by looking for qtuples boundaries in all four - ;; directions and then calling update-score-in-direction. - ;; Finally all squares received the right increment, and then are up to - ;; date, except possibly for SQUARE itself if we are taking a move back for - ;; its score had been set to -1 at the time. - (let* ((x (gomoku-index-to-x square)) - (y (gomoku-index-to-y square)) - (imin (max -4 (- 1 x))) - (jmin (max -4 (- 1 y))) - (imax (min 0 (- gomoku-board-width x 4))) - (jmax (min 0 (- gomoku-board-height y 4)))) - (gomoku-update-score-in-direction imin imax - square 1 0 dval) - (gomoku-update-score-in-direction jmin jmax - square 0 1 dval) - (gomoku-update-score-in-direction (max imin jmin) (min imax jmax) - square 1 1 dval) - (gomoku-update-score-in-direction (max (- 1 y) -4 - (- x gomoku-board-width)) - (min 0 (- x 5) - (- gomoku-board-height y 4)) - square -1 1 dval))) - -(defun gomoku-update-score-in-direction (left right square dx dy dval) - "Update scores for all squares in the qtuples starting between the LEFTth -square and the RIGHTth after SQUARE, along the DX, DY direction, considering -that DVAL has been added on SQUARE." - ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well - ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that - ;; DX,DY direction. - (cond - ((> left right)) ; Quit - (t ; Else .. - (let (depl square0 square1 square2 count delta) - (setq depl (gomoku-xy-to-index dx dy) - square0 (+ square (* left depl)) - square1 (+ square (* right depl)) - square2 (+ square0 (* 4 depl))) - ;; Compute the contents of the first qtuple: - (setq square square0 - count 0) - (while (<= square square2) - (setq count (+ count (aref gomoku-board square)) - square (+ square depl))) - (while (<= square0 square1) - ;; Update the squares of the qtuple beginning in SQUARE0 and ending - ;; in SQUARE2. - (setq delta (- (aref gomoku-score-trans-table count) - (aref gomoku-score-trans-table (- count dval)))) - (cond ((not (zerop delta)) ; or else nothing to update - (setq square square0) - (while (<= square square2) - (if (zerop (aref gomoku-board square)) ; only for free squares - (aset gomoku-score-table square - (+ (aref gomoku-score-table square) delta))) - (setq square (+ square depl))))) - ;; Then shift the qtuple one square along DEPL, this only requires - ;; modifying SQUARE0 and SQUARE2. - (setq square2 (+ square2 depl) - count (+ count (- (aref gomoku-board square0)) - (aref gomoku-board square2)) - square0 (+ square0 depl))))))) - -;;; -;;; GAME CONTROL. -;;; - -;; Several variables are used to monitor a game, including a GAME-HISTORY (the -;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back -;; (anti-updating the score table) and to compute the table from scratch in -;; case of an interruption. - -(defvar gomoku-game-in-progress nil - "Non-nil if a game is in progress.") - -(defvar gomoku-game-history nil - "A record of all moves that have been played during current game.") - -(defvar gomoku-number-of-moves nil - "Number of moves already played in current game.") - -(defvar gomoku-number-of-human-moves nil - "Number of moves already played by human in current game.") - -(defvar gomoku-emacs-played-first nil - "Non-nil if Emacs played first.") - -(defvar gomoku-human-took-back nil - "Non-nil if Human took back a move during the game.") - -(defvar gomoku-human-refused-draw nil - "Non-nil if Human refused Emacs offer of a draw.") - -(defvar gomoku-emacs-is-computing nil - ;; This is used to detect interruptions. Hopefully, it should not be needed. - "Non-nil if Emacs is in the middle of a computation.") - - -(defun gomoku-start-game (n m) - "Initialize a new game on an N by M board." - (setq gomoku-emacs-is-computing t) ; Raise flag - (setq gomoku-game-in-progress t) - (setq gomoku-board-width n - gomoku-board-height m - gomoku-vector-length (1+ (* (+ m 2) (1+ n))) - gomoku-draw-limit (/ (* 7 n m) 10)) - (setq gomoku-game-history nil - gomoku-number-of-moves 0 - gomoku-number-of-human-moves 0 - gomoku-emacs-played-first nil - gomoku-human-took-back nil - gomoku-human-refused-draw nil) - (gomoku-init-display n m) ; Display first: the rest takes time - (gomoku-init-score-table) ; INIT-BOARD requires that the score - (gomoku-init-board) ; table be already created. - (setq gomoku-emacs-is-computing nil)) - -(defun gomoku-play-move (square val &optional dont-update-score) - "Go to SQUARE, play VAL and update everything." - (setq gomoku-emacs-is-computing t) ; Raise flag - (cond ((= 1 val) ; a Human move - (setq gomoku-number-of-human-moves (1+ gomoku-number-of-human-moves))) - ((zerop gomoku-number-of-moves) ; an Emacs move. Is it first ? - (setq gomoku-emacs-played-first t))) - (setq gomoku-game-history - (cons (cons square (aref gomoku-score-table square)) - gomoku-game-history) - gomoku-number-of-moves (1+ gomoku-number-of-moves)) - (gomoku-plot-square square val) - (aset gomoku-board square val) ; *BEFORE* UPDATE-SCORE ! - (if dont-update-score nil - (gomoku-update-score-table square val) ; previous val was 0: dval = val - (aset gomoku-score-table square -1)) - (setq gomoku-emacs-is-computing nil)) - -(defun gomoku-take-back () - "Take back last move and update everything." - (setq gomoku-emacs-is-computing t) - (let* ((last-move (car gomoku-game-history)) - (square (car last-move)) - (oldval (aref gomoku-board square))) - (if (= 1 oldval) - (setq gomoku-number-of-human-moves (1- gomoku-number-of-human-moves))) - (setq gomoku-game-history (cdr gomoku-game-history) - gomoku-number-of-moves (1- gomoku-number-of-moves)) - (gomoku-plot-square square 0) - (aset gomoku-board square 0) ; *BEFORE* UPDATE-SCORE ! - (gomoku-update-score-table square (- oldval)) - (aset gomoku-score-table square (cdr last-move))) - (setq gomoku-emacs-is-computing nil)) - -;;; -;;; SESSION CONTROL. -;;; - -(defvar gomoku-number-of-emacs-wins 0 - "Number of games Emacs won in this session.") - -(defvar gomoku-number-of-human-wins 0 - "Number of games you won in this session.") - -(defvar gomoku-number-of-draws 0 - "Number of games already drawn in this session.") - - -(defun gomoku-terminate-game (result) - "Terminate the current game with RESULT." - (let (message) - (cond - ((eq result 'emacs-won) - (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - (setq message - (cond ((< gomoku-number-of-moves 20) - "This was a REALLY QUICK win.") - (gomoku-human-refused-draw - "I won... Too bad you refused my offer of a draw !") - (gomoku-human-took-back - "I won... Taking moves back will not help you !") - ((not gomoku-emacs-played-first) - "I won... Playing first did not help you much !") - ((and (zerop gomoku-number-of-human-wins) - (zerop gomoku-number-of-draws) - (> gomoku-number-of-emacs-wins 1)) - "I'm becoming tired of winning...") - (t - "I won.")))) - ((eq result 'human-won) - (setq gomoku-number-of-human-wins (1+ gomoku-number-of-human-wins)) - (setq message - (cond - (gomoku-human-took-back - "OK, you won this one. I, for one, never take my moves back...") - (gomoku-emacs-played-first - "OK, you won this one... so what ?") - (t - "OK, you won this one. Now, let me play first just once.")))) - ((eq result 'human-resigned) - (setq gomoku-number-of-emacs-wins (1+ gomoku-number-of-emacs-wins)) - (setq message "So you resign. That's just one more win for me.")) - ((eq result 'nobody-won) - (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) - (setq message - (cond - (gomoku-human-took-back - "This is a draw. I, for one, never take my moves back...") - (gomoku-emacs-played-first - "This is a draw. Just chance, I guess.") - (t - "This is a draw. Now, let me play first just once.")))) - ((eq result 'draw-agreed) - (setq gomoku-number-of-draws (1+ gomoku-number-of-draws)) - (setq message - (cond - (gomoku-human-took-back - "Draw agreed. I, for one, never take my moves back...") - (gomoku-emacs-played-first - "Draw agreed. You were lucky.") - (t - "Draw agreed. Now, let me play first just once.")))) - ((eq result 'crash-game) - (setq message - "Sorry, I have been interrupted and cannot resume that game..."))) - - (gomoku-display-statistics) - (if message (message message)) - (ding) - (setq gomoku-game-in-progress nil))) - -(defun gomoku-crash-game () - "What to do when Emacs detects it has been interrupted." - (setq gomoku-emacs-is-computing nil) - (gomoku-terminate-game 'crash-game) - (sit-for 4) ; Let's see the message - (gomoku-prompt-for-other-game)) - -;;; -;;; INTERACTIVE COMMANDS. -;;; - -;;;###autoload -(defun gomoku (&optional n m) - "Start a Gomoku game between you and Emacs. -If a game is in progress, this command allow you to resume it. -If optional arguments N and M are given, an N by M board is used. - -You and Emacs play in turn by marking a free square. You mark it with X -and Emacs marks it with O. The winner is the first to get five contiguous -marks horizontally, vertically or in diagonal. -You play by moving the cursor over the square you choose and hitting -\\<gomoku-mode-map>\\[gomoku-human-plays]. -Use \\[describe-mode] for more info." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (let ((max-width (gomoku-max-width)) - (max-height (gomoku-max-height))) - (or n (setq n max-width)) - (or m (setq m max-height)) - (cond ((< n 1) - (error "I need at least 1 column")) - ((< m 1) - (error "I need at least 1 row")) - ((> n max-width) - (error "I cannot display %d columns in that window" n))) - (if (and (> m max-height) - (not (equal m gomoku-saved-board-height)) - ;; Use EQUAL because SAVED-BOARD-HEIGHT may be nil - (not (y-or-n-p (format "Do you really want %d rows " m)))) - (setq m max-height))) - (message "One moment, please...") - (gomoku-start-game n m) - (if (y-or-n-p "Do you allow me to play first ") - (gomoku-emacs-plays) - (gomoku-prompt-for-move))) - ((y-or-n-p "Shall we continue our game ") - (gomoku-prompt-for-move)) - (t - (gomoku-human-resigns)))) - -(defun gomoku-emacs-plays () - "Compute Emacs next move and play it." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (gomoku-prompt-for-other-game)) - (t - (message "Let me think...") - (let (square score) - (setq square (gomoku-strongest-square)) - (cond ((null square) - (gomoku-terminate-game 'nobody-won)) - (t - (setq score (aref gomoku-score-table square)) - (gomoku-play-move square 6) - (cond ((>= score gomoku-winning-threshold) - (gomoku-find-filled-qtuple square 6) - (gomoku-cross-winning-qtuple) - (gomoku-terminate-game 'emacs-won)) - ((zerop score) - (gomoku-terminate-game 'nobody-won)) - ((and (> gomoku-number-of-moves gomoku-draw-limit) - (not gomoku-human-refused-draw) - (gomoku-offer-a-draw)) - (gomoku-terminate-game 'draw-agreed)) - (t - (gomoku-prompt-for-move))))))))) - -(defun gomoku-click (click) - "Play at the square where you click." - (interactive "e") - (mouse-set-point click) - (gomoku-human-plays)) - -(defun gomoku-human-plays () - "Signal to the Gomoku program that you have played. -You must have put the cursor on the square where you want to play. -If the game is finished, this command requests for another game." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (gomoku-prompt-for-other-game)) - (t - (let (square score) - (setq square (gomoku-point-square)) - (cond ((null square) - (error "Your point is not on a square. Retry !")) - ((not (zerop (aref gomoku-board square))) - (error "Your point is not on a free square. Retry !")) - (t - (setq score (aref gomoku-score-table square)) - (gomoku-play-move square 1) - (cond ((and (>= score gomoku-loosing-threshold) - ;; Just testing SCORE > THRESHOLD is not enough for - ;; detecting wins, it just gives an indication that - ;; we confirm with GOMOKU-FIND-FILLED-QTUPLE. - (gomoku-find-filled-qtuple square 1)) - (gomoku-cross-winning-qtuple) - (gomoku-terminate-game 'human-won)) - (t - (gomoku-emacs-plays))))))))) - -(defun gomoku-human-takes-back () - "Signal to the Gomoku program that you wish to take back your last move." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (message "Too late for taking back...") - (sit-for 4) - (gomoku-prompt-for-other-game)) - ((zerop gomoku-number-of-human-moves) - (message "You have not played yet... Your move ?")) - (t - (message "One moment, please...") - ;; It is possible for the user to let Emacs play several consecutive - ;; moves, so that the best way to know when to stop taking back moves is - ;; to count the number of human moves: - (setq gomoku-human-took-back t) - (let ((number gomoku-number-of-human-moves)) - (while (= number gomoku-number-of-human-moves) - (gomoku-take-back))) - (gomoku-prompt-for-move)))) - -(defun gomoku-human-resigns () - "Signal to the Gomoku program that you may want to resign." - (interactive) - (gomoku-switch-to-window) - (cond - (gomoku-emacs-is-computing - (gomoku-crash-game)) - ((not gomoku-game-in-progress) - (message "There is no game in progress")) - ((y-or-n-p "You mean, you resign ") - (gomoku-terminate-game 'human-resigned)) - ((y-or-n-p "You mean, we continue ") - (gomoku-prompt-for-move)) - (t - (gomoku-terminate-game 'human-resigned)))) ; OK. Accept it - -;;; -;;; PROMPTING THE HUMAN PLAYER. -;;; - -(defun gomoku-prompt-for-move () - "Display a message asking for Human's move." - (message (if (zerop gomoku-number-of-human-moves) - "Your move ? (move to a free square and hit X, RET ...)" - "Your move ?")) - ;; This may seem silly, but if one omits the following line (or a similar - ;; one), the cursor may very well go to some place where POINT is not. - (save-excursion (set-buffer (other-buffer)))) - -(defun gomoku-prompt-for-other-game () - "Ask for another game, and start it." - (if (y-or-n-p "Another game ") - (gomoku gomoku-board-width gomoku-board-height) - (message "Chicken !"))) - -(defun gomoku-offer-a-draw () - "Offer a draw and return T if Human accepted it." - (or (y-or-n-p "I offer you a draw. Do you accept it ") - (prog1 (setq gomoku-human-refused-draw t) - nil))) - -;;; -;;; DISPLAYING THE BOARD. -;;; - -;; You may change these values if you have a small screen or if the squares -;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1). - -(defconst gomoku-square-width 4 - "*Horizontal spacing between squares on the Gomoku board.") - -(defconst gomoku-square-height 2 - "*Vertical spacing between squares on the Gomoku board.") - -(defconst gomoku-x-offset 3 - "*Number of columns between the Gomoku board and the side of the window.") - -(defconst gomoku-y-offset 1 - "*Number of lines between the Gomoku board and the top of the window.") - - -(defun gomoku-max-width () - "Largest possible board width for the current window." - (1+ (/ (- (window-width (selected-window)) - gomoku-x-offset gomoku-x-offset 1) - gomoku-square-width))) - -(defun gomoku-max-height () - "Largest possible board height for the current window." - (1+ (/ (- (window-height (selected-window)) - gomoku-y-offset gomoku-y-offset 2) - ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! - gomoku-square-height))) - -(defun gomoku-point-x () - "Return the board column where point is, or nil if it is not a board column." - (let ((col (- (current-column) gomoku-x-offset))) - (if (and (>= col 0) - (zerop (% col gomoku-square-width)) - (<= (setq col (1+ (/ col gomoku-square-width))) - gomoku-board-width)) - col))) - -(defun gomoku-point-y () - "Return the board row where point is, or nil if it is not a board row." - (let ((row (- (count-lines 1 (point)) gomoku-y-offset 1))) - (if (and (>= row 0) - (zerop (% row gomoku-square-height)) - (<= (setq row (1+ (/ row gomoku-square-height))) - gomoku-board-height)) - row))) - -(defun gomoku-point-square () - "Return the index of the square point is on, or nil if not on the board." - (let (x y) - (and (setq x (gomoku-point-x)) - (setq y (gomoku-point-y)) - (gomoku-xy-to-index x y)))) - -(defun gomoku-goto-square (index) - "Move point to square number INDEX." - (gomoku-goto-xy (gomoku-index-to-x index) (gomoku-index-to-y index))) - -(defun gomoku-goto-xy (x y) - "Move point to square at X, Y coords." - (goto-line (+ 1 gomoku-y-offset (* gomoku-square-height (1- y)))) - (move-to-column (+ gomoku-x-offset (* gomoku-square-width (1- x))))) - -(defun gomoku-plot-square (square value) - "Draw 'X', 'O' or '.' on SQUARE (depending on VALUE), leave point there." - (gomoku-goto-square square) - (gomoku-put-char (cond ((= value 1) ?X) - ((= value 6) ?O) - (t ?.))) - (sit-for 0)) ; Display NOW - -(defun gomoku-put-char (char) - "Draw CHAR on the Gomoku screen." - (let ((inhibit-read-only t)) - (insert char) - (delete-char 1) - (backward-char 1))) - -(defun gomoku-init-display (n m) - "Display an N by M Gomoku board." - (buffer-disable-undo (current-buffer)) - (let ((inhibit-read-only t)) - (erase-buffer) - (let (string1 string2 string3 string4) - ;; We do not use gomoku-plot-square which would be too slow for - ;; initializing the display. Rather we build STRING1 for lines where - ;; board squares are to be found, and STRING2 for empty lines. STRING1 is - ;; like STRING2 except for dots every DX squares. Empty lines are filled - ;; with spaces so that cursor moving up and down remains on the same - ;; column. - (setq string1 (concat (make-string (1- gomoku-square-width) ? ) ".") - string1 (apply 'concat - (make-list (1- n) string1)) - string1 (concat (make-string gomoku-x-offset ? ) "." string1 "\n") - string2 (make-string (+ 1 gomoku-x-offset - (* (1- n) gomoku-square-width)) - ? ) - string2 (concat string2 "\n") - string3 (apply 'concat - (make-list (1- gomoku-square-height) string2)) - string3 (concat string3 string1) - string3 (apply 'concat - (make-list (1- m) string3)) - string4 (apply 'concat - (make-list gomoku-y-offset string2))) - (insert string4 string1 string3)) - (gomoku-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board - (sit-for 0))) ; Display NOW - -(defun gomoku-display-statistics () - "Obnoxiously display some statistics about previous games in mode line." - ;; We store this string in the mode-line-process local variable. - ;; This is certainly not the cleanest way out ... - (setq mode-line-process - (cond - ((not (zerop gomoku-number-of-draws)) - (format ": Won %d, lost %d, drew %d" - gomoku-number-of-human-wins - gomoku-number-of-emacs-wins - gomoku-number-of-draws)) - (t - (format ": Won %d, lost %d" - gomoku-number-of-human-wins - gomoku-number-of-emacs-wins)))) - (force-mode-line-update)) - -(defun gomoku-switch-to-window () - "Find or create the Gomoku buffer, and display it." - (interactive) - (let ((buff (get-buffer "*Gomoku*"))) - (if buff ; Buffer exists: - (switch-to-buffer buff) ; no problem. - (if gomoku-game-in-progress - (gomoku-crash-game)) ; buffer has been killed or something - (switch-to-buffer "*Gomoku*") ; Anyway, start anew. - (gomoku-mode)))) - -;;; -;;; CROSSING WINNING QTUPLES. -;;; - -;; When someone succeeds in filling a qtuple, we draw a line over the five -;; corresponding squares. One problem is that the program does not know which -;; squares ! It only knows the square where the last move has been played and -;; who won. The solution is to scan the board along all four directions. - -(defvar gomoku-winning-qtuple-beg nil - "First square of the winning qtuple.") - -(defvar gomoku-winning-qtuple-end nil - "Last square of the winning qtuple.") - -(defvar gomoku-winning-qtuple-dx nil - "Direction of the winning qtuple (along the X axis).") - -(defvar gomoku-winning-qtuple-dy nil - "Direction of the winning qtuple (along the Y axis).") - - -(defun gomoku-find-filled-qtuple (square value) - "Return T if SQUARE belongs to a qtuple filled with VALUEs." - (or (gomoku-check-filled-qtuple square value 1 0) - (gomoku-check-filled-qtuple square value 0 1) - (gomoku-check-filled-qtuple square value 1 1) - (gomoku-check-filled-qtuple square value -1 1))) - -(defun gomoku-check-filled-qtuple (square value dx dy) - "Return T if SQUARE belongs to a qtuple filled with VALUEs along DX, DY." - ;; And record it in the WINNING-QTUPLE-... variables. - (let ((a 0) (b 0) - (left square) (right square) - (depl (gomoku-xy-to-index dx dy)) - a+4) - (while (and (> a -4) ; stretch tuple left - (= value (aref gomoku-board (setq left (- left depl))))) - (setq a (1- a))) - (setq a+4 (+ a 4)) - (while (and (< b a+4) ; stretch tuple right - (= value (aref gomoku-board (setq right (+ right depl))))) - (setq b (1+ b))) - (cond ((= b a+4) ; tuple length = 5 ? - (setq gomoku-winning-qtuple-beg (+ square (* a depl)) - gomoku-winning-qtuple-end (+ square (* b depl)) - gomoku-winning-qtuple-dx dx - gomoku-winning-qtuple-dy dy) - t)))) - -(defun gomoku-cross-winning-qtuple () - "Cross winning qtuple, as found by `gomoku-find-filled-qtuple'." - (gomoku-cross-qtuple gomoku-winning-qtuple-beg - gomoku-winning-qtuple-end - gomoku-winning-qtuple-dx - gomoku-winning-qtuple-dy)) - -(defun gomoku-cross-qtuple (square1 square2 dx dy) - "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction." - (save-excursion ; Not moving point from last square - (let ((depl (gomoku-xy-to-index dx dy))) - ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1 - (while (not (= square1 square2)) - (gomoku-goto-square square1) - (setq square1 (+ square1 depl)) - (cond - ((and (= dx 1) (= dy 0)) ; Horizontal - (let ((n 1)) - (while (< n gomoku-square-width) - (setq n (1+ n)) - (forward-char 1) - (gomoku-put-char ?-)))) - ((and (= dx 0) (= dy 1)) ; Vertical - (let ((n 1)) - (while (< n gomoku-square-height) - (setq n (1+ n)) - (next-line 1) - (gomoku-put-char ?|)))) - ((and (= dx -1) (= dy 1)) ; 1st Diagonal - (backward-char (/ gomoku-square-width 2)) - (next-line (/ gomoku-square-height 2)) - (gomoku-put-char ?/)) - ((and (= dx 1) (= dy 1)) ; 2nd Diagonal - (forward-char (/ gomoku-square-width 2)) - (next-line (/ gomoku-square-height 2)) - (gomoku-put-char ?\\)))))) - (sit-for 0)) ; Display NOW - -;;; -;;; CURSOR MOTION. -;;; -(defun gomoku-move-left () - "Move point backward one column on the Gomoku board." - (interactive) - (let ((x (gomoku-point-x))) - (backward-char (cond ((null x) 1) - ((> x 1) gomoku-square-width) - (t 0))))) - -(defun gomoku-move-right () - "Move point forward one column on the Gomoku board." - (interactive) - (let ((x (gomoku-point-x))) - (forward-char (cond ((null x) 1) - ((< x gomoku-board-width) gomoku-square-width) - (t 0))))) - -(defun gomoku-move-down () - "Move point down one row on the Gomoku board." - (interactive) - (let ((y (gomoku-point-y))) - (next-line (cond ((null y) 1) - ((< y gomoku-board-height) gomoku-square-height) - (t 0))))) - -(defun gomoku-move-up () - "Move point up one row on the Gomoku board." - (interactive) - (let ((y (gomoku-point-y))) - (previous-line (cond ((null y) 1) - ((> y 1) gomoku-square-height) - (t 0))))) - -(defun gomoku-move-ne () - "Move point North East on the Gomoku board." - (interactive) - (gomoku-move-up) - (gomoku-move-right)) - -(defun gomoku-move-se () - "Move point South East on the Gomoku board." - (interactive) - (gomoku-move-down) - (gomoku-move-right)) - -(defun gomoku-move-nw () - "Move point North West on the Gomoku board." - (interactive) - (gomoku-move-up) - (gomoku-move-left)) - -(defun gomoku-move-sw () - "Move point South West on the Gomoku board." - (interactive) - (gomoku-move-down) - (gomoku-move-left)) - -(provide 'gomoku) - -;;; gomoku.el ends here
--- a/lisp/games/hanoi.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,249 +0,0 @@ -;;; hanoi.el --- towers of hanoi in GNUmacs - -;; Author: Damon Anton Permezel -;; Maintainer: FSF -;; Keywords: games - -; Author (a) 1985, Damon Anton Permezel -; This is in the public domain -; since he distributed it without copyright notice in 1985. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; Solves the Towers of Hanoi puzzle while-U-wait. -;; -;; The puzzle: Start with N rings, decreasing in sizes from bottom to -;; top, stacked around a post. There are two other posts. Your mission, -;; should you choose to accept it, is to shift the pile, stacked in its -;; original order, to another post. -;; -;; The challenge is to do it in the fewest possible moves. Each move -;; shifts one ring to a different post. But there's a rule; you can -;; only stack a ring on top of a larger one. -;; -;; The simplest nontrivial version of this puzzle is N = 3. Solution -;; time rises as 2**N, and programs to solve it have long been considered -;; classic introductory exercises in the use of recursion. -;; -;; The puzzle is called `Towers of Hanoi' because an early popular -;; presentation wove a fanciful legend around it. According to this -;; myth (uttered long before the Vietnam War), there is a Buddhist -;; monastery at Hanoi which contains a large room with three time-worn -;; posts in it surrounded by 21 golden discs. Monks, acting out the -;; command of an ancient prophecy, have been moving these disks, in -;; accordance with the rules of the puzzle, once every day since the -;; monastery was founded over a thousand years ago. They are said -;; believe that when the last move of the puzzle is completed, the -;; world will end in a clap of thunder. Fortunately, they are nowhere -;; even close to being done... - -;;; Code: - -;;; -;;; hanoi-topos - direct cursor addressing -;;; -(defun hanoi-topos (row col) - (goto-line row) - (beginning-of-line) - (forward-char col)) - -;;; -;;; hanoi - user callable Towers of Hanoi -;;; -;;;###autoload -(defun hanoi (nrings) - "Towers of Hanoi diversion. Argument is number of rings." - (interactive - (list (if (null current-prefix-arg) - 3 - (prefix-numeric-value current-prefix-arg)))) - (if (<= nrings 0) (error "Negative number of rings")) - (let* (floor-row - fly-row - (window-height (1- (window-height (selected-window)))) - (window-width (window-width (selected-window))) - - ;; This is half the spacing to use between poles. - (pole-spacing (/ window-width 6))) - (if (not (and (> window-height (1+ nrings)) - (> pole-spacing nrings))) - (progn - (delete-other-windows) - (if (not (and (> (setq window-height - (1- (window-height (selected-window)))) - (1+ nrings)) - (> (setq pole-spacing (/ window-width 6)) - nrings))) - (error "Window is too small (need at least %dx%d)" - (* 6 (1+ nrings)) (+ 2 nrings))))) - (setq floor-row (if (> (- window-height 3) (1+ nrings)) - (- window-height 3) window-height)) - (let ((fly-row (- floor-row nrings 1)) - ;; pole: column . fill height - (pole-1 (cons (1- pole-spacing) floor-row)) - (pole-2 (cons (1- (* 3 pole-spacing)) floor-row)) - (pole-3 (cons (1- (* 5 pole-spacing)) floor-row)) - (rings (make-vector nrings nil))) - ;; construct the ring list - (let ((i 0)) - (while (< i nrings) - ;; ring: [pole-number string empty-string] - (aset rings i (vector nil - (make-string (+ i i 3) (+ ?0 (% i 10))) - (make-string (+ i i 3) ?\ ))) - (setq i (1+ i)))) - ;; - ;; init the screen - ;; - (switch-to-buffer "*Hanoi*") - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((i 0)) - (while (< i floor-row) - (setq i (1+ i)) - (insert-char ?\ (1- window-width)) - (insert ?\n))) - (insert-char ?= (1- window-width)) - - (let ((n 1)) - (while (< n 6) - (hanoi-topos fly-row (1- (* n pole-spacing))) - (setq n (+ n 2)) - (let ((i fly-row)) - (while (< i floor-row) - (setq i (1+ i)) - (next-line 1) - (insert ?\|) - (delete-char 1) - (backward-char 1))))) - ;(sit-for 0) - ;; - ;; now draw the rings in their initial positions - ;; - (let ((i 0) - ring) - (while (< i nrings) - (setq ring (aref rings (- nrings 1 i))) - (aset ring 0 (- floor-row i)) - (hanoi-topos (cdr pole-1) - (- (car pole-1) (- nrings i))) - (hanoi-draw-ring ring t nil) - (setcdr pole-1 (1- (cdr pole-1))) - (setq i (1+ i)))) - (setq buffer-read-only t) - (sit-for 0) - ;; Disable display of line and column numbers, for speed. - (let ((line-number-mode nil) - (column-number-mode nil)) - ;; do it! - (hanoi0 (1- nrings) pole-1 pole-2 pole-3)) - (goto-char (point-min)) - (message "Done") - (setq buffer-read-only t) - (force-mode-line-update) - (sit-for 0)))) - -;;; -;;; hanoi0 - work horse of hanoi -;;; -(defun hanoi0 (n from to work) - (cond ((input-pending-p) - (signal 'quit (list "I can tell you've had enough"))) - ((< n 0)) - (t - (hanoi0 (1- n) from work to) - (hanoi-move-ring n from to) - (hanoi0 (1- n) work to from)))) - -;;; -;;; hanoi-move-ring - move ring 'n' from 'from' to 'to' -;;; -;;; -(defun hanoi-move-ring (n from to) - (let ((ring (aref rings n)) ; ring <- ring: (ring# . row) - (buffer-read-only nil)) - (let ((row (aref ring 0)) ; row <- row ring is on - (col (- (car from) n 1)) ; col <- left edge of ring - (dst-col (- (car to) n 1)) ; dst-col <- dest col for left edge - (dst-row (cdr to))) ; dst-row <- dest row for ring - (hanoi-topos row col) - (while (> row fly-row) ; move up to the fly row - (hanoi-draw-ring ring nil t) ; blank out ring - (previous-line 1) ; move up a line - (hanoi-draw-ring ring t nil) ; redraw - (sit-for 0) - (setq row (1- row))) - (setcdr from (1+ (cdr from))) ; adjust top row - ;; - ;; fly the ring over to the right pole - ;; - (while (not (equal dst-col col)) - (cond ((> dst-col col) ; dst-col > col: right shift - (end-of-line 1) - (delete-backward-char 2) - (beginning-of-line 1) - (insert ?\ ?\ ) - (sit-for 0) - (setq col (1+ (1+ col)))) - ((< dst-col col) ; dst-col < col: left shift - (beginning-of-line 1) - (delete-char 2) - (end-of-line 1) - (insert ?\ ?\ ) - (sit-for 0) - (setq col (1- (1- col)))))) - ;; - ;; let the ring float down - ;; - (hanoi-topos fly-row dst-col) - (while (< row dst-row) ; move down to the dest row - (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring - (next-line 1) ; move down a line - (hanoi-draw-ring ring t nil) ; redraw ring - (sit-for 0) - (setq row (1+ row))) - (aset ring 0 dst-row) - (setcdr to (1- (cdr to)))))) ; adjust top row - -;;; -;;; draw-ring - draw the ring at point, leave point unchanged -;;; -;;; Input: -;;; ring -;;; f1 - flag: t -> draw, nil -> erase -;;; f2 - flag: t -> erasing and need to draw ?\| -;;; -(defun hanoi-draw-ring (ring f1 f2) - (save-excursion - (let* ((string (if f1 (aref ring 1) (aref ring 2))) - (len (length string))) - (delete-char len) - (insert string) - (if f2 - (progn - (backward-char (/ (+ len 1) 2)) - (delete-char 1) (insert ?\|)))))) - -(provide 'hanoi) - -;;; hanoi.el ends here
--- a/lisp/games/life.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,288 +0,0 @@ -;;; life.el --- John Horton Conway's `Life' game for GNU Emacs - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Kyle Jones <kyle@uunet.uu.net> -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; A demonstrator for John Horton Conway's "Life" cellular automaton -;; in Emacs Lisp. Picks a random one of a set of interesting Life -;; patterns and evolves it according to the familiar rules. - -;;; Code: - -(defconst life-patterns - [("@@@" " @@" "@@@") - ("@@@ @@@" "@@ @@ " "@@@ @@@") - ("@@@ @@@" "@@ @@" "@@@ @@@") - ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@") - ("@@@@@@@@@@") - (" @@@@@@@@@@ " - " @@@@@@@@@@ " - " @@@@@@@@@@ " - "@@@@@@@@@@ " - "@@@@@@@@@@ ") - ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@") - ("@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @" - "@ @" "@ @" "@ @") - ("@@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@ " " @@ " " @@ " - " @@") - ("@@@@@@@@@" "@ @ @" "@ @@@@@ @" "@ @ @ @" "@@@ @@@" - "@ @ @ @" "@ @@@@@ @" "@ @ @" "@@@@@@@@@")] - "Vector of rectangles containing some Life startup patterns.") - -;; Macros are used macros for manifest constants instead of variables -;; because the compiler will convert them to constants, which should -;; eval faster than symbols. -;; -;; Don't change any of the life-* macro constants unless you thoroughly -;; understand the `life-grim-reaper' function. - -(defmacro life-life-char () ?@) -(defmacro life-death-char () (1+ (life-life-char))) -(defmacro life-birth-char () 3) -(defmacro life-void-char () ?\ ) - -(defmacro life-life-string () (char-to-string (life-life-char))) -(defmacro life-death-string () (char-to-string (life-death-char))) -(defmacro life-birth-string () (char-to-string (life-birth-char))) -(defmacro life-void-string () (char-to-string (life-void-char))) -(defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]")) - -(defmacro life-increment (variable) (list 'setq variable (list '1+ variable))) - - -;; list of numbers that tell how many characters to move to get to -;; each of a cell's eight neighbors. -(defconst life-neighbor-deltas nil) - -;; window display always starts here. Easier to deal with than -;; (scroll-up) and (scroll-down) when trying to center the display. -(defconst life-window-start nil) - -;; For mode line -(defconst life-current-generation nil) -;; Sadly, mode-line-format won't display numbers. -(defconst life-generation-string nil) - -(defvar life-initialized nil - "Non-nil if `life' has been run at least once.") - -;;;###autoload -(defun life (&optional sleeptime) - "Run Conway's Life simulation. -The starting pattern is randomly selected. Prefix arg (optional first -arg non-nil from a program) is the number of seconds to sleep between -generations (this defaults to 1)." - (interactive "p") - (or life-initialized - (random t)) - (setq life-initialized t) - (or sleeptime (setq sleeptime 1)) - (life-setup) - (life-display-generation sleeptime) - (catch 'life-exit - (while t - (let ((inhibit-quit t)) - (life-grim-reaper) - (life-expand-plane-if-needed) - (life-increment-generation) - (life-display-generation sleeptime))))) - -(defalias 'life-mode 'life) -(put 'life-mode 'mode-class 'special) - -(defun life-setup () - (let (n) - (switch-to-buffer (get-buffer-create "*Life*") t) - (erase-buffer) - (kill-all-local-variables) - ;; XEmacs change: - (set-specifier scrollbar-height 0 (current-buffer)) - (set-specifier scrollbar-width 0 (current-buffer)) - (setq case-fold-search nil - mode-name "Life" - major-mode 'life-mode - truncate-lines t - life-current-generation 0 - life-generation-string "0" - mode-line-buffer-identification '("Life: generation " - life-generation-string) - fill-column (1- (window-width)) - life-window-start 1) - (buffer-disable-undo (current-buffer)) - ;; stuff in the random pattern - (life-insert-random-pattern) - ;; make sure (life-life-char) is used throughout - (goto-char (point-min)) - (while (re-search-forward (life-not-void-regexp) nil t) - (replace-match (life-life-string) t t)) - ;; center the pattern horizontally - (goto-char (point-min)) - (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2)) - (while (not (eobp)) - (indent-to n) - (forward-line)) - ;; center the pattern vertically - (setq n (/ (- (1- (window-height)) - (count-lines (point-min) (point-max))) - 2)) - (goto-char (point-min)) - (newline n) - (goto-char (point-max)) - (newline n) - ;; pad lines out to fill-column - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (indent-to fill-column) - (move-to-column fill-column) - (delete-region (point) (progn (end-of-line) (point))) - (forward-line)) - ;; expand tabs to spaces - (untabify (point-min) (point-max)) - ;; before starting be sure the automaton has room to grow - (life-expand-plane-if-needed) - ;; compute initial neighbor deltas - (life-compute-neighbor-deltas))) - -(defun life-compute-neighbor-deltas () - (setq life-neighbor-deltas - (list -1 (- fill-column) - (- (1+ fill-column)) (- (+ 2 fill-column)) - 1 fill-column (1+ fill-column) - (+ 2 fill-column)))) - -(defun life-insert-random-pattern () - (insert-rectangle - (elt life-patterns (random (length life-patterns)))) - (insert ?\n)) - -(defun life-increment-generation () - (life-increment life-current-generation) - (setq life-generation-string (int-to-string life-current-generation))) - -(defun life-grim-reaper () - ;; Clear the match information. Later we check to see if it - ;; is still clear, if so then all the cells have died. - (store-match-data nil) - (goto-char (point-min)) - ;; For speed declare all local variable outside the loop. - (let (point char pivot living-neighbors list) - (while (search-forward (life-life-string) nil t) - (setq list life-neighbor-deltas - living-neighbors 0 - pivot (1- (point))) - (while list - (setq point (+ pivot (car list)) - char (char-after point)) - (cond ((eq char (life-void-char)) - (subst-char-in-region point (1+ point) - (life-void-char) 1 t)) - ((< char 3) - (subst-char-in-region point (1+ point) char (1+ char) t)) - ((< char 9) - (subst-char-in-region point (1+ point) char 9 t)) - ((>= char (life-life-char)) - (life-increment living-neighbors))) - (setq list (cdr list))) - (if (memq living-neighbors '(2 3)) - () - (subst-char-in-region pivot (1+ pivot) - (life-life-char) (life-death-char) t)))) - (if (null (match-beginning 0)) - (life-extinct-quit)) - (subst-char-in-region 1 (point-max) 9 (life-void-char) t) - (subst-char-in-region 1 (point-max) 1 (life-void-char) t) - (subst-char-in-region 1 (point-max) 2 (life-void-char) t) - (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t) - (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t)) - -(defun life-expand-plane-if-needed () - (catch 'done - (goto-char (point-min)) - (while (not (eobp)) - ;; check for life at beginning or end of line. If found at - ;; either end, expand at both ends, - (cond ((or (eq (following-char) (life-life-char)) - (eq (progn (end-of-line) (preceding-char)) (life-life-char))) - (goto-char (point-min)) - (while (not (eobp)) - (insert (life-void-char)) - (end-of-line) - (insert (life-void-char)) - (forward-char)) - (setq fill-column (+ 2 fill-column)) - (scroll-left 1) - (life-compute-neighbor-deltas) - (throw 'done t))) - (forward-line))) - (goto-char (point-min)) - ;; check for life within the first two lines of the buffer. - ;; If present insert two lifeless lines at the beginning.. - (cond ((search-forward (life-life-string) - (+ (point) fill-column fill-column 2) t) - (goto-char (point-min)) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (setq life-window-start (+ life-window-start fill-column 1)))) - (goto-char (point-max)) - ;; check for life within the last two lines of the buffer. - ;; If present insert two lifeless lines at the end. - (cond ((search-backward (life-life-string) - (- (point) fill-column fill-column 2) t) - (goto-char (point-max)) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (insert-char (life-void-char) fill-column) - (insert ?\n) - (setq life-window-start (+ life-window-start fill-column 1))))) - -(defun life-display-generation (sleeptime) - (goto-char life-window-start) - (recenter 0) - - ;; Redisplay; if the user has hit a key, exit the loop. - (or (eq t (sit-for sleeptime)) - (throw 'life-exit nil))) - -(defun life-extinct-quit () - (life-display-generation 0) - (signal 'life-extinct nil)) - -;; XEmacs change -(define-error 'life-extinct "All life has perished" 'quit) - -(provide 'life) - -;;; life.el ends here
--- a/lisp/games/mpuz.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,445 +0,0 @@ -;;; mpuz.el --- multiplication puzzle for XEmacs - -;; Copyright (C) 1990 Free Software Foundation, Inc. - -;; Author: Philippe Schnoebelen <phs@lifia.imag.fr> -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; When this package is loaded, `M-x mpuz' generates a random multiplication -;; puzzle. This is a multiplication example in which each digit has been -;; consistently replaced with some letter. Your job is to reconstruct -;; the original digits. Type `?' while the mode is active for detailed help. - -;;; Code: - -(random t) ; randomize - -(defvar mpuz-silent nil - "*Set this to T if you don't want dings on inputs.") - -(defun mpuz-ding () - "Dings, unless global variable `mpuz-silent' forbids it." - (or mpuz-silent (ding t))) - - -;; Mpuz mode and keymaps -;;---------------------- -(defvar mpuz-mode-hook nil) - -(defvar mpuz-mode-map nil - "Local keymap to use in Mult Puzzle.") - -(if mpuz-mode-map nil - (setq mpuz-mode-map (make-sparse-keymap)) - (define-key mpuz-mode-map "a" 'mpuz-try-letter) - (define-key mpuz-mode-map "b" 'mpuz-try-letter) - (define-key mpuz-mode-map "c" 'mpuz-try-letter) - (define-key mpuz-mode-map "d" 'mpuz-try-letter) - (define-key mpuz-mode-map "e" 'mpuz-try-letter) - (define-key mpuz-mode-map "f" 'mpuz-try-letter) - (define-key mpuz-mode-map "g" 'mpuz-try-letter) - (define-key mpuz-mode-map "h" 'mpuz-try-letter) - (define-key mpuz-mode-map "i" 'mpuz-try-letter) - (define-key mpuz-mode-map "j" 'mpuz-try-letter) - (define-key mpuz-mode-map "A" 'mpuz-try-letter) - (define-key mpuz-mode-map "B" 'mpuz-try-letter) - (define-key mpuz-mode-map "C" 'mpuz-try-letter) - (define-key mpuz-mode-map "D" 'mpuz-try-letter) - (define-key mpuz-mode-map "E" 'mpuz-try-letter) - (define-key mpuz-mode-map "F" 'mpuz-try-letter) - (define-key mpuz-mode-map "G" 'mpuz-try-letter) - (define-key mpuz-mode-map "H" 'mpuz-try-letter) - (define-key mpuz-mode-map "I" 'mpuz-try-letter) - (define-key mpuz-mode-map "J" 'mpuz-try-letter) - (define-key mpuz-mode-map "\C-g" 'mpuz-offer-abort) - (define-key mpuz-mode-map "?" 'describe-mode)) - -(defun mpuz-mode () - "Multiplication puzzle mode. - -You have to guess which letters stand for which digits in the -multiplication displayed inside the `*Mult Puzzle*' buffer. - -You may enter a guess for a letter's value by typing first the letter, -then the digit. Thus, to guess that A=3, type A 3. - -To leave the game to do other editing work, just switch buffers. -Then you may resume the game with M-x mpuz. -You may abort a game by typing \\<mpuz-mode-map>\\[mpuz-offer-abort]." - (interactive) - (setq major-mode 'mpuz-mode - mode-name "Mult Puzzle") - (use-local-map mpuz-mode-map) - (run-hooks 'mpuz-mode-hook)) - - -;; Some variables for statistics -;;------------------------------ -(defvar mpuz-nb-errors 0 - "Number of errors made in current game.") - -(defvar mpuz-nb-completed-games 0 - "Number of games completed.") - -(defvar mpuz-nb-cumulated-errors 0 - "Number of errors made in previous games.") - - -;; Some variables for game tracking -;;--------------------------------- -(defvar mpuz-in-progress nil - "True if a game is currently in progress.") - -(defvar mpuz-found-digits (make-vector 10 nil) - "A vector recording which digits have been decrypted.") - -(defmacro mpuz-digit-solved-p (digit) - (list 'aref 'mpuz-found-digits digit)) - - -;; A puzzle uses a permutation of [0..9] into itself. -;; We use both the permutation and its inverse. -;;--------------------------------------------------- -(defvar mpuz-digit-to-letter (make-vector 10 0) - "A permutation from [0..9] to [0..9].") - -(defvar mpuz-letter-to-digit (make-vector 10 0) - "The inverse of mpuz-digit-to-letter.") - -(defmacro mpuz-to-digit (letter) - (list 'aref 'mpuz-letter-to-digit letter)) - -(defmacro mpuz-to-letter (digit) - (list 'aref 'mpuz-digit-to-letter digit)) - -(defun mpuz-build-random-perm () - "Initialize puzzle coding with a random permutation." - (let ((letters (list 0 1 2 3 4 5 6 7 8 9)) ; new cons cells, because of delq - (index 10) - elem) - (while letters - (setq elem (nth (random index) letters) - letters (delq elem letters) - index (1- index)) - (aset mpuz-digit-to-letter index elem) - (aset mpuz-letter-to-digit elem index)))) - - -;; A puzzle also uses a board displaying a multiplication. -;; Every digit appears in the board, crypted or not. -;;------------------------------------------------------ -(defvar mpuz-board (make-vector 10 nil) - "The board associates to any digit the list of squares where it appears.") - -(defun mpuz-put-digit-on-board (number square) - "Put (last digit of) NUMBER on SQUARE of the puzzle board." - ;; i.e. push SQUARE on NUMBER square-list - (setq number (% number 10)) - (aset mpuz-board number (cons square (aref mpuz-board number)))) - -(defun mpuz-check-all-solved () - "Check whether all digits have been solved. Return t if yes." - (catch 'found - (let ((digit -1)) - (while (> 10 (setq digit (1+ digit))) - (if (and (not (mpuz-digit-solved-p digit)) ; unsolved - (aref mpuz-board digit)) ; and appearing in the puzzle ! - (throw 'found nil)))) - t)) - - -;; To build a puzzle, we take two random numbers and multiply them. -;; We also take a random permutation for encryption. -;; The random numbers are only use to see which digit appears in which square -;; of the board. Everything is stored in individual squares. -;;--------------------------------------------------------------------------- -(defun mpuz-random-puzzle () - "Draw random values to be multiplied in a puzzle." - (mpuz-build-random-perm) - (fillarray mpuz-board nil) ; erase the board - (let (A B C D E) - ;; A,B,C,D & E, are the five rows of our multiplication. - ;; Choose random values, discarding uninteresting cases. - (while (progn - (setq A (random 1000) - B (random 100) - C (* A (% B 10)) - D (* A (/ B 10)) - E (* A B)) - (or (< C 1000) (< D 1000)))) ; forbid leading zeros in C or D - ;; Individual digits are now put on their respective squares. - ;; [NB: A square is a pair <row,column> of the screen.] - (mpuz-put-digit-on-board A '(2 . 9)) - (mpuz-put-digit-on-board (/ A 10) '(2 . 7)) - (mpuz-put-digit-on-board (/ A 100) '(2 . 5)) - (mpuz-put-digit-on-board B '(4 . 9)) - (mpuz-put-digit-on-board (/ B 10) '(4 . 7)) - (mpuz-put-digit-on-board C '(6 . 9)) - (mpuz-put-digit-on-board (/ C 10) '(6 . 7)) - (mpuz-put-digit-on-board (/ C 100) '(6 . 5)) - (mpuz-put-digit-on-board (/ C 1000) '(6 . 3)) - (mpuz-put-digit-on-board D '(8 . 7)) - (mpuz-put-digit-on-board (/ D 10) '(8 . 5)) - (mpuz-put-digit-on-board (/ D 100) '(8 . 3)) - (mpuz-put-digit-on-board (/ D 1000) '(8 . 1)) - (mpuz-put-digit-on-board E '(10 . 9)) - (mpuz-put-digit-on-board (/ E 10) '(10 . 7)) - (mpuz-put-digit-on-board (/ E 100) '(10 . 5)) - (mpuz-put-digit-on-board (/ E 1000) '(10 . 3)) - (mpuz-put-digit-on-board (/ E 10000) '(10 . 1)))) - -;; Display -;;-------- -(defconst mpuz-framework - " - . . . - Number of errors (this game): 0 - x . . - ------- - . . . . - Number of completed games: 0 - . . . . - --------- Average number of errors: 0.00 - . . . . ." - "The general picture of the puzzle screen, as a string.") - -(defun mpuz-create-buffer () - "Create (or recreate) the puzzle buffer. Return it." - (let ((buff (get-buffer-create "*Mult Puzzle*"))) - (save-excursion - (set-buffer buff) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert mpuz-framework) - (mpuz-paint-board) - (mpuz-paint-errors) - (mpuz-paint-statistics))) - buff)) - -(defun mpuz-paint-errors () - "Paint error count on the puzzle screen." - (mpuz-switch-to-window) - (let ((buffer-read-only nil)) - (goto-line 3) - (move-to-column 49) - (mpuz-delete-line) - (insert (prin1-to-string mpuz-nb-errors)))) - -(defun mpuz-paint-statistics () - "Paint statistics about previous games on the puzzle screen." - (let* ((mean (if (zerop mpuz-nb-completed-games) 0 - (/ (+ mpuz-nb-completed-games (* 200 mpuz-nb-cumulated-errors)) - (* 2 mpuz-nb-completed-games)))) - (frac-part (% mean 100))) - (let ((buffer-read-only nil)) - (goto-line 7) - (move-to-column 51) - (mpuz-delete-line) - (insert (prin1-to-string mpuz-nb-completed-games)) - (goto-line 9) - (move-to-column 50) - (mpuz-delete-line) - (insert (format "%d.%d%d" (/ mean 100) (/ frac-part 10) (% frac-part 10)))))) - -(defun mpuz-paint-board () - "Paint board situation on the puzzle screen." - (mpuz-switch-to-window) - (let ((letter -1)) - (while (> 10 (setq letter (1+ letter))) - (mpuz-paint-digit (mpuz-to-digit letter)))) - (goto-char (point-min))) - -(defun mpuz-paint-digit (digit) - "Paint all occurrences of DIGIT on the puzzle board." - ;; (mpuz-switch-to-window) - (let ((char (if (mpuz-digit-solved-p digit) - (+ digit ?0) - (+ (mpuz-to-letter digit) ?A))) - (square-l (aref mpuz-board digit))) - (let ((buffer-read-only nil)) - (while square-l - (goto-line (car (car square-l))) ; line before column ! - (move-to-column (cdr (car square-l))) - (insert char) - (delete-char 1) - (backward-char 1) - (setq square-l (cdr square-l)))))) - -(defun mpuz-delete-line () - "Clear from point to next newline." ; & put nothing in the kill ring - (while (not (= ?\n (char-after (point)))) - (delete-char 1))) - -(defun mpuz-get-buffer () - "Get the puzzle buffer if it exists." - (get-buffer "*Mult Puzzle*")) - -(defun mpuz-switch-to-window () - "Find or create the Mult-Puzzle buffer, and display it." - (let ((buff (mpuz-get-buffer))) - (or buff (setq buff (mpuz-create-buffer))) - (switch-to-buffer buff) - (or buffer-read-only (toggle-read-only)) - (mpuz-mode))) - - -;; Game control -;;------------- -(defun mpuz-abort-game () - "Abort any puzzle in progress." - (message "Mult Puzzle aborted.") - (setq mpuz-in-progress nil - mpuz-nb-errors 0) - (fillarray mpuz-board nil) - (let ((buff (mpuz-get-buffer))) - (if buff (kill-buffer buff)))) - -(defun mpuz-start-new-game () - "Start a new puzzle." - (message "Here we go...") - (setq mpuz-nb-errors 0 - mpuz-in-progress t) - (fillarray mpuz-found-digits nil) ; initialize mpuz-found-digits - (mpuz-random-puzzle) - (mpuz-switch-to-window) - (mpuz-paint-board) - (mpuz-paint-errors) - (mpuz-ask-for-try)) - -(defun mpuz-offer-new-game () - "Ask if user wants to start a new puzzle." - (if (y-or-n-p "Start a new game ") - (mpuz-start-new-game) - (message "OK. I won't."))) - -;;;###autoload -(defun mpuz () - "Multiplication puzzle with GNU Emacs." - ;; Main entry point - (interactive) - (mpuz-switch-to-window) - (if mpuz-in-progress - (mpuz-offer-abort) - (mpuz-start-new-game))) - -(defun mpuz-offer-abort () - "Ask if user wants to abort current puzzle." - (interactive) - (if (y-or-n-p "Abort game ") - (mpuz-abort-game) - (mpuz-ask-for-try))) - -(defun mpuz-ask-for-try () - "Ask for user proposal in puzzle." - (message "Your try ?")) - -(defun mpuz-try-letter () - "Propose a digit for a letter in puzzle." - (interactive) - (if mpuz-in-progress - (let (letter-char digit digit-char message) - (setq letter-char (upcase last-command-char) - digit (mpuz-to-digit (- letter-char ?A))) - (cond ((mpuz-digit-solved-p digit) - (message "%c already solved." letter-char)) - ((null (aref mpuz-board digit)) - (message "%c does not appear." letter-char)) - ((progn (message "%c = " letter-char) - ;; <char> has been entered. - ;; Print "<char> =" and - ;; read <num> or = <num> - (setq digit-char (read-char)) - (if (eq digit-char ?=) - (setq digit-char (read-char))) - (message "%c = %c" letter-char digit-char) - (or (> digit-char ?9) (< digit-char ?0))) ; bad input - (ding t)) - (t - (mpuz-try-proposal letter-char digit-char)))) - (mpuz-offer-new-game))) - -(defun mpuz-try-proposal (letter-char digit-char) - "Propose LETTER-CHAR as code for DIGIT-CHAR." - (let* ((letter (- letter-char ?A)) - (digit (- digit-char ?0)) - (correct-digit (mpuz-to-digit letter))) - (cond ((mpuz-digit-solved-p correct-digit) - (message "%c has already been found.")) - ((= digit correct-digit) - (message "%c = %c correct !" letter-char digit-char) - (mpuz-ding) - (mpuz-correct-guess digit)) - (t ;;; incorrect guess - (message "%c = %c incorrect !" letter-char digit-char) - (mpuz-ding) - (setq mpuz-nb-errors (1+ mpuz-nb-errors)) - (mpuz-paint-errors))))) - -(defun mpuz-correct-guess (digit) - "Handle correct guessing of DIGIT." - (aset mpuz-found-digits digit t) ; Mark digit as solved - (mpuz-paint-digit digit) ; Repaint it (now as a digit) - (if (mpuz-check-all-solved) - (mpuz-close-game))) - -(defun mpuz-close-game () - "Housecleaning when puzzle has been solved." - (setq mpuz-in-progress nil - mpuz-nb-cumulated-errors (+ mpuz-nb-cumulated-errors mpuz-nb-errors) - mpuz-nb-completed-games (1+ mpuz-nb-completed-games)) - (mpuz-paint-statistics) - (let ((message (mpuz-congratulate))) - (message message) - (sit-for 4) - (if (y-or-n-p (concat message " Start a new game ")) - (mpuz-start-new-game) - (message "Good Bye !")))) - -(defun mpuz-congratulate () - "Build a congratulation message when puzzle is solved." - (format "Puzzle solved with %d errors. %s" - mpuz-nb-errors - (cond ((= mpuz-nb-errors 0) "That's perfect !") - ((= mpuz-nb-errors 1) "That's very good !") - ((= mpuz-nb-errors 2) "That's good.") - ((= mpuz-nb-errors 3) "That's not bad.") - ((= mpuz-nb-errors 4) "That's not too bad...") - ((and (>= mpuz-nb-errors 5) - (< mpuz-nb-errors 10)) "That's bad !") - ((and (>= mpuz-nb-errors 10) - (< mpuz-nb-errors 15)) "That's awful.") - ((>= mpuz-nb-errors 15) "That's not serious.")))) - -(defun mpuz-show-solution () - "Display solution for debugging purposes." - (interactive) - (mpuz-switch-to-window) - (let (digit list) - (setq digit -1) - (while (> 10 (setq digit (1+ digit))) - (or (mpuz-digit-solved-p digit) - (setq list (cons digit list)))) - (mapcar 'mpuz-correct-guess list))) - -;;; mpuz.el ends here
--- a/lisp/games/spook.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; spook.el --- spook phrase utility for overloading the NSA line eater - -;; Copyright (C) 1988, 1993 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: games -;; Created: May 1987 - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Steve Strassmann <straz@media-lab.media.mit.edu> didn't write -;; this, and even if he did, he really didn't mean for you to use it -;; in an anarchistic way. -;; -;; To use this: -;; Just before sending mail, do M-x spook. -;; A number of phrases will be inserted into your buffer, to help -;; give your message that extra bit of attractiveness for automated -;; keyword scanners. - -;;; Code: - -(require 'cookie1) - -; Variables -(defvar spook-phrases-file (concat data-directory "spook.lines") - "Keep your favorite phrases here.") - -(defvar spook-phrase-default-count 15 - "Default number of phrases to insert") - -;;;###autoload -(defun spook () - "Adds that special touch of class to your outgoing mail." - (interactive) - (cookie-insert spook-phrases-file - spook-phrase-default-count - "Checking authorization..." - "Checking authorization...Approved")) - -;;;###autoload -(defun snarf-spooks () - "Return a vector containing the lines from `spook-phrases-file'." - (cookie-snarf spook-phrases-file - "Checking authorization..." - "Checking authorization...Approved")) - -;; Note: the implementation that used to take up most of this file has been -;; cleaned up, generalized, gratuitously broken by esr, and now resides in -;; cookie1.el. - -;;; spook.el ends here
--- a/lisp/games/studly.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -;;; studly.el --- StudlyCaps (tm)(r)(c)(xxx) - -;; This is in the public domain, since it was distributed -;; by its author without a copyright notice in 1986. - -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: - -;; Functions to studlycapsify a region, word, or buffer. Possibly the -;; esoteric significance of studlycapsification escapes you; that is, -;; you suffer from autostudlycapsifibogotification. Too bad. - -;;; Code: - -(defun studlify-region (begin end) - "Studlify-case the region" - (interactive "*r") - (save-excursion - (goto-char begin) - (setq begin (point)) - (while (and (<= (point) end) - (not (looking-at "\\W*\\'"))) - (forward-word 1) - (backward-word 1) - (setq begin (max (point) begin)) - (forward-word 1) - (let ((offset 0) - (word-end (min (point) end)) - c) - (goto-char begin) - (while (< (point) word-end) - (setq offset (+ offset (following-char))) - (forward-char 1)) - (setq offset (+ offset (following-char))) - (goto-char begin) - (while (< (point) word-end) - (setq c (following-char)) - (if (and (= (% (+ c offset) 4) 2) - (let ((ch (following-char))) - (or (and (>= ch ?a) (<= ch ?z)) - (and (>= ch ?A) (<= ch ?Z))))) - (progn - (delete-char 1) - (insert (logxor c ? )))) - (forward-char 1)) - (setq begin (point)))))) - -(defun studlify-word (count) - "Studlify-case the current word, or COUNT words if given an argument" - (interactive "*p") - (let ((begin (point)) end rb re) - (forward-word count) - (setq end (point)) - (setq rb (min begin end) re (max begin end)) - (studlify-region rb re))) - -(defun studlify-buffer () - "Studlify-case the current buffer" - (interactive "*") - (studlify-region (point-min) (point-max))) - -;;; studly.el ends here
--- a/lisp/games/tetris.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,840 +0,0 @@ -;;; tetris.el -- Implementation of Tetris for Emacs. - -;; Copyright (C) 1997 Glynn Clements <glynn@sensei.co.uk> - -;; Author: Glynn Clements <glynn@sensei.co.uk> -;; Version: 1.8 -;; Created: 1997-08-13 -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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 of the License, or -;; (at your option) any later version. - -;; XEmacs 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 synched. - -;;; Commentary: - -;; Modified: 1997-08-17, added tetris-move-bottom -;; Modified: 1997-08-22, changed setting of display table for compatibility -;; with XEmacs 19.15 -;; Modified: 1997-08-23, changed setting of display table for TTY compatibility -;; Modified: 1997-08-24, various changes for FSF Emacs compatibility -;; Modified: 1997-08-25 -;; modified existing docstrings, added new docstrings -;; L now rotates the same way as T and mirror-L -;; now adds tetris-end-game to buffer-local value of kill-buffer-hook -;; Modified: 1997-08-26, miscellaneous bugfixes -;; Modified: 1997-08-27 -;; added color support for non-glyph mode -;; added tetris-mode-hook -;; added tetris-update-speed-function -;; Modified: 1997-09-09, changed layout to work in a 22 line window -;; Modified: 1997-09-12 -;; fixed tetris-shift-down to deal with multiple rows correctly -;; Modified: 1997-09-14, added tetris-setup-default-face -;; URL: ftp://sensei.co.uk/misc/tetris.el.gz -;; Tested with XEmacs 20.3-beta and Emacs 19.34 -;; Reported to work with XEmacs 19.15 and 20.2 - -(eval-when-compile - (require 'cl)) - -;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar tetris-use-glyphs t - "Non-nil means use glyphs when available") - -(defvar tetris-use-color t - "Non-nil means use color when available") - -(defvar tetris-draw-border-with-glyphs t - "Non-nil means draw a border even when using glyphs") - -(defvar tetris-font "-*-courier-medium-r-*-*-*-140-100-75-*-*-iso8859-*" - "Name of the font used for tetris in X mode") - -(defvar tetris-default-tick-period 0.3 - "The default time taken for a shape to drop one row") - -(defvar tetris-update-speed-function - 'tetris-default-update-speed-function - "Function run whenever the Tetris score changes -Called with two arguments: (SHAPES ROWS) -SHAPES is the number of shapes which have been dropped -ROWS is the number of rows which have been completed - -If the return value is a number, it is used as the timer period") - -(defvar tetris-mode-hook nil - "Hook run upon starting Tetris") - -;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst tetris-buffer-name "*Tetris*" - "Name used for Tetris buffer") - -(defconst tetris-space-char [?\040] - "Character vector used for a space") - -(defconst tetris-block-char [?\040] - "Character vector for a full square in text mode") - -(defconst tetris-emacs-block-char [?O] - "Character vector for a full square in text mode under Emacs") - -(defconst tetris-border-char [?\+] - "Character vector for a border square in text mode") - -(defconst tetris-buffer-width 30 - "Width of used portion of buffer") - -(defconst tetris-buffer-height 22 - "Height of used portion of buffer") - -(defconst tetris-width 10 - "Width of playing area") - -(defconst tetris-height 20 - "Height of playing area") - -(defconst tetris-top-left-x 3 - "X position of top left of playing area") - -(defconst tetris-top-left-y 1 - "Y position of top left of playing area") - -(defconst tetris-next-x (+ (* 2 tetris-top-left-x) tetris-width) - "X position of next shape") - -(defconst tetris-next-y tetris-top-left-y - "Y position of next shape") - -(defconst tetris-score-x tetris-next-x - "X position of score") - -(defconst tetris-score-y (+ tetris-next-y 6) - "Y position of score") - -(defconst tetris-blank 0) - -(defconst tetris-space ?\.) - -(defconst tetris-border ?\*) - -(defconst tetris-shapes - [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]] - [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]] - [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]] - [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]] - [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]] - [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]] - [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]] - [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]] - [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]] - [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]] - [[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]] - [[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]] - [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]] - - [[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]] - [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]] - [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]] - [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]]) - -(defconst tetris-shape-dimensions - [[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]]) - -(defconst tetris-text-colors - ["black" "blue" "white" "yellow" - "magenta" "cyan" "green" "red"] - "Vector of colors of the various shapes in text mode -Element 0 is the background color") - -(defconst tetris-colors - [[0 0 0] [0 0 1] [0.7 0 1] [1 1 0] - [1 0 1] [0 1 1] [0 1 0] [1 0 0] - [0.5 0.5 0.5]] - "Vector of colors of the various shapes -Element 0 is the background color -Element 8 is the border color") - -(defconst tetris-xpm "\ -/* XPM */ -static char *noname[] = { -/* width height ncolors chars_per_pixel */ -\"16 16 3 1\", -/* colors */ -\"+ s col1\", -\". s col2\", -\"- s col3\", -/* pixels */ -\"---------------+\", -\"--------------++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"-+++++++++++++++\", -\"++++++++++++++++\" -}; -" - "XPM format image used for each square") - -(defun tetris-default-update-speed-function (shapes rows) - (/ 20.0 (+ 50.0 rows))) - -;; ;;;;;;;;;;;;; variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar tetris-faces (make-vector 256 nil)) - -(defvar tetris-buffer-start 1) - -(defvar tetris-display-mode nil) - -(defvar tetris-shape 0) -(defvar tetris-rot 0) -(defvar tetris-next-shape 0) -(defvar tetris-n-shapes 0) -(defvar tetris-n-rows 0) -(defvar tetris-pos-x 0) -(defvar tetris-pos-y 0) - -(defvar tetris-timer nil) - -(defvar tetris-display-table nil) - -;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar tetris-mode-map - (make-sparse-keymap 'tetris-mode-map)) - -(define-key tetris-mode-map "n" 'tetris-start-game) -(define-key tetris-mode-map "q" 'tetris-end-game) - -(define-key tetris-mode-map " " 'tetris-move-bottom) -(define-key tetris-mode-map [left] 'tetris-move-left) -(define-key tetris-mode-map [right] 'tetris-move-right) -(define-key tetris-mode-map [up] 'tetris-rotate-prev) -(define-key tetris-mode-map [down] 'tetris-rotate-next) - -(defvar tetris-null-map - (make-sparse-keymap 'tetris-null-map)) - -(define-key tetris-null-map "n" 'tetris-start-game) - -;; ;;;;;;;;;;;;;;;; timer functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun tetris-start-timer (period) - (setq tetris-timer - (if (featurep 'itimer) - (start-itimer - "Tetris" - 'tetris-update-game period period - nil t (current-buffer)) - (run-with-timer - period period - 'tetris-update-game (current-buffer))))) - -(defun tetris-set-timer (delay) - (if tetris-timer - (if (featurep 'itimer) - (set-itimer-restart tetris-timer delay) - (timer-set-time tetris-timer - (list (aref tetris-timer 1) - (aref tetris-timer 2) - (aref tetris-timer 3)) - delay)))) - -(defun tetris-kill-timer () - (if tetris-timer - (if (featurep 'itimer) - (delete-itimer tetris-timer) - (timer-set-time tetris-timer '(0 0 0) nil))) - (setq tetris-timer nil)) - -;; ;;;;;;;;;;;;; display functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun tetris-color (col shade) - (let* ((vec (aref tetris-colors col)) - (v (floor (* shade 255))) - (r (* v (aref vec 0))) - (g (* v (aref vec 1))) - (b (* v (aref vec 2)))) - (format "#%02x%02x%02x" r g b))) - -(defun tetris-set-font (face) - (if tetris-font - (condition-case nil - (set-face-font face tetris-font) - ('error nil)))) - -(defun tetris-setup-face (face color) - (set-face-foreground face color) - (set-face-background face color) - (tetris-set-font face) - (condition-case nil - (set-face-background-pixmap face [nothing]) ;; XEmacs - ('error nil)) - (condition-case nil - (set-face-background-pixmap face nil) ;; Emacs - ('error nil))) - -(defun tetris-make-mono-tty-face () - (let ((face (make-face 'tetris-mono-tty-face))) - (condition-case nil - (set-face-property face 'reverse t) - ('error nil)) - face)) - -(defun tetris-make-color-tty-face (c) - (let* ((name (intern (format "tetris-color-tty-face-%d" c))) - (face (make-face name))) - (tetris-setup-face face (aref tetris-text-colors c)) - face)) - -(defun tetris-make-x-border-face () - (let ((face (make-face 'tetris-x-border-face))) - (tetris-set-font face) - face)) - -(defun tetris-make-mono-x-face () - (let ((face (make-face 'tetris-mono-x-face)) - (color (face-foreground 'default))) - (if (null color) - (setq color - (cdr-safe (assq 'foreground-color (frame-parameters))))) - (tetris-setup-face face color) - face)) - -(defun tetris-make-color-x-face (c) - (let* ((name (intern (format "tetris-color-x-face-%d" c))) - (face (make-face name))) - (tetris-setup-face face (tetris-color c 1.0)) - face)) - -(defun tetris-make-mono-tty-faces () - (let ((face (tetris-make-mono-tty-face))) - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((or (= c 0) (> c 7)) - 'default) - (t - face)))))) - -(defun tetris-make-color-tty-faces () - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((> c 7) - 'default) - (t - (tetris-make-color-tty-face c)))))) - -(defun tetris-make-mono-x-faces () - (let ((face (tetris-make-mono-x-face)) - (face2 (tetris-make-x-border-face))) - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((or (= c 0) (= c tetris-border)) - face2) - ((> c 7) - 'default) - (t - face)))))) - -(defun tetris-make-color-x-faces () - (loop for c from 0 to 255 do - (aset tetris-faces c - (cond - ((= c tetris-border) - (tetris-make-x-border-face)) - ((> c 7) - 'default) - (t - (tetris-make-color-x-face c)))))) - -(defun tetris-make-glyph (index) - (make-glyph - (vector - 'xpm - :data tetris-xpm - :color-symbols (list - (cons "col1" (tetris-color index 0.6)) - (cons "col2" (tetris-color index 0.8)) - (cons "col3" (tetris-color index 1.0)))))) - -(defun tetris-make-display-table () - (setq tetris-display-table (make-display-table)) - (aset tetris-display-table tetris-space tetris-space-char) - (case tetris-display-mode - ('glyph - (aset tetris-display-table tetris-border (tetris-make-glyph 8)) - (aset tetris-display-table tetris-blank (tetris-make-glyph 0))) - (otherwise - (aset tetris-display-table tetris-border tetris-border-char) - (aset tetris-display-table tetris-blank tetris-space-char))) - (loop for i from 1 to 7 do - (aset tetris-display-table - (+ tetris-blank i) - (case tetris-display-mode - ('glyph - (tetris-make-glyph i)) - ('emacs-tty - tetris-emacs-block-char) - (otherwise - tetris-block-char))))) - -(defun tetris-color-display-p () - (if (fboundp 'device-class) - (eq (device-class (selected-device)) 'color) - (eq (cdr-safe (assq 'display-type (frame-parameters))) 'color))) - -(defun tetris-display-type () - (cond ((and tetris-use-glyphs (eq window-system 'x) (featurep 'xpm)) - 'glyph) - ((and tetris-use-color (eq window-system 'x) (tetris-color-display-p)) - 'color-x) - ((eq window-system 'x) - 'mono-x) - ((and tetris-use-color (tetris-color-display-p)) - 'color-tty) - (t - (if (fboundp 'set-face-property) - 'mono-tty - 'emacs-tty)))) - -(defun tetris-initialize-display () - (setq tetris-display-mode (tetris-display-type)) - (tetris-make-display-table) - (case tetris-display-mode - ('mono-tty - (tetris-make-mono-tty-faces)) - ('color-tty - (tetris-make-color-tty-faces)) - ('mono-x - (tetris-make-mono-x-faces)) - ('color-x - (tetris-make-color-x-faces)))) - -(defun tetris-set-display-table () - (if (fboundp 'specifierp) - (add-spec-to-specifier current-display-table - tetris-display-table - (current-buffer) - nil 'remove-locale) - (setq buffer-display-table tetris-display-table))) - -(defun tetris-setup-default-face () - (cond ((eq tetris-display-mode 'glyph) - (let* ((font-spec (face-property 'default 'font)) - (name (font-name font-spec)) - (glyph (aref tetris-display-table tetris-blank)) - (height (glyph-height glyph))) - (while (> (font-height font-spec) height) - (setq name (x-find-smaller-font name)) - (add-spec-to-specifier font-spec name (current-buffer))))))) - -(defun tetris-hide-cursor () - (if (fboundp 'specifierp) - (set-specifier text-cursor-visible-p nil (current-buffer)))) - -(defun tetris-draw-border-p () - (or (not (eq tetris-display-mode 'glyph)) - tetris-draw-border-with-glyphs)) - -(defun tetris-set-color (c) - (unless (eq tetris-display-mode 'glyph) - (put-text-property - (1- (point)) (point) 'face (aref tetris-faces c)))) - -;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun tetris-get-tick-period () - (if (boundp 'tetris-update-speed-function) - (let ((period (apply tetris-update-speed-function - tetris-n-shapes - tetris-n-rows nil))) - (and (numberp period) period)))) - -(defun tetris-cell-offset (x y) - (+ tetris-buffer-start - (* (1+ tetris-buffer-width) y) - x)) - -(defun tetris-get-cell (x y) - (char-after (tetris-cell-offset x y))) - -(defun tetris-set-cell (x y c) - (save-excursion - (let ((buffer-read-only nil)) - (goto-char (tetris-cell-offset x y)) - (delete-char 1) - (insert-char c 1) - (tetris-set-color c)))) - -(defun tetris-get-shape-cell (x y) - (aref - (aref - (aref - (aref tetris-shapes tetris-shape) - y) - tetris-rot) - x)) - -(defun tetris-shape-width () - (aref (aref tetris-shape-dimensions tetris-shape) - (% tetris-rot 2))) - -(defun tetris-shape-height () - (aref (aref tetris-shape-dimensions tetris-shape) - (- 1 (% tetris-rot 2)))) - -(defun tetris-draw-score () - (let ((strings (vector - (format "Shapes: %05d" tetris-n-shapes) - (format "Rows: %05d" tetris-n-rows)))) - (loop for y from 0 to 1 do - (let* ((string (aref strings y)) - (len (length string))) - (loop for x from 0 to (1- len) do - (tetris-set-cell - (+ tetris-score-x x) - (+ tetris-score-y y) - (aref string x))))))) - -(defun tetris-update-score () - (tetris-draw-score) - (let ((period (tetris-get-tick-period))) - (if period (tetris-set-timer period)))) - -(defun tetris-new-shape () - (setq tetris-shape tetris-next-shape) - (setq tetris-rot 0) - (setq tetris-next-shape (random 7)) - (setq tetris-pos-x (random (- tetris-width (tetris-shape-width)))) - (setq tetris-pos-y 0) - (setq tetris-n-shapes (1+ tetris-n-shapes)) - (tetris-draw-next-shape) - (tetris-update-score)) - -(defun tetris-draw-next-shape () - (loop for y from 0 to 3 do - (loop for x from 0 to 3 do - (tetris-set-cell - (+ tetris-next-x x) - (+ tetris-next-y y) - (let ((tetris-shape tetris-next-shape) - (tetris-rot 0)) - (tetris-get-shape-cell x y)))))) - -(defun tetris-draw-shape () - (loop for y from 0 to (1- (tetris-shape-height)) do - (loop for x from 0 to (1- (tetris-shape-width)) do - (let ((c (tetris-get-shape-cell x y))) - (if (/= c tetris-blank) - (tetris-set-cell - (+ tetris-top-left-x tetris-pos-x x) - (+ tetris-top-left-y tetris-pos-y y) - c)))))) - -(defun tetris-erase-shape () - (loop for y from 0 to (1- (tetris-shape-height)) do - (loop for x from 0 to (1- (tetris-shape-width)) do - (let ((c (tetris-get-shape-cell x y))) - (if (/= c tetris-blank) - (tetris-set-cell - (+ tetris-top-left-x tetris-pos-x x) - (+ tetris-top-left-y tetris-pos-y y) - tetris-blank)))))) - -(defun tetris-test-shape () - (let ((hit nil)) - (loop for y from 0 to (1- (tetris-shape-height)) do - (loop for x from 0 to (1- (tetris-shape-width)) do - (unless hit - (setq hit - (let ((c (tetris-get-shape-cell x y)) - (xx (+ tetris-pos-x x)) - (yy (+ tetris-pos-y y))) - (and (/= c tetris-blank) - (or (>= xx tetris-width) - (>= yy tetris-height) - (/= (tetris-get-cell - (+ tetris-top-left-x xx) - (+ tetris-top-left-y yy)) - tetris-blank)))))))) - hit)) - -(defun tetris-full-row (y) - (let ((full t)) - (loop for x from 0 to (1- tetris-width) do - (if (= (tetris-get-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y)) - tetris-blank) - (setq full nil))) - full)) - -(defun tetris-shift-row (y) - (loop for x from 0 to (1- tetris-width) do - (let ((c (tetris-get-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y -1)))) - (tetris-set-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - c)))) - -(defun tetris-shift-down () - (loop for y0 from 0 to (1- tetris-height) do - (if (tetris-full-row y0) - (progn - (setq tetris-n-rows (1+ tetris-n-rows)) - (tetris-update-score) - (loop for y from y0 downto 1 do - (tetris-shift-row y)))))) - -(defun tetris-init-buffer () - (let ((line (concat - (make-string tetris-buffer-width tetris-space) - "\n")) - (buffer-read-only nil)) - (erase-buffer) - (setq tetris-buffer-start (point)) - (dotimes (i tetris-buffer-height) - (insert-string line)) - (goto-char (point-min)) - (if (tetris-draw-border-p) - (loop for y from -1 to tetris-height do - (loop for x from -1 to tetris-width do - (tetris-set-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-border)))) - (loop for y from 0 to (1- tetris-height) do - (loop for x from 0 to (1- tetris-width) do - (tetris-set-cell - (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-blank))) - (if (tetris-draw-border-p) - (loop for y from -1 to 4 do - (loop for x from -1 to 4 do - (tetris-set-cell - (+ tetris-next-x x) - (+ tetris-next-y y) - tetris-border)))))) - -(defun tetris-reset-game () - (tetris-kill-timer) - (tetris-init-buffer) - (setq tetris-next-shape (random 7)) - (setq tetris-shape 0 - tetris-rot 0 - tetris-n-shapes 0 - tetris-n-rows 0 - tetris-pos-x 0 - tetris-pos-y 0) - (tetris-new-shape) - (tetris-draw-shape)) - -(defun tetris-shape-done () - (tetris-shift-down) - (tetris-new-shape) - (if (tetris-test-shape) - (progn - (tetris-end-game)) - (tetris-draw-shape))) - -(defun tetris-update-game (tetris-buffer) - "Called on each clock tick. -Drops the shape one square, testing for collision." - (if (eq (current-buffer) tetris-buffer) - (let (hit) - (tetris-erase-shape) - (setq tetris-pos-y (1+ tetris-pos-y)) - (setq hit (tetris-test-shape)) - (if hit - (setq tetris-pos-y (1- tetris-pos-y))) - (tetris-draw-shape) - (if hit - (tetris-shape-done))))) - -(defun tetris-move-bottom () - "Drops the shape to the bottom of the playing area" - (interactive) - (let ((hit nil)) - (tetris-erase-shape) - (while (not hit) - (setq tetris-pos-y (1+ tetris-pos-y)) - (setq hit (tetris-test-shape))) - (setq tetris-pos-y (1- tetris-pos-y)) - (tetris-draw-shape) - (tetris-shape-done))) - -(defun tetris-move-left () - "Moves the shape one square to the left" - (interactive) - (unless (= tetris-pos-x 0) - (tetris-erase-shape) - (setq tetris-pos-x (1- tetris-pos-x)) - (if (tetris-test-shape) - (setq tetris-pos-x (1+ tetris-pos-x))) - (tetris-draw-shape))) - -(defun tetris-move-right () - "Moves the shape one square to the right" - (interactive) - (unless (= (+ tetris-pos-x (tetris-shape-width)) - tetris-width) - (tetris-erase-shape) - (setq tetris-pos-x (1+ tetris-pos-x)) - (if (tetris-test-shape) - (setq tetris-pos-x (1- tetris-pos-x))) - (tetris-draw-shape))) - -(defun tetris-rotate-prev () - "Rotates the shape clockwise" - (interactive) - (tetris-erase-shape) - (setq tetris-rot (% (+ 1 tetris-rot) 4)) - (if (tetris-test-shape) - (setq tetris-rot (% (+ 3 tetris-rot) 4))) - (tetris-draw-shape)) - -(defun tetris-rotate-next () - "Rotates the shape anticlockwise" - (interactive) - (tetris-erase-shape) - (setq tetris-rot (% (+ 3 tetris-rot) 4)) - (if (tetris-test-shape) - (setq tetris-rot (% (+ 1 tetris-rot) 4))) - (tetris-draw-shape)) - -(defun tetris-end-game () - "Terminates the current game" - (interactive) - (tetris-kill-timer) - (use-local-map tetris-null-map)) - -(defun tetris-start-game () - "Starts a new game of Tetris" - (interactive) - (tetris-reset-game) - (use-local-map tetris-mode-map) - (let ((period (or (tetris-get-tick-period) - tetris-default-tick-period))) - (tetris-start-timer period))) - -(put 'tetris-mode 'mode-class 'special) - -(defun tetris-mode () - "A mode for playing Tetris. - -tetris-mode keybindings: - \\{tetris-mode-map} -" - (kill-all-local-variables) - - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'tetris-end-game nil t) - - (make-local-variable 'tetris-display-mode) - (make-local-variable 'tetris-display-table) - (make-local-variable 'tetris-faces) - (make-local-variable 'tetris-timer) - (make-local-variable 'tetris-buffer-start) - (make-local-variable 'tetris-shape) - (make-local-variable 'tetris-rot) - (make-local-variable 'tetris-next-shape) - (make-local-variable 'tetris-n-shapes) - (make-local-variable 'tetris-n-rows) - (make-local-variable 'tetris-pos-x) - (make-local-variable 'tetris-pos-y) - - (use-local-map tetris-null-map) - - (setq buffer-read-only t) - (setq truncate-lines 't) - (setq major-mode 'tetris-mode) - (setq mode-name "Tetris") - - (buffer-disable-undo (current-buffer)) - - (tetris-initialize-display) - (tetris-setup-default-face) - (tetris-set-display-table) - (tetris-hide-cursor) - - (run-hooks 'tetris-mode-hook)) - -;;;###autoload -(defun tetris () - "Tetris - -Shapes drop from the top of the screen, and the user has to move and -rotate the shape to fit in with those at the bottom of the screen so -as to form complete rows. - -tetris-mode keybindings: - \\<tetris-mode-map> -\\[tetris-start-game] Starts a new game of Tetris -\\[tetris-end-game] Terminates the current game -\\[tetris-move-left] Moves the shape one square to the left -\\[tetris-move-right] Moves the shape one square to the right -\\[tetris-rotate-prev] Rotates the shape clockwise -\\[tetris-rotate-next] Rotates the shape anticlockwise -\\[tetris-move-bottom] Drops the shape to the bottom of the playing area - -" - (interactive) - - (switch-to-buffer tetris-buffer-name) - (tetris-kill-timer) - (tetris-mode) - (tetris-start-game)) - -(provide 'tetris) - -;;; tetris.el ends here -
--- a/lisp/games/xmine.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,862 +0,0 @@ -;;; xmine.el --- Mine game for XEmacs - -;; Author: Jens Lautenbacher <jens@lemming0.lem.uni-karlsruhe.de> -;; Keywords: games -;; Version: 1.8 - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;; Commentary: This is a complete reimplementation of the classical -;; mine searching game known from various OS/GUIs under names like -;; xmine, minesweeper etc. - -;; The idea to implement this in elisp is from -;; Jacques Duthen <duthen@cegelec-red.fr>, -;; the author of the original mine game for GNU Emacs. This version -;; has to the best of my knowledge no code in common with his version, -;; but cudos go to him for first starting this... -;; -;; I mainly wrote this as an example how graphics handling in XEmacs -;; is possible. I think I did it the right way, using an extension to -;; the annotation mechanism and via extensive use of `slots' (realized -;; as properties of extents) to hold the data in the object itself. -;; (Of course this is not true. The keyboard handling is controlled from -;; the "outside" of the objects. But at one time during development -;; before hacking the keyboard controls the code really _was_ nice... -;; now it's a bad messing with slots and controls from the outside) -;; -;; Code: -;; -;;; First of all we'll define the needed varibles. - -(defconst xmine-version-number "1.8" "XEmacs Mine version number.") -(defconst xmine-version (format "XEmacs Mine v%s by Jens Lautenbacher © 1997" - xmine-version-number) - "Full XEmacs Mine version number.") - -(defgroup xmine nil - "The well known mine searching game." - :group 'games) - -(defcustom xmine-width 25 - "The width of the mine field" - :group 'xmine - :type 'integer) - -(defcustom xmine-height 20 - "The height of the mine field" - :group 'xmine - :type 'integer) - -(defcustom xmine-glyph-dir (concat data-directory "mine/") - "The directory where the mine glyphs reside" - :group 'xmine - :type 'directory) - -(defface xmine-hidden-face - '((t - (:background "blue"))) - "The face used for hidden tiles on ttys" - :group 'xmine) - -(defface xmine-flagged-face - '((t - (:background "red"))) - "The face used for flagged tiles on ttys" - :group 'xmine) - -(defface xmine-number-face - '((t - (:background "green"))) - "The face used for unhidden, numbered tiles on ttys" - :group 'xmine) - - -(defvar xmine-pad-glyph - (make-glyph - (if (and (eq window-system 'x) (featurep 'xpm)) - (concat xmine-glyph-dir "pad.xpm") - " "))) - -(defvar xmine-title-glyph - (make-glyph - (if (and (eq window-system 'x) (featurep 'xpm)) - (concat xmine-glyph-dir "splash.xpm") - "------------------ XEmacs XMine ------------------"))) - -(defvar xmine-glyph-production-list - '(("xmine-new-up" "new_up.gif" "new" nil) - ("xmine-new-down" "new_down.gif" "NEW" nil) - ("xmine-quit-up" "quit_up.gif" "quit" nil) - ("xmine-quit-down" "quit_down.gif" "QUIT" nil) - ("xmine-up-glyph" "empty_16_up.gif" "@ " xmine-hidden-face) - ("xmine-up-sel-glyph" "empty_16_up_sel.gif" "@<" xmine-hidden-face) - ("xmine-down-glyph" "empty_16_down.gif" "? " nil) - ("xmine-flagged-glyph" "flagged_16_up.gif" "! " xmine-flagged-face) - ("xmine-flagged-sel-glyph" "flagged_16_up_sel.gif" "!<" xmine-flagged-face) - ("xmine-mine-glyph" "bomb_16_flat.gif" "* " nil) - ("xmine-mine-sel-glyph" "bomb_16_flat.gif" "*<" nil) - ("xmine-trapped-glyph" "bomb_trapped_16_flat.gif" "X " nil) - ("xmine-0-glyph" "empty_16_flat.gif" ". " nil) - ("xmine-0-sel-glyph" "empty_16_flat_sel.gif" ".<" nil) - ("xmine-1-glyph" "1_16_flat.gif" "1 " xmine-number-face) - ("xmine-1-sel-glyph" "1_16_flat_sel.gif" "1<" xmine-number-face) - ("xmine-2-glyph" "2_16_flat.gif" "2 " xmine-number-face) - ("xmine-2-sel-glyph" "2_16_flat_sel.gif" "2<" xmine-number-face) - ("xmine-3-glyph" "3_16_flat.gif" "3 " xmine-number-face) - ("xmine-3-sel-glyph" "3_16_flat_sel.gif" "3<" xmine-number-face) - ("xmine-4-glyph" "4_16_flat.gif" "4 " xmine-number-face) - ("xmine-4-sel-glyph" "4_16_flat_sel.gif" "4<" xmine-number-face) - ("xmine-5-glyph" "5_16_flat.gif" "5 " xmine-number-face) - ("xmine-5-sel-glyph" "5_16_flat_sel.gif" "5<" xmine-number-face) - ("xmine-6-glyph" "6_16_flat.gif" "6 " xmine-number-face) - ("xmine-6-sel-glyph" "6_16_flat_sel.gif" "6<" xmine-number-face) - ("xmine-7-glyph" "7_16_flat.gif" "7 " xmine-number-face) - ("xmine-7-sel-glyph" "7_16_flat_sel.gif" "7<" xmine-number-face) - ("xmine-8-glyph" "8_16_flat.gif" "8 " xmine-number-face) - ("xmine-8-sel-glyph" "8_16_flat_sel.gif" "8<" xmine-number-face))) - -(defvar xmine-force-textual nil - "This is for debugging purposes only. No need to set it. Really.") - -(defun xmine-generate-glyphs () - (let ((list xmine-glyph-production-list) - elem var gif text face) - (while (setq elem (pop list)) - (setq var (car elem) - gif (cadr elem) - text (caddr elem) - face (cadddr elem)) - (set (intern var) - (make-glyph (if (and (not xmine-force-textual) - (eq window-system 'x)) - (concat xmine-glyph-dir gif) - text))) - (if face - (set-glyph-face (eval (intern-soft var)) face))))) - -(xmine-generate-glyphs) - -(defvar xmine-key-sel-button nil) - -(defun xmine-up-glyph (ext) - (if (equal ext xmine-key-sel-button) - (progn - (set-extent-property ext 'xmine-non-selected-glyph xmine-up-glyph) - xmine-up-sel-glyph) - xmine-up-glyph)) - -(defun xmine-flagged-glyph (ext) - (if (equal ext xmine-key-sel-button) - (progn - (set-extent-property ext 'xmine-non-selected-glyph xmine-flagged-glyph) - xmine-flagged-sel-glyph) - xmine-flagged-glyph)) - -(defcustom xmine-%-of-mines 12 - "The percentage of tiles that should be mines." - :group 'xmine - :type 'integer) - -(defcustom xmine-balloon-list (list "What are you waiting for?" - "Push me!" - "Come on. Don't sleep." - "Are you sure?" - "Are you sleeping?" - "Yes! Do it!" - "I'm getting bored." - "You will NEVER beat me.") - "(Random) texts for the balloon-help property of the tiles" - :group 'xmine - :type '(repeat (string))) - -(defcustom xmine-background "white" - "The background color of XMine's buffer. -Many colors will not blend nicely with the logo. Shades of light grey are -preferred if you don't want to use white." - :group 'xmine - :type 'color) - -(defvar xmine-keymap nil) - -(if xmine-keymap () - (setq xmine-keymap (make-sparse-keymap)) - (suppress-keymap xmine-keymap) - (define-key xmine-keymap [up] 'xmine-key-up) - (define-key xmine-keymap [down] 'xmine-key-down) - (define-key xmine-keymap [right] 'xmine-key-right) - (define-key xmine-keymap [left] 'xmine-key-left) - (define-key xmine-keymap "e" 'xmine-key-up) - (define-key xmine-keymap "c" 'xmine-key-down) - (define-key xmine-keymap "f" 'xmine-key-right) - (define-key xmine-keymap "s" 'xmine-key-left) - (define-key xmine-keymap "w" 'xmine-key-up-left) - (define-key xmine-keymap "x" 'xmine-key-down-left) - (define-key xmine-keymap "r" 'xmine-key-up-right) - (define-key xmine-keymap "v" 'xmine-key-down-right) - (define-key xmine-keymap [return] 'xmine-key-action3) - (define-key xmine-keymap "d" 'xmine-key-action3) - (define-key xmine-keymap [(shift space)] 'xmine-key-action2) - (define-key xmine-keymap "a" 'xmine-key-action2) - (define-key xmine-keymap [space] 'xmine-key-action1) - (define-key xmine-keymap [Q] 'xmine-key-quit) - (define-key xmine-keymap [N] 'xmine-key-new)) - -(defvar xmine-number-of-flagged 0) - -(defvar xmine-number-of-opened 0) - -(defvar xmine-number-of-mines 0) - -(defvar xmine-field nil) - -(defvar xmine-buffer nil) - -(defvar xmine-quit-ann nil) - -(defvar xmine-new-ann nil) - -(defvar xmine-count-ann nil) - -(defvar xmine-count-glyph (make-glyph "Mines: 00")) - -(defvar xmine-mode-hook nil - "*Hook called by `xmine-mode-hook'.") - -;; the next function is more or less stolen from annotation.el and -;; modified to fit in our scheme were all three buttons should trigger -;; actions - -(defun xmine-activate-function-button (event) - (interactive "e") - (let* ((extent (event-glyph-extent event)) - (button (number-to-string (event-button event))) - (action (intern (concat "action" button))) - (down-action (intern (concat "down-action" button))) - (restore-down-action (intern (concat "restore-down-action" button))) - (mouse-down t) - (action-do-it t) - up-glyph) - ;; make the glyph look pressed - (cond ((annotation-down-glyph extent) - (setq up-glyph (annotation-glyph extent)) - (set-annotation-glyph extent (annotation-down-glyph extent)))) - (if (extent-property extent down-action) - (setq action-do-it - (funcall (extent-property extent down-action) extent))) - (while mouse-down - (setq event (next-event event)) - (if (button-release-event-p event) - (setq mouse-down nil))) - ;; make the glyph look released - (cond ((annotation-down-glyph extent) - (set-annotation-glyph extent up-glyph))) - (if (eq extent (event-glyph-extent event)) - (if (and (extent-property extent action) action-do-it) - (funcall (extent-property extent action) extent) - (if (extent-property extent restore-down-action) - (funcall (extent-property extent restore-down-action) extent))) - (if (extent-property extent restore-down-action) - (funcall (extent-property extent restore-down-action) extent))))) - -;;; Here we define the button object's constructor function - -(defun xmine-button-create (x y type) - (let ((ext (make-annotation - xmine-up-glyph nil 'text nil nil xmine-down-glyph nil))) - (set-extent-property ext 'action1 'xmine-action1) - (set-extent-property ext 'action2 'xmine-beep) - (set-extent-property ext 'action3 'xmine-action3) - (set-extent-property ext 'down-action2 'xmine-down-action2) - (set-extent-property ext 'restore-down-action2 'xmine-restore-down-action2) - (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type)) - (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type)) - (set-extent-property ext 'xmine-type type) - (set-extent-property ext 'xmine-x x) - (set-extent-property ext 'xmine-y y) - (set-extent-property ext 'xmine-flagged nil) - (set-extent-property ext 'xmine-hidden t) - (set-extent-property ext 'end-open t) - (set-extent-property ext 'balloon-help (xmine-balloon-text)) - (aset xmine-field (+ (* (1- y) xmine-width) (1- x)) ext))) - -;;; ...and this is the second global function to change a -;;; button object. It is only needed during creation of the board. - -(defun xmine-button-change-type (ext type) - (set-extent-property ext 'xmine-glyph (xmine-type-to-glyph type)) - (set-extent-property ext 'xmine-sel-glyph (xmine-type-to-sel-glyph type)) - (set-extent-property ext 'xmine-type type)) - -;;; some needed predicates. - -(defun xmine-flat-button-p (ext) - (and ext - (not (extent-property ext 'xmine-hidden)) - (equal "0" (extent-property ext 'xmine-type)))) - -(defun xmine-enough-flagged-p (ext) - (let ((list (xmine-get-neighbours ext)) - (number (extent-property ext 'xmine-type)) - (flagged 0) elem res) - (if (not (or (equal number "mine") - (equal number "0"))) - (progn - (setq number (string-to-number number)) - (while (setq elem (pop list)) - (if (extent-property elem 'xmine-flagged) - (setq flagged (1+ flagged)))) - (setq res (>= flagged number)) - )) - res)) - - -(defun xmine-mine-button-p (ext) - (and ext - (equal "mine" (extent-property ext 'xmine-type)))) - -;;; the next three functions are helper functions used inside a button -;;; object. - -(defun xmine-balloon-text () - (nth (random (length xmine-balloon-list)) xmine-balloon-list)) - -(defun xmine-beep (&rest forget) - (beep)) - -(defun xmine-type-to-glyph (type) - (eval (intern-soft (concat "xmine-" type "-glyph")))) - -(defun xmine-type-to-sel-glyph (type) - (eval (intern-soft (concat "xmine-" type "-sel-glyph")))) - -;;; the next 3 functions are the main functions that are used -;;; inside the button objects and which are bound to the 'action1, -;;; 'action2 and 'action3 slots respectively - -(defun xmine-action1 (ext &optional no-repaint force) - "This unhides a hidden button" - (if (or force - (not (extent-property ext 'xmine-flagged))) - (progn - (if (and (not force) - (extent-property ext 'xmine-hidden)) - (setq xmine-number-of-opened (1+ xmine-number-of-opened))) - (set-extent-property ext 'xmine-hidden nil) - (set-annotation-glyph ext (if (equal ext xmine-key-sel-button) - (progn - (set-extent-property - ext 'xmine-non-selected-glyph - (extent-property ext 'xmine-glyph)) - (extent-property ext 'xmine-sel-glyph)) - (extent-property ext 'xmine-glyph))) - (set-extent-property ext 'action3 nil) - (set-extent-property ext 'action1 nil) - (set-extent-property ext 'balloon-help nil) - (set-extent-property ext 'action2 'xmine-action2) - (if (not no-repaint) - (progn - (xmine-unhide-sound) - (xmine-field-repaint ext) - (if (and (xmine-game-solved-p) - (not (xmine-mine-button-p ext))) - (xmine-end-game))))))) - -(defun xmine-action2 (ext) - "This unhides all hidden neighbours of a button. -It is meant as convenience function you can use if you're sure that -you've marked all mines around the button correctly (or you're sure -there isn't one)" - (let ((list (xmine-get-neighbours ext)) - (xmine-no-unhide-sound t) - next) -;; (xmine-restore-down-action2 ext) - (if list (xmine-unhide-many-sound)) - (while (setq next (pop list)) - (if (not (xmine-flat-button-p next)) (xmine-action1 next))))) - -(defun xmine-action3 (ext) - "This toggles the flagged status of a button. -You flag a button if you know - or think - that there's a mine under it" - (if (extent-property ext 'xmine-flagged) - (progn - (set-annotation-glyph ext (xmine-up-glyph ext)) - (set-extent-property ext 'action1 'xmine-action1) - (set-extent-property ext 'xmine-flagged nil) - (setq xmine-number-of-flagged (1- xmine-number-of-flagged)) - (xmine-flag-sound) - (set-annotation-glyph xmine-count-ann - (make-glyph - (format "Mines: %2d" - (- xmine-number-of-mines - xmine-number-of-flagged))))) - (if (= xmine-number-of-flagged xmine-number-of-mines) - (progn - (beep) - (message - "Impossible. You seem to have marked too many tiles as mines?")) - (set-annotation-glyph ext (xmine-flagged-glyph ext)) - (set-extent-property ext 'action1 nil) - (set-extent-property ext 'xmine-flagged t) - (setq xmine-number-of-flagged (1+ xmine-number-of-flagged)) - (xmine-flag-sound) - (if (xmine-game-solved-p) (xmine-end-game) - (set-annotation-glyph xmine-count-ann - (make-glyph - (format "Mines: %2d" - (- xmine-number-of-mines - xmine-number-of-flagged)))))))) - - -(defun xmine-down-action2 (ext) - (let ((list (xmine-get-neighbours ext)) - (do-it (xmine-enough-flagged-p ext)) - elem) - (if (not do-it) - (while (setq elem (pop list)) - (set-extent-property elem 'xmine-temp-glyph (annotation-glyph elem)) - (set-annotation-glyph elem (annotation-down-glyph elem)))) - do-it)) - -(defun xmine-restore-down-action2 (ext) - (let ((list (xmine-get-neighbours ext)) - elem) - (while (setq elem (pop list)) - (set-annotation-glyph elem (extent-property elem 'xmine-temp-glyph))))) - -;;; the sounds... -(defcustom xmine-play-sounds nil - "If XMine should play some sounds for various events to happen." - :group 'xmine - :type 'boolean) - -(defun xmine-play-sounds-p () - (and xmine-play-sounds - (or (featurep 'native-sound) - (featurep 'nas-sound)) - (or (device-sound-enabled-p) - (and (featurep 'native-sound) - (not native-sound-only-on-console) - (eq (device-type) 'x))))) - - -(defcustom xmine-flag-sound (concat data-directory "sounds/click.au") - "The sound played when flagging/un-flagging a tile" - :group 'xmine - :type 'file) - -(defcustom xmine-unhide-sound (concat data-directory "sounds/drip.au") - "The sound played when unhiding a tile" - :group 'xmine - :type 'file) - -(defcustom xmine-unhide-many-sound (concat data-directory "sounds/boing.au") - "The sound played when unhiding all neighbours of a tile" - :group 'xmine - :type 'file) - -(defcustom xmine-explode-sound (concat xmine-glyph-dir "explosion3.au") - "The sound played when you unhide a mine" - :group 'xmine - :type 'file) - -(defcustom xmine-solved-sound (concat data-directory "sounds/im_so_happy.au") - "The sound played if you managed to win the game." - :group 'xmine - :type 'file) - -(defun xmine-flag-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-flag-sound))) - -(defvar xmine-no-unhide-sound nil) - -(defun xmine-unhide-sound () - (if (and (xmine-play-sounds-p) - (not xmine-no-unhide-sound)) - (play-sound-file xmine-unhide-sound))) - -(defun xmine-unhide-many-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-unhide-many-sound))) - -(defun xmine-explode-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-explode-sound) - (beep))) - -(defun xmine-solved-sound () - (if (xmine-play-sounds-p) - (play-sound-file xmine-solved-sound) - (beep))) - - -;;; what to do after a button is unhidden: We (maybe) have to repaint -;;; parts of the board. This is done here recursively. - -(defun xmine-field-repaint (ext) - (let* ((flatp (xmine-flat-button-p ext)) - (minep (xmine-mine-button-p ext)) - (neighbours (xmine-get-neighbours ext)) - (max-lisp-eval-depth (* 8 xmine-width xmine-height)) - next-ext ext-list) - (cond (flatp - (while (setq next-ext (pop neighbours)) - (if (extent-property next-ext 'xmine-hidden) - (progn - (xmine-action1 next-ext 'no-repaint) - (and (equal "0" (extent-property next-ext 'xmine-type)) - (push next-ext ext-list))))) - (while ext-list - (setq next-ext (pop ext-list)) - (xmine-field-repaint next-ext))) - (minep - (set-extent-property ext 'xmine-glyph xmine-trapped-glyph) - (set-extent-property ext 'xmine-sel-glyph xmine-trapped-glyph) - (xmine-show-all) - (xmine-end-game-trapped))))) - - -(defun xmine-get-neighbours (ext) - "This gives back a list of all neighbours of a button, correctly - handling buttons at the side or corner of course" -(let* ((x (extent-property ext 'xmine-x)) - (y (extent-property ext 'xmine-y)) - next-coord next list - (neighbours (list (list (1- x) (1+ y)) - (list x (1+ y)) - (list (1+ x) (1+ y)) - (list (1- x) (1- y)) - (list x (1- y)) - (list (1+ x) (1- y)) - (list (1+ x) y) - (list (1- x) y)))) - (while (setq next-coord (pop neighbours)) - (if (setq next (xmine-field-button-at (car next-coord) - (cadr next-coord))) - (push next list))) - list)) - - -;;; the next four functions are used to know if we're at the end of -;;; the game (either successfully or exploded) and do the approbate -;;; action - -(defun xmine-game-solved-p () - "You have solved the game successfully if the number of flagged -mines plus the number of unhidden buttons equals width*height of the field" - (equal (+ xmine-number-of-flagged xmine-number-of-opened) - (* xmine-width xmine-height))) - -(defun xmine-end-game () - (set-annotation-glyph xmine-count-ann - (make-glyph " Solved. ")) - (sit-for 0) - (xmine-solved-sound)) - -(defun xmine-end-game-trapped () - (xmine-explode-sound) - (set-annotation-glyph xmine-count-ann - (make-glyph "++ RIP ++"))) - -(defun xmine-show-all () - (let ((list (append xmine-field nil)) - next) - (while (setq next (pop list)) - (xmine-action1 next 'no-repaint 'force)))) - - -(defun xmine-field-button-at (x y) - "This function gives back the button at a given coordinate pair (x y) -It is only used during creation of the board and when getting the -neighbours of a button (and for keyboard handling...), as we don't -want to use coordinates in the main loop, only the button object -itself should be referenced. Of course the use of this function could -be avoided in xmine-get-neighbours by storing the neighbour buttons -directly in the button, but this seems to be a bit oversized for this -little game." - (if (or (> x xmine-width) (< x 1) - (> y xmine-height) (< y 1)) nil - (aref xmine-field (+ (* (1- y) xmine-width) (1- x))))) - -;;;###autoload -(defun xmine-mode () -"A mode for playing the well known mine searching game. - - `\\<annotation-local-map-default>\\[xmine-activate-function-button1]' or `\\<xmine-keymap>\\[xmine-key-action1]' unhides a tile, - `\\<annotation-local-map-default>\\[xmine-activate-function-button2]' or `\\<xmine-keymap>\\[xmine-key-action2]' unhides all neighbours of a tile, - `\\<annotation-local-map-default>\\[xmine-activate-function-button3]' or `\\<xmine-keymap>\\[xmine-key-action3]' (un)flagges a tile to hold a mine. - - `\\[xmine-key-new]' starts a new game. - `\\[xmine-key-quit]' ends a game. - -All keybindings (with alternatives) currently in effect: - \\{xmine-keymap} - -The rules are quite easy: You start by unhiding (random) tiles. An unhidden -tile showing a number tells you something about the number of mines in it's -neighborhood, where the neighborhood are all 8 tiles (or less if it's -at a border) around the tile. - -E.g. a \"1\" shows you that there is only one mine in the neighborhood of -this tile. Empty tiles have no mines around them, and empty tiles in -the neighborhood of another empty tile are all automatically unhidden -if you unhide one of them. You need to find a strategy to use the -information you have from the numbers to \"flag\" the tiles with mines -under them and unhide all other tiles. If you correctly made this -without accidently unhiding a mine, you've won. - -If you are sure you have correctly flagged all mines around a unhidden tile, -you can use Button-2 or \\[xmine-key-action2] on it to unhide all it's -neighbors. But beware: If you made a mistake by flagging the wrong mines, -you'll blow up! - -Have Fun." - (interactive) - (xmine-field-create)) - -;;;###autoload -(fset 'xmine 'xmine-mode) - -(defun xmine-field-create () - "We create the playing board here." - (let ((width 1) - (height 1) - (pop-up-windows nil) - total) - (xmine-buffer-init) - (pop-to-buffer xmine-buffer) - (setq total (* xmine-height xmine-width)) - (setq xmine-field (make-vector total nil)) - (xmine-init-mines - (setq xmine-number-of-mines - (min 99 (round (* (/ (float xmine-%-of-mines) 100) total))))) - (insert "\n ") - (set-extent-end-glyph (make-extent (point) (point)) xmine-title-glyph) - (insert "\n\n") - (while (<= height xmine-height) - (insert " ") - (while (<= width xmine-width) - (if (xmine-field-button-at width height) - (xmine-button-create width height "mine") - (xmine-button-create width height "0")) - (setq width (+ width 1))) - (insert " \n") - (setq width 1) - (setq height (+ height 1))) - (insert "\n ") - (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph) - (setq xmine-new-ann - (make-annotation xmine-new-up nil - 'text nil nil xmine-new-down nil)) - (set-extent-property xmine-new-ann 'action1 '(lambda (&rest egal) - (xmine-field-create))) - (set-extent-property xmine-new-ann 'action2 nil) - (set-extent-property xmine-new-ann 'action3 nil) - (set-extent-property xmine-new-ann 'end-open t) - (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph) - (setq xmine-count-ann - (make-annotation xmine-count-glyph nil - 'text nil nil nil nil)) - (set-extent-begin-glyph (make-extent (point) (point)) xmine-pad-glyph) - (setq xmine-quit-ann - (make-annotation xmine-quit-up nil - 'text nil nil xmine-quit-down nil)) - (set-extent-property xmine-quit-ann 'action1 - '(lambda (&rest egal) - (kill-buffer (current-buffer)))) - (set-extent-property xmine-quit-ann 'action2 nil) - (set-extent-property xmine-quit-ann 'action3 nil) - (set-extent-property xmine-quit-ann 'end-open t) - (xmine-attach-numbers) - (setq xmine-number-of-flagged 0) - (setq xmine-number-of-opened 0) - (set-annotation-glyph xmine-count-ann - (make-glyph - (format "Mines: %2d" xmine-number-of-mines))) - (goto-char (point-min)) - (setq buffer-read-only 't) - (if (eq window-system 'x) - (set-specifier (face-background 'default) - xmine-background xmine-buffer)) - (set-specifier (face-background 'text-cursor) - xmine-background xmine-buffer) - (setq xmine-key-sel-button nil) - (xmine-select-button (xmine-field-button-at (/ xmine-width 2) - (/ xmine-height 2))))) - - -(defun xmine-init-mines (num) - "A subroutine for xmine-field create. -We randomly set a part of the nil-filled board vector with t to -indicate the places where mines should reside." - (let (x y elem) - (random t) - (while (> num 0) - (setq x (1+ (random xmine-width))) - (setq y (1+ (random xmine-height))) - (setq elem (xmine-field-button-at x y)) - (if (not elem) - (progn - (aset xmine-field (+ (* (1- y) xmine-width) (1- x)) t) - (setq num (1- num))))))) - -(defun xmine-attach-numbers () - "A subroutine for xmine-field-create. -The board is populated by now with empty buttons and mines. Here we -change the correct empty buttons to \"numbered\" buttons" - (let - ((buttons (append xmine-field nil)) - ext) - (while (setq ext (pop buttons)) - (let ((num 0) - (minep (xmine-mine-button-p ext)) - (neighbours (xmine-get-neighbours ext)) - next) - (if (not minep) - (progn - (while (setq next (pop neighbours)) - (if (xmine-mine-button-p next) (setq num (1+ num)))) - (if (> num 0) - (xmine-button-change-type ext (number-to-string num))))))))) - - -(defun xmine-buffer-init () - "A subroutine for xmine-create-field. -We set up the XMine buffer, set up the keymap and so on." - (if xmine-buffer (kill-buffer xmine-buffer)) - (setq xmine-buffer (get-buffer-create "XEmacs Mine")) - (save-excursion - (set-buffer xmine-buffer) - (kill-all-local-variables) - (make-local-variable 'annotation-local-map-default) - (setq truncate-lines 't) - (setq major-mode 'xmine-mode) - (setq mode-name "XMine") - (put 'xmine-mode 'mode-class 'special) - (use-local-map xmine-keymap) - (buffer-disable-undo (current-buffer)) - (setq annotation-local-map-default - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'annotation-local-map) - (define-key map 'button1 'xmine-activate-function-button) - (define-key map 'button2 'xmine-activate-function-button) - (define-key map 'button3 'xmine-activate-function-button) - map)) - (run-hooks 'xmine-mode-hook))) - -;;; The keyboard navigation. - -(defun xmine-select-button (ext) - (let ((flagged (extent-property ext 'xmine-flagged)) - (hidden (extent-property ext 'xmine-hidden)) - sel-glyph) - (setq sel-glyph (if hidden - (if flagged xmine-flagged-sel-glyph - xmine-up-sel-glyph) - (extent-property ext 'xmine-sel-glyph))) - (if xmine-key-sel-button - (set-annotation-glyph xmine-key-sel-button - (extent-property xmine-key-sel-button - 'xmine-non-selected-glyph))) - (set-extent-property ext 'xmine-non-selected-glyph - (annotation-glyph ext)) - (set-annotation-glyph ext sel-glyph) - (setq xmine-key-sel-button ext))) - -(defun xmine-key-action1 () - (interactive) - (let ((action (extent-property xmine-key-sel-button 'action1))) - (if action - (funcall action xmine-key-sel-button)))) - -(defun xmine-key-action2 () - (interactive) - (let ((action (extent-property xmine-key-sel-button 'action2))) - (if (and action (xmine-enough-flagged-p xmine-key-sel-button)) - (funcall action xmine-key-sel-button) - (beep)))) - -(defun xmine-key-action3 () - (interactive) - (let ((action (extent-property xmine-key-sel-button 'action3))) - (if action - (funcall action xmine-key-sel-button)))) - -(defun xmine-key-quit () - (interactive) - (kill-buffer (current-buffer))) - -(defun xmine-key-new () - (interactive) - (xmine-field-create)) - -(defun xmine-key-down-right () - (interactive) - (xmine-key-down) - (xmine-key-right)) - -(defun xmine-key-down-left () - (interactive) - (xmine-key-down) - (xmine-key-left)) - -(defun xmine-key-up-right () - (interactive) - (xmine-key-up) - (xmine-key-right)) - -(defun xmine-key-up-left () - (interactive) - (xmine-key-up) - (xmine-key-left)) - -(defun xmine-key-down () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at x (1+ y)))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at x 1))))) - -(defun xmine-key-up () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at x (1- y)))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at x xmine-height))))) - -(defun xmine-key-right () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at (1+ x) y))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at 1 y))))) - -(defun xmine-key-left () - (interactive) - (let* ((x (extent-property xmine-key-sel-button 'xmine-x)) - (y (extent-property xmine-key-sel-button 'xmine-y)) - (ext (xmine-field-button-at (1- x) y))) - (if ext (xmine-select-button ext) - (xmine-select-button (xmine-field-button-at xmine-width y))))) - -(provide 'xmine) -
--- a/lisp/games/yow.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ -;;; yow.el --- quote random zippyisms - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Author: Richard Mlynarik -;; Keywords: games - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Important pinheadery for GNU Emacs. -;; -;; See cookie1.el for implementation. Note --- the `n' argument of yow -;; from the 18.xx implementation is no longer; we only support *random* -;; random access now. - -;;; Code: - -(require 'cookie1) - -(defvar yow-file (concat data-directory "yow.lines") - "File containing pertinent Pinhead Phrases.") - -(defconst yow-load-message "Am I CONSING yet?...") -(defconst yow-after-load-message "I have SEEN the CONSING!!") - -;;;###autoload -(defun yow (&optional insert) - "Return or display a random Zippy quotation. With prefix arg, insert it." - (interactive "P") - (let ((yow (cookie yow-file yow-load-message yow-after-load-message))) - (cond (insert - (insert yow)) - ((not (interactive-p)) - yow) - ((not (string-match "\n" yow)) - (delete-windows-on (get-buffer-create "*Help*")) - (message "%s" yow)) - (t - (message "Yow!") - (with-output-to-temp-buffer "*Help*" - (princ yow) - (save-excursion - (set-buffer standard-output) - (help-mode))))))) - -(defun read-zippyism (prompt &optional require-match) - "Read a Zippyism from the minibuffer with completion, prompting with PROMPT. -If optional second arg is non-nil, require input to match a completion." - (read-cookie prompt yow-file yow-load-message yow-after-load-message - require-match)) - -;;;###autoload -(defun insert-zippyism (&optional zippyism) - "Prompt with completion for a known Zippy quotation, and insert it at point." - (interactive (list (read-zippyism "Pinhead wisdom: " t))) - (insert zippyism)) - -;;;###autoload -(defun apropos-zippy (regexp) - "Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." - (interactive "sApropos Zippy (regexp): ") - ;; Make sure yows are loaded - (cookie yow-file yow-load-message yow-after-load-message) - (let* ((case-fold-search t) - (cookie-table-symbol (intern yow-file cookie-cache)) - (string-table (symbol-value cookie-table-symbol)) - (matches nil) - (len (length string-table)) - (i 0)) - (save-match-data - (while (< i len) - (and (string-match regexp (aref string-table i)) - (setq matches (cons (aref string-table i) matches))) - (setq i (1+ i)))) - (and matches - (setq matches (sort matches 'string-lessp))) - (and (interactive-p) - (cond ((null matches) - (message "No matches found.")) - (t - (let ((l matches)) - (with-output-to-temp-buffer "*Zippy Apropos*" - (while l - (princ (car l)) - (setq l (cdr l)) - (and l (princ "\n\n")))))))) - matches)) - - -;; Yowza!! Feed zippy quotes to the doctor. Watch results. -;; fun, fun, fun. Entertainment for hours... -;; -;; written by Kayvan Aghaiepour - -;;;###autoload -(defun psychoanalyze-pinhead () - "Zippy goes to the analyst." - (interactive) - (doctor) ; start the psychotherapy - (message "") - (switch-to-buffer "*doctor*") - (sit-for 0) - (while (not (input-pending-p)) - (insert-string (yow)) - (sit-for 0) - (doctor-ret-or-read 1) - (doctor-ret-or-read 1))) - -(provide 'yow) - -;;; yow.el ends here
--- a/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ -Hello, - -I've written a new version (5.8) of my html package for the XEmacs -and the GNU Emacs 19. The name of the package is: - - hm--html-menus-5.8.tar.gz - -With this package it is very easy to write html pages for the World Wide -Web (WWW). Eg: In most cases the user gets help to construct a specific -link by examples or by a completition list with possible input strings. -It is also possible to insert links and images by just clicking on its -source and destination (drag and drop feature). - -The biggest new features compared with release 5.7 are: -- use of the customize package for customization -- the header of the main files should no be 'package finder' compatible -- in the XEmacs a drag and drop mouse pointer will be used - during drag and drop -- the minor mode (hm--html-minor-mode) could now be used in many - other major modes -- better popup menu support for the hm--html-minor-mode in the - Emacs 19 -- the emacs start up options -u, -q, -no-site-file are now - respected -- some bug fixes -Read the NEWS file to see news in detail... - -You should find hm--html-menus-5.8.tar.gz on the following ftp server: - sunsite.unc.edu in /pub/Linux/apps/editors/emacs/ - ftp.tnt.uni-hannover.de in /pub/editors/xemacs/contrib - -It may take some time, before the package is copied by the ftp admins -from the incoming directories to the above listed directories. - -There is a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html - -This package provides also a minor mode (hm--html-minor-mode), which -can be used together with other html major modes, like the psgml-html -mode or other major edit modes, like the perl-mode. - -The package provides functions to insert the following stuff in html-pages: -1. Anchors: - relative links, general link; - html link, info link, gopher link, file link; - ftp link, news link, mailbox link, mailto link, wais (direct) link, - wais (gateway) link; - proggate link, local proggate link, - link target; -2. Frame elements: - full html frame with doctype, doctype, html, head, body, title, - header and signature elements or only the single elements; - meta, isindex, link and base element; - html 'created'- and 'changed'- comments; - the current date in the title; -3. Structure elements: - menu or list item, menu, unordered list, ordered list, directory list; - description list, description title, description entry; - table, table title, table header, table row, table entry; - new paragraph, new line, horizontal rule, document division; -4. for formatting paragraphs: - preformated, blockquote; - basefont, font, center, style; - html comment; -5. formatting: - bold, italic, underline, typewriter, strikethru, super and subscript, - emphasized, strong, small, big, - definition, keyboard, variable, code, sample, citation, -6. include: - top aligned image, middle aligned image, bottom aligned image; - general image element, map, area and all together; - applet, parameter, script; -7. forms: - form; - text, password, isindex, integer, float, date, url, scribble fields; - checkbox, radio, reset, image, audio and submit buttons; - option menus, scrolled lists and option entries; - textarea; -8. entities: - most of the special ISO- characters, less, greater and ampersand; - -If it makes sense, the functions worked also on selected regions. -I've used the same menu items and the same keystrokes. Therefore, you -don't need to learn different menus or keys for similar functions. - -You can choose the popup menus between an expert menu and an novice -menu interactively. - -With the pulldown menu, you can do the following things: -- select the popup menu -- start a drag and drop command -- get help on a drag and drop command -- remove numeric names -- quotify hrefs -- reload the config files -- load html templates from a template directory (two templates are included - in the package); templates written in a special template language are - expanded automatically; -- preview html documents with the netscape -- preview html documents with the xmosaic -- preview html documents with the w3 package for the XEmacs and emacs - -You can insert links and images by clicking with Meta Control Button1 -on its source and then on its destination. For this drag and drop -interface the following destinations and links are supported: - the -inclusion of an GIF- or JPEG- image by clicking on its name - in a dired buffer -- a file or relative link to any other file by clicking on its name - in a dired buffer -- a file or relative link to a directory by clicking on a line without - a filename in the dired buffer -- a file or relative link to a file by clicking in a buffer with this - file -- a http or relative link to a html page by clicking in the w3 buffer, - which displays this page -- a http or relative link, which is in another html page by clicking - on the link in a w3 buffer -If there is an activated region in the source buffer, then the link -is inserted around it, so that the region is used as the name of the -link. - -You can configure the html mode with a special configuration file for -your site and with another file specific for a user. - -The html specification is under development and therefore this -package is also under development. So, if you have any ideas to -extend the package, feel free to email them to -muenkel@tnt.uni-hannover.de. - - -Heiko
--- a/lisp/hm--html-menus/NEWS Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,624 +0,0 @@ -20.07.97 - -- BUILDED the version 5.8 of the package -- -19.07.97 - The minor mode (hm--html-minor-mode) in the Emacs 19 has now - an entry to get the major mode menu - propably not the best - solution, but better than nothing. - Updated the Texinfo documentation. -17.07.97 - Added dummy definitions for defgroup and defcustom for the - Emacs 19. - The variable `site-run-file' is now used, if `site-start-file' - doesn't exists (for Emacs 19 compatibility). - Fixed a bug in the minor mode popup menu, which occured - in the XEmacs together with the html-mode of the psgml - package. -15.07.97 - The minor mode (hm--html-minor-mode) could now be used in many - other (non html) major modes in the XEmacs, like the java-mode - or the perl-mode. In these modes, in the XEmacs it adds it's - own popup menu at the beginning of the major mode menu. -06.07.97 - Changed the file header of hm--html-mode.el, - internal-drag-and-drop.el and tmpl-minor-mode.el. - They should now be compliant with standards. - The mouse pointer in the XEmacs changes now it's shape, - during the drag and drop. -01.07.97 - The package uses now the customisation stuff. - Applied a patch from Dave Love <d.love@dl.ac.uk>, which fixed - some font-lock bugs. - Fixed a bug in `hm--html-insert-modified-line'. Thanks to - David M. Cook <dmcook@cts.com>, who reported this bug. - The package respects now the emacs flags -q, -u and - -no-site-file. -u is only respected, if the user config - file isn't given neither by the environment variable nor by the - lisp variable. -31.05.97 - Added the functions `define-obsolete-variable-alias' and - `define-obsolete-variable-alias' for the Emacs 19 to the file - adapt.el. This fixed a load bug in the Emacs 19. -24.05.97 - Added `hm--html-automatic-create-title-date' and changed the - variable `hm--html-automatic-new-date' to - `hm--html-automatic-update-title-date'. `hm--html-automatic-new-date' - is now an obsolete variable and will be deleted in the future. - Applied a patch from Luca Pisati <pisati@nichimen.com>, which - fixed a bug in `hm--html-indent-region'. - Fixed a bug in the `hm--html-minor-region-mode-map'. Thanks to - Luca Pisati, for the bug report. - Applied a patch from Gary D. Foster <Gary.Foster@Corp.Sun.COM> - to fix the misspelled words *formatted and *formating. Thanks Gary. - Changed `hm--html-indent-line' so that the indentation leaves the - point now at the old text position, if it was behind the - indentation column. - -- BUILDED the version 5.7 of the package -- -23.05.97 - Changed the special character entities &circumflex to &circ, - thanks to Guylaine Prat <prat@cisi.cnes.fr>, for the bug report. - Added the variables `hm--html-automatic-changed-comment-prefix', - `hm--html-automatic-created-comment-prefix' and - `hm--html-automatic-comment-infix' to make the automatic insertation - of created and changed comments more flexible. - Added the command `hm--html-insert-modified-line' and the - variables `hm--html-automatic-create-modified-line', - `hm--html-automatic-update-modified-line', `hm--html-modified-prefix', - `hm--html-modified-start-tag', `hm--html-modified-end-tag' and - `hm--html-modified-insert-before', for inserting and updating - a visible "Modified line". -08.05.97 - Added the function `idd-get-buffer'. -29.03.97 - Fixed the problem with `:keys "\\[idd-help-mouse-drag-and-drop]"' - in the Emacs 19. - Fixed the template commands for the Emacs 19. - Added the commands `tmpl-util-indent-region' and - `tmpl-util-indent-buffer', which are useful utilities in - template files. - Changed frame.html.tmpl and command-description.html.tmpl, so that - they now will be indented after their insertation. -28.03.97 - Fixed the commands `idd-mouse-drag-and-drop-click' and - `idd-mouse-drag-and-drop-press-button-during-move' for the Emacs 19. - Fixed also the mouse keybinding for these commands in the Emacs 19. - Fixed the command `idd-start-mouse-drag-and-drop' for the Emacs 19. - Therefore the internal drag and drop is now working again in the - Emacs 19. - The idd help functions are fixed for the Emacs 19. - Fixed the function `hm--html-is-one-element-tag-p' for the Emacs 19. -26.03.97 - Applied a patch from Michael D. Harnois to fix the documentation. - Fixed a bug in adapt.el. - -- BUILDED the version 5.6 of the package -- -25.03.97 - Fixed a bug in `hm--html-search-place-for-element-in-head'. - Fixed bugs in `hm--html-add-base' and `hm--html-add-isindex'. - Renamed all calls to `hm--html-add-mail-link*' to - `hm--html-add-mail-box-link*' - this fixed bugs in the menus and - keybindings. - Fixed `hm--html-frame-template-file'. - Fixed some keybinding bugs. - -- BUILDED the version 5.5 of the package -- -24.03.97 - Added the function `mouse-event-p' for the Emacs 19 to adapt.el. - The internal-drag-and-drop package uses know the function - `file-remote-p' instead of `ange-ftp-ftp-path'. If this - function is not available in an emacs, the function will be - defined and will use the function `ange-ftp-ftp-path'. - Fixed bugs in `idd-mouse-drag-and-drop-click' for the Emacs 19. -23.03.97 - Fixed some bugs, so that the package is now again loadable - in the Emacs 19 (19.34). - Changed popup-menu-up-p to popup-up-p, menu-event-p to - misc-user-event-p. - Fixed some other XEmacs compilation bugs. - Fixed bugs in `hm--html-add-isindex' and `hm--html-add-base'. - Moved the commands `hm--html-add-server-side-include-file', - `hm--html-add-server-side-include-command' and - `hm--html-add-server-side-include-command-with-isindex-parameter' - to hm--html-not-standard.el. - Fixed a bug in `hm--html-add-document-division-to-region'. - Deleted some obsolete stuff in `hm--html-add-link'. - Fixed bugs in `hm--html-add-basefont', `hm--html-add-mail-box-link', - `hm--html-add-mail-box-link-to-region', `idd-list-1-subset-of-list-2', - `idd-same-elements-p', `idd-start-mouse-drag-and-drop', - `idd-mouse-drag-and-drop-click', `idd-if-minor-mode-p', - `idd-if-modifiers-p' and `tmpl-read-template-filename'. -22.03.97 - Fixed some documentation bugs in tmpl-minor-mode.el. - Changed the key bindings in the tmpl-minor-mode. They are now - using all the prefix C-c C-c. - Fixed some documentation bugs in internal-drag-and-drop.el. - Added a package documentation as Texinfo file. It documents also - the included packages for internal drag and drop and for - templates. - -- BUILDED the version 5.4 of the package -- -18.03.97 - Applied a patch from Martin Buchholz <mrb@Eng.Sun.COM>, - to fix some spelling errors. - Changed the value of the variable `tmpl-sign' to \000. -25.02.97 - Fixed two bugs, which occured during loading the mode - after the psgml-html-mode. - In the minor mode, the HM--HTML menu will now be added before - the HTML menu. - Due to a patch of psgm-html.el it is now possible to call the minor - mode from a hook variable in the html-mode and the html3-mode. - -- BUILDED the version 5.3 of the package -- -22.02.97 - Fixed 'hm--html-add-strikethru-to-region'. - Changed `hm--html-view-www-package-docu' for the new location - of the package documentation. - Moved all functions, which added obsolete or non HTML 3.2 elements, - to hm--html-not-standard.el. This file is not used by default. - Therefore this mode fulfils now the whole HTML 3.2 standard! - Added keybindings for new html functions. - Changed some old keybindings. - Moved the menu items for inserting HTML comments to the - "Formating Paragraphs" menu. - Fixed a bug in the function `hm--html-add-meta'. - The variable `indent-line-function' is now local in all - hm--html-mode buffers. This fixed the bug, that the hm--html-mode - had set the indentation function to `hm--html-indent-line' global. - Added the html elements STYLE and SCRIPT. - -- 23:20: My doughter Sarah Madeleine is born! -- -18.02.97 - Fixed a compilation bug. - -- BUILDED the version 5.2 of the package -- -17.02.97 - Changed the function `hm--html-read-alignment' according to the - HTML version 3.2. - Added a more general command for adding images. - Added the HTML elements MAP and AREA. - Added a command for adding an image and a map. -15.02.97 - Fixed some bugs in the insert full frame stuff. - Added the DOCTYPE to the full frame stuff. - Added the HTML elements DIV, FONT and BASEFONT. -14.02.97 - Added the HTML elements DOCTYPE, ISINDEX, BASE, META. - Added all one tag elements used in HTML 3.2 to the list - `hm--html-tag-name-alist' to make the indentation happy. - Fixed a bug in the indentation after one tag elements. -12.02.97 - Renamed command-description.tmpl to command-description.html.tmpl. - The indentation stuff can now be disabled by setting the - variable `hm--html-disable-indentation' to t. - Fixed the long annoying bug, that the directory in the pop up - frame for selecting the template file was wrong in most cases. - -- BUILDED the version 5.1 of the package -- -11.02.97: - Changed the whole indentation stuff. It is now all working - - with the exceptions, that the list `hm--html-tag-name-alist' - contains not all "one element tags", and also text between - pre tags will be intended. -09.02.97: - Fixed a bug in the template stuff. - Moved the whole indentation stuff to the new file - hm--html-indentation.el. -06.02.97: - The indentation of two tag elements are now working. -03.02.97: - It is now possible to use an own site specific configuration file. - For that the variable `hm--html-site-config-file' was added. - Added some code from Bob Weiner to modify the syntax table, - change the comment start and end and the sentence end. - Started to add the indentation. - The indentation in comments is now working. -01.02.97: - In the source and destination description of a drag and drop - are now used marks instead of points. This fixed bugs, which - occured, if the source and the destination buffer are the same. - A help feature was implemented. -30.01.97: - Added some new features to the drag and drop interface, like - the macro `idd-start-mouse-drag-and-drop', which is usefull to - define action functions. The event is now also stored in the source - and destination description. - Changed the order of the arguments destination and source - to source and destination. - Changed the name of all idd specification type functions - to idd-if-*-p. -27.01.97: - Changed the source and destination in the drag and drop functions, - so that they are now used in a standard way. - Added the command `idd-start-mouse-drag-and-drop', which could - be used to start a drag and drop command without a button-press-event. - Used the command `idd-start-mouse-drag-and-drop' in the hm--html - menus. -26.01.97: - Renamed the function `tmpl-insert-template-file' to - `tmpl-insert-template-file-from-fixed-dirs'. - Added a function `tmpl-insert-template-file', which doesn't use - a file filter and a list of directories. - Changed both functions, so that they now use the variables - `tmpl-template-dir-list', `tmpl-automatic-expand', - `tmpl-filter-regexp' and `tmpl-history-variable-name' - instead of optional arguments. - Changed the name of the file frame.html to frame.html.tmpl. This is - usefull, if you've templates for multiple modes in one directory and - you want to use the new filter feature of the command - `tmpl-insert-template-file-from-fixed-dirs'. - Changed the function `hm--html-insert-template' and added - the function `hm--html-insert-template-from-fixed-dirs'. They are - using the functions `tmpl-insert-template-file' and - `tmpl-insert-template-file-from-fixed-dirs'. - The function `hm--html-insert-created-comment' is no longer - called in this functions. If needed, then this function must be - inserted in the template file. This is done now with the file - frame.html.tmpl. -22.01.97: - Changed the function `tmpl-insert-template-file': - It is now possible to use a file filter and a list - of directories, in which template files could be. -19.01.97: - Applied a patch from Andreas Ernst to fix bugs in the table stuff. - Added a '(let ((case-fold-seach t))' in all functions of hm--html.el, - which are call a search function with lowercase letters. - The functions to insert ordered, normal and dired list are fixed to - use <LI> </LI> tags instead of only <LI>. - Fixed a keybind bug for C-c C-s i. - Fixed a wrong call to `hm--html-add-only-description-entry'. - Fixed a bug in the argument list of hm--html-add-tags-to-region. - Fixed a bug in `hm--html-add-tags-to-region', which was caused by the - indentation. - Fixed a bug in `hm--html-add-relative-link-to-region' and - `hm--html-add-relative-link'. - Replaced `hm--html-file-relative-name' with `file-relative-name'. - Changed the font-lock stuff. It uses now the property list of - `font-lock-defaults' and the three keyword lists - 'html-font-lock-keywords', `html-font-lock-keywords-1' and - `html-font-lock-keywords-2'. - Fixed a bug in the drag and drop variables. - Changed the drag and drop command, so that it could be called - also from a menu. - Added the drag and drop command to the pop up menus. -15.08.96: - The items of the menu "Set popup menu" are now radio items. - -- BUILDED the version 5.0 of the package -- -03.08.96: - Applied a patch from Jerry G. DeLapp <jgd@lanl.gov> to - `html-font-lock-keywords'. - Added the param tag for the applet element. - Added the functions `hm--html-add-relative-link' and - `hm--html-add-relative-link-to-region', which have better - support for relative links than the functions for inserting - general links. - Added functions to insert the center element. - Added functions to insert the small and big elements. -31.07.96: - Added the applet element. - The tags for menu items and description entries and titles - are now inserted with a start and a end tag. - Fixed some keybinding bugs. - Added the function 'hm--html-indent-region'. At the moment - the indentation works only in the minor mode and if the major - mode provides an indentation function, like it is in the psgml - mode. -20.07.96: - Fixed bugs in the popup and pulldown menu handling in the Emacs 19. - Speeded up the first popup of some of the menus in the Emacs 19. - The keybinding for the popup menu in the Emacs 19 has changed to - C-down-mouse-3. The variables - `hm--html-emacs19-popup-noregion-menu-button' and - `hm--html-emacs19-popup-region-menu-button' should be used in the Emacs - 19 to change the keybindings. They are defined in hm--html-keys.el. - Fixed a bug in the font-lock stuff for the Emacs 19. - The popup menus of the minor mode worked now also in the Emacs 19. - The pulldown menu of the minor mode worked now also in the Emacs 19. - The name of the pulldown menu can now be changed with the variable - `hm--html-mode-pulldown-menu-name'. - All settings in hm--configuration.el are now made with `defvar'. - So it's easier now to overwrite this values in other files. - All old lisp stuff deleted. - Added Keybindings for the commands in the include and the forms - submenu. - Fixed a bug in the command `hm--html-smart-less-than'. -19.07.96: - Changed the functions hm--popup-html* to hm--html-popup*. - The Emacs 19 popup menus are now realized as direct bindings of - the menu maps to the mouse button. This fixed a bug. -18.07.96: - The popup menus in the Emacs 19 are now much faster, because - the keymaps are only computed once from the XEmacs menu - description instead of each time. - Fixed a bug in the keybinding stuff for the Emacs 19. -16.07.96: - Added the function `hm--html-smart-ampersand'. - Added the minor modes `hm--html-minor-mode' and - `hm--html-minor-region-mode'. They should provide - the menus and commands of this package for the - psgml-html-mode. - The prefix key of the minor and of the major modes - could now be changed with `hm--html-minor-mode-prefix-key' - and `hm--html-mode-prefix-key'. -14.07.96: - Ported the internal drag and drop interface for the Emacs 19. - Changed the Keybinding for the drag and drop function to - M-C-button1 (M-C-mouse-1). - Changed hm--install-html-menu for the Emacs 19. It uses now the - package easy-menu to install the pulldown menu. This fixes the - bug, that the HTML pulldown menu is a global menu. -13.07.96: - Updated the file header comments a little bit. -10.07.96: - Added the file hm--html-mode.el instead of html-mode.el. - Changed the mode name to hm--html-mode. - Fixed a bug in the function `hm--html-generate-help-buffer-faces', - which occurs, if a color is set to nil. - The font-lock mode is no longer called direct from the - hm--html-mode. - The file html-mode.el should no longer be needed for this mode. -09.07.96: - Added the functions `hm--html-add-normal-link', - `hm--html-add-address', `html-add-list-or-menu-item`, - `hm--html-add-list', `hm--html-add-menu', - `hm--html-add-description-list', `hm--html-add-description-entry', - `hm--html-add-plaintext', `hm--html-add-blockquote', - `hm--html-add-listing', `hm--html-add-fixed', - `hm--html-add-emphasized', `hm--html-add-strong', - `hm--html-add-keyboard', `hm--html-add-variable', - `hm--html-add-sample', `hm--html-add-citation', - `hm--html-quotify-hrefs' to the file hm--html.el. Similar - functions are defined in the past in the file html-mode without - the prefix hm--. - Removed Marc's menu. Maybe a simple flat menu will be added - in the future, similar to Marc's menu. - Removed the old keymaps from the configuration file. - Moved the provide forms to the end of the files. -07.07.96: - Added the drag and drop interface. With that it is possible - to insert links and images by just Meta Button 1 clicking - on its source and destination. -01.03.96: - Added the function `tmpl-insert-template-file'. -18.02.96: - -- BUILDED the version 4.16 of the package -- -17.02.96: - Added the mailto link. -03.02.96: - Fixed the 'void function font-lock-hack-keywords' bug. -15.10.95: - Added support for the swedish ISO-Characters aring and Aring. - It was a patch from Ola Stromfors <Ola.Stromfors@linkoping.trab.se>. -17.09.95: - It is now possible to disable the keybindings for the ISO Latin 1 - character entities. - -- BUILDED the version 4.15 of the package -- -05.09.95: - Fixed a bug in the changed comment functions. - Fixed a description typo. - -- BUILDED the version 4.14 of the package -- -24.08.95: - Fixed the new keybindings for the Emacs 19. -22.08.95: - Added smart functions for inserting <,> or their html entities. - Added the function 'hm--html-send-buffer-to-netscape' to support - netscape. - Added a menu item to view the WWW page of the package. - -- BUILDED the version 4.13 of the package -- -18.08.95: - Fixed the Makefile to include also the file hm--html-keys.el. - Fixed the 'missing util-return-end-of-line' bug. - Fixed the read-file-name bug in the Emacs 19. - Fixed a bug in the changed comment functions. -29.07.95: - Fixed some bugs in the table code. - New, better and more key bindings. - Added functions to insert ISO 8851-1 characters as html entities. - Thanks to Berthold Crysmann <crysmann@rrz.uni-hamburg.de> for - providing the code for it. - -- BUILDED the version 4.12 of the package -- -12.05.95: - Changed the color handling functions, so that the font-lock colors - are now longer overwritten by this mode. - Added functions to insert the paragraph element with start and - end tag. - Applied a patch from Noriaki Seki <kerolyn@rst.fujixerox.co.jp>, - which fixes a bug in searching the string </head>. - Fixed a typo in hm--html-load-config-files (Thanks to - "Valeriy E. Ushakov" <uwe@snark.niif.spb.su>). - Added a command to insert a <LINK> element as suggested by - ssd@tad.eds.com (Sean Dowd). - Fixed a typo in hm--html-set-point-for-signature. - Added a new template file: frame.tmpl. - Changed the name of command-description-template-2.html to - command-description.tmpl and deleted the file - command-description-template.html. - Added the new menu item: "Frame Template" as suggested by - ssd@tad.eds.com (Sean Dowd). - Fixed a bug hm--html-remove-numeric-names (Thanks to - D-P Deng <deng@owl.rhic.bnl.gov>). - Added a command to submit bug reports (suggested by - D-P Deng <deng@owl.rhic.bnl.gov>). - Changed `(defconst html-font-lock-keywords' to - `(defvar html-font-lock-keywords' (suggested by - rickb@isdn-szerelem.mti.sgi.com (Rick Braumoeller). - Fixed the table functions. - -- BUILDED the version 4.11 of the package -- -02.03.95: - -- BUILDED the version 4.8 of the package -- - Included the changes from the XEmacs 19.12 Beta 26. - Added Support for the finder package. - -- BUILDED the version 4.9 of the package -- - Fixed some minor documentation bugs. - -- BUILDED the version 4.10 of the package -- -30.03.95: - Changed all calls of `concat', so that no longer numbers are - given as arguments to concat. - Removed the file .hm--html-configuration.el from the distribution. - This does not mean, that the file is no longer supported. The - file was only an example and the user has to build his own one. - The example is now given in the README file. - Fixed a bug in the region minor mode. - -14.01.95: - -- BUILDED the version 4.7 of the package -- -12.01.95: - Changed the behaviour of the function `hm--html-add-table'. -06.01.95: - Added the variable `hm--html-user-config-file', as onother way - to specify the user config file. - -- BUILDED the version 4.6 of the package -- -04.01.95: - Added functions to insert tables. - -- BUILDED the version 4.5 of the package -- -03.01.95: - Faces are only modified, if they don't exist (I hope :-). - html-view.el works now with Mosaic 2.4. - `hm--html-add-full-html-frame' now tries only to insert a signature, - if `hm--html-signature-file' is non-nil. - Added the functions: - `hm--html-add-strikethru' and `hm--html-add-strikethru-to-region', - `hm--html-add-superscript' and `hm--html-add-superscript-to-region', - `hm--html-add-subscript' and `hm--html-add-subscript-to-region', - `hm--html-add-command' and `hm--html-add-command-to-region', - `hm--html-add-argument' and `hm--html-add-argument-to-region', - `hm--html-add-quote' and `hm--html-add-quote-to-region', - `hm--html-add-person' and `hm--html-add-person-to-region', - `hm--html-add-acronym' and `hm--html-add-acronym-to-region', - `hm--html-add-abbrevation' and `hm--html-add-abbrevation-to-region', - `hm--html-add-literature' and `hm--html-add-literature-to-region', - `hm--html-add-abstract' and `hm--html-add-abstract-to-region', - `hm--html-add-footnote' and `hm--html-add-footnote-to-region', - `hm--html-add-margin' and `hm--html-add-margin-to-region', - `hm--html-add-author' and `hm--html-add-author-to-region', - `hm--html-add-publication' and `hm--html-add-publication-to-region', - `hm--html-add-editor' and `hm--html-add-editor-to-region', - `hm--html-add-credits' and `hm--html-add-credits-to-region', - `hm--html-add-copyright' and `hm--html-add-copyright-to-region', - `hm--html-add-isbn' and `hm--html-add-isbn-to-region', - `hm--html-form-add-input-integer', - `hm--html-form-add-input-float', - `hm--html-form-add-input-date', - `hm--html-form-add-input-url', - `hm--html-form-add-input-scribble', - `hm--html-form-add-input-audio'. -15.03.94: - -- ANNOUNCEMENT of version 4.0 of the package -- - Added the missing file hm--date.el to the package. - Changed the line ` (let ((config-file (format "/tmp/xmosaic.%d"' - to `(let ((config-file (format "/tmp/Mosaic.%d"' in the file - html-mode.el for the new Mosaic. -03.03.94: - Deleted the wrong "external viewer stuff" for the include images. -17.02.94: - Fixed a bug in the function `hm--html-insert-changed-comment'. - -- ANNOUNCEMENT of version 3.9 of the package -- -14.02.94: - Changed the function adapt-emacsp to adapt-emacs19p. - -- ANNOUNCEMENT of version 3.8 of the package -- -13.02.94: - One can now set the font lock color also in the GNU Emacs 19. - Deleted the highlighting stuff. -01.02.94: - Fixed a lot of spelling errors by jml. -18.01.94: - -- ANNOUNCEMENT of version 3.7 of the package -- -11.01.94: - Fixed a bug in html-view.el. -10.01.94: - Fixed a bug in the function read-number. - The automatic switch between region and noregion commands is now - working also in the GNU Emacs 19. - Fixed a bug in the region popup menu fo novice users. - The font-lock-mode (except of the use of colors) is now working in - then GNU Emacs 19. - -- ANNOUNCEMENT of version 3.6 of the package -- -09.01.94: - Added the highlighting feature of the examples for the GNU Emacs 19. -07.01.94: - The pulldown menu and the popup menus are now working in the - GNU Emacs 19. - -- ANNOUNCEMENT of version 3.5 of the package -- -29.12.93: - Added a function to insert the image input field. - Added a function to insert the form tags to an active region. - Changed the function hm--html-select-directory. - Added a function to remove numeric names. - The variable hm--html-delete-wrong-path-prefix can now be used as - string and as list of strings. Therfore it is now possible to - specify more than one path prefixes, which should be removed. - Changed the pulldown menu. - The package can now be loaded in the GNU Emacs 19. But the menus - doesn't work correct and the functions are not tested. -28.12.93: - Added a function to expand templates (Look at templates.el). - Whitespaces are now allowed between the closing bracket of the date - and the tag </TITLE>, if you want to update the date of the document. - Fixed the wrong use of the html command <inc srvurl "|command">. - Fixed a little Bug in the function, which includes the tags for a form. - The config files are now searched on standard places, if no environment - variables are specified. - Changed the file html-view.el for the use of the Mosaic-2.1. It uses - now also the variable html-sigusr1-signal-value instead of a hard coded - value for the SIGUSR1 value. - Added a function to insert the isindex input field in a form tag. -15.12.93: - -- ANNOUNCEMENT of version 3.0 of the package -- - -11.12.93: - New functions, to insert the tags <BR>, <HR> and <P> (<P> without a - leading Blank). - Fixed a Bug in the function hm--html-add-description-list-to-region - (<DT> instead of </DT>). - Added the function hm--html-add-normal-link-to-region to fix the - problem with inactivating the region during the link generation. - Added functions to insert direct links to wais server - (HREF="wais://...). - Changed the wrong functionnamess html-add-definion-to-region and - html-add-definion in the menus to hm--html-add-definion-to-region - and hm--html-add-definion (the old symbols were void). - Added function to insert middle aligned inline images. - Added the 'ALT'- attribute to the 'add-image'- functions. - Changed the submenu "Inligned images". - Added support for the server side include directives. - Added functions to insert "created" and "changed" comments. - Added function to update the date in the title. - Added support for forms. -27.10.93: - Setting of hm--html-font-lock-color in one of the files - .hm--html-configuration.el or hm--html-configuration.el to determine - the color of the html-tags works now correct. -24.10.93: - -- ANNOUNCEMENT of version 2.0 of the package -- - The file hm--date.el is now also in this package. - Deleted the numeric anchor name stuff altogether. Therefore the - package can now use the version 2.1 of Marc Andreessens html-mode.el - instead of the version 2.0. - Added some keytable entrys. - Added the minor mode html-region-mode, which is active, if a region - is active. The minor-mode has its own keytable. That is why it is now - possible to use the same key sequences with different two functions, - one for adding something to an active region and one for adding some- - thing without a region. - All keys, without the keys which are defined by Marc Andreessen in - his file html-mode.el, are now defined in the general configuration - file hm--html-configuration.el. -25.09.93: - Fixed the wrong string "adress". - Added functions and menu items to insert html, head, and body elements - and to insert a complete html frame with the above elements, the title - the header and the signature. - The functions, which adds the header and the title at the same time - are now only using the header size 1. - Added functions for inserting underline and definition styles. - Changed the menu "Formated" according to the HTML quick reference - from Michael Grobe. - Changed the menu item name "Fixed" to "Typewriter". - Added functions to insert directory lists. - Changed the names of menu items in the submenu "Structure" according - to the HTML quick reference from Michael Grobe. -23.09.93: - Changed the functions to add the signature and the title. - This functions uses now the new tags <html>, </html>, - <head>, </body> and <isindex> to places the signature and - the title in a html-file. - Fixed also some minor bugs; - - -Local Variables: -mode: text -minor-mode: auto-fill-mode -fill-prefix: " " -End: \ No newline at end of file
--- a/lisp/hm--html-menus/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,286 +0,0 @@ -This README file describes the emacs lisp package hm--html-menus-5.8. - -The package provides functions and various popup and pulldown menus -for a html mode called hm--html-mode, a mode for writing html pages. -It provides also a minor mode (hm--html-minor-mode), which can be used -together with another html major mode, like the psgml-html mode in the -XEmacs 19.15. - -It has an interface to view the html documents in a W3 browser with -Netscape, the w3-package from William M. Perry and Mosaic with the -file html-view.el from Ron Tapia. It provides also a drag and drop -interface, which makes it very easy to insert links or images, by just -clicking on them. - -Look at the file NEWS, to see what is new in this release. Some -of the major changes are also listed in the ANNOUNCEMENT file. - -You should (but don't need) also get the w3 package from: - - cs.indiana.edu:/pub/elisp/w3/w3.tar.z - -which provides an world wide web browser mode for the xemacs, emacs -and epoch. - - -This package is tested with the xemacs 19.15 on Suns with SunOS 5.5 -and on PC's with linux. But it should work also on other (possibly -only UNIX ?) platforms. - -Read the file README-EMACS-19, if you want to use this package with -GNU Emacs 19. - -Thanks to Richard Stallman, who helped me to port this package to the -Emacs 19, thanks to John Ladwig, who corrected a lot of the text and -comments in this package and thanks to Michael D. Harnois, who -corrected the Texinfo documentation and to all the other people like -Jerry G. DeLapp, Andreas Ernst, Bob Weiner, Luca Pisati, Guylaine -Prat, Gary D. Foster, Martin Buchholz, Ola Stromfors, Berthold -Crysmann, Noriaki Seki, Valeriy E. Ushakov, D-P Deng, Rick -Braumoeller, Sean Dowd and so on, who provided code, ideas, bug fixes -or bug reports for this package. - - -The package consists of the following files: - -README : this file; -README-EMACS-19 : only for the GNU Emacs 19 user; -ANNOUNCEMENT : Text of the announcement of this package; -LSM : Entry for the Linux Software Map; -NEWS : Change logfile; -adapt.el : provides functions to use this package - with the GNU Emacs 19 -hm--html.el : provides functions to write html pages; - in this file are all commands defined, - which inserts html elements and entities; -hm--html-indentation.el : provides the indentation stuff; -hm--html-keys.el : provides the keybindings; -hm--html-menu.el : provides the menus; -hm--html-mode.el : provides the functions for the definition - of the hm--html-mode; this is now the - main file of the package; -hm--html-not-standard.el : provides functions to insert some - non standard html elements; - this file is not evaluated by default; -hm--html-configuration.el : configuration file for the html mode; - choose this as system configuration file; -hm--html-drag-and-drop.el : defines the HTML- specific functions - for the drag and drop interface; -hm--date.el : defines the function hm--date, which - returns the date in the format - "day-month-year" like "30-Jun-1993". -html-view.el : Ron Tapia's html-view.el to view html-pages - in the Xmosaic; it is patched for the use - with the xemacs; -internal-drag-and-drop.el : provides the general (html-mode - independend functions) of the drag and - drop interface; -templates.doc : describes the syntax of the templates - provided in the file tmpl-minor-mode.el -tmpl-minor-mode.el : provides functions for the tmpl-minor-mode; - with this mode you can expand templates, - which are described in the file - templates-syntax.doc (look at the files - command-description.html.tmpl and - frame.html.tmpl for examples); - templates can be expanded automatically, if - you include a file with templates via the - html pulldown menu item "Templates ..." - or with the item "Templates (fixed dirs)..."; -command-description.html.tmpl : Templatefile for the use with the - tmpl-minor-mode; -frame.html.tmpl : Templatefile, provides a simple frame; -drop : xbm file with the drag and drop mouse pointer -dropmsk : xbm file with mask for the d&d mouse pointer -doc/hm--html-mode.texinfo : Package documentation in the Texinfo format; -doc/umlaute.texinfo : Texinfo include file for german vowel - mutation (deutsche Umlaute); - - - - -INSTALLATION: -============= - -Note: In this version the setting of the environment variables -HTML_CONFIG_FILE and HTML_USER_CONFIG_FILE are no longer necessary, -if you put the user configuration file in the home directory and -the system configuration file in one of the load path directories -of your XEmacs or Emacs 19. - -1. Put all the *.el files in one of your xemacs (or emacs) lisp load - directories (i.e. lisp/packages). - -2. For XEmacs only: Put the files drop and dropmask in the - directory specified by the lisp variable `idd-data-directory'. - By default this directory is <prefix>/lib/xemacs-<version>/etc/idd. - (eg: if you've installed the Xemacs 19.15 in /usr/local, it is - /usr/local/xemacs/lib/xemacs-19.15/etc/idd). - If you'd like to put the files in another directory, then you must - set the variable `idd-data-directory' to this directory (eg: - (setq idd-data-directory "/usr/local/data") - -3. Put the following in your .emacs (or default.el or site-init.el): - - (autoload 'hm--html-mode "hm--html-mode" "HTML major mode." t) - (autoload 'hm--html-minor-mode "hm--html-mode" "HTML minor mode." t) - (or (assoc "\\.html$" auto-mode-alist) - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist))) - - (autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" - "Expand all templates in the current buffer." t) - - (autoload 'html-view-start-mosaic "html-view" "Start Xmosaic." t) - (autoload 'html-view-view-buffer - "html-view" - "View the current buffer in Xmosaic." - t) - (autoload 'html-view-view-file - "html-view" - "View a file in Xmosaic." - t) - (autoload 'html-view-goto-url - "html-view" - "Goto url in Xmosaic." - t) - (autoload 'html-view-get-display - "html-view" - "Get the display for Xmosaic (i.e. hostxy:0.0)." - t) - (autoload 'w3-preview-this-buffer "w3" "WWW Previewer" t) - (autoload 'w3 "w3" "WWW Browser" t) - (autoload 'w3-open-local "w3" "Open local file for WWW browsing" t) - (autoload 'w3-fetch "w3" "Open remote file for WWW browsing" t) - (autoload 'w3-use-hotlist "w3" "Use shortcuts to view WWW docs" t) - - The above lines assume that you have not installed already another - html mode. If this isn't true, then you should use the following - - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist)) - - instead of - - (or (assoc "\\.html$" auto-mode-alist) - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist))) - - It could also be, that you've already the autoload lines for - the w3 package in your emacs. - - If you want to use this the hm--html-minor-mode together - with the psgml-html modes, then you should add the following - line (works only in XEmacs version >= 19.15 and != 20.0) - (add-hook 'html-mode-hook 'hm--html-minor-mode) - -4. Set (if you want) the environment variable HTML_CONFIG_FILE - to the html system configuration file i.e.: - setenv HTML_CONFIG_FILE /usr/xemacs/lisp/hm--html-configuration.el - -5. Set (if you want) the environment variable HTML_USER_CONFIG_FILE to - the html user configuration file i.e.: - setenv HTML_USER_CONFIG_FILE ~/.hm--html-configuration.el - And put the file .hm--html-configuration.el in your Home directory. - An example for this user specific file is given below. - -6. Check the files hm--html-configuration.el and - .hm--html-configuration.el whether all variables are set suitable for - you and your site or not. You can make changes in both of these files - and you can also create a site specific configuration file, called - hm--html-site-config-file.el and specified by the lisp variable - hm--html-site-config-file or the environment variable - HTML_SITE_CONFIG_FILE, and put your site specific settings in this - file. A site specific configuration file is useful, if you're a - system administrator and want to make site specific settings - without changing a file of this package or use the normal emacs - configuration files. - Note that .hm--html-configuration.el precedes the settings in - hm--html-site-config-file.el, which precedes the settings in - hm--html-configuration.el (user specific configuration overwrites - site specific configuration and site specific configuration - overwrites the settings made by the package). - - Look at first at the following variables: - - hm--html-signaturefile - hm--html-username - hm--html-template-dir - hm--html-favorite-http-server-host-name - html-document-previewer - html-view-mosaic-command - w3-default-homepage - -7. If you want to use templatefiles, you should put these files - in the directory to which `hm--html-template-dir' points. - You can use the file command-description.html.tmpl as - an example. - -8. If you don't want to use the feature of adding html comments - about the creation date and author and with a change log, then - you should set the following three variables to nil: - hm--html-automatic-changed-comment - hm--html-automatic-created-comment - -9. If you don't want to set a date in the title line, than you should - set the following to nil: - hm--html-automatic-new-date - -The following is an example for a user specific configuration file -called .hm--html-configuration.el. You should put such a file in your -home directory and put all the variable settings in it, which are user -specific. - ----- BEGIN of .hm--html-configuration.el ---- -;;; Private html configuration file - -;; Signature file -(setq hm--html-signature-file - "http://www.tnt.uni-hannover.de:80/data/info/www/tnt/org/tnt/whois/wissmit/muenkel.html") - -;; Username (Only necessary if it differs from the passwd entry) -(setq hm--html-username "Heiko Münkel") - - -;; X Window System display for the html-view -(setq html-view-display "daedalus:0.0") - - -;; Use the expert menus? -(setq hm--html-expert t) - - -;; Delete the automounter path prefix /tmp_mount -(setq hm--html-delete-wrong-path-prefix "/tmp_mount") - - -;;; -; -; W3 - -;; Default Home Page for w3-mode in lemacs or GNU Emacs -(setq w3-default-homepage "file:/home/muenkel/data/docs/www/home.html") ----- END of .hm--html-configuration.el ---- - - -Every hm--*.el file has a description and installation part. Look at first -at these parts, if you have any questions. - -Look at first at the configuration files, if you have problems with -this package! - -You should also look at the Texinfo documentation of this package. - -There is a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html - - -Please send any bug reports, fixes or comments to - muenkel@daedalus.tnt.uni-hannover.de - - -I hope these files will be useful, - -Heiko - -
--- a/lisp/hm--html-menus/adapt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,490 +0,0 @@ -;;; $Id: adapt.el,v 1.5 1997/07/26 22:09:44 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; General functions to port XEmacs functions to GNU Emacs 19. -;;; -;;; Installation: -;;; -;;; Put this file in one of your lisp load directories. -;;; - - -(defun adapt-xemacsp () - "Returns non nil if the editor is the XEmacs." - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - - -(defun adapt-lemacsp () - "Returns non nil if the editor is the XEmacs. -Old version, use `adapt-xemacsp' instead of this." - (or (string-match "Lucid" emacs-version) - (string-match "XEmacs" emacs-version))) - - -(defun adapt-emacs19p () - "Returns non nil if the editor is the GNU Emacs 19." - (and - (not (adapt-xemacsp)) - (string= (substring emacs-version 0 2) "19"))) - -;;; Functions, which don't exist in both emacs versions - -(defun adapt-region-active-p () - "Returns t, if a region is active." - (if (adapt-xemacsp) - (mark) - mark-active)) - -(if (not (fboundp 'file-remote-p)) - (defun file-remote-p (file) - "Test wether file resides on the local system. -The special value 'unknown is returned if no remote file acess package -has been loaded." - (if (not (featurep 'ange-ftp)) - (require 'ange-ftp)) - (if (not (fboundp 'ange-ftp-ftp-p)) - nil ; better than nothing, if no ange-ftp-ftp-p exists - (ange-ftp-ftp-path file)))) - - -;;; Functions, which don't exist in the Emacs 19 -(if (adapt-emacs19p) - (progn - (load-library "lucid") - - (load-library "lmenu") - - (if window-system - (require 'font-lock) - ) - - (make-face 'font-lock-comment-face) - - (defun read-number (prompt &optional integers-only) - "Reads a number from the minibuffer." - (interactive) - (let ((error t) - (number nil)) - (if integers-only - (while error - (let ((input-string (read-string prompt))) - (setq number (if (string= "" input-string) - nil - (read input-string))) - (if (integerp number) - (setq error nil)))) - (while error - (let ((input-string (read-string prompt))) - (setq number (if (string= "" input-string) - nil - (read input-string))) - (if (numberp number) - (setq error nil))))) - number)) - - (defvar original-read-string-function nil - "Points to the original Emacs 19 function read-string.") - - (if (not original-read-string-function) - (fset 'original-read-string-function - (symbol-function 'read-string))) - - (defun read-string (prompt &optional initial-contents history) - "Return a string from the minibuffer, prompting with string PROMPT. -If non-nil, optional second arg INITIAL-CONTENTS is a string to insert -in the minibuffer before reading. -Third arg HISTORY, if non-nil, specifies a history list." - (read-from-minibuffer prompt initial-contents nil nil history)) - - (defun make-extent (beg end &optional buffer) - (make-overlay beg end buffer)) - - (defun set-extent-property (extent prop value) - (if (eq prop 'duplicable) - (cond ((and value (not (overlay-get extent prop))) - ;; If becoming duplicable, - ;; copy all overlay props to text props. - (add-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent))) - ;; If becoming no longer duplicable, remove these text props. - ((and (not value) (overlay-get extent prop)) - (remove-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent)))) - ;; If extent is already duplicable, put this property - ;; on the text as well as on the overlay. - (if (overlay-get extent 'duplicable) - (put-text-property (overlay-start extent) - (overlay-end extent) - prop value (overlay-buffer extent)))) - (overlay-put extent prop value)) - - (defun set-extent-face (extent face) - (set-extent-property extent 'face face)) - - (defun delete-extent (extent) - (set-extent-property extent 'duplicable nil) - (delete-overlay extent)) - -; (defun make-extent (from to &optional buffer) -; "Make extent for range [FROM, TO) in BUFFER -- BUFFER defaults to -;current buffer. Insertions at point TO will be outside of the extent; -;insertions at FROM will be inside the extent (and the extent will grow.). -;This is only a simple emulation of the Lucid Emacs extents !" -; (list 'extent from to buffer)) -; -; (defun set-extent-face (extent face) -; "Make the given EXTENT have the graphic attributes specified by FACE. -;This is only a simple emulation of the Lucid Emacs extents !" -; (put-text-property (car (cdr extent)) -; (car (cdr (cdr extent))) -; 'face -; face -; (car (cdr (cdr (cdr extent)))))) -; -; (defun delete-extent (extent_obj) -; "Remove EXTENT from its buffer; this does not modify the buffer's text, -;only its display properties. -;This is only a simple emulation of the Lucid Emacs extents !" -; (remove-text-properties (car (cdr extent_obj)) -; (car (cdr (cdr extent_obj))) -; (list 'face nil) -; (car (cdr (cdr (cdr extent_obj)))))) -; - - (if (not (fboundp 'emacs-pid)) - (defun emacs-pid () - "Return the process ID of Emacs, as an integer. -This is a dummy function for old versions of the Emacs 19. -You should install a new version, which has `emacs-pid' implemented." - 0) - ) - - (if (not (fboundp 'facep)) - (defun facep (object) - "Whether OBJECT is a FACE. -It's only a dummy function in the Emacs 19, which returns always nil." - nil)) - -; (if (not (fboundp 'set-extent-property)) -; (defun set-extent-property (extent property value) -; "Change a property of an extent. -;Only a dummy version in Emacs 19.")) - - (if (not (fboundp 'region-active-p)) - (defun region-active-p () - "Non-nil iff the region is active. -If `zmacs-regions' is true, this is equivalent to `region-exists-p'. -Otherwise, this function always returns false." - (adapt-region-active-p))) - - (if (not (fboundp 'next-command-event)) - (defun next-command-event (&optional event prompt) - "Unlike the XEmacs version it reads the next event, if -it is a command event or not. - -Return the next available \"user\" event. - Pass this object to `dispatch-event' to handle it. - - If EVENT is non-nil, it should be an event object and will be filled in - and returned; otherwise a new event object will be created and returned. - If PROMPT is non-nil, it should be a string and will be displayed in the - echo area while this function is waiting for an event. - - The event returned will be a keyboard, mouse press, or mouse release event. - If there are non-command events available (mouse motion, sub-process output, - etc) then these will be executed (with `dispatch-event') and discarded. This - function is provided as a convenience; it is equivalent to the lisp code - - (while (progn - (next-event event prompt) - (not (or (key-press-event-p event) - (button-press-event-p event) - (button-release-event-p event) - (misc-user-event-p event)))) - (dispatch-event event))" - (message prompt) - (or event - (read-event)))) - - (if (not (fboundp 'button-event-p)) - (defun button-event-p (obj) - "True if OBJ is a button-press or button-release event object." - (and (eventp obj) - (or (eq 'mouse-1 (event-basic-type obj)) - (eq 'mouse-2 (event-basic-type obj)) - (eq 'mouse-3 (event-basic-type obj)) - (eq 'down-mouse-1 (event-basic-type obj)) - (eq 'down-mouse-2 (event-basic-type obj)) - (eq 'down-mouse-3 (event-basic-type obj)) - (eq 'up-mouse-1 (event-basic-type obj)) - (eq 'up-mouse-2 (event-basic-type obj)) - (eq 'up-mouse-3 (event-basic-type obj)) - (eq 'drag-mouse-1 (event-basic-type obj)) - (eq 'drag-mouse-2 (event-basic-type obj)) - (eq 'drag-mouse-3 (event-basic-type obj)) - )))) - - (if (not (fboundp 'button-drag-event-p)) - (defun button-drag-event-p (obj) - "True if OBJ is a mouse-button-drag event object." - (and (button-event-p obj) - (member 'drag (event-modifiers obj))))) - - (if (not (fboundp 'button-press-event-p)) - (defun button-press-event-p (obj) - "True if OBJ is a mouse-button-press event object." - (and (button-event-p obj) - (member 'down (event-modifiers obj))))) - - (if (not (fboundp 'button-release-event-p)) - (defun button-release-event-p (obj) - "True if OBJ is a mouse-button-release event object." - (and (button-event-p obj) - (not (button-press-event-p obj))))) - - (if (not (fboundp 'button-click-event-p)) - (defun button-click-event-p (obj) - "True if OBJ is a click event obkect." - ;; only for the Emacs 19 - ;; doesn't exist and can't (?) exist in the XEmacs - (and (button-event-p obj) - (member 'click (event-modifiers obj))))) - - (if (not (fboundp 'mouse-event-p)) - (defun mouse-event-p (obj) - "True if OBJ is a button-press, button-release, or mouse-motion event object." - (or (button-event-p obj) - (member 'drag (event-modifiers obj))))) - - (if (not (fboundp 'event-window)) - (defun event-window (event) - "Return the window of the given mouse EVENT. -This may be nil if the event occurred in the border or over a toolbar. -The modeline is considered to be in the window it represents. - -If the EVENT is a mouse drag event, then the end event window is returned." - (if (button-drag-event-p event) - (and (listp event) - (third event) - (listp (third event)) - (windowp (car (third event))) - (car (third event))) - (and (eventp event) - (listp event) - (second event) - (listp (second event)) - (windowp (car (second event))) - (car (second event)))))) - -; (listp (cdr event)) -; (listp (car (cdr event))) -; (windowp (car (car (cdr event)))) -; (car (car (cdr event)))))) - - (if (not (fboundp 'event-buffer)) - (defun event-buffer (event) - "Given a mouse-motion, button-press, or button-release event, -return the buffer on which that event occurred. This will be nil for -non-mouse events. If event-over-text-area-p is nil, this will also be nil." - (if (button-event-p event) - (window-buffer (event-window event))))) - - - (if (not (fboundp 'event-closest-point)) - (defun event-closest-point (event) - "Return the character position of the given mouse EVENT. -If the EVENT did not occur over a window or over text, return the -closest point to the location of the EVENT. If the Y pixel position -overlaps a window and the X pixel position is to the left of that -window, the closest point is the beginning of the line containing the -Y position. If the Y pixel position overlaps a window and the X pixel -position is to the right of that window, the closest point is the end -of the line containing the Y position. If the Y pixel position is -above a window, return 0. If it is below a window, return the value -of (window-end). - -If the EVENT is a drag event, the event-end will be used." - (if (button-drag-event-p event) - (posn-point (event-end event)) - (posn-point (event-start event))))) - - (if (not (fboundp 'add-minor-mode)) - (defun add-minor-mode (toggle - name - &optional - keymap - after - toggle-fun) - "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. -TOGGLE is a symbol whose value as a variable specifies whether the -minor mode is active. NAME is the name that should appear in the -modeline (it should be a string beginning with a space). KEYMAP is a -keymap to make active when the minor mode is active. AFTER is the -toggling symbol used for another minor mode. If AFTER is non-nil, -then it is used to position the new mode in the minor-mode alists. - -TOGGLE-FUN is only a dummy variable in the Emacs 19. In the XEmacs -it has the following description: -TOGGLE-FUN specifies an interactive function that is called to toggle -the mode on and off; this affects what happens when button2 is pressed -on the mode, and when button3 is pressed somewhere in the list of -modes. If TOGGLE-FUN is nil and TOGGLE names an interactive function, -TOGGLE is used as the toggle function. - -Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map) - -WARNING: THIS FUNCTION ISN'T READ YET." - (if after - (add-minor-mode-1 toggle name keymap after) - (if (not (assq toggle minor-mode-alist)) - (progn - (setq minor-mode-alist - (cons (list toggle name) - minor-mode-alist)))) - (if (not (assq toggle minor-mode-map-alist)) - (progn - (setq minor-mode-map-alist - (cons (cons toggle keymap) - minor-mode-map-alist)))) - )) - ) - - (if (not (fboundp 'redraw-modeline)) - (defalias 'redraw-modeline 'force-mode-line-update)) - - (if (not (fboundp 'mouse-track)) - (defalias 'mouse-track 'mouse-drag-region)) - - (if (not (fboundp 'windows-of-buffer)) - (defun windows-of-buffer (&optional buffer) - "Returns a list of windows that have BUFFER in them. -If BUFFER is not specified, the current buffer will be used." - (get-buffer-window-list buffer))) - - (if (not (boundp 'help-selects-help-window)) - (defvar help-selects-help-window t - "*If nil, use the \"old Emacs\" behavior for Help buffers. -This just displays the buffer in another window, rather than selecting -the window.")) - - (if (not (fboundp 'with-displaying-help-buffer)) - (defun with-displaying-help-buffer (thunk) - (let ((winconfig (current-window-configuration)) - (was-one-window (one-window-p)) - (help-not-visible - (not (and (windows-of-buffer "*Help*") ;shortcut - (member (selected-frame) - (mapcar 'window-frame - (windows-of-buffer "*Help*"))))))) - (prog1 (with-output-to-temp-buffer "*Help*" - (prog1 (funcall thunk) - (save-excursion - (set-buffer standard-output) - (help-mode)))) - (let ((helpwin (get-buffer-window "*Help*"))) - (if helpwin - (progn - (save-excursion - (set-buffer (window-buffer helpwin)) - ;;If the *Help* buffer is already displayed on this - ;; frame, don't override the previous configuration -; (if help-not-visible -; (set-frame-property -; (selected-frame) -; 'help-window-config winconfig))) - ) - (if help-selects-help-window - (select-window helpwin)) - (cond ((eq helpwin (selected-window)) - (message - (substitute-command-keys - "\\[scroll-up] to scroll the help." - ))) - (was-one-window - (message - (substitute-command-keys - "\\[scroll-other-window] to scroll the help." - ))) - (t - (message - (substitute-command-keys - "\\[scroll-other-window] to scroll the help." - ))))))))))) - - (if (not (fboundp 'set-extent-mouse-face)) - (defun set-extent-mouse-face (extent face) - "Set the face used to highlight EXTENT when the mouse passes over it. -FACE can also be a list of faces, and all faces listed will apply, -with faces earlier in the list taking priority over those later in the -list. - -In the Emacs 19, the argument FACE could not be a list of faces." - (put-text-property (overlay-start extent) - (overlay-end extent) - 'mouse-face face) - )) - - - (if (not (fboundp 'read-directory-name)) - (defalias 'read-directory-name 'read-file-name)) - - (if (not (fboundp 'define-obsolete-function-alias)) - (defsubst define-obsolete-function-alias (oldfun newfun) - "Define OLDFUN as an obsolete alias for function NEWFUN. -This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN -as obsolete." - (define-function oldfun newfun) - (make-obsolete oldfun newfun))) - - (if (not (fboundp 'define-obsolete-variable-alias)) - (defsubst define-obsolete-variable-alias (oldvar newvar) - "Define OLDVAR as an obsolete alias for varction NEWVAR. -This makes referencing or setting OLDVAR equivalent to referencing or -setting NEWVAR and marks OLDVAR as obsolete. - -It is not full implemented in the Emacs 19, because of the lack of -the function defvaralias.y" - ;;(defvaralias oldvar newvar) <- doesn't exist in the Emacs 19.34 - (make-obsolete-variable oldvar newvar))) - - (if (not (fboundp 'defgroup)) - (defmacro defgroup (symbol members doc &rest args) - "Dummy definition. Used, if the custom package isn't installed. -The dummy definition makes nothing, it returns only nil." - nil)) - - (if (not (fboundp 'defcustom)) - (defmacro defcustom (symbol value doc &rest args) - "Simulates the defcustom definition from the custom package. -It calles a `defvar' with the arguments SYMBOL, VALUE and DOC." - `(defvar ,symbol ,value ,doc))) - - - )) - - -(provide 'adapt)
--- a/lisp/hm--html-menus/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'hm--html-menus-autoloads) (error "Already loaded")) - -;;;### (autoloads (hm--html-minor-mode hm--html-mode) "hm--html-mode" "hm--html-menus/hm--html-mode.el") - -(autoload 'hm--html-mode "hm--html-mode" "\ -Major mode for editing HTML hypertext documents. -Special commands:\\{hm--html-mode-map} -Turning on hm--html-mode calls the value of the variable hm--html-mode-hook, -if that value is non-nil." t nil) - -(autoload 'hm--html-minor-mode "hm--html-mode" "\ -Toggle hm--html-minor-mode. -With arg, turn hm--html-minor-mode on iff arg is positive." t nil) - -;;;*** - -;;;### (autoloads (html-view-get-display html-view-goto-url html-view-view-buffer html-view-view-file html-view-start-mosaic) "html-view" "hm--html-menus/html-view.el") - -(autoload 'html-view-start-mosaic "html-view" "\ -Start Mosaic." t nil) - -(autoload 'html-view-view-file "html-view" "\ -View an html file with Mosaic." t nil) - -(autoload 'html-view-view-buffer "html-view" "\ -View html buffer with Mosaic. -If BUFFER-TO-VIEW is nil, then the current buffer is used." t nil) - -(autoload 'html-view-goto-url "html-view" "\ -Goto an URL in Mosaic." t nil) - -(autoload 'html-view-get-display "html-view" "\ -Get the display for Mosaic." t nil) - -;;;*** - -;;;### (autoloads (tmpl-insert-template-file tmpl-insert-template-file-from-fixed-dirs tmpl-expand-templates-in-buffer tmpl-expand-templates-in-region) "tmpl-minor-mode" "hm--html-menus/tmpl-minor-mode.el") - -(autoload 'tmpl-expand-templates-in-region "tmpl-minor-mode" "\ -Expands the templates in the region from BEGIN to END. -If BEGIN and END are nil, then the current region is used." t nil) - -(autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" "\ -Expands all templates in the current buffer." t nil) - -(autoload 'tmpl-insert-template-file-from-fixed-dirs "tmpl-minor-mode" "\ -Inserts a template FILE and expands it, if `tmpl-automatic-expand' is t. -This command tries to read the template file from a list of -predefined directories (look at `tmpl-template-dir-list') and it filters -the contents of these directories with the regular expression -`tmpl-filter-regexp' (look also at this variable). -The command uses a history variable, which could be changed with the -variable `tmpl-history-variable-name'. - -The user of the command is able to change interactively to another -directory by entering at first the string \"Change the directory\". -This may be too difficult for the user. Therefore another command -called `tmpl-insert-template-file' exist, which doesn't use fixed -directories and filters." t nil) - -(autoload 'tmpl-insert-template-file "tmpl-minor-mode" "\ -Inserts a template FILE and expand it, if `tmpl-automatic-expand' is t. -Look also at `tmpl-template-dir-list', to specify a default template directory. -You should also take a look at `tmpl-insert-template-file-from-fixed-dirs' -which has additional advantages (and disadvantages :-). - -ATTENTION: The interface of this function has changed. The old -function had the argument list (&optional TEMPLATE-DIR AUTOMATIC-EXPAND). -The variables `tmpl-template-dir-list' and `tmpl-automatic-expand' must -now be used instead of the args TEMPLATE-DIR and AUTOMATIC-EXPAND." t nil) - -;;;*** - -(provide 'hm--html-menus-autoloads)
--- a/lisp/hm--html-menus/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -(custom-put 'hm--html-links 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-menus 'custom-loads '("hm--html-configuration")) -(custom-put 'mouse 'custom-loads '("internal-drag-and-drop")) -(custom-put 'hm--html-display 'custom-loads '("hm--html-configuration")) -(custom-put 'idd-drag-and-drop 'custom-loads '("internal-drag-and-drop")) -(custom-put 'hypermedia 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-keys 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-indentation 'custom-loads '("hm--html-configuration")) -(custom-put 'data 'custom-loads '("tmpl-minor-mode")) -(custom-put 'hm--html-hooks 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-document-information 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-templates 'custom-loads '("hm--html-configuration")) -(custom-put 'hm--html-files 'custom-loads '("hm--html-configuration")) -(custom-put 'tmpl-minor 'custom-loads '("tmpl-minor-mode"))
--- a/lisp/hm--html-menus/hm--date.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -;;; $Id: hm--date.el,v 1.1.1.1 1996/12/18 22:43:20 steve Exp $ -;;; -;;; Copyright (C) 1993, 1996 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines the function hm--date, which returns the date in the -;;; format "day-month-year" like "30-Jun-1993". -;;; -;;; Installation: -;;; -;;; Put this file in one of your lisp load path directories. -;;; The files which uses this function must only have -;;; following line: -;;; (require 'hm--date) -;;; - - -(provide 'hm--date) - - - -(defun hm--date () - "Returns the current date in the format \"day-month-year\"." - (let* ((time-string (current-time-string)) - (day (substring time-string 8 10)) - (month (substring time-string 4 7)) - (year (substring time-string 20 24))) - (concat day "-" month "-" year)))
--- a/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1040 +0,0 @@ -;;; hm--html-configuration.el - Configurationfile for the html-mode -;;; -;;; $Id: hm--html-configuration.el,v 1.7 1997/07/26 22:09:45 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; This file is for the system wide configuration of the html mode. -;;; User specific configuration should be done in the file -;;; ~/.hm--html-configuration.el, which precedes the settings in -;;; this file. -;;; All settings in this file are done with defvar's, therefore -;;; you could overwrite them also with the function setq in your -;;; .emacs or default.el and so on. -;;; -;;; Installation: -;;; -;;; Put this file in one of your lisp load path directories or -;;; set the environment variable HTML_CONFIG_FILE to this file. -;;; For example: -;;; setenv HTML_CONFIG_FILE "~/data/hm--htm-environment.el" -;;; if you have put this file in the directory "~/data/" -;;; - -;(require 'adapt) - -(defgroup hm--html nil - "A package for writing HTML pages. -It provides a major mode and a minor mode. The minor mode can be -used together with the psgml html-mode." - :group 'hypermedia) - -(defgroup hm--html-files nil - "hm--html configuration files." - :group 'hm--html) - -(defgroup hm--html-document-information nil - "Variables relating to the insertation of document information. -This contains the user name of the document author, his signature, -the creation and change dates, the HTML doctype and the meta element." - :group 'hm--html) - -(defgroup hm--html-menus nil - "Variables relating to the pulldown and popup menus." - :group 'hm--html) - -(defgroup hm--html-links nil - "Variables relating to the insertation of links." - :group 'hm--html) - -(defgroup hm--html-templates nil - "Variables relating to inserting HTML templates." - :group 'hm--html) - -(defgroup hm--html-keys nil - "Variables relating to the key and mouse bindings and drag and drop." - :group 'hm--html) - -(defgroup hm--html-display nil - "Variables relating to the display of the HTML sources and the previewing." - :group 'hm--html) - -(defgroup hm--html-hooks nil - "Hooks relating to the hm--html modes." - :group 'hm--html) - -(defgroup hm--html-indentation nil - "Variables relating to the indentation in the `hm--html-mode'." - :group 'hm--html) - - -;;; The User config file (an proposal of Manoj Srivastava) -(defcustom hm--html-user-config-file nil - "*The location of the users config file. -This variable will only be used, if no environment variable -\"HTML_USER_CONFIG_FILE\" is set. -Example value: \"~/.hm--html-configuration.el\". - -If this is set to nil and no \"HTML_USER_CONFIG_FILE\" is set, -then the file ~/.hm--html-configuration.el will be used. In this case -also the variable `init-file-user' will be respected." - :group 'hm--html-files - :type '(choice (const :tag "~/.hm--html-configuration.el" :value nil) - file)) - -;;; The site specific config file -(defcustom hm--html-site-config-file nil - "*The location of a site specific config file. -This variable will only be used, if no environment variable -\"HTML_SITE_CONFIG_FILE\" is set." - :group 'hm--html-files - :type '(choice (const :tag "No Site Specific Configuration" :value nil) - file)) - -;;; Chose the initial popup menu -(defcustom hm--html-expert nil - "*t : Use the HTML expert popup menu, -nil : Use the HTML novice (simple) menu. - -NOTE: In the Emacs 19 you should set this variable only before - loading the mode." - :group 'hm--html-menus - :type '(choice (const :tag "Use Expert Popup Menu" :value t) - (const :tag "Use Novice Popup Menu" :value nil))) - -;;; Your Signature - -(defcustom hm--html-signature-file nil - "*Your Signature file. -For example: \"http://www.tnt.uni-hannover.de:80/data/info/www/tnt/info/tnt/whois/muenkel.html\"." - :group 'hm--html-document-information - :type '(choice (const :tag "No Signature file" :value nil) - string)) - - -(defcustom hm--html-username nil - "*Your Name for the signature. For example: \"Heiko Münkel\"." - :group 'hm--html-document-information - :type '(choice (const :tag "Use Value Of `(user-full-name)'" :value nil) - string)) - - -;;; HTML Doctype -(defcustom hm--html-html-doctype-version "-//W3C//DTD HTML 3.2 Final//EN" - "*The HTML version. This is used in the doctype element." - :group 'hm--html-document-information - :type 'string) - - -;;; Your favorite server (eg: the name of the host of your own http server) -;;; This is used in some other variables - -(defcustom hm--html-favorite-http-server-host-name "www.tnt.uni-hannover.de" - "*The name of your favorite http server host. It must be specified !" - :group 'hm--html-links - :type 'string) - - -;;; For links to Info Gateways - -(defcustom hm--html-info-hostname:port-alist - '(("www.tnt.uni-hannover.de:8005")) - "*Alist with hostnames and ports for the Info gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-info-hostname:port-default "www.tnt.uni-hannover.de:8005" - "*Default hostname with port for the Info gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-info-path-alist '((1 . "/appl/lemacs/Global/emacs/info") - (2 . "/appl/emacs/info") - (3 . "/appl/gnu/Global/info") - (4 . "/appl/emacs-19/Global/info") - (5 . "/")) - "*Alist with directories for the Info gateway." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to WAIS Gateways - -(defcustom hm--html-wais-hostname:port-alist '(("www.tnt.uni-hannover.de:8001") - ("info.cern.ch:8001")) - "*Alist with hostnames and ports for the WAIS gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-wais-hostname:port-default "www.tnt.uni-hannover.de:8001" - "*Default hostname with port for the WAIS gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-wais-servername:port-alist - '(("wais.tnt.uni-hannover.de:210") - ("daedalus.tnt.uni-hannover.de:21408") - ("ikarus.tnt.uni-hannover.de:21401")) - "*Alist with servernames and ports for the WAIS gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-wais-servername:port-default "www.tnt.uni-hannover.de:210" - "*Default servername with port for the WAIS gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-wais-path-alist nil - "*Alist with directories for the wais gateway." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For links to HTML servers - -(defcustom hm--html-html-hostname:port-alist '(("www.tnt.uni-hannover.de:80") - ("vxcrna.cern.ch:80") - ("www.ncsa.uiuc.edu:80")) - "*Alist with hostnames and ports for the HTML server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-html-hostname:port-default "www.tnt.uni-hannover.de:80" - "*Default hostname with port for the HTML server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-html-path-alist '((1 . "/data/info/www/tnt/") - (2 . "/data/info/www/") - (3 . "/data/info/") - (4 . "/data/") - (5 . "/appl/") - (6 . "/project/") - (7 . "~/") - (8 . "/")) - "*Alist with directories for the HTML server." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to file gateways - -(defcustom hm--html-file-path-alist '((1 . "/data/info/www/tnt/") - (2 . "/data/info/www/") - (3 . "/data/info/") - (4 . "/data/") - (5 . "/appl/") - (6 . "/project/") - (7 . "~/") - (8 . "/")) - "*Alist with directories for the file gateway." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to ftp servers - -(defcustom hm--html-ftp-hostname:port-alist - '(("ftp.tnt.uni-hannover.de") - ("ftp.rrzn.uni-hannover.de") - ("wega.informatik.uni-hannover.de") - ("rusmv1.rus.uni-stuttgart.de") - ("export.lcs.mit.edu") - ) - "*Alist with hostnames and ports for the ftp server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-ftp-hostname:port-default "ftp.rrzn.uni-hannover.de" - "*Default hostname with port for the ftp server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-ftp-path-alist '((1 . "/pub") - (2 . "/pub/gnu") - (3 . "/pub/linux") - (4 . "/pub/unix") - (5 . "/incoming") - (6 . "/")) - "*Alist with directories for the ftp server." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to gopher servers - -(defcustom hm--html-gopher-hostname:port-alist - '(("newsserver.rrzn.uni-hannover.de:70") - ("solaris.rz.tu-clausthal.de:70") - ("veronica.scs.unr.edu:70") - ("pinus.slu.se:70") - ("sunic.sunet.se:70") - ) - "*Alist with hostnames and ports for the gopher server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-gopher-hostname:port-default - "newsserver.rrzn.uni-hannover.de:70" - "*Default hostname with port for the gopher server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-gopher-doctype-alist '(("/1") - ("/11") - ("/00")) - "*Alist with doctype strings for the gopher server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-gopher-doctype-default "/1" - "*Default doctype string for the gopher server." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-gopher-anchor-alist - '(("veronica") - ("Wide%20Area%20Information%20Services%20databases") - ("Subject%20Tree")) - "*Alist with directories for the gopher server." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For the links to the Program Gateway - -(defcustom hm--html-proggate-hostname:port-alist - '(("www.tnt.uni-hannover.de:8007") - ) - "*Alist with hostnames and ports for the proggate server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-proggate-hostname:port-default - "www.tnt.uni-hannover.de:8007" - "*Default hostname with port for the proggate server." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-proggate-allowed-file "/appl/www/bin/proggate.allowed" - "*The filename (with path) of the proggate allowed file." - :group 'hm--html-links - :type 'file) - - -;;; For links to the Local Program Gatewy - -(defcustom hm--html-local-proggate-path-alist '((1 . "/bin/") - (2 . "/usr/bin/") - (3 . "/usr/local/bin/") - (4 . "/appl/util/bin/") - (5 . "/appl/gnu/Global/bin/") - (6 . "/") - (7 . "/appl/") - (8 . "~/appl/Global/bin/") - (9 . "~/")) - "*Alist with directories for the local program gateway." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For links to the mail gateway - -(defcustom hm--html-mail-hostname:port-alist '(("www.tnt.uni-hannover.de:8003") - ) - "*Alist with hostnames and ports for the mail gateway." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-mail-hostname:port-default "www.tnt.uni-hannover.de:8003" - "*Default hostname with port for the mail gateway." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-mail-path-alist '((1 . "~/data/docs/mail") - (2 . "~/data/docs/news") - (3 . "~/docs/mail") - (4 . "~/docs/news") - (5 . "~/mail") - (6 . "~/news") - (7 . "~/") - (8 . "/data/info/mail") - (9 . "/data/info/news") - (10 . "/")) - "*Alist with directories for the mail gateway." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For mailto links - -(defcustom hm--html-mailto-alist '(("muenkel@tnt.uni-hannover.de")) - "*Alist with mail adresses for the mailto alist. -The value of `user-mail-address' will also be added by the package to -this alist." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For the server side include directive -;;; not sure, if these directives works on any server - -(defcustom hm--html-server-side-include-command-alist '(("/bin/date") - ("/usr/bin/finger") - ("/bin/df")) - "*Alist with commands for the server side include directive. -These commands needs no parameter." - :group 'hm--html-links - :type '(repeat string)) - -(defcustom hm--html-server-side-include-command-with-parameter-alist - '(("/usr/bin/man") - ("/usr/bin/finger") - ("/usr/bin/ls") - ("/bin/cat")) - "*Alist with commands for the server side include directive. -These commands needs parameters." - :group 'hm--html-links - :type '(repeat string)) - - -;;; Alist with URL'S for FORMS and IMAGE tags - -(defcustom hm--html-url-alist - (list - '("http://hoohoo.ncsa.uiuc.edu/htbin-post/post-query" - POST) - '("http://hoohoo.ncsa.uiuc.edu/htbin/query" - GET) - (list - (concat "http://" - hm--html-favorite-http-server-host-name - "/") - 'IMAGE)) - "*Alist with URL's for FORMS and IMAGE tags. -The cdr of each list contains symbols, which specifys the use of the -URL." - :group 'hm--html-links - :type '(repeat cons)) - - -;;; For the marking of examples in the help buffer - -(defcustom hm--html-help-foreground "red" - "The foreground color to highlight examples." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-help-background nil - "The background color to highlight examples." - :group 'hm--html-links - :type 'string) - -(defcustom hm--html-help-font (face-font 'bold) - "The font to highlight examples." - :group 'hm--html-links - :type 'string) - - -;;; For the Templates - -(defcustom hm--html-template-dir "/data/info/www/tnt/guide/templates" - "*A directory with templatefiles. -It is now also possible to use it as a list of directories. -Look at the variable `tmpl-template-dir-list' for further descriptions." - :group 'hm--html-templates - :type 'directory) - -(if (listp hm--html-template-dir) - (unless (file-exists-p (car hm--html-template-dir)) - ;; Use a system directory, if the above one doesn't exist - ;; This may only be useful, in the XEmacs >= 19.12 - (setq hm--html-template-dir (cons (concat data-directory - "../lisp/hm--html-menus/") - hm--html-template-dir))) - (unless (file-exists-p hm--html-template-dir) - ;; Use a system directory, if the above one doesn't exist - ;; This may only be useful, in the XEmacs >= 19.12 - (setq hm--html-template-dir (concat data-directory - "../lisp/hm--html-menus/")))) - -(defcustom hm--html-frame-template-file (concat data-directory - "../lisp/hm--html-menus/" - "frame.html.tmpl") - "File, which is used as template for a html frame." - :group 'hm--html-templates - :type 'file) - -(defcustom hm--html-automatic-expand-templates t - "*Automatic expansion of templates. This feature needs the file -tmpl-minor-mode.el from Heiko Muenkel (muenkel@tnt.uni-hannover.de), -which is distributed with the package hm--html-menus." - :group 'hm--html-templates - :type 'boolean) - -(defcustom hm--html-template-filter-regexp ".*\\.html\\.tmpl$" - "*Regexp for filtering out non template files in a directory." - :group 'hm--html-templates - :type 'string) - -;;; for deleting the automounter path-prefix -(defcustom hm--html-delete-wrong-path-prefix '("/tmp_mnt" "/phys/[^/]+") - "If non nil, it specifies path-prefixes, which should be deleted in pathes. -The Sun automounter adds a temporary prefix to the automounted directories - (At our site the prefix is /tmp_mnt). But you can't select such a path, if -the automounter has currently not mounted the directory and so you can't -follow a html-link, which consists of such a path. To overcome this behaviour, -you can set this variable to the prefix (eg. \"/tmp_mnt\"). After that, the -prefix should be stripped from the pathes during the creation of the links. -ATTENTION: This variable is used as regular expression ! -It can be set to a string or to a list of strings." - :group 'hm--html-links - :type '(repeat string)) - - -;;; For insertation of created and changed comments and automatic -;;; date update in the title line and a visible modification date - -(defcustom hm--html-automatic-create-title-date t - "*t => A date string will be inserted in the title line. -This will be updated each time before file saving, if -`hm--html-automatic-update-title-date' is also set to t." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-automatic-update-title-date t - "*t => The date in the title line will be updated before filesaving. -nil => No automatic update of the date." - :group 'hm--html-document-information - :type 'boolean) - -(define-obsolete-variable-alias 'hm--html-automatic-new-date - 'hm--html-automatic-update-title-date) - -(defcustom hm--html-automatic-changed-comment t - "*t => A \"changed comment\" line will be added before filesaving. -nil => No automatic insertation of a \"changed comment\" line." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-changed-comment-prefix "Changed by: " - "*The prefix text of the \"changed comment\" lines." - :group 'hm--html-document-information - :type 'string) - -(defcustom hm--html-created-comment-prefix "Created by: " - "*The prefix text of the \"created comment\" lines." - :group 'hm--html-document-information - :type 'string) - -(defcustom hm--html-comment-infix nil - "*The infix (second part) of the \"changed/created comment\" lines. -By default, if this variable is nil, the username is used. -Then the infix looks like \"Heiko Münkel, \". -Set it to an empty string, if you don't want to have your name -in the comments." - :group 'hm--html-document-information - :type '(choice (const :tag "Use The Username" :value nil) - string)) - -(defcustom hm--html-automatic-created-comment t - "*t => A \"created comment\" line will be added. -nil => No automatic insertation of a \"created comment\" line." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-automatic-create-modified-line nil - "*t => Inserts a visible \"modified\" line with the current date. -Visible means, that it is not a HTML comment." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-automatic-update-modified-line nil - "*t => Updates a visible \"modified\" line with the current date. -Visible means, that it is not a HTML comment." - :group 'hm--html-document-information - :type 'boolean) - -(defcustom hm--html-modified-prefix "Modified: " - "*Prefix of the last modified entry." - :group 'hm--html-document-information - :type 'string) - -(defcustom hm--html-modified-start-tag "<EM>" - "*Start tag of the modified line. -If you change this, you'll need to change also -`hm--html-modified-end-tag'." - :group 'hm--html-document-information - :type '(choice (const :tag "Emphasized" :value "<EM>") - (const :tag "Strong" :value "<STRONG>") - (const :tag "No Tags" :value "") - (const :tag "Bold" :value "<B>") - (const :tag "Italic" :value "<I>") - (const :tag "Typewriter" :value "<TT>") - (const :tag "Small" :value "<SMALL>") - (const :tag "Big" :value "<BIG>") - (const :tag "Underline" :value "<U>") - string)) - -(defcustom hm--html-modified-end-tag "</EM>" - "*End tag of the modified line. -If you change this, you'll need to change also -`hm--html-modified-start-tag'." - :group 'hm--html-document-information - :type '(choice (const :tag "Emphasized" :value "</EM>") - (const :tag "Strong" :value "</STRONG>") - (const :tag "No Tags" :value "") - (const :tag "Bold" :value "</B>") - (const :tag "Italic" :value "</I>") - (const :tag "Typewriter" :value "</TT>") - (const :tag "Small" :value "</SMALL>") - (const :tag "Big" :value "</BIG>") - (const :tag "Underline" :value "</U>") - string)) - -(defcustom hm--html-modified-insert-before "</body>" - "Insert modified line before this string. -The search will be done from the end to the beginning." - :group 'hm--html-document-information - :type 'string) - - -;;; Keybindings: - -(defcustom hm--html-bind-latin-1-char-entities t - "Set this to nil, if you don't want to use the ISO Latin 1 character entities. -This is only useful, if `hm--html-use-old-keymap' is set to nil. It is only -used during loading the html package the first time." - :group 'hm--html-keys - :type 'boolean) - - -;;; The drag and drop interface -(defcustom hm--html-idd-create-relative-links t - "If t, then the hm--html-idd-* functions are creating relative links. -Otherwise absolute links are used. The idd functions are used for -drag and drop." - :group 'hm--html-keys - :type 'boolean) - -(defcustom hm--html-idd-actions - '((nil (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpg\\)")) - hm--html-idd-add-include-image-from-dired-line) - (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-no-file-on-line-p . nil)) - hm--html-idd-add-file-link-to-file-on-dired-line) - (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-no-file-on-line-p . t)) - hm--html-idd-add-file-link-to-directory-of-buffer) - (((idd-if-major-mode-p . w3-mode) - (idd-if-url-at-point-p . t)) - hm--html-idd-add-html-link-from-w3-buffer-point) - (((idd-if-major-mode-p . w3-mode)) - hm--html-idd-add-html-link-to-w3-buffer) - (((idd-if-local-file-p . t)) - hm--html-idd-add-file-link-to-buffer))) - "The action list for the destination mode `hm--html-mode'. -Look at the description of the variable idd-actions." - :group 'hm--html-keys - :type 'list) - - -;;; The font lock keywords - -(defcustom hm--html-font-lock-keywords-1 - (list - '("<!--.*-->" . font-lock-comment-face) - '("<[^>]*>" . font-lock-keyword-face) -; '("<[^>=]*href[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t) -; '("<[^>=]src[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t) - '("<[^>=]*\\(href\\|src\\)[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" - 2 font-lock-string-face t)) - "Subdued level highlighting for hm--html-mode." - :group 'hm--html-display - :type '(repeat cons)) - -(defcustom hm--html-font-lock-keywords-2 - (append hm--html-font-lock-keywords-1 - (list - '(">\\([^<]+\\)</a>" 1 font-lock-reference-face) - '("</b>\\([^<]+\\)</b>" 1 bold) - '("</i>\\([^<]+\\)</i>" 1 italic) - )) - "Gaudy level highlighting for hm--html-mode." - :group 'hm--html-display - :type '(repeat cons)) - -(defcustom hm--html-font-lock-keywords hm--html-font-lock-keywords-1 - "Default expressions to highlight in the hm--html-mode." - :group 'hm--html-display - :type '(repeat cons)) - - - -;;; The Prefix- Key for the keytables -(defcustom hm--html-minor-mode-prefix-key "\C-z" - "The prefix key for the keytables in the `hm--html-minor-mode'." - :group 'hm--html-keys - :type 'string) - -(defcustom hm--html-mode-prefix-key "\C-c" - "The prefix key for the hm--html keys in the `hm--html-mode'." - :group 'hm--html-keys - :type 'string) - - -;;; The pulldown menu names -(defcustom hm--html-minor-mode-pulldown-menu-name "HM-HTML" - "The name of the pulldown menu in the minor html mode." - :group 'hm--html-menus - :type 'string - ) - -(defcustom hm--html-mode-pulldown-menu-name "HTML" - "The name of the pulldown menu in the major html mode." - :group 'hm--html-menus - :type 'string) - - -;;; The hook variables -(defcustom hm--html-load-hook nil - "*Hook variable to execute functions after loading the package." - :group 'hm--html-hooks - :type 'hook) - -(defcustom hm--html-mode-hook nil - "*This hook will be called each time, when the hm--html-mode is invoked." - :group 'hm--html-hooks - :type 'hook) - - -;;; For the file html-view.el -;;; There are also some other variables in hmtl-view.el -;;; Look at that file, if you've trouble with the functions -;;; to preview the html document with the Mosaic -(defcustom html-view-mosaic-command "/sol/www/bin/mosaic" - "The command that runs Mosaic on your system." - :group 'hm--html-display - :type '(choice (const :tag "mosaic" :value "mosaic") - (const :value "/usr/local/bin/mosaic") - file)) - -(defcustom html-sigusr1-signal-value 16 - "Value for the SIGUSR1 signal on your system. -See, usually, /usr/include/sys/signal.h. - SunOS 4.1.x : (setq html-sigusr1-signal-value 30) - SunOS 5.x : (setq html-sigusr1-signal-value 16) - Linux : (setq html-sigusr1-signal-value 10))" - :group 'hm--html-display - :type '(choice (const :tag "On SunOS 4.1.x" :value 30) - (const :tag "On SunOS 5.x" :value 16) - (const :tag "On Linux" :value 10) - integer)) - - -;;; Meta information -(defcustom hm--html-meta-name-alist '(("Expires") ("Keys") ("Author")) - "*Alist with possible names for the name or http-equiv attribute of meta." - :group 'hm--html-document-information - :type '(repeat (list (choice (const "Expires") - (const "Keys") - (const "Author") - string)))) - -;;; indentation - -(defcustom hm--html-disable-indentation nil - "*Set this to t, if you want to disable the indentation in the hm--html-mode. -And may be send me (muenkel@tnt.uni-hannover.de) a note, why you've -done this." - :group 'hm--html-indentation - :type 'boolean) - -(defcustom hm--html-inter-tag-indent 2 - "*The indentation after a start tag." - :group 'hm--html-indentation - :type 'integer) - -(defcustom hm--html-comment-indent 5 - "*The indentation of a comment." - :group 'hm--html-indentation - :type 'integer) - -(defcustom hm--html-intra-tag-indent 2 - "*The indentation after the start of a tag." - :group 'hm--html-indentation - :type 'integer) - -(defcustom hm--html-tag-name-alist - '(("!--" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("!doctype" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("isindex" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (prompt))) - ("base" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (href)) - (:hm--html-optional-attributes nil)) - ("meta" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (content)) - (:hm--html-optional-attributes (http-equiv name))) - ("link" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (href rel rev title))) - ("hr" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align noshade size width))) - ("input" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (type name value checked size maxlength src align))) - ("img" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (src)) - (:hm--html-optional-attributes - (alt align height width border hspace vspace usemap ismap))) - ("param" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (name)) - (:hm--html-optional-attributes (value))) - ("br" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (clear))) - ("basefont" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes size)) - ("area" (:hm--html-one-element-tag t) - (:hm--html-required-attributes (alt)) - (:hm--html-optional-attributes (shape coords href nohref))) - ("option" (:hm--html-one-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (selected value))) - - ("html" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("head" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("body" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (bgcolor text link vlink alink background)) - ) - ("h1" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h2" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h3" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h4" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h5" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("h6" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("address" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("p" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("ul" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (type compact))) - ("ol" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (type start compact))) - ("dl" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (compact))) - ("li" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (type (value "ol")))) - ("dt" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("dd" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("dir" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (compact))) - ("menu" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (compact))) - ("pre" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (width))) - ("div" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("center" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("blockquote" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("form" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (action method enctype))) - ("select" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (name)) - (:hm--html-optional-attributes (size multiple))) - ("textarea" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (name rows cols)) - (:hm--html-optional-attributes nil)) - ("table" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (align width border cellspacing cellpading))) - ("caption" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align))) - ("tr" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (align valign))) - ("th" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (nowrap rowspan colspan align valign width height))) - ("td" (:hm--html-one-or-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes - (nowrap rowspan colspan align valign width height))) - ("tt" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("i" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("b" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("u" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("strike" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("big" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("small" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("sub" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("sup" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("em" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("strong" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("dfn" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("code" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("samp" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("kbd" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("var" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("cite" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("a" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (name href rel rev title))) - ("applet" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (code width height)) - (:hm--html-optional-attributes (codebase alt name align hspace vspace))) - ("font" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes (size color))) - ("map" (:hm--html-two-element-tag t) - (:hm--html-required-attributes (name)) - (:hm--html-optional-attributes nil)) - ("style" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ("script" (:hm--html-two-element-tag t) - (:hm--html-required-attributes nil) - (:hm--html-optional-attributes nil)) - ) - "An alist with tag names known by the `hm--html-mode'. -CURRENTLY THIS LIST MIGHT NOT CONTAIN ALL TAGS!!!!. - -It is used to determine, if a tag is a one element tag or not. - -In the future it should also be used to get possible parameters of -the tag. - -Use lower case characters in this list!!!!" - :group 'hm--html-indentation - :type 'list) -; :type '(repeat lisp)) -; :type '(repeat (list string -; (list (const -; :tag "Element with one tag" -; :value (:hm--html-one-element-tag t)) -; (const -; :tag "Element with two tags" -; :value (:hm--html-two-element-tag t)) -; (const -; :tag "Element with one or two tags" -; :value (:hm--html-one-or-two-element-tag t)) -; ) -; (list :format "%t%v" -; :tag "" -; (const :format "" -; :value :hm--html-required-attributes) -; (repeat :tag "Repeat Required Attributes" -; symbol)) -; (list :format "%t%v" -; :tag "" -; (const :format "" -; :value :hm--html-optional-attributes) -; (repeat :tag "Repeat Optional Attributes" -; symbol)) -; ))) - - -;;; Announce the feature hm--html-configuration -(provide 'hm--html-configuration) -
--- a/lisp/hm--html-menus/hm--html-drag-and-drop.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -;;; $Id: hm--html-drag-and-drop.el,v 1.2 1997/02/15 22:21:03 steve Exp $ -;;; -;;; Copyright (C) 1996, 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; This package contains functions to insert links and other -;;; HTML stuff with the mouse with drag and drop. -;;; -;;; For further descriptions look at the file -;;; internal-drag-and-drop.el, which implements the basic (and -;;; more genreal functions) for the drag and drop interface. -;;; -;;; Installation: -;;; -;;; Put this file in your load path. -;;; - -(require 'internal-drag-and-drop) -(require 'cl) - -;(defun hm--html-first-non-matching-position (string1 string2) -; "Compares both strings and returns the first position, which is not equal." -; (let ((n 0) -; (max-n (min (length string1) (length string2))) -; (continue t)) -; (while (and continue (< n max-n)) -; (when (setq continue (= (aref string1 n) (aref string2 n))) -; (setq n (1+ n)))) -; n)) - -;(defun hm--html-count-subdirs (directory) -; "Returns the number of subdirectories of DIRECTORY." -; (let ((n 0) -; (max-n (1- (length directory))) -; (count 0)) -; (while (< n max-n) -; (when (= ?/ (aref directory n)) -; (setq count (1+ count))) -; (setq n (1+ n))) -; (when (and (not (= 0 (length directory))) -; (not (= ?/ (aref directory 0)))) -; (setq count (1+ count))) -; count)) - -;(defun hm--html-return-n-backwards (n) -; "Returns a string with N ../" -; (cond ((= n 0) "") -; (t (concat "../" (hm--html-return-n-backwards (1- n)))))) - -;(defun* hm--html-file-relative-name (file-name -; &optional (directory default-directory)) -; "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." -; (let* ((pos (hm--html-first-non-matching-position file-name directory)) -; (backwards (hm--html-count-subdirs (substring directory pos))) -; (relative-name (concat (hm--html-return-n-backwards backwards) -; (substring file-name pos)))) -; (if (= 0 (length relative-name)) -; "./" -; (if (= ?/ (aref relative-name 0)) -; (if (= 1 (length relative-name)) -; "./" -; (substring relative-name 1)) -; relative-name)))) - -(defun hm--html-idd-add-include-image-from-dired-line (source destination) - "Inserts an include image tag at the DESTINATION. -The name of the image is on a line in a dired buffer. It is specified by the -SOURCE." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-add-image-top (file-relative-name - (idd-get-dired-filename-from-line source)) - (file-name-nondirectory - (idd-get-dired-filename-from-line source))) - (hm--html-add-image-top (idd-get-dired-filename-from-line source) - (file-name-nondirectory - (idd-get-dired-filename-from-line source))))) - -(defun hm--html-idd-add-link-to-region (link-object destination) - "Inserts a link with the LINK-OBJECT in the DESTINATION. -It uses the region as the name of the link." - (idd-set-region destination) - (hm--html-add-normal-link-to-region link-object) - ) - -(defun hm--html-idd-add-link (link-object destination) - "Inserts a link with the LINK-OBJECT in the DESTINATION." - (idd-set-point destination) - (hm--html-add-normal-link link-object)) - -(defun hm--html-idd-add-link-to-point-or-region (link-object destination) - "Inserts a link with the LINK-OBJECT in the DESTINATION. -It uses the region as the name of the link, if the region was active -in the DESTINATION." - (if (cdr (assoc ':region-active destination)) - (hm--html-idd-add-link-to-region link-object destination) - (hm--html-idd-add-link link-object destination))) - -(defun hm--html-idd-add-file-link-to-file-on-dired-line (source destination) - "Inserts a file link in DESTINATION to the file on the dired line of SOURCE." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-idd-add-link-to-point-or-region - (file-relative-name - (idd-get-dired-filename-from-line source)) - destination) - (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-dired-filename-from-line source)) - destination))) - -(defun hm--html-idd-add-file-link-to-buffer (source destination) - "Inserts a file link at DESTINATION to the file of the SOURCE buffer." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-idd-add-link-to-point-or-region - (file-relative-name (idd-get-local-filename source)) - destination) - (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-local-filename source)) - destination))) - -(defun hm--html-idd-add-file-link-to-directory-of-buffer (source - destination) - "Inserts a file link at DESTINATION to the directory of the SOURCE buffer." - (idd-set-point destination) - (if hm--html-idd-create-relative-links - (hm--html-idd-add-link-to-point-or-region - (file-relative-name (idd-get-directory-of-buffer source)) - destination) - (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-directory-of-buffer source)) - destination))) - -(defun hm--html-idd-add-html-link-to-w3-buffer (source destination) - "Inserts a link at DESTINATION to the w3 buffer specified by the SOURCE. -Note: Relative links are currently not supported for this function." - (idd-set-point destination) - (hm--html-idd-add-link-to-point-or-region (idd-get-buffer-url source) - destination)) - -(defun hm--html-idd-add-html-link-from-w3-buffer-point (source destination) - "Inserts a link at DESTINATION to a lin in the w3 buffer. -The link in the w3-buffer is specified by the SOURCE. -Note: Relative links are currently not supported for this function." - (idd-set-point destination) - (hm--html-idd-add-link-to-point-or-region (idd-get-url-at-point source) - destination)) - -;;; Announce the feature hm--html-drag-and-drop -(provide 'hm--html-drag-and-drop)
--- a/lisp/hm--html-menus/hm--html-indentation.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,271 +0,0 @@ -;;; hm--html-indentation.el -;;; v1.00; 9-Feb-1997 -;;; Copyright (C) 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines functions for the indentation. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; - -(defun hm--html-point-between-strings-p (string-1 - string-2 - &optional boundary) - "Returns non nil, if the current point is between STRING-1 and STRING-2." - (when (and (re-search-backward (concat "\\(" - (regexp-quote string-1) - "\\)\\|\\(" - (regexp-quote string-2) - "\\)") - boundary - t) - (match-string 1)) - (point))) - -(defun hm--html-in-comment-p () - "Checks if the current point is in a comment block. -If this is the case, then the start point of the comment is returned. -Otherwise nil is returned." - (save-excursion - (hm--html-point-between-strings-p comment-start comment-end))) - -(defun hm--html-previous-line-start () - "Returns the start of the previous non blank line." - (save-excursion - (beginning-of-line) - (skip-chars-backward " \t\n") - (beginning-of-line) - (point))) - -(defun hm--html-look-at-comment-end-p () - "T, if the current line starts with the comment end." - (looking-at (regexp-quote comment-end))) - -(defun hm--html-column-of-previous-regexp (regexp) - "Returns the column of the start of the previous REGEXP. -It searches backward until the REGEXP is found. If no -REGEXP is found, then it returns 0." - (save-excursion - (if (re-search-backward regexp nil t) - (current-column) - 0))) - -(defun hm--html-look-at-end-tag-p () - "Returns the end tag name if the point is at the start of an end tag. -nil is returned otherwise." - (when (looking-at "\\(<[ \t\n]*/[ \t\n]*\\)\\([^ \t\n>]+\\)") - (match-string 2))) - - -(defun hm--html-previous-line-indentation () - "Returns the indentation of the previous non blank line." - (save-excursion - (beginning-of-line) - (skip-chars-backward " \t\n") - (back-to-indentation) - (current-column))) - -(defun hm--html-in-tag-p () - "Checks if the current point is in a tag. -If this is the case, then the start point of the tag is returned. -Otherwise nil is returned." - (save-excursion - (let ((start (re-search-backward "\\(<\\)\\|\\(>\\)" nil t))) - (when (match-string 1) - start)))) - -(defun hm--html-return-beginning-of-line () - "Returns the beginning of the current line." - (save-excursion - (beginning-of-line) - (point))) - -(defun hm--html-return-end-of-line () - "Returns the end of the current line." - (save-excursion - (end-of-line) - (point))) - -(defun hm--html-paramter-column-in-line-after-point (point) - "Returns the column where the second non blank text after POINT starts. -This point must be in the line with POINT otherwise it returns nil." - (save-excursion - (goto-char point) - (when (re-search-forward "<[ \t]*[^ \t]+[ \t]" - (hm--html-return-end-of-line) - t) - (when (looking-at "[^\n]") - (current-column))))) - -(defun hm--html-column-of-point (point) - "Returns the column of the POINT." - (save-excursion - (goto-char point) - (current-column))) - -(defun hm--html-search-previous-tag-in-current-line () - "Searches tags from the `(point)' to the beginning of the line. -It returns nil, if there is no tag and the tag name, if there is -a tag. The tag name contains a leading /, if it is an end tag." - (when (re-search-backward ">" (hm--html-return-beginning-of-line) t) - (when (re-search-backward - "\\(<[ \t\n]*\\(/?\\)\\([ \t\n]*[^> \t\n]+\\)[^>]*\\)" - nil - t) - (concat (match-string 2) (match-string 3))))) - -(defun hm--html-search-start-tag (tag-name until) - "Searches start tag backwards from the current point until the point UNTIL. -The name of the tag is TAG-NAME. After this function the point is at UNTIL - (then it returns nil) or at the start of the tag, then it returns t." - (if (re-search-backward (concat "\\(<[ \t\n]*\\)\\(/?\\)\\(" - tag-name - "\\)\\([^>]*>\\)") until t) - (if (string= "/" (match-string 2)) - (progn - (hm--html-search-start-tag tag-name until) - (hm--html-search-start-tag tag-name until)) - t) - (goto-char until) - nil)) - -(defun hm--html-is-one-element-tag-p (tag-name) - "Returns t, if the tag with the tag-name is a one element tag." - (assoc ':hm--html-one-element-tag - (cdr (assoc* (downcase tag-name) - hm--html-tag-name-alist - :test 'string=)))) - -(defun hm--html-calculate-indent-according-to-previous-tags () - "Calculate the indent according to the previous tags in this line. -If no tags are found, then nil is returned." - (save-excursion - (let ((tag (hm--html-search-previous-tag-in-current-line))) - (cond ((not tag) nil) - - ((eq ?/ (elt tag 0)) ; end tag found - (if (hm--html-search-start-tag - (substring tag 1) - (point-min)) - (or (hm--html-calculate-indent-according-to-previous-tags) - (progn - (backward-to-indentation 0) - (current-column))) - 0)) ; it may be that the current indentation is better here - - ((hm--html-is-one-element-tag-p tag) ; one element tag - (or (hm--html-calculate-indent-according-to-previous-tags) - (progn - (backward-to-indentation 0) - (current-column)))) - - (t ; start tag found - (+ (current-column) hm--html-inter-tag-indent)))))) - - -(defun hm--html-calculate-indent () - "Calculate the indentation of the current line." - (let ((match-point) - (tag)) - (save-excursion - (beginning-of-line) - (back-to-indentation) - (cond ((eq (count-lines (point-min) (point)) 0) 0) ; Filestart - - ((setq match-point (hm--html-in-comment-p)) ; in a comment - (if (>= match-point (hm--html-previous-line-start)) ; 1. line - (if (hm--html-look-at-comment-end-p) - (hm--html-column-of-previous-regexp - (regexp-quote comment-start)) - (+ (hm--html-column-of-previous-regexp - (regexp-quote comment-start)) - hm--html-comment-indent)) - (if (hm--html-look-at-comment-end-p) - (- (hm--html-previous-line-indentation) - hm--html-comment-indent) - (hm--html-previous-line-indentation)))) - - ((setq tag (hm--html-look-at-end-tag-p)) ; look at end tag - (hm--html-search-start-tag tag (point-min)) - (current-column)) - - ((looking-at ">") - (hm--html-column-of-previous-regexp "<")) - - ((setq match-point (hm--html-in-tag-p)) - (if (>= match-point (hm--html-previous-line-start)) ; 1. line - (or (hm--html-paramter-column-in-line-after-point match-point) - (+ (hm--html-column-of-point match-point) - hm--html-intra-tag-indent)) - (hm--html-previous-line-indentation))) - - (t (or (save-excursion ; check previous line - (skip-chars-backward " \t\n") - (hm--html-calculate-indent-according-to-previous-tags)) - (hm--html-previous-line-indentation))) - )))) - - -;;; Indentation commands - -(defun hm--html-indent-line () - "Indent the current line line." - (interactive) - (unless hm--html-disable-indentation - (let ((pos (- (point-max) (point)))) - (indent-line-to (max 0 (hm--html-calculate-indent))) - (when (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))))) - -;(defun hm--html-indent-region (begin end) -; "Indents the region between BEGIN and END according to the major mode." -; (interactive "d\nm") -; (when (< end begin) -; (let ((a end)) -; (setq end begin) -; (setq begin a))) -; (save-excursion -; (goto-char begin) -; (let ((old-point)) -; (while (and (<= (point) end) -; (not (eq (point) old-point))) -; (setq old-point (point)) -; (indent-according-to-mode) -; (forward-line) -; )))) - -(defun hm--html-indent-region (begin end) - "Indents the region between BEGIN and END according to the major mode." - (interactive "d\nm") - (when (< end begin) - (let ((a end)) - (setq end begin) - (setq begin a))) - (let ((lines (count-lines begin end))) - (save-excursion - (goto-char begin) - (loop repeat lines - do (indent-according-to-mode) - (forward-line)))) - ) - -(provide 'hm--html-indentation)
--- a/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,766 +0,0 @@ -;;; $Id: hm--html-keys.el,v 1.7 1997/05/29 23:49:42 steve Exp $ -;;; -;;; Copyright (C) 1995, 1996, 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines the new keybindigs for the hm--html-menus package. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; - -(if (adapt-emacs19p) - (progn - - (defvar hm--html-emacs19-popup-noregion-menu-button [C-down-mouse-3] - "This is the mouse button , which pops up the noregion menus. -It could have the same value as -`hm--html-emacs19-popup-region-menu-button'.") - - (defvar hm--html-emacs19-popup-region-menu-button [C-down-mouse-3] - "This is the mouse button , which pops up the region menus. -It could have the same value as -`hm--html-emacs19-popup-noregion-menu-button'.") - - )) - - -(defvar hm--html-noregion-anchor-map nil - "Noregion sub keymap for inserting anchors.") - -(if hm--html-noregion-anchor-map - () - (setq hm--html-noregion-anchor-map (make-sparse-keymap)) - (define-key hm--html-noregion-anchor-map "r" 'hm--html-add-relative-link) - (define-key hm--html-noregion-anchor-map "h" 'hm--html-add-html-link) - (define-key hm--html-noregion-anchor-map "i" 'hm--html-add-info-link) - (define-key hm--html-noregion-anchor-map "g" 'hm--html-add-gopher-link) - (define-key hm--html-noregion-anchor-map "f" 'hm--html-add-file-link) - (define-key hm--html-noregion-anchor-map "\C-f" 'hm--html-add-ftp-link) - (define-key hm--html-noregion-anchor-map "n" 'hm--html-add-news-link) - (define-key hm--html-noregion-anchor-map "m" 'hm--html-add-mail-box-link) - (define-key hm--html-noregion-anchor-map - [(control m)] 'hm--html-add-mailto-link) - (define-key hm--html-noregion-anchor-map "w" 'hm--html-add-direct-wais-link) - (define-key hm--html-noregion-anchor-map "\C-w" 'hm--html-add-wais-link) - (define-key hm--html-noregion-anchor-map "p" 'hm--html-add-proggate-link) - (define-key hm--html-noregion-anchor-map - "\C-p" 'hm--html-add-local-proggate-link) - (define-key hm--html-noregion-anchor-map "l" 'hm--html-add-normal-link) - (define-key hm--html-noregion-anchor-map "t" 'hm--html-add-link-target) - ) - -(defvar hm--html-region-anchor-map nil - "Region sub keymap for inserting anchors.") - -(if hm--html-region-anchor-map - () - (setq hm--html-region-anchor-map (make-sparse-keymap)) - (define-key hm--html-region-anchor-map - "r" 'hm--html-add-relative-link-to-region) - (define-key hm--html-region-anchor-map "h" 'hm--html-add-html-link-to-region) - (define-key hm--html-region-anchor-map "i" 'hm--html-add-info-link-to-region) - (define-key hm--html-region-anchor-map - "g" 'hm--html-add-gopher-link-to-region) - (define-key hm--html-region-anchor-map "f" 'hm--html-add-file-link-to-region) - (define-key hm--html-region-anchor-map - "\C-f" 'hm--html-add-ftp-link-to-region) - (define-key hm--html-region-anchor-map "n" 'hm--html-add-news-link-to-region) - (define-key hm--html-region-anchor-map "m" 'hm--html-add-mail-box-link-to-region) - (define-key hm--html-region-anchor-map - [(control m)] 'hm--html-add-mailto-link-to-region) - (define-key hm--html-region-anchor-map - "w" 'hm--html-add-direct-wais-link-to-region) - (define-key hm--html-region-anchor-map - "\C-w" 'hm--html-add-wais-link-to-region) - (define-key hm--html-region-anchor-map - "p" 'hm--html-add-proggate-link-to-region) - (define-key hm--html-region-anchor-map - "\C-p" 'hm--html-add-local-proggate-link-to-region) - (define-key hm--html-region-anchor-map - "l" 'hm--html-add-normal-link-to-region) - (define-key hm--html-region-anchor-map - "t" 'hm--html-add-link-target-to-region) - ) - -(defvar hm--html-noregion-frame-map nil - "Noregion sub keymap for inserting frame elements.") - -(if hm--html-noregion-frame-map - () - (setq hm--html-noregion-frame-map (make-sparse-keymap)) - (define-key hm--html-noregion-frame-map "f" 'hm--html-add-full-html-frame) - (define-key hm--html-noregion-frame-map [(control d)] 'hm--html-add-doctype) - (define-key hm--html-noregion-frame-map [(control h)] 'hm--html-add-html) - (define-key hm--html-noregion-frame-map [(meta h)] 'hm--html-add-head) - (define-key hm--html-noregion-frame-map "b" 'hm--html-add-body) - (define-key hm--html-noregion-frame-map - [(control t)] 'hm--html-add-title-and-header) - (define-key hm--html-noregion-frame-map "t" 'hm--html-add-title) - (define-key hm--html-noregion-frame-map "h" 'hm--html-add-header) - (define-key hm--html-noregion-frame-map "m" 'hm--html-add-meta) - (define-key hm--html-noregion-frame-map "n" 'hm--html-add-normal-node-link) - (define-key hm--html-noregion-frame-map "i" 'hm--html-add-isindex) - (define-key hm--html-noregion-frame-map [(meta d)] 'hm--html-add-base) - (define-key hm--html-noregion-frame-map "a" 'hm--html-add-address) - (define-key hm--html-noregion-frame-map "s" 'hm--html-add-signature) - (define-key hm--html-noregion-frame-map - [(control c)] 'hm--html-insert-created-comment) - (define-key hm--html-noregion-frame-map "c" 'hm--html-insert-changed-comment) - (define-key hm--html-noregion-frame-map - [(control m)] 'hm--html-insert-modified-line) - (define-key hm--html-noregion-frame-map "d" 'hm--html-new-date) - ) - -(defvar hm--html-region-frame-map nil - "Region sub keymap for inserting frame elements.") - -(if hm--html-region-frame-map - () - (setq hm--html-region-frame-map (make-sparse-keymap)) - (define-key hm--html-region-frame-map - "f" 'hm--html-add-full-html-frame-with-region) - (define-key hm--html-region-frame-map - [(meta h)] 'hm--html-add-head-to-region) - (define-key hm--html-region-frame-map "b" 'hm--html-add-body-to-region) - (define-key hm--html-region-frame-map - [(control t)] 'hm--html-add-title-and-header-to-region) - (define-key hm--html-region-frame-map "t" 'hm--html-add-title-to-region) - (define-key hm--html-region-frame-map "h" 'hm--html-add-header-to-region) - (define-key hm--html-region-frame-map "a" 'hm--html-add-address-to-region) - ) - -(defvar hm--html-noregion-structure-map nil - "Noregion sub keymap for inserting entities.") - -(if hm--html-noregion-structure-map - () - (setq hm--html-noregion-structure-map (make-sparse-keymap)) - (define-key hm--html-noregion-structure-map - "i" 'hm--html-add-list-or-menu-item) - (define-key hm--html-noregion-structure-map "m" 'hm--html-add-menu) - (define-key hm--html-noregion-structure-map "u" 'hm--html-add-list) - (define-key hm--html-noregion-structure-map "o" 'hm--html-add-numberlist) - (define-key hm--html-noregion-structure-map "d" 'hm--html-add-directory-list) - (define-key hm--html-noregion-structure-map - "\C-dl" 'hm--html-add-description-list) - (define-key hm--html-noregion-structure-map - "\C-dt" 'hm--html-add-description-title) - (define-key hm--html-noregion-structure-map - "\C-de" 'hm--html-add-description-entry) - (define-key hm--html-noregion-structure-map - "\C-d\C-t" 'hm--html-add-description-title-and-entry) - (define-key hm--html-noregion-structure-map - "\C-tt" 'hm--html-add-table) - (define-key hm--html-noregion-structure-map - "\C-t\C-t" 'hm--html-add-table-title) - (define-key hm--html-noregion-structure-map - "\C-th" 'hm--html-add-table-header) - (define-key hm--html-noregion-structure-map - "\C-tr" 'hm--html-add-first-table-row) - (define-key hm--html-noregion-structure-map - "\C-t\C-r" 'hm--html-add-additional-table-row) - (define-key hm--html-noregion-structure-map "p" 'hm--html-add-paragraph) - (define-key hm--html-noregion-structure-map - "\C-p" 'hm--html-add-paragraph-separator) - (define-key hm--html-noregion-structure-map - [(meta d)] 'hm--html-add-document-division) - (define-key hm--html-noregion-structure-map "\C-m" 'hm--html-add-line-break) - (define-key hm--html-noregion-structure-map - "h" 'hm--html-add-horizontal-rule) - ) - -(defvar hm--html-region-structure-map nil - "Region sub keymap for inserting entities.") - -(if hm--html-region-structure-map - () - (setq hm--html-region-structure-map (make-sparse-keymap)) - (define-key hm--html-region-structure-map - "i" 'hm--html-add-list-or-menu-item-to-region) - (define-key hm--html-region-structure-map "m" 'hm--html-add-menu-to-region) - (define-key hm--html-region-structure-map "u" 'hm--html-add-list-to-region) - (define-key hm--html-region-structure-map - "o" 'hm--html-add-numberlist-to-region) - (define-key hm--html-region-structure-map - "d" 'hm--html-add-directorylist-to-region) - (define-key hm--html-region-structure-map - "\C-dl" 'hm--html-add-description-list-to-region) - (define-key hm--html-region-structure-map - "\C-dt" 'hm--html-add-description-title-to-region) - (define-key hm--html-region-structure-map - "\C-de" 'hm--html-add-description-entry-to-region) - (define-key hm--html-region-structure-map - "\C-tt" 'hm--html-add-table-to-region) - (define-key hm--html-region-structure-map - "\C-t\C-t" 'hm--html-add-table-title-to-region) - (define-key hm--html-region-structure-map - "p" 'hm--html-add-paragraph-to-region) - (define-key hm--html-region-structure-map - [(meta d)] 'hm--html-add-document-division-to-region) - ) - -(defvar hm--html-noregion-formatting-paragraph-map nil - "Noregion sub keymap for inserting paragraph formatting elements.") - -(if hm--html-noregion-formatting-paragraph-map - () - (setq hm--html-noregion-formatting-paragraph-map (make-sparse-keymap)) -; (define-key hm--html-noregion-formatting-paragraph-map -; "o" 'hm--html-add-plaintext) - (define-key hm--html-noregion-formatting-paragraph-map - "p" 'hm--html-add-preformatted) - (define-key hm--html-noregion-formatting-paragraph-map - "b" 'hm--html-add-blockquote) - (define-key hm--html-noregion-formatting-paragraph-map - "\C-b" 'hm--html-add-basefont) - (define-key hm--html-noregion-formatting-paragraph-map - "f" 'hm--html-add-font) - (define-key hm--html-noregion-formatting-paragraph-map - "c" 'hm--html-add-center) - (define-key hm--html-noregion-formatting-paragraph-map - "\C-c" 'hm--html-add-comment) -; (define-key hm--html-noregion-formatting-paragraph-map -; "l" 'hm--html-add-listing) -; (define-key hm--html-noregion-formatting-paragraph-map -; "a" 'hm--html-add-abstract) - ) - -(defvar hm--html-region-formatting-paragraph-map nil - "Region sub keymap for inserting paragraph formatting elements.") - -(if hm--html-region-formatting-paragraph-map - () - (setq hm--html-region-formatting-paragraph-map (make-sparse-keymap)) -; (define-key hm--html-region-formatting-paragraph-map -; "o" 'hm--html-add-plaintext-to-region) - (define-key hm--html-region-formatting-paragraph-map - "p" 'hm--html-add-preformatted-to-region) - (define-key hm--html-region-formatting-paragraph-map - "b" 'hm--html-add-blockquote-to-region) - (define-key hm--html-region-formatting-paragraph-map - "\C-b" 'hm--html-add-basefont-to-region) - (define-key hm--html-region-formatting-paragraph-map - "f" 'hm--html-add-font-to-region) - (define-key hm--html-region-formatting-paragraph-map - "c" 'hm--html-add-center-to-region) - (define-key hm--html-region-formatting-paragraph-map - "\C-c" 'hm--html-add-comment-to-region) -; (define-key hm--html-region-formatting-paragraph-map -; "l" 'hm--html-add-listing-to-region) -; (define-key hm--html-region-formatting-paragraph-map -; "a" 'hm--html-add-abstract-to-region) - ) - -(defvar hm--html-noregion-formatting-word-map nil - "Norgion sub keymap for inserting physical text formatting elements.") - -(if hm--html-noregion-formatting-word-map - () - (setq hm--html-noregion-formatting-word-map (make-sparse-keymap)) - (define-key hm--html-noregion-formatting-word-map - "b" 'hm--html-add-bold) - (define-key hm--html-noregion-formatting-word-map - "i" 'hm--html-add-italic) - (define-key hm--html-noregion-formatting-word-map - "u" 'hm--html-add-underline) - (define-key hm--html-noregion-formatting-word-map - "t" 'hm--html-add-fixed) - (define-key hm--html-noregion-formatting-word-map - "s" 'hm--html-add-strikethru) - (define-key hm--html-noregion-formatting-word-map - "\C-p" 'hm--html-add-superscript) - (define-key hm--html-noregion-formatting-word-map - "\C-b" 'hm--html-add-subscript) - (define-key hm--html-noregion-formatting-word-map - "e" 'hm--html-add-emphasized) - (define-key hm--html-noregion-formatting-word-map - "\C-s" 'hm--html-add-strong) - (define-key hm--html-noregion-formatting-word-map - "\M-s" 'hm--html-add-small) - (define-key hm--html-noregion-formatting-word-map - "\M-b" 'hm--html-add-big) - ) - -(defvar hm--html-region-formatting-word-map nil - "Region sub keymap for inserting word text formatting elements.") - -(if hm--html-region-formatting-word-map - () - (setq hm--html-region-formatting-word-map (make-sparse-keymap)) - (define-key hm--html-region-formatting-word-map - "b" 'hm--html-add-bold-to-region) - (define-key hm--html-region-formatting-word-map - "i" 'hm--html-add-italic-to-region) - (define-key hm--html-region-formatting-word-map - "u" 'hm--html-add-underline-to-region) - (define-key hm--html-region-formatting-word-map - "t" 'hm--html-add-fixed-to-region) - (define-key hm--html-region-formatting-word-map - "s" 'hm--html-add-strikethru-to-region) - (define-key hm--html-region-formatting-word-map - "\C-p" 'hm--html-add-superscript-to-region) - (define-key hm--html-region-formatting-word-map - "\C-b" 'hm--html-add-subscript-to-region) - (define-key hm--html-region-formatting-word-map - "e" 'hm--html-add-emphasized-to-region) - (define-key hm--html-region-formatting-word-map - "\C-s" 'hm--html-add-strong-to-region) - (define-key hm--html-region-formatting-word-map - "\M-s" 'hm--html-add-small-to-region) - (define-key hm--html-region-formatting-word-map - "\M-b" 'hm--html-add-big-to-region) - ) - -(defvar hm--html-noregion-include-map nil - "Noregion sub keymap for include images and other stuff.") - -(if hm--html-noregion-include-map - () - (setq hm--html-noregion-include-map (make-sparse-keymap)) - (define-key hm--html-noregion-include-map - [(control i) (t)] 'hm--html-add-image-top) - (define-key hm--html-noregion-include-map - [(control i) (m)] 'hm--html-add-image-middle) - (define-key hm--html-noregion-include-map - [(control i) (b)] 'hm--html-add-image-bottom) - (define-key hm--html-noregion-include-map "i" 'hm--html-add-image) - (define-key hm--html-noregion-include-map [(meta i)] 'hm--html-add-image-map) - (define-key hm--html-noregion-include-map "m" 'hm--html-add-map) - (define-key hm--html-noregion-include-map [(control a)] 'hm--html-add-area) - (define-key hm--html-noregion-include-map "a" 'hm--html-add-applet) - (define-key hm--html-noregion-include-map "p" 'hm--html-add-applet-parameter) - ) - -(defvar hm--html-region-include-map nil - "Region sub keymap for include images and other stuff.") - -(if hm--html-region-include-map - () - (setq hm--html-region-include-map (make-sparse-keymap)) - (define-key hm--html-region-include-map "m" 'hm--html-add-map-to-region) - (define-key hm--html-region-include-map "a" 'hm--html-add-applet-to-region) - ) - -;(defvar hm--html-noregion-text-elements-map nil -; "Noregion sub keymap for inserting text elements.") - -;(if hm--html-noregion-text-elements-map -; () -; (setq hm--html-noregion-text-elements-map (make-sparse-keymap)) -; ) - -;(defvar hm--html-region-text-elements-map nil -; "Region sub keymap for inserting text elements.") - -;(if hm--html-region-text-elements-map -; () -; (setq hm--html-region-text-elements-map (make-sparse-keymap)) -; ) - -(defvar hm--html-noregion-forms-map nil - "Noregion sub keymap for inserting forms.") - -(if hm--html-noregion-forms-map - () - (setq hm--html-noregion-forms-map (make-sparse-keymap)) - - (define-key hm--html-noregion-forms-map "f" 'hm--html-add-form) - (define-key hm--html-noregion-forms-map "a" 'hm--html-form-add-input-audio) - (define-key hm--html-noregion-forms-map - "c" 'hm--html-form-add-input-checkbox) - (define-key hm--html-noregion-forms-map - "d" 'hm--html-form-add-input-date) - (define-key hm--html-noregion-forms-map - "\C-f" 'hm--html-form-add-input-float) - (define-key hm--html-noregion-forms-map "i" 'hm--html-form-add-input-image) - (define-key hm--html-noregion-forms-map - "\C-i" 'hm--html-form-add-input-integer) - (define-key hm--html-noregion-forms-map - "\M-i" 'hm--html-form-add-input-isindex) - (define-key hm--html-noregion-forms-map - "p" 'hm--html-form-add-input-password) - (define-key hm--html-noregion-forms-map "r" 'hm--html-form-add-input-radio) - (define-key hm--html-noregion-forms-map - "\C-r" 'hm--html-form-add-input-reset) - (define-key hm--html-noregion-forms-map - "\C-s" 'hm--html-form-add-input-scribble) - (define-key hm--html-noregion-forms-map "s" 'hm--html-form-add-input-submit) - (define-key hm--html-noregion-forms-map "t" 'hm--html-form-add-input-text) - (define-key hm--html-noregion-forms-map "u" 'hm--html-form-add-input-url) - (define-key hm--html-noregion-forms-map "o" 'hm--html-form-add-select-option) - (define-key hm--html-noregion-forms-map - "m" 'hm--html-form-add-select-option-menu) - (define-key hm--html-noregion-forms-map - "l" 'hm--html-form-add-select-scrolled-list) - (define-key hm--html-noregion-forms-map "\C-t" 'hm--html-form-add-textarea) - ) - -(defvar hm--html-region-forms-map nil - "Region sub keymap for inserting forms.") - -(if hm--html-region-forms-map - () - (setq hm--html-region-forms-map (make-sparse-keymap)) - - (define-key hm--html-region-forms-map "f" 'hm--html-add-form-to-region) - ) - -(defvar hm--html-region-sub-map-1 nil - "Region sub keymap for the `hm--html-mode'.") - -(if hm--html-region-sub-map-1 - () - (setq hm--html-region-sub-map-1 (make-sparse-keymap)) - (define-key hm--html-region-sub-map-1 "\C-o" hm--html-region-forms-map) - (define-key hm--html-region-sub-map-1 "\C-a" hm--html-region-anchor-map) - (define-key hm--html-region-sub-map-1 "\C-i" hm--html-region-include-map) -; (define-key hm--html-region-sub-map-1 -; "\C-t" hm--html-region-text-elements-map) - (define-key hm--html-region-sub-map-1 "\C-f" hm--html-region-frame-map) - (define-key hm--html-region-sub-map-1 "\C-s" hm--html-region-structure-map) - (define-key hm--html-region-sub-map-1 - "\C-p" hm--html-region-formatting-paragraph-map) - (define-key hm--html-region-sub-map-1 - "\C-w" hm--html-region-formatting-word-map) - ) - -(defvar hm--html-noregion-sub-map-1 nil - "Noregion sub keymap for the `hm--html-mode'.") - -(if hm--html-noregion-sub-map-1 - () - (setq hm--html-noregion-sub-map-1 (make-sparse-keymap)) - - (define-key hm--html-noregion-sub-map-1 "\C-o" hm--html-noregion-forms-map) - (define-key hm--html-noregion-sub-map-1 "\C-a" hm--html-noregion-anchor-map) - (define-key hm--html-noregion-sub-map-1 - [(control i)] hm--html-noregion-include-map) -; (define-key hm--html-noregion-sub-map-1 -; "\C-t" hm--html-noregion-text-elements-map) - (define-key hm--html-noregion-sub-map-1 "\C-f" hm--html-noregion-frame-map) - (define-key hm--html-noregion-sub-map-1 - "\C-s" hm--html-noregion-structure-map) - (define-key hm--html-noregion-sub-map-1 - "\C-p" hm--html-noregion-formatting-paragraph-map) - (define-key hm--html-noregion-sub-map-1 - "\C-w" hm--html-noregion-formatting-word-map) - ) - -(defvar hm--html-region-sub-map nil - "Region sub keymap for the `hm--html-mode'.") - -(if hm--html-region-sub-map - () - (setq hm--html-region-sub-map (make-sparse-keymap)) -; (define-key hm--html-region-sub-map "\C-n" hm--html-noregion-sub-map-1) -; (define-key hm--html-region-sub-map "\C-r" hm--html-region-sub-map-1) - (define-key hm--html-region-sub-map "\M-n" hm--html-noregion-sub-map-1) - (define-key hm--html-region-sub-map "\M-r" hm--html-region-sub-map-1) - - (if (adapt-emacs19p) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-region-sub-map - (vector key-description-list) binding)) -; (single-key-description key-description-list) binding)) - hm--html-region-sub-map-1) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-region-sub-map - key-description-list binding)) - hm--html-region-sub-map-1) - ) - ) - -(defvar hm--html-noregion-sub-map nil - "Noregion keymap for the `hm--html-mode'.") - -(if hm--html-noregion-sub-map - () - (setq hm--html-noregion-sub-map (make-sparse-keymap)) -; (define-key hm--html-noregion-sub-map "\C-n" hm--html-noregion-sub-map-1) -; (define-key hm--html-noregion-sub-map "\C-r" hm--html-region-sub-map-1) - (define-key hm--html-noregion-sub-map "\M-n" hm--html-noregion-sub-map-1) - (define-key hm--html-noregion-sub-map "\M-r" hm--html-region-sub-map-1) - - (if (adapt-emacs19p) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-noregion-sub-map - (vector key-description-list) binding)) -; (single-key-description key-description-list) binding)) - hm--html-noregion-sub-map-1) - (map-keymap '(lambda (key-description-list binding) - (define-key hm--html-noregion-sub-map - key-description-list binding)) - hm--html-noregion-sub-map-1) - ) - ) - -(defvar hm--html-mode-map nil - "Normal and noregion keymap for the `hm--html-mode'.") - -(if hm--html-mode-map - () - (setq hm--html-mode-map (make-sparse-keymap)) - (define-key hm--html-mode-map - hm--html-mode-prefix-key hm--html-noregion-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-mode-map '(button3) 'hm--html-popup-menu) - (define-key hm--html-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) -; (define-key hm--html-mode-map [down-mouse-3] 'hm--html-popup-menu) - (if hm--html-expert - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - (define-key hm--html-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - (if hm--html-bind-latin-1-char-entities - (progn - (define-key hm--html-mode-map [adiaeresis] 'hm--html_ae) - (define-key hm--html-mode-map [odiaeresis] 'hm--html_oe) - (define-key hm--html-mode-map [udiaeresis] 'hm--html_ue) - (define-key hm--html-mode-map [aring] 'hm--html_aa) - (define-key hm--html-mode-map [Adiaeresis] 'hm--html_Ae) - (define-key hm--html-mode-map [Odiaeresis] 'hm--html_Oe) - (define-key hm--html-mode-map [Udiaeresis] 'hm--html_Ue) - (define-key hm--html-mode-map [Aring] 'hm--html_Aa) - (define-key hm--html-mode-map [ediaeresis] 'hm--html_ediaeresis) - (define-key hm--html-mode-map [Ediaeresis] 'hm--html_Ediaeresis) - (define-key hm--html-mode-map [idiaeresis] 'hm--html_idiaeresis) - (define-key hm--html-mode-map [Idiaeresis] 'hm--html_Idiaeresis) - (define-key hm--html-mode-map [ssharp] 'hm--html_sz) - (define-key hm--html-mode-map [aacute] 'hm--html_aacute) - (define-key hm--html-mode-map [eacute] 'hm--html_eacute) - (define-key hm--html-mode-map [iacute] 'hm--html_iacute) - (define-key hm--html-mode-map [oacute] 'hm--html_oacute) - (define-key hm--html-mode-map [uacute] 'hm--html_uacute) - (define-key hm--html-mode-map [Aacute] 'hm--html_Aacute) - (define-key hm--html-mode-map [Eacute] 'hm--html_Eacute) - (define-key hm--html-mode-map [Iacute] 'hm--html_Iacute) - (define-key hm--html-mode-map [Oacute] 'hm--html_Oacute) - (define-key hm--html-mode-map [Uacute] 'hm--html_Uacute) - (define-key hm--html-mode-map [agrave] 'hm--html_agrave) - (define-key hm--html-mode-map [egrave] 'hm--html_egrave) - (define-key hm--html-mode-map [igrave] 'hm--html_igrave) - (define-key hm--html-mode-map [ograve] 'hm--html_ograve) - (define-key hm--html-mode-map [ugrave] 'hm--html_ugrave) - (define-key hm--html-mode-map [Agrave] 'hm--html_Agrave) - (define-key hm--html-mode-map [Egrave] 'hm--html_Egrave) - (define-key hm--html-mode-map [Igrave] 'hm--html_Igrave) - (define-key hm--html-mode-map [Ograve] 'hm--html_Ograve) - (define-key hm--html-mode-map [Ugrave] 'hm--html_Ugrave) - (define-key hm--html-mode-map [ccedilla] 'hm--html_ccedilla) - (define-key hm--html-mode-map [Ccedilla] 'hm--html_Ccedilla) - (define-key hm--html-mode-map [acircumflex] 'hm--html_acircumflex) - (define-key hm--html-mode-map [ecircumflex] 'hm--html_ecircumflex) - (define-key hm--html-mode-map [icircumflex] 'hm--html_icircumflex) - (define-key hm--html-mode-map [ocircumflex] 'hm--html_ocircumflex) - (define-key hm--html-mode-map [ucircumflex] 'hm--html_ucircumflex) - (define-key hm--html-mode-map [Acircumflex] 'hm--html_Acircumflex) - (define-key hm--html-mode-map [Ecircumflex] 'hm--html_Ecircumflex) - (define-key hm--html-mode-map [Icircumflex] 'hm--html_Icircumflex) - (define-key hm--html-mode-map [Ocircumflex] 'hm--html_Ocircumflex) - (define-key hm--html-mode-map [Ucircumflex] 'hm--html_Ucircumflex) - (define-key hm--html-mode-map [atilde] 'hm--html_atilde) - (define-key hm--html-mode-map [otilde] 'hm--html_otilde) - (define-key hm--html-mode-map [ntilde] 'hm--html_ntilde) - (define-key hm--html-mode-map [Atilde] 'hm--html_Atilde) - (define-key hm--html-mode-map [Otilde] 'hm--html_Otilde) - (define-key hm--html-mode-map [Ntilde] 'hm--html_Ntilde) - (define-key hm--html-mode-map [eth] 'hm--html_eth) - (define-key hm--html-mode-map [ETH] 'hm--html_Eth) - (define-key hm--html-mode-map [thorn] 'hm--html_thorn) - (define-key hm--html-mode-map [THORN] 'hm--html_Thorn) - )) - (define-key hm--html-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-mode-map "&" 'hm--html-smart-ampersand) - ) - -(defvar hm--html-region-mode-map nil - "Region keymap for the `hm--html-mode'.") - -(if hm--html-region-mode-map - () - (setq hm--html-region-mode-map (make-sparse-keymap)) - (define-key hm--html-region-mode-map - hm--html-mode-prefix-key hm--html-region-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-region-mode-map - '(button3) 'hm--html-popup-menu-region) - (define-key hm--html-region-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) -; (define-key hm--html-region-mode-map -; [down-mouse-3] 'hm--html-popup-menu-region) - (if hm--html-expert - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map)) - (define-key hm--html-region-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - ;; It maybe a better idea to set the following to undefine in this list... -; (if hm--html-bind-latin-1-char-entities -; (progn -; (define-key hm--html-region-mode-map [adiaeresis] 'hm--html_ae) -; (define-key hm--html-region-mode-map [odiaeresis] 'hm--html_oe) -; (define-key hm--html-region-mode-map [udiaeresis] 'hm--html_ue) -; (define-key hm--html-region-mode-map [aring] 'hm--html_aa) -; (define-key hm--html-region-mode-map [Adiaeresis] 'hm--html_Ae) -; (define-key hm--html-region-mode-map [Odiaeresis] 'hm--html_Oe) -; (define-key hm--html-region-mode-map [Udiaeresis] 'hm--html_Ue) -; (define-key hm--html-region-mode-map [Aring] 'hm--html_Aa) -; (define-key hm--html-region-mode-map -; [ediaeresis] 'hm--html_ediaeresis) -; (define-key hm--html-region-mode-map -; [Ediaeresis] 'hm--html_Ediaeresis) -; (define-key hm--html-region-mode-map -; [idiaeresis] 'hm--html_idiaeresis) -; (define-key hm--html-region-mode-map -; [Idiaeresis] 'hm--html_Idiaeresis) -; (define-key hm--html-region-mode-map [ssharp] 'hm--html_sz) -; (define-key hm--html-region-mode-map [aacute] 'hm--html_aacute) -; (define-key hm--html-region-mode-map [eacute] 'hm--html_eacute) -; (define-key hm--html-region-mode-map [iacute] 'hm--html_iacute) -; (define-key hm--html-region-mode-map [oacute] 'hm--html_oacute) -; (define-key hm--html-region-mode-map [uacute] 'hm--html_uacute) -; (define-key hm--html-region-mode-map [Aacute] 'hm--html_Aacute) -; (define-key hm--html-region-mode-map [Eacute] 'hm--html_Eacute) -; (define-key hm--html-region-mode-map [Iacute] 'hm--html_Iacute) -; (define-key hm--html-region-mode-map [Oacute] 'hm--html_Oacute) -; (define-key hm--html-region-mode-map [Uacute] 'hm--html_Uacute) -; (define-key hm--html-region-mode-map [agrave] 'hm--html_agrave) -; (define-key hm--html-region-mode-map [egrave] 'hm--html_egrave) -; (define-key hm--html-region-mode-map [igrave] 'hm--html_igrave) -; (define-key hm--html-region-mode-map [ograve] 'hm--html_ograve) -; (define-key hm--html-region-mode-map [ugrave] 'hm--html_ugrave) -; (define-key hm--html-region-mode-map [Agrave] 'hm--html_Agrave) -; (define-key hm--html-region-mode-map [Egrave] 'hm--html_Egrave) -; (define-key hm--html-region-mode-map [Igrave] 'hm--html_Igrave) -; (define-key hm--html-region-mode-map [Ograve] 'hm--html_Ograve) -; (define-key hm--html-region-mode-map [Ugrave] 'hm--html_Ugrave) -; (define-key hm--html-region-mode-map [ccedilla] 'hm--html_ccedilla) -; (define-key hm--html-region-mode-map [Ccedilla] 'hm--html_Ccedilla) -; (define-key hm--html-region-mode-map -; [acircumflex] 'hm--html_acircumflex) -; (define-key hm--html-region-mode-map -; [ecircumflex] 'hm--html_ecircumflex) -; (define-key hm--html-region-mode-map -; [icircumflex] 'hm--html_icircumflex) -; (define-key hm--html-region-mode-map -; [ocircumflex] 'hm--html_ocircumflex) -; (define-key hm--html-region-mode-map -; [ucircumflex] 'hm--html_ucircumflex) -; (define-key hm--html-region-mode-map -; [Acircumflex] 'hm--html_Acircumflex) -; (define-key hm--html-region-mode-map -; [Ecircumflex] 'hm--html_Ecircumflex) -; (define-key hm--html-region-mode-map -; [Icircumflex] 'hm--html_Icircumflex) -; (define-key hm--html-region-mode-map -; [Ocircumflex] 'hm--html_Ocircumflex) -; (define-key hm--html-region-mode-map -; [Ucircumflex] 'hm--html_Ucircumflex) -; (define-key hm--html-region-mode-map [atilde] 'hm--html_atilde) -; (define-key hm--html-region-mode-map [otilde] 'hm--html_otilde) -; (define-key hm--html-region-mode-map [ntilde] 'hm--html_ntilde) -; (define-key hm--html-region-mode-map [Atilde] 'hm--html_Atilde) -; (define-key hm--html-region-mode-map [Otilde] 'hm--html_Otilde) -; (define-key hm--html-region-mode-map [Ntilde] 'hm--html_Ntilde) -; (define-key hm--html-region-mode-map [eth] 'hm--html_eth) -; (define-key hm--html-region-mode-map [ETH] 'hm--html_Eth) -; (define-key hm--html-region-mode-map [thorn] 'hm--html_thorn) -; (define-key hm--html-region-mode-map [THORN] 'hm--html_Thorn) -; )) - (define-key hm--html-region-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-region-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-region-mode-map "&" 'hm--html-smart-ampersand) - ) - - -;;; For the hm--html minor modes -(defvar hm--html-minor-mode-map nil - "Normal and noregion keymap for the `hm--html-minor-mode'.") - -(if hm--html-minor-mode-map - () - (setq hm--html-minor-mode-map (make-sparse-keymap)) - (define-key hm--html-minor-mode-map - hm--html-minor-mode-prefix-key hm--html-noregion-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-minor-mode-map - '(button3) 'hm--html-popup-minor-html-menu) - (define-key hm--html-minor-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) - (if hm--html-expert - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - (define-key hm--html-minor-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - (define-key hm--html-minor-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-minor-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-minor-mode-map "&" 'hm--html-smart-ampersand) - ) - - -(defvar hm--html-minor-region-mode-map nil - "Region keymap for the `hm--html-minor-mode'.") - -(if hm--html-minor-region-mode-map - () - (setq hm--html-minor-region-mode-map (make-sparse-keymap)) - (define-key hm--html-minor-region-mode-map - hm--html-minor-mode-prefix-key hm--html-region-sub-map) - (if (adapt-xemacsp) - (progn - (define-key hm--html-minor-region-mode-map - '(button3) 'hm--html-popup-minor-html-menu-region) - (define-key hm--html-minor-region-mode-map - [(meta control button1)] 'idd-mouse-drag-and-drop)) - (if hm--html-expert - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map)) - (define-key hm--html-minor-region-mode-map - [(meta control mouse-1)] 'idd-mouse-drag-and-drop)) - (define-key hm--html-minor-region-mode-map "<" 'hm--html-smart-less-than) - (define-key hm--html-minor-region-mode-map ">" 'hm--html-smart-greater-than) - (define-key hm--html-minor-region-mode-map "&" 'hm--html-smart-ampersand) - ) - - -;;; Announce the feature hm--html-keys -(provide 'hm--html-keys)
--- a/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,860 +0,0 @@ -;;; hm--html-menu --- A menu for the hm--html-mode. -;;; -;;; $Id: hm--html-menu.el,v 1.8 1997/07/26 22:09:45 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines pulldown and popup menus for the html mode (hm--html-mode). -;;; -;;; You should also have the w3 package from William M. Perry, for -;;; browsing html- files in the xemacs and the program Xmosaic together -;;; with the file html-view.el from Ron Tapia for browsing html- files -;;; in the Xmosaic. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; -;;; Look at the files hm--html-mode.el and hm--html-configuration -;;; for further installation points. -;;; - -;; -;; Menu "HTML" -;; - -(defvar hm--html-pulldown-menu nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-region-expert nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-region-novice nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-noregion-expert nil "*A List with the HTML-Menu.") -(defvar hm--html-menu-noregion-novice nil "*A List with the HTML-Menu.") - -(setq hm--html-menu-noregion-expert - '("HTML Noregion Expert Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link t] - ["General link..." hm--html-add-normal-link t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link t] - ["Info link..." hm--html-add-info-link t] - ["Gopher link..." hm--html-add-gopher-link t] - ["File link..." hm--html-add-file-link t] - "----" - ["Ftp link..." hm--html-add-ftp-link t] - ["News link..." hm--html-add-news-link t] - ["Mailbox link..." hm--html-add-mail-box-link t] - ["Mailto link..." hm--html-add-mailto-link t] - ["Wais link (direct)..." hm--html-add-direct-wais-link t] - ["Wais link (gateway)..." hm--html-add-wais-link t] - "----" - ["Proggate link..." hm--html-add-proggate-link t] - ["Local Proggate link..." hm--html-add-local-proggate-link t] - "----" - ["Link target..." hm--html-add-link-target t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame t] - ["Frame template..." - (hm--html-insert-template hm--html-frame-template-file) - (file-exists-p hm--html-frame-template-file)] - "----" - ["Doctype" hm--html-add-doctype t] - ["Html" hm--html-add-html t] - ["Head" hm--html-add-head t] - ["Body" hm--html-add-body t] - "----" - ["Title and Header..." hm--html-add-title-and-header t] - ["Title..." hm--html-add-title t] - ["Header..." hm--html-add-header t] - ["Address" hm--html-add-address t] - ["Signature" hm--html-add-signature t] - "----" - ["Meta information..." hm--html-add-meta t] - ["Node Link..." hm--html-add-normal-node-link t] - ["Isindex..." hm--html-add-isindex t] - ["Document Base..." hm--html-add-base t] - "----" - ["Created comment" hm--html-insert-created-comment t] - ["Changed comment" hm--html-insert-changed-comment t] - ["Modified line" hm--html-insert-modified-line t] - ["New date in title" hm--html-new-date t] - ) - ("Structure" - ["Menu or list item" hm--html-add-list-or-menu-item t] - ["Menu" hm--html-add-menu t] - ["Unordered list" hm--html-add-list t] - ["Ordered list" hm--html-add-numberlist t] - ["Directory list" hm--html-add-directory-list t] - "----" - ["Description list" hm--html-add-description-list t] - ["Description title" hm--html-add-description-title t] - ["Description entry" hm--html-add-description-entry t] - ["Description title + entry" - hm--html-add-description-title-and-entry t] - "----" - ["Table..." hm--html-add-table t] - ["Table title..." hm--html-add-table-title t] - ["Table header..." hm--html-add-table-header t] - ["Table first row..." hm--html-add-first-table-row t] - ["Table additional row..." hm--html-add-additional-table-row t] - ("Additional Commands" - ["Table row frame..." hm--html-add-row-frame t] - ["Table header entry..." hm--html-add-header-entry t] - ["Table row entry..." hm--html-add-row-entry t] - ["Span columns..." hm--html-table-add-colspan-attribute t] - ["Span rows..." hm--html-table-add-rowspan-attribute t] - ) - "----" - ["Paragraph container" hm--html-add-paragraph t] - ["Paragraph start tag" hm--html-add-paragraph-separator t] - ["Document division" hm--html-add-document-division t] - ["New line" hm--html-add-line-break t] - ["Horizontal rule" hm--html-add-horizontal-rule t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext t] - ["Preformatted" hm--html-add-preformatted t] - ["Blockquote" hm--html-add-blockquote t] - "----" - ["Basefont..." hm--html-add-basefont t] - ["Font..." hm--html-add-font t] - ["Center" hm--html-add-center t] - ["Style" hm--html-add-style t] - "----" - ["HTML Comment" hm--html-add-comment t] -; ["Listing" hm--html-add-listing t] -; ["Abstract" hm--html-add-abstract t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold t] - ["Italic" hm--html-add-italic t] - ["Typewriter" hm--html-add-fixed t] - ["Small" hm--html-add-small t] - ["Big" hm--html-add-big t] - ["Superscript" hm--html-add-superscript t] - ["Subscript" hm--html-add-subscript t] - "----" - ["Underline" hm--html-add-underline t] - ["Strikethru" hm--html-add-strikethru t] - "----" -; ["Emphasized" hm--html-add-emphasized t] -; ["Strong" hm--html-add-strong t] -; "----" - ("Phrase" - ["Emphasized" hm--html-add-emphasized t] - ["Strong" hm--html-add-strong t] - "----" - ["Definition" hm--html-add-definition t] - ["Keyboard" hm--html-add-keyboard t] - ["Variable" hm--html-add-variable t] - ["Code" hm--html-add-code t] - ["Sample" hm--html-add-sample t] - ["Citation" hm--html-add-citation t] - ) -;; All the following commands are still implemented, but most -;; of them are not defined in HTM 3.2 -;; You've to load hm--html-not-standard.el to use them -; ("Computing" -; ["Definition" hm--html-add-definition t] -; ["Keyboard" hm--html-add-keyboard t] -; ["Command" hm--html-add-command t] -; ["Argument" hm--html-add-argument t] -; ["Option" hm--html-add-option t] -; ["Variable" hm--html-add-variable t] -; ["Instance" hm--html-add-instance t] -; ["Code" hm--html-add-code t] -; ["Sample" hm--html-add-sample t] -; ) -; ("Literature" -; ["Quote" hm--html-add-quote t] -; ["Acronym" hm--html-add-acronym t] -; ["Abbreviation" hm--html-add-abbreviation t] -; ["Citation" hm--html-add-citation t] -; ["Literature" hm--html-add-literature t] -; ["Publication" hm--html-add-publication t] -; ["ISBN" hm--html-add-isbn t] -; ) -; ("Person" -; ["Person" hm--html-add-person t] -; ["Author" hm--html-add-author t] -; ["Editor" hm--html-add-editor t] -; ["Credits" hm--html-add-credits t] -; ["Copyright" hm--html-add-copyright t] -; ) -; "----" -; ["Footnote" hm--html-add-footnote t] -; ["Margin" hm--html-add-margin t] -; "----" -; ["HTML Comment" hm--html-add-comment t] - ) - ("Include" - ["Top aligned image..." hm--html-add-image-top t] - ["Middle aligned image..." hm--html-add-image-middle t] - ["Bottom aligned image..." hm--html-add-image-bottom t] - ["Image as map? ..." hm--html-add-image t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Image map..." hm--html-add-image-map t] - ["Map..." hm--html-add-map t] - ["Area..." hm--html-add-area t] - "----" - ["Applet..." hm--html-add-applet t] - ["Parameter..." hm--html-add-applet-parameter t] - ["Script" hm--html-add-script t] -; "----" -; ["File..." hm--html-add-server-side-include-file t] -; ["Command..." hm--html-add-server-side-include-command t] -; ["Command with isindex parameter..." -; hm--html-add-server-side-include-command-with-isindex-parameter -; t] - ) - ("Forms" - ["Form..." hm--html-add-form t] - "----" - ["Text field..." hm--html-form-add-input-text t] - ["Password field..." hm--html-form-add-input-password t] - ["Isindex field..." hm--html-form-add-input-isindex t] - ["Integer field..." hm--html-form-add-input-integer t] - ["Float field..." hm--html-form-add-input-float t] - ["Date field..." hm--html-form-add-input-date t] - ["Url field..." hm--html-form-add-input-url t] - ["Scribble field..." hm--html-form-add-input-scribble t] - "----" - ["Checkbox button..." hm--html-form-add-input-checkbox t] - ["Radio button..." hm--html-form-add-input-radio t] - ["Reset button..." hm--html-form-add-input-reset t] - ["Submit button..." hm--html-form-add-input-submit t] - ["Image button..." hm--html-form-add-input-image t] - ["Audio button..." hm--html-form-add-input-audio t] - "----" - ["Option Menu..." hm--html-form-add-select-option-menu t] - ["Scrolled List..." hm--html-form-add-select-scrolled-list t] - ["Option..." hm--html-form-add-select-option t] - "----" - ["Textarea..." hm--html-form-add-textarea t] - ) - )) - - -(setq hm--html-menu-noregion-novice - '("HTML No-region Novice Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link t] - ["File link..." hm--html-add-file-link t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame t] - "----" - ["Title and Header..." hm--html-add-title-and-header t] - ["Signature" hm--html-add-signature t] - ) - ("Structure" - ["Menu item" hm--html-add-list-or-menu-item t] - ["Menu" hm--html-add-menu t] - "----" - ["Paragraph Container" hm--html-add-paragraph t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext t] - ["Preformatted" hm--html-add-preformatted t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold t] - ["Italic" hm--html-add-italic t] - ["Underline" hm--html-add-underline t] - ["Typewriter" hm--html-add-fixed t] - ))) - -(setq hm--html-menu-region-expert - '("HTML Region Expert Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link-to-region t] - ["General link..." hm--html-add-normal-link-to-region t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link-to-region t] - ["Info link..." hm--html-add-info-link-to-region t] - ["Gopher link..." hm--html-add-gopher-link-to-region t] - ["File link..." hm--html-add-file-link-to-region t] - "----" - ["Ftp link..." hm--html-add-ftp-link-to-region t] - ["News link..." hm--html-add-news-link-to-region t] - ["Mailbox link..." hm--html-add-mail-box-link-to-region t] - ["Mailto link..." hm--html-add-mailto-link-to-region t] - ["WAIS link (direct)..." hm--html-add-direct-wais-link-to-region t] - ["WAIS link (gateway)..." hm--html-add-wais-link-to-region t] - "----" - ["Proggate link..." hm--html-add-proggate-link-to-region t] - ["Local Proggate link..." - hm--html-add-local-proggate-link-to-region - t] - "----" - ["Link target..." hm--html-add-link-target-to-region t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame-with-region t] - "----" - ["Head" hm--html-add-head-to-region t] - ["Body" hm--html-add-body-to-region t] - "----" - ["Title and Header..." hm--html-add-title-and-header-to-region t] - ["Title" hm--html-add-title-to-region t] - ["Header..." hm--html-add-header-to-region t] - ["Address" hm--html-add-address-to-region t] - ) - ("Structure" - ["Menu item" hm--html-add-list-or-menu-item-to-region t] - ["Menu" hm--html-add-menu-to-region t] - ["Unordered list" hm--html-add-list-to-region t] - ["Ordered list" hm--html-add-numberlist-to-region t] - ["Directory list" hm--html-add-directorylist-to-region t] - "----" - ["Description list" hm--html-add-description-list-to-region t] - ["Description title" hm--html-add-description-title-to-region t] - ["Description entry" hm--html-add-description-entry-to-region t] - "----" - ["Table..." hm--html-add-table-to-region t] - ["Table Title..." hm--html-add-table-title-to-region t] - ("Additional Commands" - ["Table row frame..." hm--html-add-row-frame-to-region t] - ) - "----" - ["Paragraph container" hm--html-add-paragraph-to-region t] - ["Document division" hm--html-add-document-division-to-region t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext-to-region t] - ["Preformatted" hm--html-add-preformatted-to-region t] - ["Blockquote" hm--html-add-blockquote-to-region t] - "----" - ["Font..." hm--html-add-font-to-region t] - ["Center" hm--html-add-center-to-region t] - ["Style" hm--html-add-style-to-region t] - "----" - ["HTML Comment" hm--html-add-comment-to-region t] -; ["Listing" hm--html-add-listing-to-region t] -; ["Abstract" hm--html-add-abstract-to-region t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold-to-region t] - ["Italic" hm--html-add-italic-to-region t] - ["Typewriter" hm--html-add-fixed-to-region t] - ["Small" hm--html-add-small-to-region t] - ["Big" hm--html-add-big-to-region t] - ["Superscript" hm--html-add-superscript-to-region t] - ["Subscript" hm--html-add-subscript-to-region t] - "----" - ["Underline" hm--html-add-underline-to-region t] - ["Strikethru" hm--html-add-strikethru-to-region t] - ;; ["Render" hm--html-add-render-to-region t] - "----" -; ["Emphasized" hm--html-add-emphasized-to-region t] -; ["Strong" hm--html-add-strong-to-region t] -; "----" - ("Phrase" - ["Emphasized" hm--html-add-emphasized-to-region t] - ["Strong" hm--html-add-strong-to-region t] - "----" - ["Definition" hm--html-add-definition-to-region t] - ["Keyboard" hm--html-add-keyboard-to-region t] - ["Variable" hm--html-add-variable-to-region t] - ["Code" hm--html-add-code-to-region t] - ["Sample" hm--html-add-sample-to-region t] - ["Citation" hm--html-add-citation-to-region t] - ) -;; All the following commands are still implemented, but most -;; of them are not defined in HTM 3.2 -; ("Computing" -; ["Definition" hm--html-add-definition-to-region t] -; ["Keyboard" hm--html-add-keyboard-to-region t] -; ["Command" hm--html-add-command-to-region t] -; ["Argument" hm--html-add-argument-to-region t] -; ["Option" hm--html-add-option-to-region t] -; ["Variable" hm--html-add-variable-to-region t] -; ["Instance" hm--html-add-instance-to-region t] -; ["Code" hm--html-add-code-to-region t] -; ["Sample" hm--html-add-sample-to-region t] -; ) -; ("Literature" -; ["Quote" hm--html-add-quote-to-region t] -; ["Acronym" hm--html-add-acronym-to-region t] -; ["Abbrevation" hm--html-add-abbrevation-to-region t] -; ["Citation" hm--html-add-citation-to-region t] -; ["Literature" hm--html-add-literature-to-region t] -; ["Publication" hm--html-add-publication-to-region t] -; ["ISBN" hm--html-add-isbn-to-region t] -; ) -; ("Person" -; ["Person" hm--html-add-person-to-region t] -; ["Author" hm--html-add-author-to-region t] -; ["Editor" hm--html-add-editor-to-region t] -; ["Credits" hm--html-add-credits-to-region t] -; ["Copyright" hm--html-add-copyright-to-region t] -; ) -; "----" -; ["Footnote" hm--html-add-footnote-to-region t] -; ["Margin" hm--html-add-margin-to-region t] -; "----" -; ["HTML Comment" hm--html-add-comment-to-region t] - ) - ("Include" - ["Map..." hm--html-add-map-to-region t] - "----" - ["Applet..." hm--html-add-applet-to-region t] - ["Script" hm--html-add-script-to-region t] - ) - ("Forms" - ["Form..." hm--html-add-form-to-region t]) - )) - - -(setq hm--html-menu-region-novice - '("HTML Region Novice Menu" - ("Anchors" - ["Relative link..." hm--html-add-relative-link-to-region t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - "----" - ["Html link..." hm--html-add-html-link-to-region t] - ["File link..." hm--html-add-file-link-to-region t] - ) - ("Frame" - ["Full html frame..." hm--html-add-full-html-frame-with-region t] - "----" - ["Title and Header..." hm--html-add-title-and-header-to-region t] - ) - ("Structure" - ["Menu item" hm--html-add-list-or-menu-item-to-region t] - ["Menu" hm--html-add-menu-to-region t] - ) - ("Formatting Paragraphs" -; ["Without links" hm--html-add-plaintext-to-region t] - ["Preformatted" hm--html-add-preformatted-to-region t] - ) - ("Formatting Words" - ["Bold" hm--html-add-bold-to-region t] - ["Italic" hm--html-add-italic-to-region t] - ["Underline" hm--html-add-underline-to-region t] - ["Typewriter" hm--html-add-fixed-to-region t] - ) - )) - - -(if (adapt-xemacsp) - ;; The reason for this if form is, that the Emacs 19 can't - ;; work correct with `:keys "\\[idd-help-mouse-drag-and-drop]"' - (setq hm--html-pulldown-menu - '("HTML Config Menu" - ("Set popup menu" - ["Novice menu" - hm--html-use-novice-menu - :active t - :style radio - :selected (not hm--html-expert)] - ["Expert menu" - hm--html-use-expert-menu - :active t - :style radio - :selected hm--html-expert] - ) - ["Reload config files" hm--html-load-config-files t] - ["Templates (fixed dirs) ..." - hm--html-insert-template-from-fixed-dirs - t] - ["Templates ..." hm--html-insert-template t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t - :keys "\\[idd-mouse-drag-and-drop]"] - ["Drag & Drop Help" - idd-start-help-mouse-drag-and-drop - :active t - :keys "\\[idd-help-mouse-drag-and-drop]"] - "----" - ["Remove numeric names" hm--html-remove-numeric-names t] - ["Quotify hrefs" hm--html-quotify-hrefs t] - "----" - ["Submit bug report..." hm--html-submit-bug-report t] - ["WWW Package Docs" hm--html-view-www-package-docu t] - "----" - ("Preview Document" - ["Netscape view buffer" (hm--html-send-buffer-to-netscape - (current-buffer)) t] - "----" - ["Xmosaic start" html-view-start-mosaic t] - ["Xmosaic view buffer" html-view-view-buffer t] - ["Xmosaic view file" html-view-view-file t] - ["Xmosaic goto url" html-view-goto-url t] - ["Xmosaic get display" html-view-get-display t] - "----" - ["W3 start" w3 t] - ["W3 view buffer" w3-preview-this-buffer t] - ["W3 open remote file..." w3-fetch t] - ["W3 open local..." w3-open-local t] - ["W3 use hotlist..." w3-use-hotlist t] - ) - )) - (setq hm--html-pulldown-menu - '("HTML Config Menu" - ("Set popup menu" - ["Novice menu" - hm--html-use-novice-menu - :active t - :style radio - :selected (not hm--html-expert)] - ["Expert menu" - hm--html-use-expert-menu - :active t - :style radio - :selected hm--html-expert] - ) - ["Reload config files" hm--html-load-config-files t] - ["Templates (fixed dirs) ..." - hm--html-insert-template-from-fixed-dirs - t] - ["Templates ..." hm--html-insert-template t] - ["Drag & Drop" - idd-start-mouse-drag-and-drop - :active t] - ["Drag & Drop Help" - idd-start-help-mouse-drag-and-drop - :active t] - "----" - ["Remove numeric names" hm--html-remove-numeric-names t] - ["Quotify hrefs" hm--html-quotify-hrefs t] - "----" - ["Submit bug report..." hm--html-submit-bug-report t] - ["WWW Package Docs" hm--html-view-www-package-docu t] - "----" - ("Preview Document" - ["Netscape view buffer" (hm--html-send-buffer-to-netscape - (current-buffer)) t] - "----" - ["Xmosaic start" html-view-start-mosaic t] - ["Xmosaic view buffer" html-view-view-buffer t] - ["Xmosaic view file" html-view-view-file t] - ["Xmosaic goto url" html-view-goto-url t] - ["Xmosaic get display" html-view-get-display t] - "----" - ["W3 start" w3 t] - ["W3 view buffer" w3-preview-this-buffer t] - ["W3 open remote file..." w3-fetch t] - ["W3 open local..." w3-open-local t] - ["W3 use hotlist..." w3-use-hotlist t] - ) - )) - ) - -(if (adapt-xemacsp) - (defun hm--install-html-menu (menu-name) - (if (and current-menubar (not (assoc menu-name current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-submenu nil - (cons menu-name (cdr hm--html-pulldown-menu)) - "HTML")))) - - (defun hm--install-html-menu (menu-name) - (if (eq major-mode 'hm--html-mode) - (easy-menu-define hm--html-menu-map - hm--html-mode-map - "The hm--html-mode pulldown menu." - (cons menu-name - (cdr hm--html-pulldown-menu))) - (easy-menu-define hm--html-minor-menu-map - hm--html-minor-mode-map - "The hm--html-minor-mode pulldown menu." - (cons menu-name - (cdr hm--html-pulldown-menu)))) - )) - -(if (adapt-emacs19p) - (progn - - (setq hm--html-menu-noregion-expert-map - (make-lucid-menu-keymap (car hm--html-menu-noregion-expert) - (cdr hm--html-menu-noregion-expert))) - - (setq hm--html-menu-region-expert-map - (make-lucid-menu-keymap (car hm--html-menu-region-expert) - (cdr hm--html-menu-region-expert))) - - (setq hm--html-menu-noregion-novice-map - (make-lucid-menu-keymap (car hm--html-menu-noregion-novice) - (cdr hm--html-menu-noregion-novice))) - - (setq hm--html-menu-region-novice-map - (make-lucid-menu-keymap (car hm--html-menu-region-novice) - (cdr hm--html-menu-region-novice))) - - ;; Speeds up the first popup of a menu - (if hm--html-expert - (progn - (x-popup-menu nil hm--html-menu-noregion-expert-map) - (x-popup-menu nil hm--html-menu-region-expert-map) - ) - (x-popup-menu nil hm--html-menu-noregion-novice-map) - (x-popup-menu nil hm--html-menu-region-novice-map)) - - - ) - - (defun hm--html-popup-menu (event) - "Pops the HTML- menu up, if no region is active." - (interactive "@e") - (if hm--html-expert - (popup-menu hm--html-menu-noregion-expert) - (popup-menu hm--html-menu-noregion-novice))) - - - (defun hm--html-popup-menu-region (event) - "Pops the HTML- menu up, if a region is active." - (interactive "@e") - (if hm--html-expert - (popup-menu hm--html-menu-region-expert) - (popup-menu hm--html-menu-region-novice))) - ) - - -(if (adapt-xemacsp) - (progn - - (defun hm--html-use-novice-menu () - "Changes the HTML popup menu to the novice menu." - (interactive) - (setq hm--html-expert nil) - ) - - - (defun hm--html-use-expert-menu () - "Changes the HTML popup menu to the expert menu." - (interactive) - (setq hm--html-expert t) - ) - ) - - ;; For the Emacs 19 - (defun hm--html-use-novice-menu () - "Changes the HTML popup menu to the novice menu." - (interactive) - (setq hm--html-expert nil) - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map) - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-novice-map) - (if (not hm--html-region-mode) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - (if (not hm--html-minor-region-mode) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map)) - ) - - (defun hm--html-use-expert-menu () - "Changes the HTML popup menu to the expert menu." - (interactive) - (setq hm--html-expert t) - (define-key hm--html-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (define-key hm--html-minor-region-mode-map - hm--html-emacs19-popup-region-menu-button - hm--html-menu-region-expert-map) - (if (not hm--html-region-mode) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map)) - (if (not hm--html-minor-region-mode) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map)) - ) - ) - - -(defvar hm--html-use-psgml t - "Set this to t, if functions from the psgml-mode should be used.") - -;;; Popup the menus in the minor mode - -(if (adapt-xemacsp) - (progn - - (defadvice sgml-xemacs-get-popup-value (around - hm--html-popup-menu-advice - activate) - "Calls `hm--html-sgml-xemacs-get-popup-value' instead of the original. -`hm--html-sgml-xemacs-get-popup-value' is only called, if the -`hm--html-minor-mode' is active. -`hm--html-sgml-xemacs-get-popup-value' adds the 'hm--html-mode' popup -menus to the psgml popup menu." - (if hm--html-minor-mode - (setq ad-return-value - (hm--html-sgml-xemacs-get-popup-value (ad-get-arg 0))) - ad-do-it)) - - (defun hm--html-sgml-xemacs-get-popup-value (menudesc) - (let ((value nil) - (event nil)) - ;; (popup-menu menudesc) - (popup-menu (append hm--html-popup-menu ; for the hm--html-menu - (list "==" ; - (car menudesc) ; - "==") ; - (cdr menudesc))) ; - (while (popup-up-p) - (setq event (next-command-event event)) - (cond ((misc-user-event-p event) - (cond - ((eq (event-object event) 'abort) - (signal 'quit nil)) - ((eq (event-object event) 'menu-no-selection-hook) - nil) - ((commandp (event-object event)) ; for the - (set-mark hm--html-mark) ; - (goto-char hm--html-point) ; - (call-interactively (event-object event)) ; hm--html-menu - (signal 'quit nil)) ; items - (t - (eval (event-object event))))) - ((button-release-event-p event) ; don't beep twice - nil) - ((and (fboundp 'event-matches-key-specifier-p) - (event-matches-key-specifier-p event (quit-char))) - (signal 'quit nil)) - (t - (beep) - (message "please make a choice from the menu.")))) - value)) - ) - - ;; For the Emacs 19 - (defun hm--html-add-major-menu-to-minor-menus () - "Adds an entry to get the general major menu in the minor mode menus. -This function is only used in the Emacs 19." - (define-key hm--html-menu-noregion-novice-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu)) - (define-key hm--html-menu-noregion-expert-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu)) - (define-key hm--html-menu-region-novice-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu)) - (define-key hm--html-menu-region-expert-map - [mouse-major-mode-menu] - '("Major Mode Menu" . mouse-major-mode-menu))) - - (defun hm--html-remove-major-menu-from-minor-menus () - "Removes the entry to get the general major menu in the minor mode menus. -This function is only used in the Emacs 19." - (define-key hm--html-menu-noregion-novice-map - [mouse-major-mode-menu] 'undefined) - (define-key hm--html-menu-noregion-expert-map - [mouse-major-mode-menu] 'undefined) - (define-key hm--html-menu-region-novice-map - [mouse-major-mode-menu] 'undefined) - (define-key hm--html-menu-region-expert-map - [mouse-major-mode-menu] 'undefined)) - ) - -(if (adapt-xemacsp) - (progn - - (defun hm--html-popup-minor-html-menu (event) - "Pops the HTML- menu up, if no region is active." - (interactive "@e") - (if (eq major-mode 'html-mode) - (if hm--html-use-psgml - (let ((hm--html-popup-menu (if hm--html-expert - hm--html-menu-noregion-expert - hm--html-menu-noregion-novice)) - (hm--html-point (point)) - (hm--html-mark (mark))) - (sgml-tags-menu event)) - (if hm--html-expert - (popup-menu hm--html-menu-noregion-expert) - (popup-menu hm--html-menu-noregion-novice)) - ) - (popup-menu (append ;mode-popup-menu - ;'("===") - (if hm--html-expert - hm--html-menu-noregion-expert - hm--html-menu-noregion-novice) - (list "===" - (car mode-popup-menu) - "===") - (cdr mode-popup-menu) - )))) - - - - (defun hm--html-popup-minor-html-menu-region (event) - "Pops the HTML- menu up, if a region is active." - (interactive "@e") - (if (eq major-mode 'html-mode) - (if hm--html-use-psgml - (let ((hm--html-popup-menu (if hm--html-expert - hm--html-menu-region-expert - hm--html-menu-region-novice)) - (hm--html-point (point)) - (hm--html-mark (mark))) - (sgml-tags-menu event)) - (if hm--html-expert - (popup-menu hm--html-menu-region-expert) - (popup-menu hm--html-menu-region-novice)) - ) - (popup-menu (append mode-popup-menu - '("---") - (if hm--html-expert - hm--html-menu-noregion-expert - hm--html-menu-noregion-novice))))) - - )) - - -(run-hooks 'hm--html-menu-load-hook) - - -;;; Announce the feature hm--html-menu -(provide 'hm--html-menu)
--- a/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,348 +0,0 @@ -;;; hm--html-mode --- Major mode for editing HTML documents for the WWW - -;; Copyright (C) 1996, 1997 Heiko Muenkel - -;; Author: Heiko Muenkel <muenkel@tnt.uni-hannover.de> -;; Keywords: hypermedia languages help docs wp - -;; $Id: hm--html-mode.el,v 1.7 1997/07/26 22:09:45 steve Exp $ - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; This program 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 part of Emacs. - -;;; Commentary: - -;; Description: - -;; This file defines the hm--html-mode, a mode for editing html -;; files. It is the main file of the package hm--html-menus. -;; Previous releases had used the file html-mode.el from Marc -;; Andreessen. In that times the mode was called html-mode. I've -;; changed the name of the mode to distinquish it from other -;; html modes. But feel free to set a -;; (defalias 'hm--html-mode 'html-mode) -;; to get back the old name of the mode. - -;; In the earlier releases of the package the main file was -;; hm--html-menu.el. This has been changed to hm--html-mode.el. - - -;; Installation: - -;; Put this file and all the other files of the package -;; in one of your load path directories and the -;; following lines in your .emacs: - -;; (autoload 'hm--html-mode "hm--html-mode" "HTML major mode." t) - -;; (or (assoc "\\.html$" auto-mode-alist) -;; (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) -;; auto-mode-alist))) -;; If there is already another html-mode (like psgml in the XEmacs -;; 19.14, then you must put the following instead of the last form -;; in your .emacs: -;; (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) -;; auto-mode-alist)) - -;; But you can also use the hm--html-minor-mode as an addition to -;; the psgml html modes. For that you've to put the following line in -;; your .emacs: -;; (add-hook 'html-mode-hook 'hm--html-minor-mode) - -;; Note: This works only in an XEmacs version greater than 19.14 and -;; also not in the XEmacs 20.0. - -;; Look at the file hm--html-configuration for further installation -;; points. - -;;; Code: - -(require 'font-lock) -(require 'cl) -(require 'adapt) -(require 'hm--date) -(require 'hm--html) -;(require 'hm--html-not-standard) - -(eval-when-compile - (require 'hm--html-configuration)) - -(hm--html-load-config-files) -(require 'hm--html-indentation) - -(defvar hm--html-minor-mode nil - "Non-nil, if the `hm--html-minor-mode' is active.") - -(require 'hm--html-menu) - -(require 'hm--html-keys) - -;(defvar hm--html-minor-mode nil -; "Non-nil, if the `hm--html-minor-mode' is active.") -; -;(require 'hm--html-menu) -(require 'hm--html-drag-and-drop) - - -;;; The package version -(defconst hm--html-menus-package-maintainer "muenkel@tnt.uni-hannover.de") - -(defconst hm--html-menus-package-name "hm--html-menus") - -(defconst hm--html-menus-package-version "5.8") - - -;;; Generate the help buffer faces -(hm--html-generate-help-buffer-faces) - -;;; syntax table - -(defvar hm--html-mode-syntax-table nil - "Syntax table used while in html mode.") - -(if hm--html-mode-syntax-table - () - (setq hm--html-mode-syntax-table (make-syntax-table)) -; (modify-syntax-entry ?\" ". " hm--html-mode-syntax-table) -; (modify-syntax-entry ?\\ ". " hm--html-mode-syntax-table) -; (modify-syntax-entry ?' "w " hm--html-mode-syntax-table) - (modify-syntax-entry ?\\ "." hm--html-mode-syntax-table) - (modify-syntax-entry ?' "w" hm--html-mode-syntax-table) - (modify-syntax-entry ?< "(>" hm--html-mode-syntax-table) - (modify-syntax-entry ?> ")<" hm--html-mode-syntax-table) - (modify-syntax-entry ?\" "\"" hm--html-mode-syntax-table) - (modify-syntax-entry ?= "." hm--html-mode-syntax-table)) - - -;;; abbreviation table - -(defvar hm--html-mode-abbrev-table nil - "Abbrev table used while in html mode.") - -(define-abbrev-table 'hm--html-mode-abbrev-table ()) - -;;; the hm--html-mode - -(defvar hm--html-mode-name-string "HTML" - "The hm--html-mode name string.") - -;;;###autoload -(defun hm--html-mode () - "Major mode for editing HTML hypertext documents. -Special commands:\\{hm--html-mode-map} -Turning on hm--html-mode calls the value of the variable hm--html-mode-hook, -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map hm--html-mode-map) - (setq mode-name hm--html-mode-name-string) - (setq major-mode 'hm--html-mode) - (setq local-abbrev-table hm--html-mode-abbrev-table) - (set-syntax-table hm--html-mode-syntax-table) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (setq comment-start "<!--" comment-end "-->") - (make-local-variable 'sentence-end) - (setq sentence-end "[<>.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") - (make-local-variable 'indent-line-function) - (setq indent-line-function 'hm--html-indent-line) - (setq idd-actions hm--html-idd-actions) - (hm--install-html-menu hm--html-mode-pulldown-menu-name) - (make-variable-buffer-local 'write-file-hooks) - (add-hook 'write-file-hooks 'hm--html-maybe-new-date-and-changed-comment) - (if (adapt-xemacsp) - (put major-mode 'font-lock-defaults '((hm--html-font-lock-keywords - hm--html-font-lock-keywords-1 - hm--html-font-lock-keywords-2) - t - t - nil - nil)) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '((hm--html-font-lock-keywords - hm--html-font-lock-keywords-1 - hm--html-font-lock-keywords-2) - t - t - nil - nil))) - (run-hooks 'hm--html-mode-hook)) - -;;;; Minor Modes - -;;; hm--html-region-mode - -(defvar hm--html-region-mode nil - "T, if the region is active in the `hm--html-mode'.") - -(make-variable-buffer-local 'hm--html-region-mode) - -(add-minor-mode 'hm--html-region-mode " Region" hm--html-region-mode-map) - -(if (adapt-xemacsp) - - (defun hm--html-region-mode (&optional arg) - "Toggle 'hm--html-region-mode'. -With ARG, turn hm--html-region-mode on iff ARG is positive. - -If the `major-mode' isn't the `hm--html-mode' then the minor -mode is switched off, regardless of the ARG and the state -of `hm--html-region-mode'." - (interactive "P") - (setq zmacs-regions-stays t) - (setq hm--html-region-mode - (and (eq major-mode 'hm--html-mode) - (if (null arg) (not hm--html-region-mode) - (> (prefix-numeric-value arg) 0)))) - ) - - (defun hm--html-region-mode (&optional arg) - "Toggle 'hm--html-region-mode'. -With ARG, turn hm--html-region-mode on iff ARG is positive. - -If the `major-mode' isn't the `hm--html-mode' then the minor -mode is switched off, regardless of the ARG and the state -of `hm--html-region-mode'." - (interactive "P") - (setq hm--html-region-mode - (and (eq major-mode 'hm--html-mode) - (if (null arg) (not hm--html-region-mode) - (> (prefix-numeric-value arg) 0)))) - (if hm--html-region-mode - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - nil) - (if hm--html-expert - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map))) - ) - - ) - - -;;; hm--html-minor-mode -(make-variable-buffer-local 'hm--html-minor-mode) - -(add-minor-mode 'hm--html-minor-mode " HM-HTML" hm--html-minor-mode-map) - -;;;###autoload -(defun hm--html-minor-mode (&optional arg) - "Toggle hm--html-minor-mode. -With arg, turn hm--html-minor-mode on iff arg is positive." - (interactive "P") - (setq hm--html-minor-mode - (if (null arg) (not hm--html-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if hm--html-minor-mode - (progn - (hm--install-html-menu hm--html-minor-mode-pulldown-menu-name) - (when (adapt-emacs19p) - (hm--html-add-major-menu-to-minor-menus))) - (when (and current-menubar (assoc hm--html-minor-mode-pulldown-menu-name - current-menubar)) - (delete-menu-item (list hm--html-minor-mode-pulldown-menu-name))) - (when (adapt-emacs19p) - (hm--html-remove-major-menu-from-minor-menus))) - ) - - -;;; hm--html-minor-region-mode - -(defvar hm--html-minor-region-mode nil - "Non-nil, if the `hm--html-minor-region-mode' is active.") - -(make-variable-buffer-local 'hm--html-minor-region-mode) - -(add-minor-mode 'hm--html-minor-region-mode - " Region" - hm--html-minor-region-mode-map) - - -(if (adapt-xemacsp) - - (defun hm--html-minor-region-mode (&optional arg) - "Toggle `hm--html-minor-region-mode'. -With arg, turn `hm--html-minor-region-mode' on iff arg is positive. - -But however, if the `hm--html-minor-mode' isn't active, then it -turns `hm--html-minor-region-mode' off." - (interactive "P") - (setq zmacs-regions-stays t) - (setq hm--html-minor-region-mode - (and hm--html-minor-mode - (if (null arg) (not hm--html-minor-region-mode) - (> (prefix-numeric-value arg) 0)))) - ) - - (defun hm--html-minor-region-mode (&optional arg) - "Toggle `hm--html-minor-region-mode'. -With arg, turn `hm--html-minor-region-mode' on iff arg is positive. - -But however, if the `hm--html-minor-mode' isn't active, then it -turns `hm--html-minor-region-mode' off." - (interactive "P") - (setq hm--html-minor-region-mode - (and hm--html-minor-mode - (if (null arg) (not hm--html-minor-region-mode) - (> (prefix-numeric-value arg) 0)))) - (if hm--html-minor-region-mode - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - nil) - (if hm--html-expert - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-expert-map) - (define-key hm--html-minor-mode-map - hm--html-emacs19-popup-noregion-menu-button - hm--html-menu-noregion-novice-map))) - ) - ) - - - -;;; Hook function for toggling the region minor modes -(defun hm--html-switch-region-modes-on () - "Switches the region minor modes of the hm--html-menus package on. -This function should be only be used for the `zmacs-activate-region-hook' -or for the `activate-mark-hook'." - (hm--html-region-mode 1) - (hm--html-minor-region-mode 1)) - -(defun hm--html-switch-region-modes-off () - "Switches the region minor modes of the hm--html-menus package on. -This function should be only be used for the `zmacs-deactivate-region-hook' -or for the `deactivate-mark-hook'." - (hm--html-region-mode -1) - (hm--html-minor-region-mode -1)) - - -;;; Run the load hook -(run-hooks 'hm--html-load-hook) - - -;;; Announce the feature hm--html-configuration -(provide 'hm--html-mode) - - -;;; hm--html-mode.el ends here
--- a/lisp/hm--html-menus/hm--html-not-standard.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,439 +0,0 @@ -;;; hm--html-not-standard.el -;;; v1.00; 22-Feb-1997 -;;; Copyright (C) 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; This file contains lisp code for the insertation of non standard -;;; HTML 3.2 elements. I don't think, that's a good idea to use this -;;; elements in any HTML documents :-) -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; -;;; Put a (require 'hm--html-not-standard) in your .emacs -;;; -;;; Look at the files hm--html-mode.el and hm--html-configuration -;;; for further installation points. -;;; - -;(require 'hm--html-mode) - -(defun hm--html-add-server-side-include-command-with-parameter (command - parameter) - "This function adds a server side include command directive in the buffer. -The directive is only supported by the NCSA http daemon." - (interactive (list - (completing-read - "Include Command: " - hm--html-server-side-include-command-with-parameter-alist) - (read-string "Parameterlist sepearted by '?': "))) - (if (string= command "") - (error "ERROR: No command specified !") - (if (string= parameter "") - (error "ERROR: No parameter specified !") - (if (= ?| (string-to-char command)) - (if (= ?? (string-to-char parameter)) - (insert "<INC SRVURL \"" command parameter "\">") - (insert "<INC SRVURL \"" command "?" parameter "\">")) - (if (= ?? (string-to-char parameter)) - (insert "<INC SRVURL \"|" command parameter "\">") - (insert "<INC SRVURL \"|" command "?" parameter "\">")))))) - - -(defun hm--html-add-server-side-include-command-with-isindex-parameter - (command) - "This function adds a server side include command directive in the buffer. -The include command uses the \"isindex\"- parameter for the specified command." - (interactive (list - (completing-read "Include Command: " - hm--html-server-side-include-command-alist))) - (hm--html-add-server-side-include-command command t)) - - -(defun hm--html-add-server-side-include-command (command &optional srvurl) - "This function adds a server side include command directive in the buffer. -The directive is only supported by the NCSA http daemon. -If SRVURL is t, then the attribute srvurl instead of srv is used for the -include command. With srvurl, the include command uses the \"isindex\"- -parameter for the specified command." - (interactive (list - (completing-read "Include Command: " - hm--html-server-side-include-command-alist))) - (let ((attribute (if srvurl "SRVURL" "SRV"))) - (if (string= command "") - (error "ERROR: No command specified !") - (if (= ?| (string-to-char command)) - (insert "<INC " attribute" \"" command "\">") - (insert "<INC " attribute " \"|" command "\">"))))) - - -(defun hm--html-add-server-side-include-file (file) - "This function adds a server side include file directive in the buffer. -The directive is only supported by the NCSA http daemon." - (interactive "FInclude File: ") - (if (string= file "") - (error "ERROR: No filename specified !") - (insert "<INC SRV \"" file "\">"))) - - -(defun hm--html-add-plaintext () - "Adds the HTML tags for plaintext." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<XMP>" - 'hm--html-insert-end-tag-with-newline - "</XMP>")) - - -(defun hm--html-add-plaintext-to-region () - "Adds the HTML tags for plaintext to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<XMP>" - 'hm--html-insert-end-tag-with-newline - "</XMP>")) - - -(defun hm--html-add-abstract () - "Adds the HTML tags for abstract text at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<ABSTRACT>" - 'hm--html-insert-end-tag-with-newline - "</ABSTRACT>")) - - -(defun hm--html-add-abstract-to-region () - "Adds the HTML tags for abstract text to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<ABSTRACT>" - 'hm--html-insert-end-tag-with-newline - "</ABSTRACT>")) - - -(defun hm--html-add-quote () - "Adds the HTML tags for Quote at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<Q>" - 'hm--html-insert-end-tag - "</Q>")) - - -(defun hm--html-add-quote-to-region () - "Adds the HTML tags for Quote to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<Q>" - 'hm--html-insert-end-tag - "</Q>")) - - -(defun hm--html-add-person () - "Adds the HTML tags for Person at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<PERSON>" - 'hm--html-insert-end-tag - "</PERSON>")) - - -(defun hm--html-add-person-to-region () - "Adds the HTML tags for Person to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<PERSON>" - 'hm--html-insert-end-tag - "</PERSON>")) - - -(defun hm--html-add-instance () - "Adds the HTML tags for Instance at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<INS>" - 'hm--html-insert-end-tag - "</INS>")) - - -(defun hm--html-add-instance-to-region () - "Adds the HTML tags for Instance to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<INS>" - 'hm--html-insert-end-tag - "</INS>")) - - -(defun hm--html-add-publication () - "Adds the HTML tags for Publication at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<PUB>" - 'hm--html-insert-end-tag - "</PUB>")) - - -(defun hm--html-add-publication-to-region () - "Adds the HTML tags for Publication to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<PUB>" - 'hm--html-insert-end-tag - "</PUB>")) - - -(defun hm--html-add-author () - "Adds the HTML tags for Author at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<AUTHOR>" - 'hm--html-insert-end-tag - "</AUTHOR>")) - - -(defun hm--html-add-author-to-region () - "Adds the HTML tags for Author to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<AUTHOR>" - 'hm--html-insert-end-tag - "</AUTHOR>")) - - -(defun hm--html-add-editor () - "Adds the HTML tags for Editor at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<EDITOR>" - 'hm--html-insert-end-tag - "</EDITOR>")) - - -(defun hm--html-add-editor-to-region () - "Adds the HTML tags for Editor to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<EDITOR>" - 'hm--html-insert-end-tag - "</EDITOR>")) - - -(defun hm--html-add-credits () - "Adds the HTML tags for Credits at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<CREDITS>" - 'hm--html-insert-end-tag - "</CREDITS>")) - - -(defun hm--html-add-credits-to-region () - "Adds the HTML tags for Credits to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<CREDITS>" - 'hm--html-insert-end-tag - "</CREDITS>")) - - -(defun hm--html-add-copyright () - "Adds the HTML tags for Copyright at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<COPYRIGHT>" - 'hm--html-insert-end-tag - "</COPYRIGHT>")) - - -(defun hm--html-add-copyright-to-region () - "Adds the HTML tags for Copyright to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<COPYRIGHT>" - 'hm--html-insert-end-tag - "</COPYRIGHT>")) - - -(defun hm--html-add-isbn () - "Adds the HTML tags for ISBN at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<ISBN>" - 'hm--html-insert-end-tag - "</ISBN>")) - - -(defun hm--html-add-isbn-to-region () - "Adds the HTML tags for ISBN to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<ISBN>" - 'hm--html-insert-end-tag - "</ISBN>")) - - -(defun hm--html-add-acronym () - "Adds the HTML tags for Acronym at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<ACRONYM>" - 'hm--html-insert-end-tag - "</ACRONYM>")) - - -(defun hm--html-add-acronym-to-region () - "Adds the HTML tags for Acronym to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<ACRONYM>" - 'hm--html-insert-end-tag - "</ACRONYM>")) - - -(defun hm--html-add-abbrevation () - "Adds the HTML tags for Abbrevation at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<ABBREV>" - 'hm--html-insert-end-tag - "</ABBREV>")) - - -(defun hm--html-add-abbrev-to-region () - "Adds the HTML tags for Abbrev to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<ABBREV>" - 'hm--html-insert-end-tag - "</ABBREV>")) - - -(defun hm--html-add-command () - "Adds the HTML tags for Command at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<CMD>" - 'hm--html-insert-end-tag - "</CMD>")) - - -(defun hm--html-add-command-to-region () - "Adds the HTML tags for Command to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<CMD>" - 'hm--html-insert-end-tag - "</CMD>")) - - -(defun hm--html-add-argument () - "Adds the HTML tags for Argument at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<ARG>" - 'hm--html-insert-end-tag - "</ARG>")) - - -(defun hm--html-add-argument-to-region () - "Adds the HTML tags for Argument to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<ARG>" - 'hm--html-insert-end-tag - "</ARG>")) - - -(defun hm--html-add-literature () - "Adds the HTML tags for Literature at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<LIT>" - 'hm--html-insert-end-tag - "</LIT>")) - - -(defun hm--html-add-literature-to-region () - "Adds the HTML tags for Literature to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<LIT>" - 'hm--html-insert-end-tag - "</LIT>")) - - -(defun hm--html-add-footnote () - "Adds the HTML tags for Footnote at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<FOOTNOTE>" - 'hm--html-insert-end-tag - "</FOOTNOTE>")) - - -(defun hm--html-add-footnote-to-region () - "Adds the HTML tags for Footnote to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<FOOTNOTE>" - 'hm--html-insert-end-tag - "</FOOTNOTE>")) - - -(defun hm--html-add-margin () - "Adds the HTML tags for Margin at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<MARGIN>" - 'hm--html-insert-end-tag - "</MARGIN>")) - - -(defun hm--html-add-margin-to-region () - "Adds the HTML tags for Margin to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<MARGIN>" - 'hm--html-insert-end-tag - "</MARGIN>")) - - -(defun hm--html-add-listing () - "Adds the HTML tags for listing." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<LISTING>" - 'hm--html-insert-end-tag-with-newline - "</LISTING>")) - - -(defun hm--html-add-listing-to-region () - "Adds the HTML tags for listing to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<LISTING>" - 'hm--html-insert-end-tag-with-newline - "</LISTING>")) - - -(provide 'hm--html-not-standard)
--- a/lisp/hm--html-menus/hm--html.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4338 +0,0 @@ -;;; $Id: hm--html.el,v 1.9 1997/07/26 22:09:45 steve Exp $ -;;; -;;; Copyright (C) 1993 - 1997 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; -;;; Description: -;;; -;;; Defines functions for the file hm--html-menu.el. -;;; -;;; Installation: -;;; -;;; Put this file in one of your load path directories. -;;; - -(defun hm--html-set-marker-at-position (&optional position) - "Creates a new marker and set the marker at the POSITION. -If POSITION is nil, then the marker is set at the current point. -The return value is the marker." - (let ((marker (make-marker))) - (if position - (set-marker marker position) - (set-marker marker (point))))) - -;;; Functions for adding html commands which consists of a start and a -;;; end tag and some text between them. (Basicfunctions) - -(defun hm--html-add-tags (function-insert-start-tag - start-tag - &optional - function-insert-end-tag - end-tag - function-insert-middle-start-tag - middle-start-tag - function-insert-middle-end-tag - middle-end-tag) - "Adds the start and the end html tag at point. -The first parameter specifies the funtion which insert the start tag -and the third parameter specifies the function which insert the end tag. -The second parameter is the string for the start tag and the fourth parameter -is the string for the end tag. The third and fourth parameters are optional. -The fifth parameter is optional. If it exists, it specifies a function which -inserts the sixth parameter (the middle-start-tag) between the start and the -end tag." - (eval (list function-insert-start-tag start-tag)) - (if function-insert-middle-start-tag - (eval (list function-insert-middle-start-tag middle-start-tag))) - (let ((position (hm--html-set-marker-at-position (point)))) - (if function-insert-middle-end-tag - (eval (list function-insert-middle-end-tag middle-end-tag))) - (if function-insert-end-tag - (eval (list function-insert-end-tag end-tag))) - (goto-char position))) - - -(defun hm--html-add-tags-to-region (function-insert-start-tag - start-tag - function-insert-end-tag - end-tag - &optional - function-insert-middle-tag - middle-tag) - "Adds the start and the end html tag to the active region. -The first parameter specifies the funtion which insert the start tag -and the third parameter specifies the function which insert the end tag. -The second parameter is the string for the start tag and the fourth parameter -is the string for the end tag. -The fifth parameter is optional. If it exists, it specifies a function which -inserts the sixth parameter (the middle-tag) between the start and the end -tag." - (save-window-excursion - (let ((start (hm--html-set-marker-at-position (region-beginning))) - (end (region-end))) - (goto-char end) - (eval (list function-insert-end-tag end-tag)) - (goto-char start) - (eval (list function-insert-start-tag start-tag)) - (if function-insert-middle-tag - (eval (list function-insert-middle-tag middle-tag))) - ))) - - -(defun hm--html-insert-start-tag (tag) - "Inserts the HTML start tag 'tag' without a Newline. -The parameter must be a string (i.e. \"<B>\")" - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)))) - - -(defun hm--html-insert-end-tag (tag) - "Inserts the HTML end tag 'tag' without a Newline. -The parameter must be a string (i.e. \"</B>\")" - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)))) - - -(defun hm--html-insert-start-tag-with-newline (tag) - "Inserts the HTML start tag 'tag' with a Newline. -The parameter must be a string (i.e. \"<PRE>\")" - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)) - ) - (insert "\n")) - - -(defun hm--html-insert-end-tag-with-newline (tag) - "Inserts the HTML end tag 'tag' with a Newline. -The parameter must be a string (i.e. \"</PRE>\")" - (insert "\n") - (let ((start (point))) - (insert tag) - (hm--html-indent-region start (point)))) - - - -;;; Functions which add simple tags of the form <tag> - -(defun hm--html-add-list-or-menu-item-separator () - "Adds a list or menu item. Assume we're at the end of the last item." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline "<LI> ")) - -(defun hm--html-add-list-or-menu-item () - "Adds the tags for a menu item at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline "<LI> " - 'hm--html-insert-end-tag " </LI>")) - -(defun hm--html-add-list-or-menu-item-to-region () - "Adds the tags for a menu item to the region in the current buffer." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag "<LI> " - 'hm--html-insert-end-tag " </LI>")) - -(defun hm--html-add-basefont (size) - "Adds the HTML tag for a basefont." - (interactive (list (hm--html-read-font-size t))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<BASEFONT SIZE=" size ">"))) - -(defun hm--html-add-line-break () - "Adds the HTML tag for a line break." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag "<BR>")) - - -(defun hm--html-add-horizontal-rule () - "Adds the HTML tag for a horizontal rule (line)." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag "<HR>")) - - -(defun hm--html-add-paragraph () - "Adds the HTML tags for a paragraph at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<P>" - 'hm--html-insert-end-tag-with-newline - "</P>")) - - -(defun hm--html-add-paragraph-to-region () - "Adds the HTML tags for a paragraph to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<P>" - 'hm--html-insert-end-tag-with-newline - "</P>")) - - -(defun hm--html-add-paragraph-separator () - "Adds the tag for a paragraph seperator." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag "<P>")) - -(defun hm--html-add-doctype () - "Adds the tag with the doctype." - (interactive) - (goto-char (point-min)) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<!DOCTYPE HTML PUBLIC \"" - hm--html-html-doctype-version - "\">")) - (newline)) - -(defun hm--html-search-place-for-element-in-head (end-point) - "Searches the point for inserting an element between the head tags." - (let ((point (point))) - (if (and end-point (< (point) end-point)) - (point) - (goto-char (point-min)) - (if (re-search-forward - (concat ;"\\(<title\\)\\|\\(<head\\)\\|\\(<html\\)\\|" - "\\(<title\\)\\|" - "\\(<isindex\\)\\|\\(<base\\)\\|\\(<link\\)\\|" - "\\(<meta\\)") - end-point - t) - (beginning-of-line) - end-point)))) - -(defun hm--html-add-isindex (prompt) - "Inserts the isindex tag. PROMPT is the value of the prompt attribute." - (interactive "sPrompt: ") - (save-excursion - (let ((point (point)) - (case-fold-search t) - (head-end-point)) - (goto-char (point-min)) - (setq head-end-point (when (re-search-forward - "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)") - (beginning-of-line) - (point))) - (goto-char (point-min)) - (cond ((re-search-forward "<isindex[^>]*>" head-end-point t) - (delete-region (match-beginning 0) (match-end 0))) - (t (goto-char point) - (hm--html-search-place-for-element-in-head head-end-point))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<ISINDEX " - (if (and prompt - (not (string= prompt ""))) - (concat " PROMPT=\"" prompt "\">") - ">")))))) - -(defun hm--html-add-base (href) - "Inserts the base tag. HREF is the value of the href attribute." - (interactive (list (hm--html-read-url "URL of this document: " - nil - nil - t - nil))) - (save-excursion - (let ((point (point)) - (case-fold-search t) - (head-end-point)) - (goto-char (point-min)) - (setq head-end-point (when (re-search-forward - "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)") - (beginning-of-line) - (point))) - (goto-char (point-min)) - (cond ((re-search-forward "<base[^>]*>" head-end-point t) - (delete-region (match-beginning 0) (match-end 0))) - (t (goto-char point) - (hm--html-search-place-for-element-in-head head-end-point))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<BASE " - (if (and href - (not (string= href ""))) - (concat " HREF=\"" href "\">") - ">")))))) - -(defun hm--html-add-meta (name content &optional name-instead-of-http-equiv) - "Inserts the meta tag." - (interactive (list (completing-read "Name: " hm--html-meta-name-alist) - (read-string "Content: "))) - (save-excursion - (let ((point (point)) - (case-fold-search t) - (head-end-point)) - (goto-char (point-min)) - (setq head-end-point (when (re-search-forward - "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)") - (beginning-of-line) - (point))) - (goto-char point) - (hm--html-search-place-for-element-in-head head-end-point) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<META " - (if name-instead-of-http-equiv - "NAME=\"" - "HTTP-EQUIV=\"") - name - "\" CONTENT=\"" - content - "\">"))))) - - -;;; Functions which include something in HTML- documents - -(defvar hm--html-url-history-list nil - "History list for the function 'hm--html-read-url'") - - -(defun hm--html-read-url-predicate (table-element-list usagesymbol) - "Predicatefunction for hm--html-read-url." - (hm--html-read-url-predicate-1 (cdr table-element-list) usagesymbol)) - - -(defun hm--html-read-url-predicate-1 (table-element-list usagesymbol) - "Internal function of hm--html-read-url-predicate." - (cond ((not table-element-list) nil) - ((eq (car table-element-list) usagesymbol)) - (t (hm--html-read-url-predicate-1 (cdr table-element-list) - usagesymbol)))) - - -(defun hm--html-read-url (prompt &optional - table - predicate - require-match - initial-contents) - "Function prompts for a URL string. -TABLE is an alist whose elements' cars are URL's. -PREDICATE limits completion to a subset of TABLE. -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless -the input is (or completes to) an element of TABLE. -INITIAL-CONTENTS is a string to insert in the minibuffer before reading. -If INITIAL-CONTENTS is nil, the car of the 'hm--html-url-history-list' -is used instead." - (if table - (completing-read prompt - table - predicate - require-match - initial-contents - hm--html-url-history-list) - (read-string prompt - (if initial-contents - initial-contents - (car hm--html-url-history-list)) - hm--html-url-history-list))) - - -(defun hm--html-read-altenate (url) - "Function reads the value for the \"ALT\"- attribute in IMG tags. -URL will be used as the default URL for the external viewer." - (let ((alttype - (string-to-int - (completing-read - "0: No ALT atribute, 1: ALT=\"\", 2: ALT=Text: " - '(("0") ("1") ("2")) - nil - t - "2")))) - (cond ((= alttype 0) nil) - ((= alttype 1) "") - ((= alttype 2) (read-string - "Text for the ALT attribute: " - (substring (file-name-nondirectory url) - 0 - (string-match - "\\." - (file-name-nondirectory url))))) - ))) - -(defun hm--html-read-alignment (prompt) - "Read the value for the align attribute." - (upcase (completing-read prompt - '(("left") ("right") ("top") ("bottom") ("middle")) - nil - t - "left"))) - -(defvar hm--html-shape-history nil - "History variable for reading the shape of an image map.") - -(defun hm--html-read-shape () - "Reads the shap for an area element." - (upcase(completing-read "The shape of the area: " - '(("rect") ("circle") ("poly")) - nil - t - (or (car hm--html-shape-history) "rect") - 'hm--html-shape-history))) - -(defun hm--html-read-rect-coords () - "Reads rectangle coordinates for the area element." - (concat (read-string "Left x position of the rectangle: ") ", " - (read-string "Top y position of the rectangle: ") ", " - (read-string "Right x position of the rectangle: ") ", " - (read-string "Bottom y position of the rectangle: "))) - -(defun hm--html-read-circle-coords () - "Reads circle coordinates for the area element." - (concat (read-string "x position of the center of the circle: ") ", " - (read-string "y position of the center of the circle: ") ", " - (read-string "Radius: "))) - -(defun hm--html-read-one-poly-coordinate (&optional empty-string-prompt) - "Reads one poly coordinate pair." - (let* ((x (read-string (concat "x coordinate" - (or empty-string-prompt "") - ": "))) - (y (unless (string= "" x) - (read-string "y coordinate: ")))) - (if (string= "" x) - "" - (concat x ", " y)))) - -(defun hm--html-read-more-poly-coordinates () - "Reads poly coordinates until an empty string is given." - (let ((coord (hm--html-read-one-poly-coordinate - " (Empty string for no further coords!)"))) - (cond ((string= "" coord) "") - (t (concat ", " coord (hm--html-read-more-poly-coordinates)))))) - -(defun hm--html-read-poly-coords () - "Reads poly coordinates for the area element." - (concat (hm--html-read-one-poly-coordinate) ", " - (hm--html-read-one-poly-coordinate) ", " - (hm--html-read-one-poly-coordinate) - (hm--html-read-more-poly-coordinates))) - -(defun hm--html-add-area (href alt shape coords) - "Adds the tags for an area at the current point." - (interactive (let* ((href (hm--html-read-url "Url for the image area: ")) - (alt (hm--html-read-altenate href)) - (shape (hm--html-read-shape)) - (coords (cond ((string= shape "RECT") - (hm--html-read-rect-coords)) - ((string= shape "CIRCLE") - (hm--html-read-circle-coords)) - ((string= shape "POLY") - (hm--html-read-poly-coords)) - (t (error "No function to read \"" - shape - "\" coordinates!"))))) - (list href alt shape coords))) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - (concat "<AREA" - " HREF=\"" href "\"" - (if alt - (concat "\nALT=\"" alt "\"") - "") - "\nSHAPE=" shape - "\nCOORDS=\"" coords "\"" - ">"))) - - -(when (adapt-emacs19p) - (defvar :ask ':ask)) - -(defvar hm--html-use-image-as-map ':ask - "Internal variable of `hm--html-add-image'. -nil => insert the image element without an usemap attribute. -t => insert the image element with an usemap attribute. -:ask => ask, if the image element should have an usemap attribute.") - -(defun hm--html-add-image (href alt alignment mapname) - "Add an image." - (interactive (let* ((href (hm--html-read-url "Image URL: ")) - (alt (hm--html-read-altenate href)) - (alignment (hm--html-read-alignment - "Alignment of the image: ")) - (use-as-map (if (eq hm--html-use-image-as-map ':ask) - (y-or-n-p - "Use the image as a map with links? ") - hm--html-use-image-as-map)) - (mapname (and use-as-map (hm--html-read-mapname)))) - (list href alt alignment mapname))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat "<IMG ALIGN=" alignment - "\nHREF=\"" href "\"" - (if alt - (concat "\nALT=\"" alt "\"") - "") - (if mapname - (concat "\nUSEMAP=\"#" mapname "\"") - "") - ">"))) - - -(defun hm--html-add-image-bottom (href alt) - "Add an image, bottom aligned." - (interactive (let ((url (hm--html-read-url "Image URL: "))) - (list url (hm--html-read-altenate url)))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat "<IMG ALIGN=BOTTOM SRC=\"" - href - (when alt - (concat "\" ALT=\"" alt)) - "\">"))) - - -(defun hm--html-add-image-middle (href alt) - "Add an image, middle aligned." - (interactive (let ((url (hm--html-read-url "Image URL: "))) - (list url (hm--html-read-altenate url)))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat "<IMG ALIGN=MIDDLE SRC=\"" - href - (when alt - (concat "\" ALT=\"" alt)) - "\">"))) - - -(defun hm--html-add-image-top (href alt) - "Add an image, top aligned." - (interactive (let ((url (hm--html-read-url "Image URL: "))) - (list url (hm--html-read-altenate url)))) - (hm--html-add-tags - 'hm--html-insert-start-tag - (concat "<IMG ALIGN=TOP SRC=\"" - href - (when alt - (concat "\" ALT=\"" alt)) - "\">"))) - - -(defun hm--html-add-applet (name code width height) - "Add an applet." - (interactive (let ((name (read-string "Applet Name: " "applet")) - (code (read-file-name "Applet Class File: ")) - (width (read-number "Width (i.e.: 100): " t)) - (height (read-number "Height (i.e.: 100): " t))) - (list name code width height))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<APPLET " - (if (string= name "") - "" - (concat "NAME=\"" name "\"\n")) - "CODE=\"" - code - "\"\n" - "WIDTH=\"" - width - "\"\n" - "HEIGHT=\"" - height - "\">") - 'hm--html-insert-start-tag-with-newline - "</APPLET>")) - -(defun hm--html-add-applet-parameter (name value) - "Adds the tag for an applet parameter at the current point. -This tag must be added between <APPLET> and </APPLET>." - (interactive "sParameter Name: \nsParameter Value: ") - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<PARAM " - "NAME=\"" - name - "\" VALUE=\"" - value - "\">"))) - - - -;;; Functions, which adds tags of the form <starttag> ... </endtag> - -(defun hm--html-add-big () - "Adds the HTML tags for Big at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<BIG>" - 'hm--html-insert-end-tag - "</BIG>")) - - -(defun hm--html-add-big-to-region () - "Adds the HTML tags for Big to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<BIG>" - 'hm--html-insert-end-tag - "</BIG>")) - - -(defun hm--html-add-small () - "Adds the HTML tags for Small at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<SMALL>" - 'hm--html-insert-end-tag - "</SMALL>")) - - -(defun hm--html-add-small-to-region () - "Adds the HTML tags for Small to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<SMALL>" - 'hm--html-insert-end-tag - "</SMALL>")) - - -(defun hm--html-add-bold () - "Adds the HTML tags for Bold at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<B>" - 'hm--html-insert-end-tag - "</B>")) - - -(defun hm--html-add-bold-to-region () - "Adds the HTML tags for Bold to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<B>" - 'hm--html-insert-end-tag - "</B>")) - - -(defun hm--html-add-italic () - "Adds the HTML tags for Italic at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<I>" - 'hm--html-insert-end-tag - "</I>")) - - -(defun hm--html-add-italic-to-region () - "Adds the HTML tags for Italic to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<I>" - 'hm--html-insert-end-tag - "</I>")) - - -(defun hm--html-add-underline () - "Adds the HTML tags for Underline at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<U>" - 'hm--html-insert-end-tag - "</U>")) - - -(defun hm--html-add-underline-to-region () - "Adds the HTML tags for Underline to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<U>" - 'hm--html-insert-end-tag - "</U>")) - - -(defun hm--html-add-definition () - "Adds the HTML tags for Definition at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<DFN>" - 'hm--html-insert-end-tag - "</DFN>")) - - -(defun hm--html-add-definition-to-region () - "Adds the HTML tags for Definition to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<DFN>" - 'hm--html-insert-end-tag - "</DFN>")) - - -(defun hm--html-add-code () - "Adds the HTML tags for Code at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<CODE>" - 'hm--html-insert-end-tag - "</CODE>")) - - -(defun hm--html-add-code-to-region () - "Adds the HTML tags for Code to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<CODE>" - 'hm--html-insert-end-tag - "</CODE>")) - - -(defun hm--html-add-citation () - "Adds the HTML tags for Citation." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<CITE>" - 'hm--html-insert-end-tag - "</CITE>")) - -(defun hm--html-add-citation-to-region () - "Adds the HTML tags for Citation to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<CITE>" - 'hm--html-insert-end-tag - "</CITE>")) - - -(defun hm--html-add-emphasized () - "Adds the HTML tags for Emphasized." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<EM>" - 'hm--html-insert-end-tag - "</EM>")) - - -(defun hm--html-add-emphasized-to-region () - "Adds the HTML tags for Emphasized to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<EM>" - 'hm--html-insert-end-tag - "</EM>")) - - -(defun hm--html-add-fixed () - "Adds the HTML tags for Fixed." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TT>" - 'hm--html-insert-end-tag - "</TT>")) - - -(defun hm--html-add-fixed-to-region () - "Adds the HTML tags for Fixed to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<TT>" - 'hm--html-insert-end-tag - "</TT>")) - - -(defun hm--html-add-keyboard () - "Adds the HTML tags for Keyboard." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<KBD>" - 'hm--html-insert-end-tag - "</KBD>")) - - -(defun hm--html-add-keyboard-to-region () - "Adds the HTML tags for Keyboard to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<KBD>" - 'hm--html-insert-end-tag - "</KBD>")) - - -(defun hm--html-add-sample () - "Adds the HTML tags for Sample." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<SAMP>" - 'hm--html-insert-end-tag - "</SAMP>")) - -(defun hm--html-add-sample-to-region () - "Adds the HTML tags for Sample to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<SAMP>" - 'hm--html-insert-end-tag - "</SAMP>")) - - -(defun hm--html-add-strong () - "Adds the HTML tags for Strong." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<STRONG>" - 'hm--html-insert-end-tag - "</STRONG>")) - - -(defun hm--html-add-strong-to-region () - "Adds the HTML tags for Strong to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<STRONG>" - 'hm--html-insert-end-tag - "</STRONG>")) - - -(defun hm--html-add-variable () - "Adds the HTML tags for Variable." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<VAR>" - 'hm--html-insert-end-tag - "</VAR>")) - -(defun hm--html-add-variable-to-region () - "Adds the HTML tags for Variable to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<VAR>" - 'hm--html-insert-end-tag - "</VAR>")) - - -(defun hm--html-add-comment () - "Adds the HTML tags for Comment at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<!-- " - 'hm--html-insert-end-tag - " -->")) - - -(defun hm--html-add-comment-to-region () - "Adds the HTML tags for Comment to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<!-- " - 'hm--html-insert-end-tag - " -->")) - - -(defun hm--html-add-document-division (alignment) - "Adds the HTML tags for document division at the current point." - (interactive (list (hm--html-read-alignment "Alignment of the division: "))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<DIV ALIGN=\"" alignment "\">") - 'hm--html-insert-end-tag-with-newline - "</DIV>")) - - -(defun hm--html-add-document-division-to-region (alignment) - "Adds the HTML tags for document division to the region." - (interactive (list (hm--html-read-alignment "Alignment of the division: "))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "<DIV ALIGN=\"" alignment "\">") - 'hm--html-insert-end-tag-with-newline - "</DIV>")) - - -(defun hm--html-add-preformatted () - "Adds the HTML tags for preformatted text at the current point." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<PRE>" - 'hm--html-insert-end-tag-with-newline - "</PRE>")) - -(define-obsolete-function-alias 'hm--html-add-preformated - 'hm--html-add-preformatted) - -(defun hm--html-add-preformatted-to-region () - "Adds the HTML tags for preformatted text to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<PRE>" - 'hm--html-insert-end-tag-with-newline - "</PRE>")) - -(define-obsolete-function-alias 'hm--html-add-preformated-to-region - 'hm--html-add-preformatted-to-region) - -(defun hm--html-add-blockquote () - "Adds the HTML tags for blockquote." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<BLOCKQUOTE>" - 'hm--html-insert-end-tag-with-newline - "</BLOCKQUOTE>")) - - -(defun hm--html-add-blockquote-to-region () - "Adds the HTML tags for blockquote to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<BLOCKQUOTE>" - 'hm--html-insert-end-tag-with-newline - "</BLOCKQUOTE>")) - -(defun hm--html-add-script () - "Adds the HTML tags for script." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<SCRIPT>" - 'hm--html-insert-end-tag-with-newline - "</SCRIPT>")) - - -(defun hm--html-add-script-to-region () - "Adds the HTML tags for script to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<SCRIPT>" - 'hm--html-insert-end-tag-with-newline - "</SCRIPT>")) - -(defun hm--html-add-style () - "Adds the HTML tags for style." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<STYLE>" - 'hm--html-insert-end-tag-with-newline - "</STYLE>")) - - -(defun hm--html-add-style-to-region () - "Adds the HTML tags for style to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<STYLE>" - 'hm--html-insert-end-tag-with-newline - "</STYLE>")) - -(defun hm--html-add-strikethru () - "Adds the HTML tags for Strikethru at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<STRIKE>" - 'hm--html-insert-end-tag - "</STRIKE>")) - - -(defun hm--html-add-strikethru-to-region () - "Adds the HTML tags for Strikethru to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<STRIKE>" - 'hm--html-insert-end-tag - "</STRIKE>")) - - -(defun hm--html-add-superscript () - "Adds the HTML tags for Superscript at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<SUP>" - 'hm--html-insert-end-tag - "</SUP>")) - - -(defun hm--html-add-superscript-to-region () - "Adds the HTML tags for Superscript to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<SUP>" - 'hm--html-insert-end-tag - "</SUP>")) - - -(defun hm--html-add-subscript () - "Adds the HTML tags for Subscript at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<SUB>" - 'hm--html-insert-end-tag - "</SUB>")) - - -(defun hm--html-add-subscript-to-region () - "Adds the HTML tags for Subscript to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<SUB>" - 'hm--html-insert-end-tag - "</SUB>")) - - -(defun hm--html-add-option () - "Adds the HTML tags for Option at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<OPT>" - 'hm--html-insert-end-tag - "</OPT>")) - - -(defun hm--html-add-option-to-region () - "Adds the HTML tags for Option to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<OPT>" - 'hm--html-insert-end-tag - "</OPT>")) - - -(defun hm--html-read-font-size (&optional only-absolute-size) - "Reads the size for the FONT element. -It returns nil, if the size should not be changed." - (let ((size - (if only-absolute-size - (completing-read "The absolute font size (1 .. 7): " - '(("7") ("6") ("5") ("4") ("3") ("2") ("1")) - nil - t - "4") - (completing-read "The relative (+/-) or absolute font size: " - '(("-7") ("-6") ("-5") ("-4") ("-3") ("-2") ("-1") - ("+7") ("+6") ("+5") ("+4") ("+3") ("+2") ("+1") - ("7") ("6") ("5") ("4") ("3") ("2") ("1") - ("use-basefont")) - nil - t - "use-basefont-size")))) - (if (string= size "use-basefont-size") - nil - size))) - -(defun hm--html-read-font-color () - "Reads the size for the FONT element. -It returns nil, if the color should not be changed." - (let ((color - (completing-read "The font color: " - '(("Black") ("Silver") ("Gray") ("White") ("Maroon") - ("Green") ("Lime") ("Olive") ("Yellow") ("Navy") - ("Red") ("Purple") ("Fuchsia") ("Blue") ("Teal") - ("Aqua") ("dont-set-color")) - nil - nil - "dont-set-color"))) - (if (string= color "dont-set-color") - nil - color))) - - -(defun hm--html-add-font (size color) - "Adds the HTML tags for Font at the point in the current buffer." - (interactive (list (hm--html-read-font-size) - (hm--html-read-font-color))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<FONT" - (if size - (concat " SIZE=" size) - "") - (if color - (concat " COLOR=" color) - "") - ">") - 'hm--html-insert-end-tag-with-newline - "</FONT>")) - - -(defun hm--html-add-font-to-region (size color) - "Adds the HTML tags for Font to the region." - (interactive (list (hm--html-read-font-size) - (hm--html-read-font-color))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "<FONT" - (if size - (concat " SIZE=" size) - "") - (if color - (concat " COLOR=" color) - "") - ">") - 'hm--html-insert-end-tag-with-newline - "</FONT>")) - - -;;; Lists - - -(defun hm--html-add-center () - "Adds the HTML tags for center at the current point." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<CENTER>" - 'hm--html-insert-end-tag-with-newline - "</CENTER>")) - -(defun hm--html-add-center-to-region () - "Adds the HTML tags for center to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<CENTER>" - 'hm--html-insert-end-tag-with-newline - "</CENTER>")) - - -(defvar hm--html-mapname-history nil - "The history variable for the function `hm--html-read-mapname'.") - -(defun hm--html-read-mapname () - "Reads the name of an image map." - (let ((name (read-string "The name of the image map: " - (or (car hm--html-mapname-history) - "map") - 'hm--html-mapname-history))) - name)) - -(defun hm--html-add-image-map () - "Adds an image and a map element." - (interactive) - (let* ((href (hm--html-read-url "Image URL: ")) - (alt (hm--html-read-altenate href)) - (alignment (hm--html-read-alignment - "Alignment of the image: ")) - (mapname (hm--html-read-mapname))) - (hm--html-add-image href alt alignment mapname) - (newline) - (hm--html-add-map mapname) - (call-interactively 'hm--html-add-area))) - -(defun hm--html-add-map (name) - "Adds the HTML tags for map at the current point." - (interactive (list (hm--html-read-mapname))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<MAP NAME=\"" name "\">") - 'hm--html-insert-end-tag - "</MAP>") - (end-of-line 0)) - -(defun hm--html-add-map-to-region (name) - "Adds the HTML tags for map to the region." - (interactive (list (hm--html-read-mapname))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "<MAP NAME=\"" name "\">") - 'hm--html-insert-end-tag-with-newline - "</MAP>")) - - -(defun hm--html-add-numberlist () - "Adds the HTML tags for a numbered list at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<OL>" - 'hm--html-insert-end-tag-with-newline - "</OL>" - 'hm--html-insert-start-tag - "<LI> " - 'hm--html-insert-end-tag - " </LI>")) - -(defun hm--html-add-numberlist-to-region () - "Adds the HTML tags for a numbered list to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<OL>" - 'hm--html-insert-end-tag-with-newline - "</OL>")) - - -(defun hm--html-add-directory-list () - "Adds the HTML tags for a directory list at the point in the current buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<DIR>" - 'hm--html-insert-end-tag-with-newline - "</DIR>" - 'hm--html-insert-start-tag - "<LI> " - 'hm--html-insert-end-tag - " </LI>")) - -(defun hm--html-add-directorylist-to-region () - "Adds the HTML tags for a directory list to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<DIR>" - 'hm--html-insert-end-tag-with-newline - "</DIR>")) - - -(defun hm--html-add-list () - "Adds the HTML tags for a (unnumbered) list to the region." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<UL>" - 'hm--html-insert-end-tag-with-newline - "</UL>" - 'hm--html-insert-start-tag - "<LI> " - 'hm--html-insert-end-tag - " </LI>")) - - -(defun hm--html-add-list-to-region () - "Adds the HTML tags for a (unnumbered) list to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<UL>" - 'hm--html-insert-end-tag-with-newline - "</UL>")) - - -(defun hm--html-add-menu () - "Adds the HTML tags for a menu." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<MENU>" - 'hm--html-insert-end-tag-with-newline - "</MENU>" - 'hm--html-insert-start-tag - "<LI> " - 'hm--html-insert-end-tag - " </LI>")) - - -(defun hm--html-add-menu-to-region () - "Adds the HTML tags for a menu to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<MENU>" - 'hm--html-insert-end-tag-with-newline - "</MENU>")) - - -(defun hm--html-add-description-title-and-entry () - "Adds a definition title and entry. -Assumes we're at the end of a previous entry." - (interactive) - (hm--html-add-description-title) - (let ((position (point)) - (case-fold-search t)) - (search-forward "</dt>") - (hm--html-add-description-entry) - (goto-char position))) - - -(defun hm--html-add-description-list () - "Adds the HTML tags for a description list. -It also inserts a tag for the description title." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<DL>" - 'hm--html-insert-end-tag-with-newline - "</DL>" - 'hm--html-insert-start-tag - "<DT> " - 'hm--html-insert-end-tag - " </DT>")) - - -(defun hm--html-add-description-list-to-region () - "Adds the HTML tags for a description list to a region. -It also inserts a tag for the description title." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<DL>" - 'hm--html-insert-end-tag-with-newline - "</DL>")) - - -(defun hm--html-add-description-title () - "Adds the HTML tags for a description title at current point in the buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "<DT> " - 'hm--html-insert-end-tag - " </DT>")) - - -(defun hm--html-add-description-title-to-region () - "Adds the HTML tags for a description title to the region in the buffer." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<DT> " - 'hm--html-insert-end-tag - " </DT>")) - - -(defun hm--html-add-description-entry () - "Adds the HTML tags for a description entry at current point in the buffer." - (interactive) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "<DD> " - 'hm--html-insert-end-tag - " </DD>")) - - -(defun hm--html-add-description-entry-to-region () - "Adds the HTML tags for a description entry to the region in the buffer." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<DD> " - 'hm--html-insert-end-tag - " </DD>")) - - -(defun hm--html-add-address () - "Adds the HTML tags for an address." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag - "<ADDRESS>" - 'hm--html-insert-end-tag - "</ADDRESS>")) - -(defun hm--html-add-address-to-region () - "Adds the HTML tags for an address to the region" - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "<ADDRESS>" - 'hm--html-insert-end-tag - "</ADDRESS>")) - - -(defvar hm--html-signature-reference-name "Signature" - "The signature reference name.") - - -(defun hm--html-make-signature-link-string (signature-file-name) - "Returns a string which is a link to a signature file." - (concat - "<A NAME=\"" - hm--html-signature-reference-name - "\"\nHREF=\"" - signature-file-name - "\">")) - - -(defun hm--html-delete-old-signature () - "Searches for the old signature and deletes it, if the user want it" - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (re-search-forward (concat "<address>[ \t\n]*" - "<a[ \t\n]+name=[ \t\n]*\"?" - hm--html-signature-reference-name - "\"?[ \t\n]+href=[ \t\n]*\"") - nil - t) - (let ((signature-start (match-beginning 0)) - (signature-end (progn - (re-search-forward "</address>[ \t]*[\n]?" - nil - t) - (point)))) - (when (yes-or-no-p "Delete the old signature (yes or no) ?") - (delete-region signature-start signature-end) - (hm--html-indent-line))))))) - - -(defun hm--html-set-point-for-signature () - "Searches and sets the point for inserting the signature. -It searches from the end to the beginning of the file. At first it -tries to use the point before the </body> tag then the point before -the </html> tag and the the end of the file." - (goto-char (point-max)) - (let ((case-fold-search t)) - (cond ((search-backward "</body>" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 1))) - ((search-backward "</html>" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 2))) - ((> (current-column) 0) - (newline 2)) - (t)))) - - -(defun hm--html-add-signature () - "Adds the owner's signature at the end of the buffer." - (interactive) - (if hm--html-signature-file - (progn - (if (not hm--html-username) - (setq hm--html-username (user-full-name))) - (save-excursion - (hm--html-delete-old-signature) - (hm--html-set-point-for-signature) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<ADDRESS>" - 'hm--html-insert-end-tag - "</A>\n</ADDRESS>" - 'hm--html-insert-start-tag - (hm--html-make-signature-link-string - hm--html-signature-file) - ) - (insert hm--html-username))) - (error "ERROR: Define your hm--html-signature-file first !"))) - - -(defun hm--html-add-header (size &optional header) - "Adds the HTML tags for a header at the point in the current buffer." - (interactive "nSize (1 .. 6; 1 biggest): ") - (if (or (< size 1) (> size 6)) - (message "The size must be a number from 1 to 6 !") - (hm--html-add-tags 'hm--html-insert-start-tag - (format "<H%d>" size) - 'hm--html-insert-start-tag-with-newline - (format "</H%d>" size)) - (if header - (insert header)))) - - -(defun hm--html-add-header-to-region (size) - "Adds the HTML tags for a header to the region. -The parameter 'size' specifies the size of the header." - (interactive "nSize (1 .. 6; 1 biggest): ") - (if (or (< size 1) (> size 6)) - (message "The size must be a number from 1 to 6 !") - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (format "<H%d>" size) - 'hm--html-insert-end-tag - (format "</H%d>" size)))) - - -(defun hm--html-set-point-for-title () - "Searches and sets the point for inserting the HTML element title. -The functions start at the beginning of the file and searches first -for the HTML tag <ISINDEX>. If such a tag exists, the point is set to the -position after the tag. If not, the function next searches for the -tag <HEAD> and sets the point after the tag, if it exists, or searches for -the tag <HTML>. If this tag exists, the point is set to the position after -this tag or the beginning of the file otherwise." - (goto-char (point-min)) - (let ((case-fold-search t)) - (cond ((search-forward-regexp "<isindex[^>]*>" nil t) (newline)) - ((search-forward-regexp "<head[^>]*>" nil t) (newline)) - ((search-forward-regexp "<html[^>]*>" nil t) (newline)) - (t)))) - - -(defun hm--html-add-title (title) - "Adds the HTML tags for a title at the beginning of the buffer." - (interactive "sTitle: ") - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (search-forward "<title>" nil t) - (let ((point-after-start-tag (point))) - (if (not (search-forward "</title>" nil t)) - nil - (goto-char (- (point) 8)) - (delete-backward-char (- (point) point-after-start-tag)) - (let ((start (point))) - (if hm--html-automatic-create-title-date - (insert title " (" (hm--date) ")") - (insert title)) - (goto-char start)))) - ;; Noch kein <TITLE> im Buffer vorhanden - (hm--html-set-point-for-title) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TITLE>" - 'hm--html-insert-end-tag - "</TITLE>" - 'insert - (if hm--html-automatic-create-title-date - (concat title " (" (hm--date) ")") - title)) - (forward-char 8) - (newline 1) - )))) - - -(defun hm--html-add-title-to-region () - "Adds the HTML tags for a title to the region." - (interactive) - (let ((title (buffer-substring (region-beginning) (region-end))) - (case-fold-search t)) - (save-excursion - (goto-char (point-min)) - (if (search-forward "<title>" nil t) - (let ((point-after-start-tag (point))) - (if (not (search-forward "</title>" nil t)) - nil - (goto-char (- (point) 8)) - (delete-backward-char (- (point) point-after-start-tag)) - (if hm--html-automatic-create-title-date - (insert title " (" (hm--date) ")") - (insert title)))) - ;; Noch kein <TITLE> im Buffer vorhanden - (hm--html-set-point-for-title) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TITLE>" - 'hm--html-insert-end-tag - "</TITLE>" - 'insert - (if hm--html-automatic-create-title-date - (concat title " (" (hm--date) ")") - title)) - (forward-char 8) - ;(newline 1) - )))) - - -(defun hm--html-add-html () - "Adds the HTML tags <HTML> and </HTML> in the buffer. -The tag <HTML> will be inserted at the beginning (after the -<!DOCTYPE ...>, if it is already there.) and </HTML> at the -end of the file." - (interactive) - (let ((new-cursor-position nil) - (case-fold-search t)) - (save-excursion - (goto-char (point-min)) - (if (search-forward "<html>" nil t) - (error "There is an old tag <HTML> in the current buffer !") - (re-search-forward "<!DOCTYPE[^>]*>[ \t\n]*" nil t) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "<HTML>") -; (newline 1) - ) - (setq new-cursor-position (point)) - (goto-char (point-max)) - (if (search-backward "</html>" nil t) - (error "There is an old tag </HTML> in the current buffer !") - (newline 1) - (hm--html-add-tags 'hm--html-insert-end-tag "</HTML>"))) - (goto-char new-cursor-position))) - - -(defun hm--html-add-head () - "Adds the HTML tags <HEAD> and </HEAD> in the buffer. -The tags will be inserted after <HTML> or at the beginning -of the file after <DOCTYPE...> (if it is already there). -The function also looks for the tags <BODY> and </TITLE>." - (interactive) - (let ((case-fold-search t)) - (goto-char (point-min)) - (re-search-forward "<!DOCTYPE[^>]*>[ \t\n]*" nil t) - (if (search-forward "<html>" nil t) - (if (search-forward "<head>" nil t) - (error "There is an old tag <HEAD> in the current buffer !") - (if (search-forward "</head>" nil t) - (error "There is an old tag </HEAD> in the current buffer !") - (newline 1)))) - (let ((start-tag-position (point))) - (if (search-forward "<body>" nil t) - (progn - (forward-line 0) - (forward-char -1) - (if (= (point) (point-min)) - (progn - (newline) - (forward-line -1))) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "</HEAD>") - (goto-char start-tag-position) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<HEAD>") - ) - (if (search-forward "</title>" nil t) - (progn - (newline 1) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "</HEAD>") - (goto-char start-tag-position) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<HEAD>")) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<HEAD>" - 'hm--html-insert-end-tag-with-newline - "</HEAD>")))))) - - -(defun hm--html-add-head-to-region () - "Adds the HTML tags <HEAD> and </HEAD> to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<HEAD>" - 'hm--html-insert-end-tag-with-newline - "</HEAD>")) - - -(defun hm--html-add-body () - "Adds the HTML tags <BODY> and </BODY> in the buffer. -The tags will be inserted before </HTML> or at the end of the file." - (interactive) - (let ((case-fold-search t)) - (goto-char (point-max)) - (if (search-backward "</html>" nil t) - (progn - (if (search-backward "</body>" nil t) - (error "There is an old tag </BODY> in the current buffer !") - (if (search-backward "<body>" nil t) - (error "There is an old tag <BODY> in the current buffer !"))) - (forward-char -1))) - (let ((end-tag-position (set-marker (make-marker) (point)))) - (if (search-backward "</head>" nil t) - (progn - (forward-char 7) - (newline 1) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "<BODY>") - (let ((cursor-position (point))) - (goto-char end-tag-position) - (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - "</BODY>") - (goto-char cursor-position) - )) - (if (not (= (current-column) 0)) - (newline)) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "<BODY>" - 'hm--html-insert-end-tag-with-newline "</BODY>"))))) - - -(defun hm--html-add-body-to-region () - "Adds the HTML tags <BODY> and </BODY> to the region." - (interactive) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - "<BODY>" - 'hm--html-insert-end-tag-with-newline - "</BODY>")) - - -(defun hm--html-add-title-and-header (title) - "Adds the HTML tags for a title and a header in the current buffer." - (interactive "sTitle and Header String: ") - (let ((case-fold-search t)) - (hm--html-add-title title) - (save-excursion - (goto-char (point-min)) - (search-forward "</title>" nil t) - (if (search-forward "</head>" nil t) - (progn - (search-forward "<body>" nil t) - (newline 1)) - (if (search-forward "<body>" nil t) - (newline 1) - (if (string= (what-line) "Line 1") - (progn - (end-of-line) - (newline 1))))) - (hm--html-add-header 1 title)))) - - -(defun hm--html-add-title-and-header-to-region () - "Adds the HTML tags for a title and a header to the region." - (interactive) - (let ((title (buffer-substring (region-beginning) (region-end)))) - (hm--html-add-header-to-region 1) - (hm--html-add-title title))) - - -(defun hm--html-add-full-html-frame (title) - "Adds a full HTML frame to the current buffer. -The frame consists of the elements html, head, body, title, -header and the signature. The parameter TITLE specifies the -title and the header of the document." - (interactive "sTitle and Header String: ") - (let ((case-fold-search t)) - (hm--html-add-doctype) - (hm--html-add-html) - (hm--html-add-head) - (hm--html-add-body) - (hm--html-add-title-and-header title) - (when hm--html-signature-file - (hm--html-add-signature)) - (goto-char (point-min)) - (search-forward "</h1>" nil t) - (forward-line 1) - (when hm--html-automatic-created-comment - (hm--html-insert-created-comment)) - (when hm--html-automatic-create-modified-line - (hm--html-insert-modified-line)))) - - -(defun hm--html-add-full-html-frame-with-region () - "Adds a full HTML frame to the current buffer with the use of a region. -The frame consists of the elements html, head, body, title, -header and the signature. The function uses the region as -the string for the title and the header of the document." - (interactive) - (hm--html-add-title-and-header-to-region) - (hm--html-add-doctype) - (hm--html-add-html) - (hm--html-add-head) - (hm--html-add-body) - (hm--html-add-signature) - (when hm--html-automatic-created-comment - (hm--html-insert-created-comment)) - (when hm--html-automatic-create-modified-line - (hm--html-insert-modified-line))) - - -(defun hm--html-add-link-target-to-region (name) - "Adds the HTML tags for a link target to the region." - (interactive "sName: ") - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "<A NAME=\"" name "\">") - 'hm--html-insert-end-tag - "</A>")) - -(defun hm--html-add-link-target (name) - "Adds the HTML tags for a link target at point in the current buffer." - (interactive "sName: ") - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<A NAME=\"" name "\">") - 'hm--html-insert-end-tag - "</A>")) - - -;;; Functions which add links - -(defun hm--html-mark-example (parameter-list) - "Marks the example of the parameterlist in the current buffer. -It returns the example extent." - (let ((case-fold-search t)) - (if (hm--html-get-example-from-parameter-list parameter-list) - (progn - (search-forward (hm--html-get-example-from-parameter-list - parameter-list)) - (let ((extent (make-extent (match-beginning 0) - (match-end 0)))) - (set-extent-face extent 'hm--html-help-face) - extent))))) - - -(defun hm--html-unmark-example (extent) - "Unmarks the example for the current question." - (if extent - (delete-extent extent))) - - -(defun hm--html-write-alist-in-buffer (alist) - "The function writes the contents of the ALIST in the currentbuffer." - (cond ((car alist) - (insert (int-to-string (car (car alist))) ":\t" (cdr (car alist))) - (newline) - (hm--html-write-alist-in-buffer (cdr alist))))) - - -(defun hm--html-select-directory (alist default) - "The function selects one of the directories of the ALIST, -or the DEFAULT or the 'default-directory' by number. See also the -documentation of the function hm--html-read-filename." - (if (or (string= default "") (not default)) - (setq default default-directory)) - (if alist - (save-window-excursion - (let ((buffername (generate-new-buffer "*html-directories*"))) - (set-buffer buffername) - (insert "Select one of the following directories by number !") - (newline) - (insert "===================================================") - (newline) - (insert "0:\t" default) - (newline) - (hm--html-write-alist-in-buffer alist) - (goto-char (point-min)) - (pop-to-buffer buffername)) - (let ((dirnumber (read-number - "Select directory prefix by number: " - t))) - (kill-buffer "*html-directories*") - (expand-file-name (or (cdr (assoc dirnumber alist)) default)))) - (expand-file-name default)) - ) - - -(defun hm--html-delete-wrong-path-prefix-1 (filename prefix-list) - "The function deletes wrong path prefixes." - (cond (prefix-list (if (string-match (car prefix-list) filename) - (substring filename (match-end 0)) - (hm--html-delete-wrong-path-prefix-1 filename - (cdr prefix-list) - ))) - (t filename))) - - -(defun hm--html-delete-wrong-path-prefix (filename) - "The function deletes wrong path prefixes. -The path prefixes are specified by the variable -`hm--html-delete-wrong-path-prefix'." - (if (not hm--html-delete-wrong-path-prefix) - filename - (if (listp hm--html-delete-wrong-path-prefix) - (hm--html-delete-wrong-path-prefix-1 filename - hm--html-delete-wrong-path-prefix) - (hm--html-delete-wrong-path-prefix-1 filename - (list - hm--html-delete-wrong-path-prefix)) - ))) - - -(defun hm--html-read-filename (parameter-list) - "The function reads a filename with its directory path, -if PARAMETER-LIST is not nil. If the PARAMETER-LIST is nil, only an empty -string will be returned. -The PARAMETER-LIST consists of the following elements: - PROMPT, ALIST, DEFAULT, REQUIRE-MATCH, EXAMPLE. -If the ALIST is nil and DEFAULT is nil, then the function only reads -a filename (without path). These precede the following. -If the ALIST isn't nil, the function lists the contents of the ALIST -in a buffer and reads a number from the minbuffer, which selects one -of the directories (lines) of the buffer. Therefore the ALIST must look -like the following alist: - ((1 . \"/appl/gnu/\") (2 . \"/\")) -If only ALIST is nil, or if you type a number which is not in the ALIST, -the DEFAULT directory is selected. If the DEFAULT is nil or \"\" the -'default-directory' is selected. -After that the function reads the name of the file from the minibuffer. -Therefore the PROMPT is printed in the minibuffer and the selected directory -is taken as the start of the path of the file. -If REQUIRE-MATCH is t, the filename with path must match an existing file." - (if parameter-list - (let ((marked-object (hm--html-mark-example parameter-list)) - (prompt (hm--html-get-prompt-from-parameter-list parameter-list)) - (alist (hm--html-get-alist-from-parameter-list parameter-list)) - (default (hm--html-get-default-from-parameter-list parameter-list)) - (require-match (hm--html-get-require-match-from-parameter-list - parameter-list)) - (filename nil)) - (if (or alist default) - (let ((directory (hm--html-select-directory alist default))) - (setq filename (read-file-name prompt - directory - directory - require-match - nil))) - (setq filename (read-file-name prompt - "" - "" - require-match - nil))) - (hm--html-unmark-example marked-object) - (hm--html-delete-wrong-path-prefix filename)) - "")) - - -(defun hm--html-completing-read (parameter-list) - "Reads a string with completing-read, if alist is non nil. -The PARAMETER-LIST consists of the following elements: - PROMPT, ALIST, DEFAULT, REQUIRE-MATCH, EXAMPLE. -If ALIST is nil, it returns the DEFAULT, or if the DEFAULT is -also nil it returns an empty string." - (let ((marked-object (hm--html-mark-example parameter-list)) - (string - (if (hm--html-get-alist-from-parameter-list parameter-list) - (completing-read - (hm--html-get-prompt-from-parameter-list parameter-list) - (hm--html-get-alist-from-parameter-list parameter-list) - nil - (hm--html-get-require-match-from-parameter-list - parameter-list) - (hm--html-get-default-from-parameter-list - parameter-list)) - (if (hm--html-get-default-from-parameter-list parameter-list) - (hm--html-get-default-from-parameter-list parameter-list) - "")))) - (hm--html-unmark-example marked-object) - string)) - - -(defvar hm--html-faces-exist nil) - - -(defun hm--html-generate-help-buffer-faces () - "Generates faces for the add-link-help-buffer." - (if (not (facep 'hm--html-help-face)) - (progn - (setq hm--html-faces-exist t) - (make-face 'hm--html-help-face) - (if hm--html-help-foreground - (set-face-foreground 'hm--html-help-face hm--html-help-foreground)) - (if hm--html-help-background - (set-face-background 'hm--html-help-face hm--html-help-background)) - (set-face-font 'hm--html-help-face hm--html-help-font) - ))) - - -(defun hm--html-get-prompt-from-parameter-list (parameter-list) - "Returns the prompt from the PARAMETER-LIST." - (car parameter-list)) - - -(defun hm--html-get-alist-from-parameter-list (parameter-list) - "Returns the alist from the PARAMETER-LIST." - (car (cdr parameter-list))) - - -(defun hm--html-get-default-from-parameter-list (parameter-list) - "Returns the default from the PARAMETER-LIST." - (car (cdr (cdr parameter-list)))) - - -(defun hm--html-get-require-match-from-parameter-list (parameter-list) - "Returns the require-match from the PARAMETER-LIST." - (car (cdr (cdr (cdr parameter-list))))) - - -(defun hm--html-get-example-from-parameter-list (parameter-list) - "Returns the example from the PARAMETER-LIST." - (car (cdr (cdr (cdr (cdr parameter-list)))))) - - -(defun hm--html-get-anchor-seperator-from-parameter-list (parameter-list) - "Returns the anchor-seperator from the PARAMETER-LIST." - (car (cdr (cdr (cdr (cdr (cdr parameter-list))))))) - - -(defun hm--html-generate-add-link-help-buffer (scheme-parameter-list - host-name:port-parameter-list - servername:port-parameter-list - path+file-parameter-list - anchor-parameter-list) - "Generates and displays a help buffer with an example for adding a link." - (let ((buffername (generate-new-buffer "*Link-Example*"))) - (pop-to-buffer buffername) - (shrink-window (- (window-height) 5)) - (insert "Example:") - (newline 2) - (if (hm--html-get-example-from-parameter-list scheme-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - scheme-parameter-list)) - (if (hm--html-get-example-from-parameter-list - scheme-parameter-list) - (progn - (insert ":") - (if (hm--html-get-example-from-parameter-list - host-name:port-parameter-list) - (insert "//")))))) - (if (hm--html-get-example-from-parameter-list - host-name:port-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - host-name:port-parameter-list)) - (if (and (hm--html-get-example-from-parameter-list - servername:port-parameter-list) - (not (string= "/" - (substring - (hm--html-get-example-from-parameter-list - servername:port-parameter-list) - 0 - 1)))) - (insert "/")))) - (if (hm--html-get-example-from-parameter-list - servername:port-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - servername:port-parameter-list)) - (if (hm--html-get-example-from-parameter-list - path+file-parameter-list) - (insert "/")))) - (if (hm--html-get-example-from-parameter-list path+file-parameter-list) - (progn - (insert (hm--html-get-example-from-parameter-list - path+file-parameter-list)))) - (if (hm--html-get-example-from-parameter-list anchor-parameter-list) - (progn - (insert (hm--html-get-anchor-seperator-from-parameter-list - anchor-parameter-list)) - (insert (hm--html-get-example-from-parameter-list - anchor-parameter-list)))) - (goto-char (point-min)) - buffername - )) - - -(defun hm--html-add-link (function-add-tags - scheme-parameter-list - host-name:port-parameter-list - servername:port-parameter-list - path+file-parameter-list - anchor-parameter-list) - "The function adds a link in the current buffer. -The parameter FUNCTION-ADD-TAGS determines the function which adds the tag -in the buffer (for example: 'hm--html-add-tags or -'hm--html-add-tags-to-region). -The parameters SCHEME-PARAMETER-LIST, HOST-NAME:PORT-PARAMETER-LIST, -SERVERNAME:PORT-PARAMETER-LIST, PATH+FILE-PARAMETER-LIST and -ANCHOR-PARAMETER-LIST are lists with a prompt string, an alist, a default -value and an example string. The ANCHOR-PARAMETER-LIST has as an additional -element an anchor seperator string. All these elements are used to read and -construct the link." -; (let ((point nil)) - (save-window-excursion - (let ((html-buffer (current-buffer)) - (html-help-buffer (hm--html-generate-add-link-help-buffer - scheme-parameter-list - host-name:port-parameter-list - servername:port-parameter-list - path+file-parameter-list - anchor-parameter-list)) - (scheme (hm--html-completing-read scheme-parameter-list)) - (hostname:port (hm--html-completing-read - host-name:port-parameter-list)) - (servername:port (hm--html-completing-read - servername:port-parameter-list)) - (path+file (hm--html-read-filename path+file-parameter-list)) - (anchor (hm--html-completing-read anchor-parameter-list)) -; (hrefname (setq html-link-counter (1+ html-link-counter))) - (anchor-seperator - (hm--html-get-anchor-seperator-from-parameter-list - anchor-parameter-list))) - (if (not (string= scheme "")) - (if (string= hostname:port "") - (setq scheme (concat scheme ":")) - (setq scheme (concat scheme "://")))) - (if (and (not (string= hostname:port "")) - (not (string= servername:port "")) - (not (string= (substring servername:port 0 1) "/"))) - (setq servername:port (concat "/" servername:port))) - (if (and (not (string= path+file "")) - (not (string= "/" (substring path+file 0 1)))) - (setq path+file (concat "/" path+file))) - (if (not (string= anchor "")) - (setq anchor (concat anchor-seperator anchor))) - (kill-buffer html-help-buffer) - (pop-to-buffer html-buffer) - (eval (list function-add-tags - ''hm--html-insert-start-tag - (concat "<A" -; "<A Name=" -; hrefname - " HREF=\"" - scheme - hostname:port - servername:port - path+file - anchor - "\">") - ''hm--html-insert-end-tag - "</A>"))) -; (setq point (point)))) -; (goto-char (point))) - )) - -(defun hm--html-add-info-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link on a GNU Info file." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Gateway and Port: " - hm--html-info-hostname:port-alist - hm--html-info-hostname:port-default - nil - "www.tnt.uni-hannover.de:8005") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-info-path-alist - nil - nil - "/appl/lemacs/Global/info/dir") - (list ; anchor - "Node: " - '(("")) - nil - nil - "emacs" - ","))) - - -(defun hm--html-add-info-link () - "Adds the HTML tags for a link on a GNU Info file." - (interactive) - (hm--html-add-info-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-info-link-to-region () - "Adds the HTML tags for a link on a GNU Info file to the region." - (interactive) - (hm--html-add-info-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-wais-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a WAIS server." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Gateway and Port: " - hm--html-wais-hostname:port-alist - hm--html-wais-hostname:port-default - nil - "www.tnt.uni-hannover.de:8001") - (list ; servername:port - "Wais Servername and Port: " - hm--html-wais-servername:port-alist - hm--html-wais-servername:port-default - nil - "quake.think.com:210") - (list ; path/file - "Database: " - hm--html-wais-path-alist - nil - nil - "database") - (list ; anchor - "Searchstring: " - '(("")) - nil - nil - "searchstring" - "?"))) - - -(defun hm--html-add-wais-link () - "Adds the HTML tags for a link to a WAIS server." - (interactive) - (hm--html-add-wais-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-wais-link-to-region () - "Adds the HTML tags for a link to a WAIS server to the region." - (interactive) - (hm--html-add-wais-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-direct-wais-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a direct link to a WAIS server. -This function uses the new direct WAIS support instead of a WAIS gateway." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "wais" - t - "wais") - (list ; hostname:port - "Wais Servername and Port: " - hm--html-wais-servername:port-alist - hm--html-wais-servername:port-default - nil - "quake.think.com:210") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Database: " - hm--html-wais-path-alist - nil - nil - "database") - (list ; anchor - "Searchstring: " - '(("")) - nil - nil - "searchstring" - "?"))) - - -(defun hm--html-add-direct-wais-link () - "Adds the HTML tags for a direct link to a WAIS server. -This function uses the new direct WAIS support instead of a WAIS gateway." - (interactive) - (hm--html-add-direct-wais-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-direct-wais-link-to-region () - "Adds the HTML tags for a direct link to a WAIS server to the region. -This function uses the new direct WAIS support instead of a WAIS gateway." - (interactive) - (hm--html-add-direct-wais-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-html-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to an HTML page." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Servername and Port: " - hm--html-html-hostname:port-alist - hm--html-html-hostname:port-default - nil - "www.tnt.uni-hannover.de:80") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-html-path-alist - nil - nil - "/data/info/www/tnt/overview.html") - (list ; anchor - "Anchor: " - '(("")) - nil - nil - "1" - "#"))) - - -(defun hm--html-add-html-link () - "Adds the HTML tags for a link to an HTML file." - (interactive) - (hm--html-add-html-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-html-link-to-region () - "Adds the HTML tags for a link to an HTML file to the region." - (interactive) - (hm--html-add-html-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-file-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a filegateway link." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "file" - t - "file") - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-file-path-alist - nil - nil - "/data/info/www/tnt/overview.html") - (list ; anchor - "Anchor: " - '(("")) - nil - nil - "1" - "#"))) - - -(defun hm--html-add-file-link () - "Adds the HTML tags for a for a filegateway link." - (interactive) - (hm--html-add-file-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-file-link-to-region () - "Adds the HTML tags for a for a filegateway link to the region." - (interactive) - (hm--html-add-file-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-ftp-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to an FTP server." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "ftp" - t - "ftp") - (list ; hostname:port - "FTP Servername: " - hm--html-ftp-hostname:port-alist - hm--html-ftp-hostname:port-default - nil - "ftp.rrzn.uni-hannover.de") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-ftp-path-alist - nil - nil - "/pub/gnu/gcc-2.4.5.tar.gz") - (list ; anchor - "" - nil - "" - t - nil - nil))) - - -(defun hm--html-add-ftp-link () - "Adds the HTML tags for a link to an FTP server." - (interactive) - (hm--html-add-ftp-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-ftp-link-to-region () - "Adds the HTML tags for a link to an FTP server to the region." - (interactive) - (hm--html-add-ftp-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-gopher-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a gopher server." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "gopher" - t - "gopher") - (list ; hostname:port - "Gopher Servername: " - hm--html-gopher-hostname:port-alist - hm--html-gopher-hostname:port-default - nil - "newsserver.rrzn.uni-hannover.de:70") - (list ; servername:port - "Documenttype: " - hm--html-gopher-doctype-alist - hm--html-gopher-doctype-default - nil - "/1") - nil ; path/file - (list ; anchor - "Entrypoint: " - hm--html-gopher-anchor-alist - nil - nil - "Subject%20Tree" - "/"))) - - -(defun hm--html-add-gopher-link () - "Adds the HTML tags for a link to a gopher server." - (interactive) - (hm--html-add-gopher-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-gopher-link-to-region () - "Adds the HTML tags for a link to a gopher server to the region." - (interactive) - (hm--html-add-gopher-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-make-proggate-alist (proggate-allowed-file) - "Makes a proggate-alist from the PROGGATE-ALLOWED-FILE." - (if (and (stringp proggate-allowed-file) - (file-exists-p proggate-allowed-file)) - (save-window-excursion - (let ((alist nil) - (buffername (find-file-noselect proggate-allowed-file)) - (case-fold-search t)) - (set-buffer buffername) - (toggle-read-only) - (goto-char (point-min)) - (while (search-forward-regexp "[^ \t\n]+" nil t) - (setq alist (append (list (list (buffer-substring - (match-beginning 0) - (match-end 0)))) - alist))) - (kill-buffer buffername) - alist)) - (error "ERROR: Can't find the 'hm--html-progate-allowed-file !"))) - - -(defun hm--html-add-proggate-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a program. -The program is called via the program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (let ((progname-alist (hm--html-make-proggate-alist - hm--html-proggate-allowed-file))) - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Servername and Port: " - hm--html-proggate-hostname:port-alist - hm--html-proggate-hostname:port-default - nil - "www.tnt.uni-hannover.de:8007") - (list ; program - "Programname: " - progname-alist - nil - nil - "/usr/ucb/man") - nil ; path/file - (list ; Program Parameter - "Programparameter: " - '(("")) - nil - nil - "8+lpd" - "+")))) - - -(defun hm--html-add-proggate-link () - "Adds the HTML tags for a link to a program. -The program is called via the program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-proggate-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-proggate-link-to-region () - "Adds the HTML tags for a link to a program to the region. -The program is called via the program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-proggate-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-local-proggate-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a program. -The program is called via the local program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "" - t - nil) - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/file: " - hm--html-local-proggate-path-alist - nil - nil - "/data/info/programs/lemacs.evlm") - (list ; anchor - "" - nil - "" - t - nil))) - - -(defun hm--html-add-local-proggate-link () - "Adds the HTML tags for a link to a program. -The program is called via the local program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-local-proggate-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-local-proggate-link-to-region () - "Adds the HTML tags for a link to a program to the region. -The program is called via the local program gateway. -Email to muenkel@tnt.uni-hannover.de for information over -this gateway." - (interactive) - (hm--html-add-local-proggate-link-1 'hm--html-add-tags-to-region)) - - -(defvar hm--html-newsgroup-alist nil - "Alist with newsgroups for the newsgateway.") - - -(defvar gnus-newsrc-assoc nil) - - -(defun hm--html-make-newsgroup-alist () - "Makes a hm--html-make-newsgroup-alist from a .newsrc.el file. -The function looks at the environment variable NNTPSERVER. -If this variable exists, it tries to open the file with the Name -~/$NNTPSERVER.el. If this file exists, the alist of the file is -returned as the newsgroup-alist. If the file doesn't exist, it -tries to use the file ~/$NNTPSERVER to make the alist. The function -returns '((\"\"))" - (if hm--html-newsgroup-alist - hm--html-newsgroup-alist - (if gnus-newsrc-assoc - (setq hm--html-newsgroup-alist gnus-newsrc-assoc) - (if (not (getenv "NNTPSERVER")) - '(("")) - (let ((newsrc-file (expand-file-name (concat "~/.newsrc-" - (getenv "NNTPSERVER"))))) - (if (file-exists-p (concat newsrc-file ".el")) - (progn - (load-file (concat newsrc-file ".el")) - (setq hm--html-newsgroup-alist gnus-newsrc-assoc)) - (if (not (file-exists-p newsrc-file)) - '(("")) - (save-window-excursion - (let ((alist nil) - (buffername (find-file-noselect newsrc-file)) - (case-fold-search t)) - (set-buffer buffername) - (toggle-read-only) - (goto-char (point-min)) - (while (search-forward-regexp "[^:!]+" nil t) - (setq alist (append (list (list (buffer-substring - (match-beginning 0) - (match-end 0)))) - alist)) - (search-forward-regexp "\n")) - (kill-buffer buffername) - (setq hm--html-newsgroup-alist alist)))))))))) - - - -(defun hm--html-add-news-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a news group." - (let ((newsgroup-alist (hm--html-make-newsgroup-alist))) - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "news" - t - "news") - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "NEWS Group: " - newsgroup-alist - nil - nil - "comp.emacs.xemacs") - nil ; path/file - (list ; anchor - "" - nil - "" - t - nil - nil)))) - - -(defun hm--html-add-news-link () - "Adds the HTML tags for a link to a news group." - (interactive) - (hm--html-add-news-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-news-link-to-region () - "Adds the HTML tags for a link to a news group to the region." - (interactive) - (hm--html-add-news-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-mail-box-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a link to a mail box." - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "http" - t - "http") - (list ; hostname:port - "Hostname and Port: " - hm--html-mail-hostname:port-alist - hm--html-mail-hostname:port-default - nil - "www.tnt.uni-hannover.de:8003") - (list ; servername:port - "" - nil - "" - t - nil) - (list ; path/file - "Path/File: " - hm--html-mail-path-alist - nil - nil - "/data/info/mail/mailbox") - (list ; anchor - "" - nil - "" - t - nil - nil))) - - -(defun hm--html-add-mail-box-link () - "Adds the HTML tags for a link to a mail box." - (interactive) - (hm--html-add-mail-box-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-mail-box-link-to-region () - "Adds the HTML tags for a link to a mail box to the region." - (interactive) - (hm--html-add-mail-box-link-1 'hm--html-add-tags-to-region)) - - -(defun hm--html-add-mailto-link-1 (function-add-tags) - "Internal function. Adds the HTML tags for a mailto link." - (let ((mailto-alist (if (and (boundp 'user-mail-address) - user-mail-address) - (cons (list user-mail-address) - hm--html-mailto-alist) - hm--html-mailto-alist))) - (hm--html-add-link function-add-tags - (list ; scheme - "" - nil - "mailto" - t - "mailto") - (list ; hostname:port - "" - nil - "" - t - nil) - (list ; servername:port - "Mailaddress: " - mailto-alist - nil - nil - "muenkel@tnt.uni-hannover.de") - nil ; path/file - (list ; anchor - "" - nil - "" - t - nil - nil)))) - -(defun hm--html-add-mailto-link () - "Adds the HTML tags for a mailto link." - (interactive) - (hm--html-add-mailto-link-1 'hm--html-add-tags)) - - -(defun hm--html-add-mailto-link-to-region () - "Adds the HTML tags for a mailto link to the region." - (interactive) - (hm--html-add-mailto-link-1 'hm--html-add-tags-to-region)) - -(defun hm--html-add-relative-link (relative-file-path) - "Adds the HTML tags for a relative link at the current point." - (interactive (list (file-relative-name - (read-file-name "Relative Filename: " - nil - nil - nil - "") - default-directory) - )) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<A HREF=\"" - relative-file-path - "\">") - 'hm--html-insert-end-tag - "</A>")) - -(defun hm--html-add-relative-link-to-region (relative-file-path) - "Adds the HTML tags for a relative link to the region." - (interactive (list (file-relative-name - (read-file-name "Relative Filename: " - nil - nil - nil - "")))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "<A HREF=\"" - relative-file-path - "\">") - 'hm--html-insert-end-tag - "</A>")) - -(defun hm--html-add-normal-link (link-object) - "Adds the HTML tags for a normal general link. -Single argument LINK-OBJECT is value of HREF in the new anchor. -Mark is set after anchor." - (interactive "sNode Link to: ") - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<A HREF=\"" - link-object - "\">") - 'hm--html-insert-end-tag - "</A>")) - -(defun hm--html-add-normal-link-to-region (link-object) - "Adds the HTML tags for a normal general link to region. -Single argument LINK-OBJECT is value of HREF in the new anchor. -Mark is set after anchor." - (interactive "sNode Link to: ") - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "<A HREF=\"" - link-object - "\">") - 'hm--html-insert-end-tag - "</A>")) - - -(defun hm--html-add-normal-node-link () - "Adds the HTML tags for a normal node link (<LINK...>) at the point." - (interactive) - (hm--html-insert-start-tag (concat "<LINK HREF=\"" - (read-string "Node Link to: ") - "\">") - )) - -;;; Functions to update the date and the changelog entries - - -(defun hm--html-maybe-new-date-and-changed-comment () - "Hook function which updates the date in the title line, if -'hm--html-automatic-update-title-date' is t and which inserts a -\"changed comment\" line, if 'hm--html-automatic-changed-comment' is t." - (when hm--html-automatic-update-title-date - (hm--html-new-date)) - (when hm--html-automatic-changed-comment - (hm--html-insert-changed-comment t)) - (when hm--html-automatic-update-modified-line - (hm--html-insert-modified-line))) - - -(defun hm--html-new-date () - "The function sets the date in the title line up." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (end-of-head (if (search-forward "</head>" nil t) - (point) - (if (search-forward "<body>" nil t) - (point) - (point-max))))) - (goto-char (point-min)) - (if (re-search-forward - (concat - "\\((\\)" - "\\([ \t]*[0-3]?[0-9]-[A-Z][a-z][a-z]-[0-9][0-9][0-9][0-9]" - "[ \t]*\\)" - "\\()[ \t\n]*</title>\\)") - end-of-head - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (goto-char (match-beginning 2)) - (insert (hm--date))))))) - - -(defun hm--html-insert-created-comment (&optional noerror) - "The function inserts a \"created comment\". -The comment looks like <!-- Created by: Heiko Münkel, 10-Dec-1993 -->. -The comment will be inserted after the title line. -An error message is printed, if there is no title line and if -noerror is nil." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (end-of-head (if (search-forward "</head>" nil t) - (point) - (if (search-forward "<body>" nil t) - (point) - (point-max)))) - (comment-infix (or hm--html-comment-infix - (concat (or hm--html-username (user-full-name)) - ", ")))) - (goto-char (point-min)) - (if (not (search-forward "</title>" end-of-head t)) - (if (not noerror) - (error "ERROR: Please insert a title in the document !")) -; (let ((end-of-title-position (point))) - (if (search-forward (concat "<!-- " - hm--html-created-comment-prefix) - end-of-head - t) - (if (yes-or-no-p - (concat "Replace the old comment \"<!-- " - hm--html-created-comment-prefix - "\" ")) - (progn - (goto-char (match-beginning 0)) - (kill-line) - (hm--html-add-comment) - (insert hm--html-created-comment-prefix - comment-infix -; (or hm--html-username (user-full-name)) -; ", " - (hm--date)))) - (newline) - (hm--html-add-comment) - (insert hm--html-created-comment-prefix - comment-infix -; (insert "Created by: " -; (or hm--html-username (user-full-name)) -; ", " - (hm--date) - )))))) - - -(defun hm--html-insert-changed-comment-1 (newline) - "Internal function of 'hm--html-insert-changed-comment'. -Inserts a newline if NEWLINE is t, before the comment is inserted." - (if newline - (progn - (newline))) - (hm--html-add-comment) - (insert hm--html-changed-comment-prefix - (or hm--html-comment-infix - (concat (or hm--html-username (user-full-name)) ", ")) - (hm--date))) - -(defun hm--html-insert-changed-comment (&optional noerror) - "The function inserts a \"changed comment\". -The comment looks by default like - <!-- Changed by: Heiko Münkel, 10-Dec-1993 -->. -The comment will be inserted after the last \"changed comment\" line, or, -if there isn't such a line, after the \"created comment\" line, or, -after the title line. If there is no title and NOERROR is nil, an error -message is generated. The line is not inserted after the end of the head -or the beginning of the body. -If the last \"changed line\" is from the same author, it is only replaced -by the new one. - -Look at the variables `hm--html-changed-comment-prefix' and -`hm--html-comment-infix', if you'd like to change the -inserted comments. You should not use different values for this -variables in the same HTML file. - -Attention: Don't write anything else in such a line!" - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (end-of-head (if (search-forward "</head>" nil t) - (point) - (if (search-forward "<body>" nil t) - (point) - (point-max)))) - (comment-infix (or hm--html-comment-infix - hm--html-username - (user-full-name)))) -; (username (or hm--html-username (user-full-name)))) - (goto-char end-of-head) -; (if (search-backward "<!-- Changed by: " nil t) - (if (search-backward (concat "<!-- " - hm--html-changed-comment-prefix) - nil - t) -; (if (string-match username - (if (string-match comment-infix - (buffer-substring (point) - (progn - (end-of-line) - (point)))) - ;; exchange the comment line - (progn - (beginning-of-line) - (delete-region (point) (progn - (end-of-line) - (point))) - (hm--html-insert-changed-comment-1 nil)) - ;; new comment line - (end-of-line) - (hm--html-insert-changed-comment-1 t)) -; (if (search-backward "<!-- Created by: " nil t) - (if (search-backward (concat "<!-- " - hm--html-created-comment-prefix) - nil - t) - (progn - (end-of-line) - (hm--html-insert-changed-comment-1 t)) - (if (search-backward "</title>" nil t) - (progn - (goto-char (match-end 0)) - (if (not (looking-at "\n")) - (progn - (newline) - (forward-char -1))) - (hm--html-insert-changed-comment-1 t)) - (if (not noerror) - (error - "ERROR: Insert at first a title in the document !")))))))) - -(defun hm--html-insert-modified-line () - "Inserts a modified line. -By default the line looks like: - <EM>Modified: 23-May-1997</EM> - -Look at the variables `hm--html-automatic-create-modified-line', -`hm--html-automatic-update-modified-line', `hm--html-modified-prefix', -`hm--html-modified-start-tag', `hm--html-modified-end-tag' and -`hm--html-modified-insert-before' to change the behaviour of this -feature." - (interactive) - (save-excursion - (goto-char (point-max)) - (if (search-backward-regexp (concat hm--html-modified-start-tag - "[ \t\n]*" - hm--html-modified-prefix) - nil - t) - (progn ; old modified line exists - (goto-char (match-end 0)) - (if (search-forward-regexp (concat "\\([ \t\n]*\\)" - "\\([^ \t\n<]+\\)" - "\\([ \t\n]*" - hm--html-modified-end-tag - "\\)")) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (goto-char (match-beginning 2)) - (insert (hm--date))) -; (replace-match (concat "\\1" (hm--date))) - (error "Destroyed \"Modified line\" found!"))) - (search-backward hm--html-modified-insert-before nil t) - (search-backward "</html>" nil t) - (search-backward "</body>" nil t) - (newline) - (indent-according-to-mode) - (forward-line -1) - (unless (= (hm--html-return-end-of-line) (point)) - (end-of-line) - (newline)) - (newline) - (indent-according-to-mode) - (insert hm--html-modified-start-tag - hm--html-modified-prefix - (hm--date) - hm--html-modified-end-tag)))) - - -;;; Functions to insert templates - -(defvar hm--html-template-file-history nil - "Historyvariable for the template files in the `hm--html-mode'.") - -(defun hm--html-insert-template (filename) - "Inserts a templatefile. -It uses `tmpl-insert-template-file' to insert -the templates. The variables `tmpl-template-dir-list', -`tmpl-automatic-expand' and `tmpl-history-variable-name' are -overwritten by `hm--html-template-dir', -`hm--html-automatic-expand-templates' and `hm--html-template-file-history'." - (interactive (list nil)) - (let ((tmpl-template-dir-list (if (listp hm--html-template-dir) - hm--html-template-dir - (list hm--html-template-dir))) - (tmpl-automatic-expand hm--html-automatic-expand-templates) - (tmpl-history-variable-name 'hm--html-template-file-history)) - (if filename - (tmpl-insert-template-file filename) - (call-interactively 'tmpl-insert-template-file)) - )) - -(defun hm--html-insert-template-from-fixed-dirs (filename) - "Inserts a templatefile. -It uses `tmpl-insert-template-file-from-fixed-dirs' to insert -the templates. The variables `tmpl-template-dir-list', -`tmpl-automatic-expand', `tmpl-filter-regexp' and -`tmpl-history-variable-name' are overwritten by -`hm--html-template-dir', `hm--html-automatic-expand-templates', -`hm--html-template-filter-regexp' and `hm--html-template-file-history'." - (interactive (list nil)) - (let ((tmpl-template-dir-list (if (listp hm--html-template-dir) - hm--html-template-dir - (list hm--html-template-dir))) - (tmpl-automatic-expand hm--html-automatic-expand-templates) - (tmpl-filter-regexp hm--html-template-filter-regexp) - (tmpl-history-variable-name 'hm--html-template-file-history)) - (if filename - (tmpl-insert-template-file-from-fixed-dirs filename) - (call-interactively 'tmpl-insert-template-file-from-fixed-dirs)) - )) - - -;;; Functions for font lock mode - -(if (adapt-emacs19p) - (progn - (make-face 'font-lock-comment-face) - (make-face 'font-lock-doc-string-face) - (make-face 'font-lock-string-face) - (or (face-differs-from-default-p 'font-lock-doc-string-face) - (copy-face 'font-lock-comment-face 'font-lock-doc-string-face)) - (or (face-differs-from-default-p 'font-lock-comment-face) - (copy-face 'italic 'font-lock-comment-face)) - (or (face-differs-from-default-p 'font-lock-string-face) - (progn - (copy-face 'font-lock-doc-string-face 'font-lock-string-face) - (set-face-underline-p 'font-lock-string-face t))) - (setq font-lock-comment-face 'font-lock-comment-face) - (setq font-lock-string-face 'font-lock-string-face))) - - -;;; Functions to insert forms - -(defun hm--html-form-read-method () - "Reads the method for a form." - (completing-read "Method of the form: " - '(("POST") ("GET")) - nil - t - "POST")) - - -(defun hm--html-form-read-action (method) - "Reads the URL for the action attribute of a form. -It returns nil if no action attribute is wanted. -METHOD is the method of the form." - (if (y-or-n-p "Current document URL as action attribute ? ") - nil - (hm--html-read-url "Query server URL: " - hm--html-url-alist - (function - (lambda (table-element-list) - (hm--html-read-url-predicate table-element-list - (car - (read-from-string - method))))) - nil - nil))) - - -(defun hm--html-add-form (&optional method) - "Adds the HTML tags for a form. -The function asks only for a method, if METHOD is nil, otherwise -the METHOD must have one of the values \"GET\" or \"POST\"." - (interactive) - (let* ((method (or method (hm--html-form-read-method))) - (action (hm--html-form-read-action method))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<FORM METHOD=\"" - method - "\"" - (if action - (concat " ACTION=\"" - action - "\"") - "") - ">") - 'hm--html-insert-end-tag-with-newline - "</FORM>"))) - - -(defun hm--html-add-form-to-region (&optional method) - "Adds the HTML tags for a form to a region. -The function asks only for a method, if METHOD is nil, otherwise -the METHOD must have one of the values \"GET\" or \"POST\"." - (interactive) - (let* ((method (or method (hm--html-form-read-method))) - (action (hm--html-form-read-action method))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "<FORM METHOD=\"" - method - "\"" - (if action - (concat " ACTION=\"" - action - "\"") - "") - ">") - 'hm--html-insert-end-tag-with-newline - "</FORM>"))) - - -(defun hm--html-form-read-name (&optional last-name) - "Reads the name for an input tag." - (read-string "Symbolic name: " last-name)) - - -(defun hm--html-form-read-value (prompt &optional initial-contents) - "Reads the value for an input tag." - (read-string prompt initial-contents)) - - -(defun hm--html-form-read-checked () - "Reads whether a button is checked by default or not." - (y-or-n-p "Should the button be checked by default ? ")) - - -(defun hm--html-form-read-size () - "Reads the size of text entry fields of input tags." - (if (y-or-n-p "Defaultsize of the Inputfield ? ") - nil - (format "%d,%d" - (read-number "Width of the input field: " t) - (read-number "Height of the input field: " t)))) - - -(defun hm--html-form-read-maxlength () - "Reads the maxlength of text entry fields of input tags." - (let ((maxlength (read-number "Maximum number of chars (0 = unlimited): " - t))) - (if (<= maxlength 0) - nil - (int-to-string maxlength)))) - - -(defun hm--html-form-read-src (prompt &optional initial-contents) - "Reads the src for an input tag." - (read-string prompt initial-contents)) - - -(defun hm--html-form-add-input (type - name - value - checked - size - maxlength - &optional src) - "Adds the HTML tags for an input tag to the buffer." - (hm--html-insert-start-tag (concat "<INPUT TYPE=\"" - type - "\"" - (if (and name (not (string= name ""))) - (concat " NAME=\"" name "\"")) - (if (and value (not (string= value ""))) - (concat " VALUE=\"" value "\"")) - (if checked " CHECKED") - (if (and size (not (string= size ""))) - (concat " SIZE=" size)) - (if (and maxlength - (not (string= maxlength ""))) - (concat " MAXLENGTH=" - maxlength - )) - (if (and src - (not (string= src ""))) - (concat " SRC=\"" - src - "\"")) - ">"))) - - -(defun hm--html-form-add-input-text (name value size maxlength) - "Adds the HTML tags for a text input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "text" name value nil size maxlength)) - - -(defun hm--html-form-add-input-password (name value size maxlength) - "Adds the HTML tags for a password input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "password" name value nil size maxlength)) - - -(defun hm--html-form-add-input-integer (name value size maxlength) - "Adds the HTML tags for a integer input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "int" name value nil size maxlength)) - - -(defun hm--html-form-add-input-float (name value size maxlength) - "Adds the HTML tags for a float input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "float" name value nil size maxlength)) - - -(defun hm--html-form-add-input-date (name value size maxlength) - "Adds the HTML tags for a date input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "date" name value nil size maxlength)) - - -(defun hm--html-form-add-input-url (name value size maxlength) - "Adds the HTML tags for a url input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "url" name value nil size maxlength)) - - -(defun hm--html-form-add-input-scribble (name value size maxlength) - "Adds the HTML tags for a scribble input field." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Defaultvalue: ") - (hm--html-form-read-size) - (hm--html-form-read-maxlength))) - (hm--html-form-add-input "scribble" name value nil size maxlength)) - - -(defun hm--html-form-add-input-checkbox (name value checked) - "Adds the HTML tags for a checkbox button." - (interactive (list (hm--html-form-read-name) - (hm--html-form-read-value "Checkbox value: ") - (hm--html-form-read-checked))) - (hm--html-form-add-input "checkbox" name value checked nil nil)) - - -(defvar hm--html-last-radio-button-name nil - "Name of the last radio button.") - - -(defun hm--html-form-add-input-radio (name value checked) - "Adds the HTML tags for a radio button." - (interactive (list (hm--html-form-read-name hm--html-last-radio-button-name) - (hm--html-form-read-value "Radiobutton value: ") - (hm--html-form-read-checked))) - (setq hm--html-last-radio-button-name name) - (hm--html-form-add-input "radio" name value checked nil nil)) - - -(defun hm--html-form-add-input-submit (value) - "Adds the HTML tags for a submit input field." - (interactive (list (hm--html-form-read-value - "Label of the submit button: " - "Submit"))) - (hm--html-form-add-input "submit" nil value nil nil nil)) - - -(defun hm--html-form-add-input-image (name src) - "Adds the HTML tags for an image input field." - (interactive (list (hm--html-form-read-name) - (hm--html-read-url "Image URL: " - hm--html-url-alist - (function - (lambda (table-element-list) - (hm--html-read-url-predicate - table-element-list - 'IMAGE))) - nil - nil))) - (hm--html-form-add-input "IMAGE" - name - nil - nil - nil - nil - src)) - - -(defun hm--html-form-add-input-audio (name src) - "Adds the HTML tags for an audio input field." - (interactive (list (hm--html-form-read-name) - (hm--html-read-url "Audio URL: " - hm--html-url-alist - (function - (lambda (table-element-list) - (hm--html-read-url-predicate - table-element-list - 'AUDIO))) - nil - nil))) - (hm--html-form-add-input "AUDIO" - name - nil - nil - nil - nil - src)) - - -(defun hm--html-form-add-input-reset (value) - "Adds the HTML tags for a reset input field." - (interactive (list (hm--html-form-read-value - "Label of the reset button: " - "Reset"))) - (hm--html-form-add-input "reset" nil value nil nil nil)) - - -(defun hm--html-form-add-input-isindex (size) - "Adds the HTML tags for an isindex input field. -Size is the value of the input field wide." - (interactive "nWidth of the input field (i.e: 20): ") - (hm--html-insert-start-tag (concat "<INPUT NAME=\"isindex\"" - (if (= size 20) - ">" - (format - " SIZE=%d>" - size))))) - - -(defun hm--html-form-add-select-option-menu (name) - "Adds the HTML tags for a select option menu to the buffer." - (interactive (list (hm--html-form-read-name))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<SELECT NAME=\"" name "\">") - 'hm--html-insert-end-tag-with-newline - "</SELECT>" - 'hm--html-insert-start-tag - "<OPTION> ")) - - -(defun hm--html-form-add-select-scrolled-list (name listsize multiple) - "Adds the HTML tags for a select scrolled list to the buffer." - (interactive (list (hm--html-form-read-name) - (read-number "No of visible items (>1): " t) - (y-or-n-p "Multiple selections allowed ? "))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<SELECT NAME=\"" - name - "\" SIZE=" - (int-to-string listsize) - (if multiple - " MULTIPLE") - ">") - 'hm--html-insert-end-tag-with-newline - "</SELECT>" - 'hm--html-insert-start-tag - "<OPTION> ")) - - -(defun hm--html-form-add-select-option (selected-by-default) - "Adds the tags for an option in a select form menu." - (interactive (list (y-or-n-p "Select this option by default ? "))) - (hm--html-insert-end-tag-with-newline (concat "<OPTION" - (if selected-by-default - " SELECTED") - "> "))) - - -(defun hm--html-form-add-textarea (name rows columns) - "Adds the tags for a textarea tag." - (interactive (list (hm--html-form-read-name) - (read-number "Number of Rows of the Textarea: " t) - (read-number "Number of Columns of the Textarea: " t))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<TEXTAREA NAME=\"" - name - "\" ROWS=" - (int-to-string rows) - " COLS=" - (int-to-string columns) - ">") - 'hm--html-insert-end-tag - "</TEXTAREA>")) - - -;;; Functions to insert tables - -(defun hm--html-add-table (border compact) - "Add the HTML tags for a table frame. -If BORDER is t, then the table should be drawn with a border. -If COMPACT is t, then the table should be drawn in a smaller size." - (interactive (list (y-or-n-p "Use a table with a border? ") - (y-or-n-p "Use a small table? "))) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - (concat "<TABLE" - (if border " border" "") - (if compact " compact" "") - ">") - 'hm--html-insert-start-tag-with-newline - "</TABLE>") - (backward-char)) - - -(defun hm--html-add-table-to-region (border compact) - "Add the HTML tags for a table frame. -If BORDER is t, then the table should be drawn with a border. -If COMPACT is t, then the table should be drawn in a smaller size." - (interactive (list (y-or-n-p "Use a table with a border? ") - (y-or-n-p "Use a small table? "))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline - (concat "<TABLE" - (if border " border" "") - (if compact " compact" "") - ">") - 'hm--html-insert-start-tag-with-newline - "</TABLE>")) - - -(defun hm--html-add-table-title (top) - "Adds the HTML tag for a table title at the current point. -If TOP is t, then the title will positioned at the top instead of the -bottom of the table." - (interactive (list (y-or-n-p "Put the title at the table top? "))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "\n<CAPTION" - (if top " align=top" " align=bottom") - "> ") - 'hm--html-insert-end-tag - " </CAPTION>")) - - -(defun hm--html-add-table-title-to-region (top) - "Adds the HTML tag for a table title to the region. -If TOP is t, then the title will positioned at the top instead of the -bottom of the table." - (interactive (list (y-or-n-p "Put the title at the table top? "))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "<CAPTION" - (if top " align=top" " align=bottom") - "> ") - 'hm--html-insert-end-tag - " </CAPTION>")) - - -(defvar hm--html-table-alignment-alist '(("default") - ("left") - ("right") - ("center")) - "Alist with table alignments.") - -(defun hm--html-table-read-cell-entries-and-alignments (cell-no - no-of-cells - &optional - alignment-list) - "Reads the alignments and the entries for NO-OF-CELLS cells. -The return is a list with strings of the form: \"align=left> entry\". -CELL-NO is the current cell no. -If (car ALIGNMENT-LIST) is non-nil, then it is used as alignment." - (if (> cell-no no-of-cells) - nil - (let ((alignment - (or (car alignment-list) - (completing-read (format "Alignment of the %d. cell: " - cell-no) - hm--html-table-alignment-alist - nil - t - "default"))) - (entry (read-string (format "Entry of the %d. cell: " cell-no)))) - (if (string= "default" alignment) - (setq alignment "") - (setq alignment (concat " align=" alignment))) - (cons (concat alignment "> " entry) - (hm--html-table-read-cell-entries-and-alignments (1+ cell-no) - no-of-cells - (cdr - alignment-list)) - )))) - -(defun hm--html-add-table-header (no-of-cells) - "Adds the HTML tags for a complete simple table header line. -It asks for the number of cells and the allignment of the cells. -The number of cells can also be given as prefix argument." - (interactive "NNo of cells in a row: ") - (if (< no-of-cells 1) - (error "ERROR: There must be at least one cell in a row!")) - (hm--html-add-tags - 'hm--html-insert-end-tag-with-newline - (concat "<TR>" - (mapconcat '(lambda (entry) - (concat "<TH" entry)) - (hm--html-table-read-cell-entries-and-alignments - 1 - no-of-cells) - " </TH>") - " </TH></TR>"))) - - -(defun hm--html-add-first-table-row (no-of-cells) - "Adds the HTML tags for a table row. -It asks for the number of cells and the allignment of the cells. -The number of cells can also be given as prefix argument." - (interactive "NNo of cells in a row: ") - (if (< no-of-cells 1) - (error "ERROR: There must be at least one cell in a row!")) - (hm--html-add-tags - 'hm--html-insert-end-tag-with-newline - (concat "<TR><TD" - (car (hm--html-table-read-cell-entries-and-alignments 1 1)) - " </TD>" - (if (<= no-of-cells 1) - "</TR>" - (concat - (mapconcat '(lambda (entry) - (concat "<TD" entry)) - (hm--html-table-read-cell-entries-and-alignments - 2 no-of-cells) - " </TD>") - " </TD></TR>"))))) - - -(defun hm--html-table-get-previous-alignments () - "Returns a list with the alignments of the previous table row. -The row must be a data row and not a header row! -An example for the return list: '(\"left\" \"default\" \"center\" \"right\")" - (save-excursion - (let* ((point-of-view (point)) - (case-fold-search t) - (end-of-last-row (search-backward "</tr>" (point-min) t)) - (begin-of-last-row (progn (search-backward "<tr" (point-min) t) - (re-search-forward "<t[dh]" - point-of-view t) - (match-beginning 0))) - (alignment-list nil)) - (goto-char begin-of-last-row) - (if (not (re-search-forward "<t[dh]" end-of-last-row t)) - (error "Error: No previous data row found!") - (goto-char end-of-last-row) - (while (> (point) begin-of-last-row) - (let ((cell-start - (search-backward-regexp "\\(<td[^>]*>\\)\\|\\(<th[^>]*>\\)" - begin-of-last-row - t))) - (if (not cell-start) - (goto-char begin-of-last-row) - (setq alignment-list - (cons - (if (search-forward-regexp "\\(align=\\)\\([^ \t\n>]*\\)" - (match-end 0) - t) - (buffer-substring (match-beginning 2) - (match-end 2)) - "default") - alignment-list)) - (goto-char cell-start)))) - alignment-list)))) - - -(defun hm--html-add-additional-table-row () - "Adds the HTML tags for a table row. -It tries to detect the number of cells and their alignments -from existing rows of the table." - (interactive) - (let* ((old-alignment-list (hm--html-table-get-previous-alignments)) - (no-of-cells (length old-alignment-list))) - (hm--html-add-tags - 'hm--html-insert-end-tag-with-newline - (concat "<TR><TD" (car (hm--html-table-read-cell-entries-and-alignments - 1 - 1 - old-alignment-list)) - " </TD>" - (if (<= no-of-cells 1) - "</TR>" - (concat - (mapconcat '(lambda (entry) - (concat "<TD" entry)) - (hm--html-table-read-cell-entries-and-alignments - 2 - no-of-cells - (cdr old-alignment-list)) - " </TD>") - " </TD></TR>")))))) - - -(defun hm--html-add-row-entry (alignment) - "Adds the HTML tag for a table row entry at the current point." - (interactive (list (completing-read "Alignment of the cell: " - hm--html-table-alignment-alist - nil - t - "default"))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<TD" - (if (string= "default" alignment) - "> " - (concat " align=" alignment "> "))))) - - -(defun hm--html-add-header-entry (alignment) - "Adds the HTML tag for a table header entry at the current point." - (interactive (list (completing-read "Alignment of the cell: " - hm--html-table-alignment-alist - nil - t - "default"))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<TH" - (if (string= "default" alignment) - "> " - (concat " align=" alignment "> "))))) - - -(defun hm--html-add-row-frame (alignment) - "Adds the HTML tags for a table row start and end at the current point." - (interactive (list (completing-read "Alignment of the start cell: " - hm--html-table-alignment-alist - nil - t - "default"))) - (hm--html-add-tags 'hm--html-insert-start-tag - (concat "<TD" - (if (string= "default" alignment) - "> " - (concat " align=" alignment "> "))) - 'hm--html-insert-end-tag - "<TR>")) - - -(defun hm--html-add-row-frame-to-region (alignment) - "Adds the HTML tags for a table row start and end to the current region." - (interactive (list (completing-read "Alignment of the start cell: " - hm--html-table-alignment-alist - nil - t - "default"))) - (hm--html-add-tags-to-region 'hm--html-insert-start-tag - (concat "<TD" - (if (string= "default" alignment) - "> " - (concat " align=" alignment "> "))) - 'hm--html-insert-end-tag - " <TR>")) - - -(defun hm--html-table-add-colspan-attribute (columns) - "Adds a colspawn attribute to a table cell. -A prefix arg is used as no of COLUMNS." - (interactive "NNo of columns, spaned by this cell: ") - (let ((case-fold-search t)) - (save-excursion - (if (and (search-backward "<" nil t) - (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) - (if (search-forward-regexp "\\([ \t\n]+colspan=\\)\\([^ \t\n>]*\\)" - nil - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (insert (format "\"%d\"" columns))) - (insert (format " colspan=\"%d\"" columns))) - (error "ERROR: Point not in a table cell!"))))) - - -(defun hm--html-table-add-rowspan-attribute (rows) - "Adds a rowspan attribute to a table cell. -A prefix arg is used as no of ROWS." - (interactive "NNo of rows, spaned by this cell: ") - (let ((case-fold-search t)) - (save-excursion - (if (and (search-backward "<" nil t) - (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) - (if (search-forward-regexp "\\([ \t\n]+rowspan=\\)\\([^ \t\n>]*\\)" - nil - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (insert (format "\"%d\"" rows))) - (insert (format " rowspan=\"%d\"" rows))) - (error "ERROR: Point not in a table cell!"))))) - - -;;; ISO-Characters for Emacs HTML-mode (Berthold Crysmann) -;(setq buffer-invisibility-spec '(hm--html-iso-entity-invisible-flag)) - -;(defvar hm--html-iso-entity-invisible-flag t -; "Controls the visibility of the iso entities.") - -;(defvar hm--html-iso-glyph-invisible-flag nil -; "Controls the visibility of the iso character glyphs.") - -;(defvar hm--html-glyph-cache nil -; "Internal variable. An assoc list with the already created glyphs.") - -;(defun hm--html-create-glyph (string) -; "Creates a glyph from the string or returns an existing one. -;The glyph is stored in `hm--html-glyph-cache'." -; (if nil ;(assoc string hm--html-glyph-cache) -; (cdr (assoc string hm--html-glyph-cache)) -; (let ((glyph (make-glyph string))) -; (setq hm--html-glyph-cache (cons (cons string glyph) -; hm--html-glyph-cache)) -; glyph))) - -;(defun hm--html-attach-glyph-to-region (start -; end -; string -; region-invisible-flag -; glyph-invisible-flag) -; "Make the region invisible and attach a glyph STRING. -;The invisible flags could be used, to toggle the visibility." -; (mapcar 'delete-annotation (annotations-at end)) ; delete old anotations -; ;; delete old extents -; (let ((extent (make-extent start end)) -; (annotation nil)) -; (set-extent-property extent 'invisible region-invisible-flag) -; (set-extent-property extent 'end-open t) -; (set-extent-property extent 'start-open t) -; (set-extent-property extent 'intangible t) -; (setq annotation (make-annotation "Hallo Du da" ;(hm--html-create-glyph string) -; end -; 'text)) -; (goto-char end))) - - -;(defun hm--html-insert-iso-char-as-entity-and-glyph (char entity) -; "Inserts an iso char as html ENTITY and displays a glyph. -;The glyph is created from the string CHAR." -; (let ((start (point))) -; (insert entity) -; (hm--html-attach-glyph-to-region start -; (point) -; char -; 'hm--html-iso-entity-invisible-flag -; 'hm--html-iso-glyph-invisible-flag))) - -;(defun hm--html_ue () -; (interactive) -; (hm--html-insert-iso-char-as-entity-and-glyph "ü" "ü")) - - -;(defun hm--html-insert-iso-char-as-entity-and-glyph (char entity) -; (let ((start (point)) -; (end nil) -; (extent nil)) -; (insert entity) -; (setq end (point)) -; (setq extent (make-extent start end)) -; (set-extent-begin-glyph extent char) -; (set-extent-property extent 'invisible t))) - -;(defun hm--html_ue () -; (interactive) -; (hm--html-insert-iso-char-as-entity-and-glyph ?ü "ü")) - -(defun hm--html_ue () - "Insert the character 'ue'." - (interactive) - (insert "ü")) - -(defun hm--html_oe () - "Insert the character 'oe'." - (interactive) - (insert "ö")) - -(defun hm--html_ae () - "Insert the character 'ae'." - (interactive) - (insert "ä")) - -(defun hm--html_aa () - "Insert the character 'aa'." - (interactive) - (insert "å")) - -(defun hm--html_Ue () - "Insert the character 'Ue'." - (interactive) - (insert "Ü")) - -(defun hm--html_Oe () - "Insert the character 'Oe'." - (interactive) - (insert "Ö")) - -(defun hm--html_Ae () - "Insert the character 'Ae'." - (interactive) - (insert "Ä")) - -(defun hm--html_Aa () - "Insert the character 'Aa'." - (interactive) - (insert "Å")) - -(defun hm--html_sz () - "Insert the character 'sz'." - (interactive) - (insert "ß")) - -(defun hm--html_aacute () - "Insert the character 'aacute'." - (interactive) - (insert "á")) - -(defun hm--html_eacute () - "Insert the character 'eacute'." - (interactive) - (insert "é")) - -(defun hm--html_iacute () - "Insert the character 'iacute'." - (interactive) - (insert "í")) - -(defun hm--html_oacute () - "Insert the character 'oacute'." - (interactive) - (insert "ó")) - -(defun hm--html_uacute () - "Insert the character 'uacute'." - (interactive) - (insert "ú")) - -(defun hm--html_Aacute () - "Insert the character 'Aacute'." - (interactive) - (insert "á")) - -(defun hm--html_Eacute () - "Insert the character 'Eacute'." - (interactive) - (insert "é")) - -(defun hm--html_Iacute () - "Insert the character 'Iacute'." - (interactive) - (insert "í")) - -(defun hm--html_Oacute () - "Insert the character 'Oacute'." - (interactive) - (insert "ó")) - -(defun hm--html_Uacute () - "Insert the character 'Uacute'." - (interactive) - (insert "ú")) - -(defun hm--html_agrave () - "Insert the character 'agrave'." - (interactive) - (insert "à")) - -(defun hm--html_egrave () - "Insert the character 'egrave'." - (interactive) - (insert "è")) - -(defun hm--html_igrave () - "Insert the character 'igrave'." - (interactive) - (insert "ì")) - -(defun hm--html_ograve () - "Insert the character 'ograve'." - (interactive) - (insert "ò")) - -(defun hm--html_ugrave () - "Insert the character 'ugrave'." - (interactive) - (insert "ù")) - -(defun hm--html_Agrave () - "Insert the character 'Agrave'." - (interactive) - (insert "À")) - -(defun hm--html_Egrave () - "Insert the character 'Egrave'." - (interactive) - (insert "È")) - -(defun hm--html_Igrave () - "Insert the character 'Igrave'." - (interactive) - (insert "Ì")) - -(defun hm--html_Ograve () - "Insert the character 'Ograve'." - (interactive) - (insert "Ò")) - -(defun hm--html_Ugrave () - "Insert the character 'Ugrave'." - (interactive) - (insert "Ù")) - -(defun hm--html_ccedilla () - "Insert the character 'ccedilla'." - (interactive) - (insert "çla;")) - -(defun hm--html_Ccedilla () - "Insert the character 'Ccedilla'." - (interactive) - (insert "Çla;")) - -(defun hm--html_atilde () - "Insert the character 'atilde'." - (interactive) - (insert "ã")) - -(defun hm--html_otilde () - "Insert the character 'otilde'." - (interactive) - (insert "õ")) - -(defun hm--html_ntilde () - "Insert the character 'ntilde'." - (interactive) - (insert "ñ")) - -(defun hm--html_Atilde () - "Insert the character 'Atilde'." - (interactive) - (insert "Ã")) - -(defun hm--html_Otilde () - "Insert the character 'Otilde'." - (interactive) - (insert "Õ")) - -(defun hm--html_Ntilde () - "Insert the character 'Ntilde'." - (interactive) - (insert "Ñ")) - -(defun hm--html_acircumflex () - "Insert the character 'acircumflex'." - (interactive) - (insert "â")) - -(defun hm--html_ecircumflex () - "Insert the character 'ecircumflex'." - (interactive) - (insert "ê")) - -(defun hm--html_icircumflex () - "Insert the character 'icircumflex'." - (interactive) - (insert "î")) - -(defun hm--html_ocircumflex () - "Insert the character 'ocircumflex'." - (interactive) - (insert "ô")) - -(defun hm--html_ucircumflex () - "Insert the character 'ucircumflex'." - (interactive) - (insert "û")) - -(defun hm--html_Acircumflex () - "Insert the character 'Acircumflex'." - (interactive) - (insert "Â")) - -(defun hm--html_Ecircumflex () - "Insert the character 'Ecircumflex'." - (interactive) - (insert "Ê")) - -(defun hm--html_Icircumflex () - "Insert the character 'Icircumflex'." - (interactive) - (insert "Î")) - -(defun hm--html_Ocircumflex () - "Insert the character 'Ocircumflex'." - (interactive) - (insert "Ô")) - -(defun hm--html_Ucircumflex () - "Insert the character 'Ucircumflex'." - (interactive) - (insert "Û")) - -(defun hm--html_ediaeresis () - "Insert the character 'ediaeresis'." - (interactive) - (insert "ë")) - -(defun hm--html_idiaeresis () - "Insert the character 'idiaeresis'." - (interactive) - (insert "ï")) - -(defun hm--html_Ediaeresis () - "Insert the character 'Ediaeresis'." - (interactive) - (insert "Ë")) - -(defun hm--html_Idiaeresis () - "Insert the character 'Idiaeresis'." - (interactive) - (insert "Ï")) - -(defun hm--html_thorn () - "Insert the character 'thorn'." - (interactive) - (insert "þ")) - -(defun hm--html_Thorn () - "Insert the character 'Thorn'." - (interactive) - (insert "Þ")) - -(defun hm--html_eth () - "Insert the character 'eth'." - (interactive) - (insert "ð")) - -(defun hm--html_Eth () - "Insert the character 'Eth'." - (interactive) - (insert "Ð")) - - -;;; -; -; smart functions - -(defvar hm--just-insert-less-than nil - "Internal variable.") - -(defun hm--html-less-than () - "Inserts the entity '>'." - (interactive) - (insert "<")) - -(defun hm--html-smart-less-than () - "Insert a '<' or the entity '<' if you execute this command twice." - (interactive) - (if (and (eq last-command 'hm--html-smart-less-than) - hm--just-insert-less-than) - (progn - (delete-char -1) - (hm--html-less-than) - (setq hm--just-insert-less-than nil)) - (insert ?<) - (setq hm--just-insert-less-than t))) - -(defvar hm--just-insert-greater-than nil - "Internal variable.") - -(defun hm--html-greater-than () - "Inserts the entity '>'." - (interactive) - (insert ">")) - -(defun hm--html-smart-greater-than () - "Insert a '>' or the entity '>' if you execute this command twice." - (interactive) - (if (and (eq last-command 'hm--html-smart-greater-than) - hm--just-insert-greater-than) - (progn - (delete-char -1) - (hm--html-greater-than) - (setq hm--just-insert-greater-than nil)) - (insert ?>) - (setq hm--just-insert-greater-than t))) - - -(defvar hm--just-insert-ampersand nil - "Internal variable.") - -(defun hm--html-ampersand () - "Inserts the entity '&'." - (interactive) - (insert "&")) - -(defun hm--html-smart-ampersand () - "Insert a '&' or the entity '&' if you execute this command twice." - (interactive) - (if (and (eq last-command 'hm--html-smart-ampersand) - hm--just-insert-ampersand) - (progn - (delete-char -1) - (hm--html-ampersand) - (setq hm--just-insert-ampersand nil)) - (insert ?&) - (setq hm--just-insert-ampersand t))) - - -;;; -; sending the contents of a html buffer to netscape -; (Thanks to Adrian Aichner for providing this function) - -(defun hm--html-send-buffer-to-netscape (buffer - &optional new-netscape new-window) - "View html buffer with Netscape. -This should be changed in the fututure, so that it doesn't need vm." - (interactive) - (require 'vm) - (if new-netscape - (vm-run-background-command vm-netscape-program buffer-file-name) - (or (equal 0 - (vm-run-command vm-netscape-program - "-remote" - (concat "openURL(file://localhost" - buffer-file-name - (if new-window ", new-window" "") - ")"))) - (hm--html-send-buffer-to-netscape buffer t new-window)))) - - - -;;; -; some other usefull functions -; - -(defun hm--html-remove-numeric-names () - "Remove the number in numbered links in the current buffer. -Eg: the string \"Name=3\". The function asks the user every time whether -the number should be removed." - (interactive) - (save-excursion - (goto-char (point-min)) - (query-replace-regexp "name=\"?[0-9]+\"?+[ \t]*" ""))) - -;;This should be extended in the future to use also other viewers. -(defun hm--html-view-www-package-docu () - "View the WWW documentation of the package." - (interactive) - (w3-fetch (concat "http://www.tnt.uni-hannover.de" - "/~muenkel/software/own/hm--html-menus/overview.html"))) - - -;;; -; Bug reporting -; - -(defun hm--html-submit-bug-report () - "Submit via mail a bug report on hm--html-menus." - (interactive) - (require 'reporter) - (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - hm--html-menus-package-maintainer - (concat hm--html-menus-package-name - " " - hm--html-menus-package-version) - (list 'emacs-version - 'major-mode - 'hm--html-automatic-changed-comment - 'hm--html-automatic-created-comment - 'hm--html-automatic-create-modified-line - 'hm--html-automatic-expand-templates - 'hm--html-automatic-update-modified-line - 'hm--html-automatic-update-title-date - 'hm--html-changed-comment-prefix - 'hm--html-comment-infix - 'hm--html-created-comment-prefix - 'hm--html-expert - 'hm--html-favorite-http-server-host-name - 'hm--html-file-path-alist - 'hm--html-ftp-hostname:port-alist - 'hm--html-ftp-hostname:port-default - 'hm--html-ftp-path-alist - 'hm--html-gopher-anchor-alist - 'hm--html-gopher-doctype-alist - 'hm--html-gopher-doctype-default - 'hm--html-gopher-hostname:port-alist - 'hm--html-gopher-hostname:port-default - 'hm--html-html-hostname:port-alist - 'hm--html-html-hostname:port-default - 'hm--html-html-path-alist - 'hm--html-info-hostname:port-alist - 'hm--html-info-hostname:port-default - 'hm--html-info-path-alist - 'hm--html-local-proggate-path-alist - 'hm--html-mail-hostname:port-alist - 'hm--html-mail-hostname:port-default - 'hm--html-mail-path-alist - 'hm--html-marc - 'hm--html-menu-load-hook - 'hm--html-modified-end-tag - 'hm--html-modified-insert-before - 'hm--html-modified-prefix - 'hm--html-modified-start-tag - 'hm--html-proggate-allowed-file - 'hm--html-proggate-hostname:port-alist - 'hm--html-proggate-hostname:port-default - 'hm--html-server-side-include-command-alist - 'hm--html-server-side-include-command-with-parameter-alist - 'hm--html-signature-file - 'hm--html-template-dir - 'hm--html-url-alist - 'hm--html-user-config-file - 'hm--html-site-config-file - 'hm--html-username - 'hm--html-wais-hostname:port-alist - 'hm--html-wais-hostname:port-default - 'hm--html-wais-path-alist - 'hm--html-wais-servername:port-alist - 'hm--html-wais-servername:port-default - 'html-document-previewer - 'hm--html-region-mode - 'html-sigusr1-signal-value - ) - nil - nil - "Decribe your Bug: " - ))) - - -;;; -; hook adding functions -; - -(if (adapt-xemacsp) - (progn - - (add-hook 'zmacs-activate-region-hook - 'hm--html-switch-region-modes-on) - - (add-hook 'zmacs-deactivate-region-hook - 'hm--html-switch-region-modes-off) - - ) - - (transient-mark-mode t) - - (add-hook 'activate-mark-hook - 'hm--html-switch-region-modes-on) - - (add-hook 'deactivate-mark-hook - 'hm--html-switch-region-modes-off) - - ) - - -;;; -; Environment loading -; - -(defun hm--html-load-config-files () - "Load the html configuration files. -First, the system config file (detemined by the environment variable -HTML_CONFIG_FILE; normaly hm--html-configuration.el(c)) is loaded. -At second a site config file is loaded, if the environment variable -HTML_SITE_CONFIG_FILE or the lisp variable `hm--html-site-config-file' -is set to such a file and if the emacs wasn't started with the -flag -no-site-file. -At least the user config file (determined by the environment variable -HTML_USER_CONFIG_FILE; normaly the file ~/.hm--html-configuration.el(c)). -If no HTML_CONFIG_FILE exists, then the file hm--html-configuration.el(c) -is searched in one of the lisp load path directories. -If no HTML_USER_CONFIG_FILE exists, then the variable -`hm--html-user-config-file' is checked. If this variable is nil or the file -also doesn't exist, then the file ~/.hm--html-configuration.el(c) is used. -In this case it is possible to use another home directory by using the -u -flag for the emacs start. In all cases, the loading of the user configuration -file can be avoided by using the -q flag." - (interactive) - ;; at first the system config file - (if (and (stringp (getenv "HTML_CONFIG_FILE")) - (file-exists-p - (expand-file-name - (getenv "HTML_CONFIG_FILE")))) - (load-library (expand-file-name (getenv "HTML_CONFIG_FILE"))) - (load-library "hm--html-configuration")) - - ;; at second the site config file - (when (or (and (boundp 'site-start-file) ;XEmacs - site-start-file) - (and (boundp 'site-run-file) ; Emacs 19 - site-run-file)) - (if (and (stringp (getenv "HTML_SITE_CONFIG_FILE")) - (file-exists-p - (expand-file-name - (getenv "HTML_SITE_CONFIG_FILE")))) - (load-file (expand-file-name (getenv "HTML_SITE_CONFIG_FILE"))) - (when (and (boundp 'hm--html-site-config-file) - (stringp hm--html-site-config-file) - (file-exists-p (expand-file-name hm--html-site-config-file))) - (load-file (expand-file-name hm--html-site-config-file))))) - - ;; and now the user config file - (when init-file-user ; may be something should be done for reloading - (cond ((and (stringp (getenv "HTML_USER_CONFIG_FILE")) - (file-exists-p - (expand-file-name - (getenv "HTML_USER_CONFIG_FILE")))) - (load-file (expand-file-name (getenv "HTML_USER_CONFIG_FILE")))) - ((and (boundp 'hm--html-user-config-file) - (stringp hm--html-user-config-file) - (file-exists-p (expand-file-name hm--html-user-config-file))) - (load-file (expand-file-name hm--html-user-config-file))) - ((file-exists-p (expand-file-name - (concat "~" - init-file-user - "/.hm--html-configuration.elc"))) - (load-file (expand-file-name - (concat "~" - init-file-user - "~/.hm--html-configuration.elc")))) - ((file-exists-p (expand-file-name - (concat "~" - init-file-user - "~/.hm--html-configuration.el"))) - (load-file (expand-file-name - (concat "~" - init-file-user - "~/.hm--html-configuration.el")))) - (t - (message (concat "WARNING: No HTML User Config File ! " - "Look at hm--html-load-config-files !"))) - )) - ) - - -;;; quotify href - -(defvar hm--html-quotify-href-regexp - "<[aA][ \t\n]+\\([nN][aA][mM][eE]=[a-zA-Z0-9]+[ \t\n]+\\)?[hH][rR][eE][fF]=" - "Regular expression used for searching hrefs.") - -(defun hm--html-quotify-hrefs () - "Insert quotes around all HREF and NAME attribute value literals. - -This remedies the problem with old HTML files that can't be processed -by SGML parsers. That is, changes <A HREF=foo> to <A HREF=\"foo\">. - -Look also at the variable `hm--html-quotify-href-regexp'." - (interactive) - (save-excursion - (goto-char (point-min)) - (while - (re-search-forward hm--html-quotify-href-regexp - (point-max) - t) - (cond - ((null (looking-at "\"")) - (insert "\"") - (re-search-forward "[ \t\n>]" (point-max) t) - (forward-char -1) - (insert "\"")))))) - - - -(provide 'hm--html)
--- a/lisp/hm--html-menus/html-view.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -;;; html-view.el --- routines for communicating with a NCSA Mosaic process -;;; -;;; Some routines for communicating with a NCSA Mosaic process. -;;; -;;; Copyright (C) 1993 Ron Tapia tapia@hydra.unm.edu -;;; Copyright (C) 1994, 1995 Heiko Münkel muenkel@tnt.uni-hannover.de -;;; -;;; VERSION: 1.10 -;;; LAST MODIFIED: 20/07/95 -;;; Keywords: comm unix wp help -;;; -;;; Adapted to the lemacs: 19.07.1993 Heiko Muenkel -;;; (muenkel@tnt.uni-hannover.de) -;;; Changed: 19.07.1993 by Heiko Muenkel -;;; Changed: 28.12.1993 by Heiko Muenkel -;;; Changed (signal-process id 30) -;;; to (signal-process id html-sigusr1-signal-value) -;;; Addapted the file for the new Mosaic-2.1 -;;; Thanks to Neal Becker, who has reported this problem. -;;; The file now requires the package hm--html-menus. -;;; But you can also delete the line (require 'hm--html) and -;;; add a line like (setq html-sigusr1-signal-value 30) -;;; Changed: 10.01.1994 by Heiko Muenkel -;;; Fixed a bug. -;;; Changed: 16.12.1994 by Heiko Münkel -;;; Addapted the file for Mosaic-2.4. -;;; Changed: 03.02.1995 by Heiko Münkel -;;; The "view-buffer" is now different from the original buffer. -;;; So the name of the original buffer isn't change anymore. -;;; Changed: 02.04.1995 by Heiko Münkel -;;; Integrated the changes from the XEmacs distribution. -;;; Changed: 20.07.1995 by Heiko Münkel -;;; Fixed a bug in html-view-goto-url. -;;; -;;; This program 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. -;;; -;;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; Commentary: -;;; To use, just set the value of html-view-mosaic-command to whatever you -;;; use to run NCSA Mosaic. You may have to set html-view-tmp-file. -;;; Type M-x html-view-start-mosaic <ret>. -;;; Afterwards, view files/buffers with html-view-view-file/ -;;; html-view-view-buffer. There's also a command, of dubious utility, -;;; for jumping to particular documents: html-view-goto-url -;;; -;;; If you have any questions or comments mail to tapia@hydra.unm.edu. - - -(require 'hm--html) - -(defvar html-view-mosaic-process nil "The NCSA Mosaic Process") - -(defvar html-view-mosaic-command "mosaic" - "The command that runs Mosaic on your system") - -(defvar html-view-mosaic-tmp-file-prefix "/tmp/Mosaic." - "Prefix for the temp files, which are used by Mosaic. -For old versions this must be \"/tmp/xmosaic.\". -For new versions it is \"/tmp/Mosaic.\".") - -(defvar html-view-tmp-file (concat "/tmp/mosaic.html-" - (user-login-name) - (emacs-pid)) - "File where buffers are saved for viewing by Mosaic") - -(defvar html-view-display nil "The display that Mosaic is using.") - -(defvar html-view-wait-counter 100000 - "*Counter for a wait loop. -The wait loop is beween the start of the Mosaic and the command -`set-process-sentinel'. If Mosaic don't start, then you must set -this value higher. You can try to set it to a lower number otherwise.") - -;;;###autoload -(defun html-view-start-mosaic () - "Start Mosaic." - (interactive) - (or (stringp html-view-display) - (call-interactively 'html-view-get-display)) - (or (and (processp html-view-mosaic-process) - (eq (process-status html-view-mosaic-process) 'run)) - (progn (setq html-view-mosaic-process - (start-process "mosaic" "mosaic" - html-view-mosaic-command - "-display" html-view-display)) - (let ((i html-view-wait-counter)) - (while (> i 0) - (setq i (1- i)))) - (set-process-sentinel html-view-mosaic-process - 'html-view-mosaic-process-sentinel)))) - -;;;###autoload -(defun html-view-view-file (filename) - "View an html file with Mosaic." - (interactive "fFile to view: ") - (or (and (processp html-view-mosaic-process) - (eq (process-status html-view-mosaic-process) 'run)) - (html-view-start-mosaic)) - (if (and (processp html-view-mosaic-process) - (eq (process-status html-view-mosaic-process) 'run)) - (progn - (let ((buffer (process-buffer html-view-mosaic-process)) - (id (process-id html-view-mosaic-process)) - (file nil)) - (save-excursion - (set-buffer buffer) - (erase-buffer) - (setq file (format "%s%s" html-view-mosaic-tmp-file-prefix id)) - (set-visited-file-name file) - ;; (set-visited-file-name (concat "/tmp/Mosaic." - ;; (number-to-string id))) - (insert-before-markers "goto\n") - (insert-before-markers (concat - "file://" - (expand-file-name filename))) - (save-buffer) - (signal-process id html-sigusr1-signal-value)))) - (message "Can't start mosaic process."))) - -;;;###autoload -(defun html-view-view-buffer (&optional buffer-to-view) - "View html buffer with Mosaic. -If BUFFER-TO-VIEW is nil, then the current buffer is used." - (interactive) - (or (bufferp buffer-to-view) - (setq buffer-to-view (current-buffer))) - (save-excursion - (find-file html-view-tmp-file) - (insert-buffer buffer-to-view) - (write-file html-view-tmp-file) - (html-view-view-file html-view-tmp-file))) - -;;;###autoload -(defun html-view-goto-url (url) - "Goto an URL in Mosaic." - (interactive "sURL: ") - (or (processp html-view-mosaic-process) - (html-view-start-mosaic)) - (if (processp html-view-mosaic-process) - (progn - (let ((buffer (process-buffer html-view-mosaic-process)) - (id (process-id html-view-mosaic-process)) - (file nil)) - (save-excursion - (set-buffer buffer) - (erase-buffer) -;; (setq file (format "%s%s" "/tmp/xmosaic." id)) - (setq file (format "%s%s" html-view-mosaic-tmp-file-prefix id)) - (set-visited-file-name file) - ;; (set-visited-file-name (concat "/tmp/Mosaic." - ;; (number-to-string id))) - (insert-before-markers "goto\n") - (insert-before-markers url) - (save-buffer) - (signal-process id html-sigusr1-signal-value)))) - (message "Can't start mosaic process."))) - -;;;###autoload -(defun html-view-get-display (display) - "Get the display for Mosaic." - (interactive "sDisplay: ") - (setq html-view-display display)) - - -(defun html-view-mosaic-process-sentinel (proc, event) - (cond ((or (string-match "exited abnormally with code" event) - (string-match "finished" event)) - (message event) - (setq html-view-mosaic-process nil)) - (t (message event)))) - - -(provide 'html-view)
--- a/lisp/hm--html-menus/internal-drag-and-drop.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,942 +0,0 @@ -;;; internal-drag-and-drop.el --- Internal drag and drop interface - -;; Copyright (C) 1996, 1997 Heiko Muenkel - -;; Author: Heiko Muenkel <muenkel@tnt.uni-hannover.de> -;; Keywords: mouse - -;; $Id: internal-drag-and-drop.el,v 1.5 1997/07/26 22:09:46 steve Exp $ - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 part of Emacs. - -;;; Commentary: - -;; Description: - -;; This package provides functions to define and call internal -;; drag and drop actions in the emacs. One could start such an -;; action by clicking with the mouse in the source buffer and -;; then in the destination buffer. The action could depend on -;; the points where you've clicked with the mouse, on the state -;; of the region, the point, the mark and any other properties -;; of the source and the destination buffers. The actions are -;; defined by the variable `idd-actions', which is a buffer local -;; variable. The following is an example for the hm--html-mode: -;; (defvar hm--html-idd-actions -;; '((nil (((idd-if-major-mode-p . dired-mode) -;; (idd-if-dired-file-on-line-p -;; . ".*\\.\\(gif\\)\\|\\(jpq\\)")) -;; hm--html-idd-add-include-image-from-dired-line) -;; (((idd-if-major-mode-p . dired-mode) -;; (idd-if-dired-no-file-on-line-p . nil)) -;; hm--html-idd-add-file-link-to-file-on-dired-line) -;; (((idd-if-major-mode-p . dired-mode) -;; (idd-if-dired-no-file-on-line-p . t)) -;; hm--html-idd-add-file-link-to-directory-of-buffer) -;; (((idd-if-major-mode-p . w3-mode) -;; (idd-if-url-at-point-p . t)) -;; hm--html-idd-add-html-link-from-w3-buffer-point) -;; (((idd-if-major-mode-p . w3-mode)) -;; hm--html-idd-add-html-link-to-w3-buffer) -;; (((idd-if-local-file-p . t)) -;; hm--html-idd-add-file-link-to-buffer))) -;; Look at the variable `idd-actions' for further descriptions. - - -;; Installation: - -;; Put this file in one of your load path directories. - -;; Put the following in your .emacs: -;; (autoload 'idd-mouse-drag-and-drop "internal-drag-and-drop" -;; "Performs a drag and drop action. -;; At first you must click on the source and -;; after that on the destination." -;; t) - -;; Define actions in the variable `idd-actions'. - -;; The variable `idd-global-mouse-keys' defines the mouse keys, -;; which are bound to the drag and drop command. - -;; The variable `idd-global-help-mouse-keys' defines the mouse keys, -;; which are bound to the drag and drop help command. - -;; The variable `idd-drag-and-drop-mouse-binding-type' determines -;; if you've to hold a mouse button down during moving the mouse -;; from the source to the destination or not. - -;; Emacs 19 users should read carefully the whole comments of -;; `idd-drag-and-drop-mouse-binding-type', `idd-global-mouse-keys' -;; and `idd-global-help-mouse-keys', if they would like to change -;; any of these variables or the mouse bindings! - -;;; Code: - -(require 'adapt) -(require 'cl) - -(defgroup idd-drag-and-drop nil - "This package provides functions to define and call internal -drag and drop actions in the emacs. One could start such an -action by clicking with the mouse in the source buffer and -then in the destination buffer. The action could depend on -the points where you've clicked with the mouse, on the state -of the region, the point, the mark and any other properties -of the source and the destination buffers. The actions are -defined by the variable `idd-actions', which is a buffer local -variable." - :group 'mouse) - -(defcustom idd-drag-and-drop-mouse-binding-type 'click - "*The type of the drag and drop mouse binding. -The value maybe `click' or `press-button-during-move'. -A value of `click' means, that you've to click over the source, leave -the button and click it again over the destination. -A value of `press-button-during-move' means, that you've to press -the button down over the source and hold it until the mouse pointer -is over the destination. - -The disadvantage of the `press-button-during-move' type compared with -the `click' type is, that you can't select a destination region and -therefore a drag and drop action depending on a selected region can't -be started with that type of mouse binding. - -Note: In the Emacs 19 you'll have to change also the keybindings of -the drag and drop commands, if you change this variable. Look at the -variables `idd-global-mouse-keys' and `idd-global-help-mouse-keys' for -this." - :group 'idd-drag-and-drop - :type '(choice (const :tag "Click on source and destination" - :value click) - (const :tag "Press button during mouse move" - :value press-button-during-move))) - -(defvar idd-global-mouse-keys (if (adapt-emacs19p) - (if (eq idd-drag-and-drop-mouse-binding-type - 'click) - [(meta control mouse-1)] - [(meta control down-mouse-1)]) - [(meta control button1)]) - "The mouse keys for the command `idd-mouse-drag-and-drop'. -The command `idd-mouse-drag-and-drop' is bound during the loading -of the package internal-drag-and-drop to this keys in the global -key map. - -Set it to nil, if you don't want to bind this function during loading. - -If the command is already bound in the global keymap during loading, -then this key sequence will not be bind. - -Note: In the Emacs 19 the mouse keys must contain the modifier -`down', if `idd-drag-and-drop-mouse-binding-type' is set to -`press-button-during-move' and must not contain the modifier, if it -is set to `click'. If you set `idd-drag-and-drop-mouse-binding-type' -before loading the package internal-drag-and-drop, the mouse will -be bind in the right way.") - -(defvar idd-global-help-mouse-keys - (if (adapt-emacs19p) - (if (eq idd-drag-and-drop-mouse-binding-type 'click) - [(meta control mouse-3)] - [(meta control down-mouse-3)]) - [(meta control button3)]) - "The mouse keys for the command `idd-help-mouse-drag-and-drop'. -The command `idd-help-mouse-drag-and-drop' is bound during the loading -of the package internal-drag-and-drop to this keys in the global -key map. - -Set it to nil, if you don't want to bind this function during loading. - -If the command is already bound in the global keymap during loading, -then this key sequence will not be bind. - -Note: In the Emacs 19 the mouse keys must contain the modifier -`down', if `idd-drag-and-drop-mouse-binding-type' is set to -`press-button-during-move' and must not contain the modifier, if it -is set to `click'. If you set `idd-drag-and-drop-mouse-binding-type' -before loading the package internal-drag-and-drop, the mouse will -be bind in the right way.") - -(defcustom idd-actions '((((idd-if-region-active-p . nil)) - (((idd-if-region-active-p . t)) - idd-action-copy-region)) - - (((idd-if-region-active-p . t)) - (((idd-if-region-active-p . t)) - idd-action-copy-replace-region)) - - (((idd-if-region-active-p . nil) - (idd-if-modifiers-p . nil)) - (((idd-if-region-active-p . t)) - idd-action-move-region)) - - (((idd-if-region-active-p . t) - (idd-if-modifiers-p . nil)) - (((idd-if-region-active-p . t)) - idd-action-move-replace-region)) - ) - "*The list with actions, depending on the source and the destination. -The list looks like: - '((<destination-specification-1> (<source-specification-1> <action-1-1>) - (<source-specification-2> <action-1-2>) - : - ) - (<destination-specification-2> (<source-specification-1> <action-2-1>) - (<source-specification-2> <action-2-2>) - : - ) - : - ) -The <source-specification> looks like the following: - '([(<specification-type> <value>)]) -with <specification-type> :== idd-if-minor-mode-p | idd-if-buffer-name-p - | idd-if-region-active-p | idd-if-url-at-point-p - | idd-if-major-mode-p | idd-if-variable-non-nil-p - | idd-if-dired-file-on-line-p - | idd-if-dired-no-file-on-line-p - | idd-if-local-file-p | idd-if-buffer-name-p - | idd-if-modifiers-p | ... - -The <specification-type> - functions must have two arguments, the first one -is the source or destination and the second is the <value>. It must return -nil, if the test wasn't successfull and a number (in general 1), which -specifies the weight of the test function. The weights of all single tests -are added to a summary weight and assigned to the action. The action -with the highest weight is called from the action handler. Look at -the definition of `idd-if-major-mode-p', `idd-if-minor-mode-p' and so on for -examples. Look at the function `idd-get-source-or-destination-alist', if -you wan't to know the structure of the 'source-or-destination' argument -of these functions. - -The <destination-specification> looks like <source-specification>, -but in general it could be set to nil in mode specific idd-action -lists. - -If <destination-specification-1> or <source-specification-1> is set to -nil, then every source or source matches. `idd-actions' is a -buffer local variable, which should be at least mode depended. So if -the <destination-specification-1> is set to nil it says, that the destination -buffer must only have a specific mode. But however, it's also possible -to define a general `idd-actions' list, where the destination mode is -specified by `idd-if-major-mode-p'. - -<action> ist a function, which has two arguments, the first specifies the -source and the second the destination. Look at the function definition -of `idd-action-copy-region' and `idd-action-copy-replace-region'. They are -examples for such actions." - :group 'idd-drag-and-drop - :type 'list) - -(make-variable-buffer-local 'idd-actions) - -(defcustom idd-help-instead-of-action nil - "*If this variable is t, then a help buffer is displayed. -No action will be performed if this variable is t. - -Note: You can also use the help mouse key instead of setting -this to t." - :group 'idd-drag-and-drop - :type 'boolean) - -(defcustom idd-mouse-pointer-image "drop" - "*The name of the image used as mouse pointer during drag and drop. -The image must be in the directory `idd-data-directory'. -Run the command `idd-make-drag-and-drop-pointer-glyph' after changing -this variable." - :group 'idd-drag-and-drop - :type 'file) - -(defcustom idd-data-directory (file-name-as-directory - (expand-file-name "idd" data-directory)) - "Data directory for the file `idd-mouse-pointer-image'. -Run the command `idd-make-drag-and-drop-pointer-glyph' after changing -this variable." - :group 'idd-drag-and-drop - :type 'directory) - -(defcustom idd-overwrite-mouse-pointers - (if (adapt-xemacsp) - '(text-pointer-glyph - nontext-pointer-glyph - selection-pointer-glyph) - nil) - "*A list with pointer glyph variables, which should be overwritten -by the idd-drag-and-drop-pointer-glyph. If it is nil, the pointer -wont be changed. Currently it must be nil in the Emacs." - :group 'idd-drag-and-drop - :type '(repeat lisp)) - -(defvar idd-drag-and-drop-pointer-glyph nil -; (if idd-overwrite-mouse-pointers -; (make-pointer-glyph -; (vector 'autodetect :data idd-mouse-pointer-image)) -; nil) - "The shape of the mouse-pointer when internal drag and drop is active.") - -(defvar idd-original-pointer-image-instances nil - "Internal variable. Alist with the saved images instances of the pointers. -This list is used to restore the old mouse pointers.") - -(defvar idd-help-start-action-keymap nil - "Keymap used in an extent in the help buffer to start the action.") - -(defvar idd-help-source nil - "Contains the source of an action. Used only in the help buffer.") - -(defvar idd-help-destination nil - "Contains the destination of an action. Used only in the help buffer.") - -(defvar idd-help-start-extent nil - "The start extent in the help buffer.") - -(defun idd-compare-a-specification (source-or-destination - specification) - "Tests if SOURCE-OR-DESTINATION matches the SPECIFICATION. -It returns a value (1 in general) if both are matching or nil." - (eval (list (car specification) - 'source-or-destination - '(cdr specification)))) - -(defun idd-get-old-pointer-image-instances (mouse-pointers) - "Returns an alist with the pointer variables and there image instances." - (cond ((not mouse-pointers) nil) - (t (cons (cons (car mouse-pointers) - (glyph-image-instance (eval (car mouse-pointers)))) - (idd-get-old-pointer-image-instances (cdr mouse-pointers)))))) - -(defun idd-set-drag-and-drop-pointer-glyphs-1 (mouse-pointers - drag-and-drop-pointer-glyph) - "Internal function." - (cond ((not mouse-pointers)) - (t (set-glyph-image (eval (car mouse-pointers)) - (glyph-image-instance drag-and-drop-pointer-glyph)) - (idd-set-drag-and-drop-pointer-glyphs-1 (cdr mouse-pointers) - drag-and-drop-pointer-glyph) - ))) - -(defun idd-set-drag-and-drop-pointer-glyphs () - "Set the shape of some pointers to the drag and drop shape. -Only the pointers in the list `idd-overwrite-mouse-pointers' are -used." - (unless (or idd-original-pointer-image-instances - (not idd-overwrite-mouse-pointers)) - (setq idd-original-pointer-image-instances - (idd-get-old-pointer-image-instances idd-overwrite-mouse-pointers)) - (idd-set-drag-and-drop-pointer-glyphs-1 idd-overwrite-mouse-pointers - idd-drag-and-drop-pointer-glyph))) - -(defun idd-restore-original-pointer-glyphs-1 (pointer-alist) - "Internal function." - (cond ((not pointer-alist)) - (t (set-glyph-image (eval (car (car pointer-alist))) - (cdr (car pointer-alist))) - (idd-restore-original-pointer-glyphs-1 (cdr pointer-alist))))) - -(defun idd-restore-original-pointer-glyphs () - "Restores the original pointer shapes." - (interactive) - (when idd-overwrite-mouse-pointers - (idd-restore-original-pointer-glyphs-1 - idd-original-pointer-image-instances) - (setq idd-original-pointer-image-instances nil))) - -(defun idd-compare-specifications-1 (source-or-destination - specifications - value) - "Internal function of `idd-compare-specifications'. -VALUE is the value of the last matches." - (cond ((not specifications) value) - (t (let ((match (idd-compare-a-specification source-or-destination - (car specifications)))) - (cond ((not match) 0) - (t (idd-compare-specifications-1 source-or-destination - (cdr specifications) - (+ value match)))))))) - -(defun idd-compare-specifications (source-or-destination - specifications) - "Determines how good SOURCE-OR-DESTINATION and SPECIFICATIONS are matching. -A return value of zero means, that they don't match. The higher the -return value the better is the matching." - (cond ((not specifications) 1) - (t (idd-compare-specifications-1 source-or-destination - specifications - 0)))) - -(defun idd-get-action-depending-on-source (source - actions-depending-on-source - destination-value - value-action-pair) - "Internal function of `idd-get-action-depending-on-source-and-destination'." - (let ((source-value (idd-compare-specifications - source - (car (car actions-depending-on-source))))) - (cond ((not actions-depending-on-source) value-action-pair) - ((or (= source-value 0) - (<= (+ destination-value source-value) (car value-action-pair))) - (idd-get-action-depending-on-source - source - (cdr actions-depending-on-source) - destination-value - value-action-pair)) - (t (idd-get-action-depending-on-source - source - (cdr actions-depending-on-source) - destination-value - (cons (+ destination-value source-value) - (second (car actions-depending-on-source)))))))) - -(defun idd-get-action-depending-on-source-and-destination (source - destination - actions - value-action-pair) - "Internal function of `idd-get-action'. -VALUE-ACTION-PAIR is a list like (<value> <action>). -It returns VALUE-ACTION-PAIR, if no other action is found, which has a -value higher than (car VALUE-ACTION-PAIR)." - (let ((destination-value - (idd-compare-specifications destination (car (car actions))))) - (cond ((not actions) value-action-pair) - ((= destination-value 0) - (idd-get-action-depending-on-source-and-destination - source - destination - (cdr actions) - value-action-pair)) - (t (idd-get-action-depending-on-source-and-destination - source - destination - (cdr actions) - (idd-get-action-depending-on-source - source - (cdr (car actions)) - destination-value - value-action-pair)))))) - -(defun idd-get-action (source destination actions) - "Returns the action, which depends on the SOURCE and the DESTINATION. -The list ACTIONS contains all possible actions. Look at the variable -`idd-actions' for a description of the format of this list." - (idd-get-action-depending-on-source-and-destination source - destination - actions - '(0 . nil))) - -;(autoload 'ange-ftp-ftp-path "ange-ftp" -; "Parse PATH according to ange-ftp-path-format (which see). -;Returns a list (HOST USER PATH), or nil if PATH does not match the format.") - -(defun idd-get-buffer (source-or-destination) - "Returns the buffer of the SOURCE-OR-DESTINATION." - (cdr (assoc ':buffer source-or-destination))) - -(defun idd-set-point (source-or-destination) - "Sets the point and buffer to SOURCE-OR-DESTINATION." - (set-buffer (idd-get-buffer source-or-destination)) - (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination)))) - -(defun idd-set-region (source-or-destination) - "Sets the point, mark and buffer to SOURCE-OR-DESTINATION. -The region is active after this function is called." - (set-buffer (idd-get-buffer source-or-destination)) - (goto-char (car (cdr (assoc ':region-active source-or-destination)))) - (set-mark (cdr (cdr (assoc ':region-active source-or-destination)))) - (if (adapt-xemacsp) - (activate-region)) - ) - - -;;; Specification type functions for the list `idd-actions' - -(defun idd-if-region-active-p (source-or-destination value) - "Checks if the region in the SOURCE-OR-DESTINATION was active. -It returns 1, if the region was active and VALUE is t, or if -the region was not active and VALUE is nil. Otherwise it returns -nil." - (if (cdr (assoc ':region-active source-or-destination)) - (if value 1 nil) - (if value nil 1))) - -(defun idd-get-buffer-url (source-or-destination) - "Returns the URL of the buffer specified by SOURCE-OR-DESTINATION." - (save-excursion - (idd-set-point source-or-destination) - (url-view-url t))) - -(defun idd-get-url-at-point (source-or-destination) - "Returns the URL at the point specified by SOURCE-OR-DESTINATION. -It returns nil, if there is no URL." - (save-excursion - (idd-set-point source-or-destination) - (w3-view-this-url t))) - -(defun idd-if-url-at-point-p (source-or-destination value) - "Checks if there is an URL at the point of SOURCE-OR-DESTINATION. -If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 -is returned. Otherwise nil is returned." - (if value - (if (idd-get-url-at-point source-or-destination) - 1 - nil) - (if (idd-get-url-at-point source-or-destination) - nil - 1))) - -(defun idd-if-major-mode-p (source-or-destination mode) - "Checks, if the major mode of SOURCE-OR-DESTINATION is MODE. -It returns 1, if that is t and nil otherwise." - (save-excursion - (set-buffer (idd-get-buffer source-or-destination)) - (if (eq major-mode mode) - 1 - nil))) - -(defun idd-if-variable-non-nil-p (source-or-destination variable) - "Checks, if the variable named VARIABLE isn't t in SOURCE-OR-DESTINATION. -It returns 1, if this is t." - (save-excursion - (set-buffer (idd-get-buffer source-or-destination)) - (if (eval variable) - 1 - nil))) - -(defun idd-if-minor-mode-p (source-or-destination minor-mode-variable) - "Checks, if the variable MINOR-MODE-VARIABLE is t in SOURCE-OR-DESTINATION. -MINOR-MODE-VARIABLE is the name of the variable!." - (idd-if-variable-non-nil-p source-or-destination minor-mode-variable)) - -(defun idd-get-dired-filename-from-line (source-or-destination) - "Returns the filename form the line in a dired buffer. -The position and the buffer is specified by SOURCE-OR-DESTINATION." - (save-excursion - (idd-set-point source-or-destination) - (dired-get-filename nil t))) - -(defun idd-if-dired-file-on-line-p (source-or-destination filename-regexp) - "Checks, if the filename on the line match FILENAME-REGEXP. -The function `dired-get-filename' is used, to get the filename from -the SOURCE-OR-DESTINATION. It returns 1, if it matchs or nil." - (let ((case-fold-search t)) - (if (and (idd-get-dired-filename-from-line source-or-destination) - (string-match filename-regexp - (idd-get-dired-filename-from-line - source-or-destination))) - 1 - nil))) - -(defun idd-if-dired-no-file-on-line-p (source-or-destination value) - "Checks, if a filename is in the dired buffer of SOURCE-OR-DESTINATION. -It returns 1, if a filename is on the line and if VALUE is t, or if -no filename is on the line and VALUE is nil, otherwise it returns -nil. For the test the function `dired-get-filename' is used." - (if (idd-get-dired-filename-from-line source-or-destination) - (if value nil 1) - (if value 1 nil))) - -(defun idd-get-local-filename (source-or-destination) - "Returns the filename of a local file specified by SOURCE-OR-DESTINATION." - (buffer-file-name (idd-get-buffer source-or-destination))) - -(defun idd-get-directory-of-buffer (source-or-destination) - "Returns the directory name assigned to the SOURCE-OR-DESTINATION buffer." - (save-excursion - (idd-set-point source-or-destination) - default-directory)) - -(defun idd-if-local-file-p (source-or-destination value) - "Checks, if SOURCE-OR-DESTINATION has a file on the local filesystem. -If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 -is returned. Otherwise nil is returned." - (let ((filename (idd-get-local-filename source-or-destination))) - (if (and filename -; (not (ange-ftp-ftp-path filename))) - (not (file-remote-p filename))) - (if value 1 nil) - (if value nil 1)))) - -(defun idd-if-buffer-name-p (source-or-destination buffer-name) - "Checks, if SOURCE-OR-DESTINATION has a buffer called BUFFER-NAME. -It returns 1 if this is the case or nil otherwise." - (if (string= buffer-name - (buffer-name (idd-get-buffer source-or-destination))) - 1 - nil)) - -(defun idd-list-1-subset-of-list-2 (list-1 list-2) - "Returns t, if LIST-1 is a subset of LIST-2." - (cond ((not list-1)) - ((member (car list-1) list-2) - (idd-list-1-subset-of-list-2 (cdr list-1) list-2)) - (t nil))) - -(defun idd-same-elements-p (list-1 list-2) - "Returns t, if both list have the same modifiers." - (and (= (length list-1) (length list-2)) - (idd-list-1-subset-of-list-2 list-1 list-2))) - -(defun idd-if-modifiers-p (source-or-destination modifiers) - "Checks, if the MODIFIERS hold during selecting the SOURCE-OR-DESTINATION. -Returns 1, if the list MODIFIERS contains the same modifiers, -or if any modyfiers are hold and MODIFIERS is t, -or if no modyfiers are hold and MODIFIERS is nil. -Otherwise nil is returned." - (let ((event-modifiers (event-modifiers - (cdr (assoc ':event source-or-destination))))) - (cond ((not modifiers) - (if event-modifiers nil 1)) - ((listp modifiers) - (if (idd-same-elements-p modifiers event-modifiers) - 1 - nil)) - (t (if event-modifiers 1 nil))))) - -;;; action functions - -(defun idd-action-copy-region (source destination) - "Copy the region from DESTINATION to SOURCE." - (idd-set-region source) - (let ((region-contents (buffer-substring (point) (mark)))) - (idd-set-point destination) - (insert region-contents))) - -(defun idd-action-copy-replace-region (source destination) - "Copy the region from SOURCE and replace the DESTINATION region with it." - (idd-set-region source) - (let ((region-contents (buffer-substring (point) (mark)))) - (idd-set-region destination) - (delete-region (point) (mark)) - (insert region-contents))) - -(defmacro* idd-with-source-and-destination (source - destination - &key - do-in-source - do-in-destination) - "Macro, usefull for the definition of action functions. -Look at the example `idd-action-move-region'." - `(progn - (if (idd-if-region-active-p ,source t) - (idd-set-region ,source) - (idd-set-point ,source)) - ,(when do-in-source - (cons 'progn do-in-source)) - (if (idd-if-region-active-p ,destination t) - (idd-set-region ,destination) - (idd-set-point ,destination)) - ,(when do-in-destination - (cons 'progn do-in-destination)))) - -(defun idd-action-move-region (source destination) - "Move the region from SOURCE to DESTINATION." - (let ((region)) - (idd-with-source-and-destination - source destination - :do-in-source ((setq region (buffer-substring (point) (mark))) - (delete-region (point) (mark))) - :do-in-destination ((insert region))))) - - -(defun idd-action-move-replace-region (source destination) - "Delete the region at SOURCE and overwrite the DESTINATION region with it." - (let ((region)) - (idd-with-source-and-destination - source destination - :do-in-source ((setq region (buffer-substring (point) (mark))) - (delete-region (point) (mark))) - :do-in-destination ((delete-region (point) (mark)) - (insert region))))) - - -;;; Performing the drag and drop - -(defun idd-display-help-about-action (action source destination) - "Display a help buffer with information about the action." - (if (> (car action) 0) - (if (symbol-function (cdr action)) - (progn - (with-displaying-help-buffer - '(lambda () - (set-buffer "*Help*") - (setq idd-help-source source) - (setq idd-help-destination destination) - (insert "Drag and drop action: `") - (let ((start (point))) - (insert (format "%s" (cdr action))) - (setq idd-help-start-extent (make-extent start (point))) - (set-extent-mouse-face idd-help-start-extent 'highlight) - (set-extent-face idd-help-start-extent 'bold) - (if (adapt-xemacsp) - (set-extent-keymap idd-help-start-extent - idd-help-start-action-keymap) - ) - ) - (insert "'\n") - (insert (format "Source buffer : `%s'\n" - (buffer-name (cdr (assoc ':buffer source))))) - (insert (format "Destination buffer : `%s'\n" - (buffer-name (cdr (assoc ':buffer destination)) - ))) - (insert "==================================================" - "====================\n") - (insert "Look at `idd-actions' in the " - "destination buffer for other actions!\n") - (insert (format "The documentation of `%s':\n\n" - (cdr action))) - (insert (documentation (cdr action))))) - ) - (error "Error: Action %s isn't a valid function!" (cdr action))) - (message "No valid action defined for this source and this destination!"))) - -(defun idd-call-action (action source destination) - "Calls the drag and drop ACTION with its arguments SOURCE and DESTINATION." - (if (> (car action) 0) - (if (symbol-function (cdr action)) - (eval (list (cdr action) 'source 'destination)) - (error "Error: Action %s isn't a valid function!" (cdr action))) - (message "No valid action defined for this source and this destination!"))) - -(defun idd-start-help-mouse-drag-and-drop () - "Starts help on `idd-start-mouse-drag-and-drop'." - (interactive) - (let ((idd-help-instead-of-action t)) - (idd-start-mouse-drag-and-drop))) - -(defun idd-start-mouse-drag-and-drop () - "Starts a drag and drop command. -This command could be used to start a drag and drop command without a -button event. Therefore this should not be bind direct to a mouse button." - (interactive) - (let ((source-event) - (drag-and-drop-message "Drag&Drop: Click on the source!")) - (message drag-and-drop-message) - (setq source-event - (next-command-event nil drag-and-drop-message)) - (if (button-press-event-p source-event) - (progn - (when (and (adapt-emacs19p) - (mouse-event-p source-event) - (eq idd-drag-and-drop-mouse-binding-type 'click)) - (while (not (button-release-event-p (next-command-event))))) - (idd-mouse-drag-and-drop source-event)) - (message "Wrong event! Exit drag and drop.")))) - -(defun idd-help-mouse-drag-and-drop (source-event) - "Displays help about the drag and drop action." - (interactive "@e") - (let ((idd-help-instead-of-action t)) - (idd-mouse-drag-and-drop source-event))) - -(defun idd-mouse-drag-and-drop (source-event) - "Performs a drag and drop action. -It calls the command `idd-mouse-drag-and-drop-click' or -`idd-mouse-drag-and-drop-press-button-during-move' depending on -the value of `idd-drag-and-drop-mouse-binding-type'." - (interactive "@e") - (if (eq idd-drag-and-drop-mouse-binding-type 'click) - (idd-mouse-drag-and-drop-click source-event) - (idd-mouse-drag-and-drop-press-button-during-move source-event))) - -(defun idd-get-source-or-destination-alist (event) - "Returns an alist with the description of a source or destination point. -The EVENT must be the button event, which has selected the source or -destination of the drag and drop command. - -The alist has the following structure: - '((:buffer . <buffer-of-the-event>) - (:drag-or-drop-point . <closest-point-to-the-event>) - (:region-active . <t-or-nil>) - (:event . EVENT)) - -Note: <closest-point-to-the-event> is (event-closest-point EVENT), -if the EVENT is a mouse event and if it isn't nil. Otherwise the -point is used." -; (set-buffer (event-buffer event)) - (list (cons ':buffer (event-buffer event)) - (cons ':drag-or-drop-point (set-marker - (make-marker) - (if (mouse-event-p event) - (or (event-closest-point event) - (point)) - (point)))) - (cons ':region-active (if (region-active-p) - (cons (set-marker (make-marker) (point)) - (set-marker (make-marker) (mark))))) - (cons ':event event)) - ) - -(defun idd-mouse-drag-and-drop-press-button-during-move (source-event) - "Performs a drag and drop action. -At first you must press the button down over the source and then -move with the pressed button to the destination, where you must leave -the button up. -This must be bind to a mouse button. The SOURCE-EVENT must be a -button-press-event. - -The disadvantage of this command compared with the command -`idd-mouse-drag-and-drop-click' is, that you can't select a -destination region." - (interactive "@e") - (idd-set-drag-and-drop-pointer-glyphs) - (let ((drag-and-drop-message - "Drag&Drop: Leave the button over the destination!") - (source (idd-get-source-or-destination-alist source-event)) - (destination nil) - (destination-event)) - (message drag-and-drop-message) - (setq destination-event - (next-command-event nil drag-and-drop-message)) - (message "") - (cond ((or (button-release-event-p destination-event) - (and (adapt-emacs19p) - (button-drag-event-p destination-event))) - (setq destination (idd-get-source-or-destination-alist - destination-event)) - (idd-set-point destination) - (if idd-help-instead-of-action - (idd-display-help-about-action (idd-get-action source - destination - idd-actions) - source - destination) - (idd-call-action (idd-get-action source destination idd-actions) - source - destination))) - (t (message "Wrong event! Exit drag and drop.") nil))) - (idd-restore-original-pointer-glyphs)) - -(defun idd-mouse-drag-and-drop-click (source-event) - "Performs a drag and drop action. -At first you must click on the source and after that on the destination. -This must be bind to a mouse button. The SOURCE-EVENT must be a -button-press-event." - (interactive "@e") - (idd-set-drag-and-drop-pointer-glyphs) - (let ((drag-and-drop-message "Drag&Drop: Click on the destination!") - (source (idd-get-source-or-destination-alist source-event)) - (destination nil) - (destination-event)) - (message drag-and-drop-message) - (when (and (adapt-xemacsp) (mouse-event-p source-event)) - (dispatch-event (next-command-event))) - (setq destination-event - (next-command-event nil drag-and-drop-message)) - (message "") - (cond ((button-press-event-p destination-event) - (mouse-track destination-event) - (setq destination (idd-get-source-or-destination-alist - destination-event)) - (idd-set-point destination) -; (when (adapt-emacs19p) -; (while (not (button-release-event-p (next-command-event))))) - (if idd-help-instead-of-action - (idd-display-help-about-action (idd-get-action source - destination - idd-actions) - source - destination) - (idd-call-action (idd-get-action source destination idd-actions) - source - destination))) - ((and (adapt-emacs19p) - (button-click-event-p destination-event)) - (setq destination (idd-get-source-or-destination-alist - destination-event)) - (idd-set-point destination) - (if idd-help-instead-of-action - (idd-display-help-about-action (idd-get-action source - destination - idd-actions) - source - destination) - (idd-call-action (idd-get-action source destination idd-actions) - source - destination))) - (t (message "Wrong event! Exit drag and drop.") nil)) - - ;; Useful for debugging - ;; (setq idd-last-source source) - ;; (setq idd-last-destination destination) - - ) - (idd-restore-original-pointer-glyphs)) - -(defun idd-help-start-action (event) - "Used to start the action from the help buffer." - (interactive "@e") - (idd-set-point idd-help-destination) - (idd-call-action (idd-get-action idd-help-source - idd-help-destination - idd-actions) - idd-help-source - idd-help-destination) - (delete-extent idd-help-start-extent)) - -(if (adapt-xemacsp) - (progn - - (defun idd-make-drag-and-drop-pointer-glyph () - "Creates the drag and drop pointer glyph. -You've to rerun this, if you change either the variable -`idd-data-directory' or `idd-mouse-pointer-image'." - (interactive) - (let ((mouse-pointer-image (if (and idd-data-directory - idd-mouse-pointer-image) - (expand-file-name - (file-name-nondirectory - idd-mouse-pointer-image) - idd-data-directory) - idd-mouse-pointer-image))) - (if (and mouse-pointer-image - (file-exists-p mouse-pointer-image)) - (setq idd-drag-and-drop-pointer-glyph - (make-pointer-glyph - (vector 'autodetect :data mouse-pointer-image))) - (setq idd-drag-and-drop-pointer-glyph (make-pointer-glyph)) - (message - "Warning: Can't find drag and drop mouse pointer image!")))) - - (idd-make-drag-and-drop-pointer-glyph) - - )) - -;; keymap for help buffer extents -(if (not idd-help-start-action-keymap) - (progn - (setq idd-help-start-action-keymap - (make-sparse-keymap 'idd-help-start-action-keymap)) - (if (adapt-emacs19p) - (define-key idd-help-start-action-keymap [(mouse-2)] - 'idd-help-start-action) - (define-key idd-help-start-action-keymap "[(button2)]" - 'idd-help-start-action)))) - -;; global key bindings -(when idd-global-mouse-keys - (unless (where-is-internal 'idd-mouse-drag-and-drop global-map t) - (define-key global-map idd-global-mouse-keys 'idd-mouse-drag-and-drop)) - (unless (where-is-internal 'idd-help-mouse-drag-and-drop global-map t) - (define-key global-map - idd-global-help-mouse-keys 'idd-help-mouse-drag-and-drop))) - - -(provide 'internal-drag-and-drop) - -;;; internal-drag-and-drop ends here
--- a/lisp/hm--html-menus/tmpl-minor-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,675 +0,0 @@ -;;; tmpl-minor-mode.el --- Template Minor Mode - -;; Copyright (C) 1993 - 1997 Heiko Muenkel - -;; Author: Heiko Muenkel <muenkel@tnt.uni-hannover.de> -;; Keywords: data tools - -;; $Id: tmpl-minor-mode.el,v 1.6 1997/07/26 22:09:46 steve Exp $ - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; This program 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 part of Emacs. - -;;; Commentary: - -;; Description: -;; This file contains functions to expand templates. -;; Look at the file templates-syntax.doc for the syntax of the -;; templates. -;; There are the following 2 interactive functions to expand -;; templates: -;; tmpl-expand-templates-in-region -;; tmpl-expand-templates-in-buffer -;; The following two interactive functions are to escape the -;; unescaped special template signs: -;; tmpl-escape-tmpl-sign-in-region -;; tmpl-escape-tmpl-sign-in-buffer -;; The following function ask for a name of a template file, inserts -;; the template file and expands the templates: -;; tmpl-insert-template-file -;; If you want to use keystrokes to call the above functions, you must -;; switch the minor mode tmpl-mode on with `tmpl-minor-mode'. After -;; that, the following keys are defined: -;; `C-c x' = tmpl-expand-templates-in-region -;; `C-c C-x' = tmpl-expand-templates-in-buffer -;; `C-c ESC' = tmpl-escape-tmpl-sign-in-region -;; `C-c C-ESC' = tmpl-escape-tmpl-sign-in-buffer -;; Type again `M-x tmpl-minor-mode' to switch the template minor mode off. - -;; This file needs also the file adapt.el ! - - -;; Installation: - -;; Put this file in one of your lisp directories and the following -;; lisp command in your .emacs: -;; (load-library "templates") - -;;; Code: - -(require 'adapt) - -(defgroup tmpl-minor nil - "A package for inserting and expanding templates." - :group 'data) - -(defcustom tmpl-template-dir-list nil - "*A list of directories with the template files. -If it is nil, then the default-directory will be used. -If more than one directory is given, then the -template filenames should differ in all directories. - -This variable is used in the commands for inserting templates. -Look at `tmpl-insert-template-file-from-fixed-dirs' and -at `tmpl-insert-template-file'. The command `tmpl-insert-template-file' -uses only the car of the list (if it is a list)." - :group 'tmpl-minor - :type '(choice (const :tag "default-directory" :value nil) - (repeat directory))) - -(defcustom tmpl-automatic-expand t - "*An inserted template will be automaticly expanded, if this is t. - -This variable is used in the commands for inserting templates. -Look at `tmpl-insert-template-file-from-fixed-dirs' and -at `tmpl-insert-template-file'." - :group 'tmpl-minor - :type 'boolean) - - -(defcustom tmpl-filter-regexp ".*\\.tmpl$" - "*Regexp for filtering out non template files in a directory. -It is used in `tmpl-insert-template-file-from-fixed-dirs' to allow -only the selecting of files, which are matching the regexp. -If it is nil, then the Filter \".*\\.tmpl$\" is used. -Set it to \".*\" if you want to disable the filter function or -use the command `tmpl-insert-template-file'." - :group 'tmpl-minor - :type 'string) - -(defvar tmpl-history-variable-name 'tmpl-history-variable - "The name of the history variable. -The history variable is used by the commands `tmpl-insert-template-file' -and `tmpl-insert-template-file-from-fixed-dirs'. - -Not used in the Emacs 19.") - -(defvar tmpl-history-variable nil - "The history variable. See also `tmpl-history-variable-name'.") - -(defcustom tmpl-sign "\000" - "Sign which marks a template expression." - :group 'tmpl-minor - :type 'string) - -(defvar tmpl-name-lisp "LISP" "Name of the lisp templates.") - - -(defvar tmpl-name-command "COMMAND" "Name of the emacs command templates.") - - -(defvar tmpl-name-comment "C" "Name of a comment template.") - - -(defvar tmpl-attribute-delete-line 'DELETE-LINE - "Attribute name of the attribute `delete-line`.") - - -(defvar tmpl-attribute-dont-delete 'DONT-DELETE - "Attribute name of the attribute `dont-delete`.") - - -(defvar tmpl-end-template "END" "End of a template.") - - -(defvar tmpl-white-spaces " - " "String with white spaces.") - - -(defmacro tmpl-save-excursion (&rest body) - "Put `save-excursion' and `save-window-excursion' around the body." - (`(save-excursion - (, (cons 'save-window-excursion - body))))) - - -(defun tmpl-current-line () - "Returns the current line number." - (save-restriction - (widen) - (save-excursion - (beginning-of-line) - (1+ (count-lines 1 (point)))))) - - -(defun tmpl-search-next-template-sign (&optional dont-unescape) - "Search the next template sign after the current point. -It returns t, if a template is found and nil otherwise. -If DONT-UNESCAPE is t, then the escaped template signs are not unescaped." - (if (search-forward tmpl-sign nil t) - (if (or (eq (point) (point-max)) - (not (string= tmpl-sign - (buffer-substring (point) (+ (length tmpl-sign) - (point)))))) - t - (if (not dont-unescape) - (delete-char (length tmpl-sign)) - (forward-char)) - (tmpl-search-next-template-sign dont-unescape)))) - - -(defun tmpl-get-template-tag () - "Return a string with the template tag. -That is the string from the current point to the next `tmpl-sign', -without the tmpl-sign. The point is set after the `tmpl-sign'." - (let ((template-start (point))) - (if (tmpl-search-next-template-sign) - (buffer-substring template-start (- (point) (length tmpl-sign))) - nil))) - - -(defun tmpl-get-template-name (template-string) - "Returns the name of the template in the TEMPLATE-STRING." - (let* ((start (string-match (concat "[^" - tmpl-white-spaces - "]") - template-string)) - (end (string-match (concat "[" - tmpl-white-spaces - "]") - template-string start))) - (if end - (substring template-string start end) - (substring template-string start)))) - - -(defun tmpl-get-template-attribute-list (template-string) - "Returns the attribute list (as a lisp list) from the template-string." - (let* ((start (string-match (concat "[^" - tmpl-white-spaces - "]") - template-string))) - (setq start (string-match (concat "[" - tmpl-white-spaces - "]") - template-string start)) - (if start - (car (read-from-string template-string start)) - nil))) - - -(defun template-delete-template (begin-of-template template-attribute-list) - "Delete the current template from BEGIN-OF-TEMPLATE to the current point." - (tmpl-save-excursion - (if (or (not (assoc tmpl-attribute-dont-delete template-attribute-list)) - (not (car (cdr (assoc tmpl-attribute-dont-delete - template-attribute-list))))) - (if (and (assoc tmpl-attribute-delete-line template-attribute-list) - (car (cdr (assoc tmpl-attribute-delete-line - template-attribute-list)))) - (let ((end-of-template (point)) - (diff 1)) - (skip-chars-forward " \t") ; Skip blanks and tabs - (if (string= "\n" (buffer-substring (point) (1+ (point)))) - (progn - (setq diff 0) ; don't delete the linefeed at the beginnig - (setq end-of-template (1+ (point))))) - (goto-char begin-of-template) - (skip-chars-backward " \t") ; Skip blanks and tabs - (if (eq (point) (point-min)) - (delete-region (point) end-of-template) - (if (string= "\n" (buffer-substring (1- (point)) (point))) - (delete-region (- (point) diff) end-of-template) - (delete-region begin-of-template end-of-template)))) - (delete-region begin-of-template (point)))))) - - -(defun tmpl-expand-comment-template (begin-of-template template-attribute-list) - "Expand the comment template, which starts at the point BEGIN-OF-TEMPLATE. -TEMPLATE-ATTRIBUTE-LIST is the attribute list of the template." - (end-of-line) - (template-delete-template begin-of-template template-attribute-list)) - - -(defun tmpl-get-template-argument () - "Return the Text between a start tag and the end tag as symbol. -The point must be after the `templ-sign' of the start tag. -After this function has returned, the point is after the -first `templ-sign' of the end tag." - (let ((start-of-argument-text (progn (skip-chars-forward tmpl-white-spaces) - (point)))) - (if (tmpl-search-next-template-sign) - (car (read-from-string (buffer-substring start-of-argument-text - (- (point) - (length tmpl-sign))))) - (widen) - (error "Error Before Line %d: First Template Sign Of End Tag Missing !" - (tmpl-current-line))))) - - -(defun tmpl-make-list-of-words-from-string (string) - "Return a list of words which occur in the string." - (cond ((or (not (stringp string)) (string= "" string)) - ()) - (t (let* ((end-of-first-word (string-match - (concat "[" - tmpl-white-spaces - "]") - string)) - (rest-of-string (substring string (1+ - (or - end-of-first-word - (1- (length string))))))) - (cons (substring string 0 end-of-first-word) - (tmpl-make-list-of-words-from-string - (substring rest-of-string (or - (string-match - (concat "[^" - tmpl-white-spaces - "]") - rest-of-string) - 0)))))))) - - -(defun tmpl-get-template-end-tag () - "Return a list with the elements of the following end tag. -The point must be after the first `templ-sign' of the end tag. -After this function has returned, the point is after the -last `templ-sign' of the end tag." - (let* ((start-point (progn (skip-chars-forward tmpl-white-spaces) - (point))) - (end-tag-string (if (tmpl-search-next-template-sign) - (buffer-substring start-point - (- (point) (length tmpl-sign))) - (widen) - (error "Error Before Line %d: Last Template Sign Of End Tag Missing !" - (tmpl-current-line))))) - (tmpl-make-list-of-words-from-string end-tag-string) - )) - - -(defun tmpl-expand-command-template (begin-of-template template-attribute-list) - "Expand the command template, which starts at the point BEGIN-OF-TEMPLATE. -TEMPLATE-ATTRIBUTE-LIST is the attribute list of the template." - (let ((template-argument (tmpl-get-template-argument)) - (template-end-tag (tmpl-get-template-end-tag))) - (if (equal (list tmpl-end-template tmpl-name-command) - template-end-tag) - (tmpl-save-excursion - (save-restriction - (widen) - (template-delete-template begin-of-template - template-attribute-list) - (command-execute template-argument))) - (widen) - (error "ERROR in Line %d: Wrong Template Command End Tag" - (tmpl-current-line))))) - - -(defun tmpl-expand-lisp-template (begin-of-template template-attribute-list) - "Expand the lisp template, which starts at the point BEGIN-OF-TEMPLATE. -TEMPLATE-ATTRIBUTE-LIST is the attribute list of the template." - (let ((template-argument (tmpl-get-template-argument)) - (template-end-tag (tmpl-get-template-end-tag))) - (if (equal (list tmpl-end-template tmpl-name-lisp) - template-end-tag) - (tmpl-save-excursion - (save-restriction - (widen) - (template-delete-template begin-of-template - template-attribute-list) - (eval template-argument))) - (widen) - (error "ERROR in Line %d: Wrong Template Lisp End Tag" - (tmpl-current-line))))) - - -(defun tmpl-expand-template-at-point () - "Expand the template at the current point. -The point must be after the sign ^@." - (let ((begin-of-template (- (point) (length tmpl-sign))) - (template-tag (tmpl-get-template-tag))) - (if (not template-tag) - (progn - (widen) - (error "ERROR In Line %d: End Sign Of Template Tag Missing !" - (tmpl-current-line))) - (let ((template-name (tmpl-get-template-name template-tag)) - (template-attribute-list (tmpl-get-template-attribute-list - template-tag))) - (cond ((not template-name) - (widen) - (error "ERROR In Line %d: No Template Name" - (tmpl-current-line))) - ((string= tmpl-name-comment template-name) - ;; comment template found - (tmpl-expand-comment-template begin-of-template - template-attribute-list)) - ((string= tmpl-name-command template-name) - ;; command template found - (tmpl-expand-command-template begin-of-template - template-attribute-list)) - ((string= tmpl-name-lisp template-name) - ;; lisp template found - (tmpl-expand-lisp-template begin-of-template - template-attribute-list)) - (t (widen) - (error "ERROR In Line %d: Wrong Template Name (%s) !" - (tmpl-current-line) template-name))))))) - -;;;###autoload -(defun tmpl-expand-templates-in-region (&optional begin end) - "Expands the templates in the region from BEGIN to END. -If BEGIN and END are nil, then the current region is used." - (interactive) - (tmpl-save-excursion - (narrow-to-region (or begin (region-beginning)) - (or end (region-end))) - (goto-char (point-min)) - (while (tmpl-search-next-template-sign) - (tmpl-expand-template-at-point)) - (widen))) - - -;;;###autoload -(defun tmpl-expand-templates-in-buffer () - "Expands all templates in the current buffer." - (interactive) - (tmpl-expand-templates-in-region (point-min) (point-max))) - - -(defun tmpl-escape-tmpl-sign-in-region (&optional begin end) - "Escapes all `tmpl-sign' with a `tmpl-sign' in the region from BEGIN to END. -If BEGIN and END are nil, then the active region between mark and point is -used." - (interactive) - (save-excursion - (narrow-to-region (or begin (region-beginning)) - (or end (region-end))) - (goto-char (point-min)) - (while (tmpl-search-next-template-sign t) - (insert tmpl-sign)) - (widen))) - - -(defun tmpl-escape-tmpl-sign-in-buffer () - "Escape all `tmpl-sign' with a `tmpl-sign' in the buffer." - (interactive) - (tmpl-escape-tmpl-sign-in-region (point-min) (point-max))) - -(defun tmpl-get-table-with-template-files (template-dirs filter-regexp) - "Returns a table (alist) with all filenames matching the FILTER-REGEXP. -It searches the files in in all directories of the list TEMPLATE-DIRS. -The alist looks like: - '((file-name . file-name-with-path) ...)" - (cond ((not template-dirs) '()) - ((file-accessible-directory-p (car template-dirs)) - (append (mapcar '(lambda (file) - (cons (file-name-nondirectory file) file)) - (if (adapt-xemacsp) - (directory-files (car template-dirs) - t - filter-regexp - nil - t) - (directory-files (car template-dirs) - t - filter-regexp - nil))) - (tmpl-get-table-with-template-files (cdr template-dirs) - filter-regexp))) - (t (tmpl-get-table-with-template-files (cdr template-dirs) - filter-regexp)))) - -(defun tmpl-insert-change-dir-entry (table) - "Insert the entry '(\"Change the directory\" . select-other-directory)." - (cons '("Change the directory" . select-other-directory) - table)) - -(defun tmpl-read-template-directory (prompt default-direcory) - "Reads a template directory. -If the directory isn't already in `tmpl-template-dirs', the it asks, -if it should be added to it." - (let ((directory (expand-file-name - (read-directory-name prompt - (or default-direcory - (default-directory)))))) - (when (and (not (member* directory tmpl-template-dir-list :test 'string=)) - (y-or-n-p - (format - "Add %s permanent to the template directory list? " - directory))) - (setq tmpl-template-dir-list (cons directory tmpl-template-dir-list))) - directory)) - -(defun tmpl-read-template-filename (&optional - template-dirs - filter-regexp - history-variable) - "Reads interactive the name of a template file. -The TEMPLATE-DIRS is a list of directories with template files. -Note: The template filenames should differ in all directories. -If it is nil, then the default-directory is used. -FILTER-REGEXP can be used to allow only the selecting of files, -which are matching the regexp. If FILTER-REGEXP is nil, then the -Filter \".*\\.tmpl$\" is used. -HISTROY-VARIABLE contains the last template file names." - (let ((filter (or filter-regexp ".*\\.tmpl$")) - (directories (or template-dirs (list (default-directory)))) - (table nil) - (file nil) - (answer nil) - (anser-not-ok t) - (internal-history (mapcar '(lambda (path) - (file-name-nondirectory path)) - (eval history-variable)))) - (while anser-not-ok - (setq table (tmpl-get-table-with-template-files directories filter)) - (while (not table) - ;; Try another filter (all files) - (setq table (tmpl-get-table-with-template-files directories ".*")) - (unless table - (setq directories (list (tmpl-read-template-directory - "No files found, try another directory: " - (car directories)))))) - (setq table (tmpl-insert-change-dir-entry table)) - (setq answer (completing-read "Templatefile: " - table - nil - t - nil - 'internal-history)) - (setq file (cdr (assoc* answer table :test 'string=))) - (setq anser-not-ok (equal file 'select-other-directory)) - (when anser-not-ok - (setq directories (list (tmpl-read-template-directory - "Directory with Templatefiles: " - (car directories)))))) - (unless (or (not history-variable) - (string= file (car (eval history-variable)))) - (set history-variable (cons file (eval history-variable)))) - file)) - - - -;;;###autoload -(defun tmpl-insert-template-file-from-fixed-dirs (file) - "Inserts a template FILE and expands it, if `tmpl-automatic-expand' is t. -This command tries to read the template file from a list of -predefined directories (look at `tmpl-template-dir-list') and it filters -the contents of these directories with the regular expression -`tmpl-filter-regexp' (look also at this variable). -The command uses a history variable, which could be changed with the -variable `tmpl-history-variable-name'. - -The user of the command is able to change interactively to another -directory by entering at first the string \"Change the directory\". -This may be too difficult for the user. Therefore another command -called `tmpl-insert-template-file' exist, which doesn't use fixed -directories and filters." - (interactive - (list (tmpl-read-template-filename tmpl-template-dir-list - tmpl-filter-regexp - tmpl-history-variable-name))) - (insert-file (expand-file-name file)) - (if tmpl-automatic-expand - (tmpl-expand-templates-in-region (point) (mark t))) - file) - - -;;;###autoload -(defun tmpl-insert-template-file (file) - "Inserts a template FILE and expand it, if `tmpl-automatic-expand' is t. -Look also at `tmpl-template-dir-list', to specify a default template directory. -You should also take a look at `tmpl-insert-template-file-from-fixed-dirs' -which has additional advantages (and disadvantages :-). - -ATTENTION: The interface of this function has changed. The old -function had the argument list (&optional TEMPLATE-DIR AUTOMATIC-EXPAND). -The variables `tmpl-template-dir-list' and `tmpl-automatic-expand' must -now be used instead of the args TEMPLATE-DIR and AUTOMATIC-EXPAND." - (interactive - (list - (let* ((default-directory (or (car tmpl-template-dir-list) - default-directory)) - (filename (if (adapt-xemacsp) - (read-file-name "Templatefile: " - (if (listp tmpl-template-dir-list) - (car tmpl-template-dir-list)) - nil - t - nil - tmpl-history-variable-name) - (read-file-name "Templatefile: " - (if (listp tmpl-template-dir-list) - (car tmpl-template-dir-list)) - nil - t - nil))) - (directory (expand-file-name (file-name-directory filename)))) - (when (and (not (member* directory - tmpl-template-dir-list - :test 'string=)) - (y-or-n-p - (format - "Add %s permanent to the template directory list? " - directory))) - (setq tmpl-template-dir-list (cons directory tmpl-template-dir-list))) - filename))) - (insert-file (expand-file-name file)) - (if tmpl-automatic-expand - (tmpl-expand-templates-in-buffer)) - file) - - -;;; General utilities, which are useful in a template file -(defun tmpl-util-indent-region (begin end) - "Indents a region acording to the mode." - (interactive "r") - (save-excursion - (goto-char end) - (let ((number-of-lines (count-lines begin (point))) - (line 0)) - (goto-char begin) - (while (< line number-of-lines) - (setq line (1+ line)) - (indent-according-to-mode) - (forward-line))))) - -(defun tmpl-util-indent-buffer () - "Indents the whole buffer acording to the mode." - (interactive) - (tmpl-util-indent-region (point-min) (point-max))) - - -;;; Definition of the minor mode tmpl - -(defvar tmpl-minor-mode nil - "*t, if the minor mode tmpl-mode is on and nil otherwise.") - - -(make-variable-buffer-local 'tmpl-minor-mode) -;(set-default 'tmpl-minor-mode nil) - - -(defvar tmpl-old-local-map nil - "Local keymap, before the minor-mode tmpl was switched on.") - - -(make-variable-buffer-local 'tmpl-old-local-map) - - - -(defvar tmpl-minor-mode-map nil - "*The keymap for the minor mode tmpl-mode.") - - -(make-variable-buffer-local 'tmpl-minor-mode-map) - - -(if (adapt-xemacsp) - (defun tmpl-define-minor-mode-keymap () - "Defines the minor mode keymap." - (define-key tmpl-minor-mode-map [(control c) (control c) x] - 'tmpl-expand-templates-in-region) - (define-key tmpl-minor-mode-map [(control c) (control c) (control x)] - 'tmpl-expand-templates-in-buffer) - (define-key tmpl-minor-mode-map [(control c) (control c) e] - 'tmpl-escape-tmpl-sign-in-region) - (define-key tmpl-minor-mode-map - [(control c) (control c) (control e)] - 'tmpl-escape-tmpl-sign-in-buffer)) - (defun tmpl-define-minor-mode-keymap () - "Defines the minor mode keymap." - (define-key tmpl-minor-mode-map [?\C-c ?\C-c ?x] - 'tmpl-expand-templates-in-region) - (define-key tmpl-minor-mode-map [?\C-c ?\C-c ?\C-x] - 'tmpl-expand-templates-in-buffer) - (define-key tmpl-minor-mode-map [?\C-c ?\C-c ?e] - 'tmpl-escape-tmpl-sign-in-region) - (define-key tmpl-minor-mode-map [?\C-c ?\C-c ?\C-e] - 'tmpl-escape-tmpl-sign-in-buffer)) - ) - - -(defun tmpl-minor-mode () - "Toggle the minor mode tmpl-mode." - (interactive) - (if tmpl-minor-mode - (progn - (setq tmpl-minor-mode nil) - (use-local-map tmpl-old-local-map) - (setq tmpl-old-local-map nil)) - (setq tmpl-minor-mode t) - (setq tmpl-old-local-map (current-local-map)) - (if tmpl-old-local-map - (setq tmpl-minor-mode-map (copy-keymap tmpl-old-local-map)) - (setq tmpl-minor-mode-map nil) - (setq tmpl-minor-mode-map (make-keymap)) - (set-keymap-name tmpl-minor-mode-map 'minor-mode-map)) - (tmpl-define-minor-mode-keymap) - (use-local-map tmpl-minor-mode-map))) - - -(setq minor-mode-alist (cons '(tmpl-minor-mode " TMPL") minor-mode-alist)) - - -(provide 'tmpl-minor-mode) - -;;; tmpl-minor-mode ends here
--- a/lisp/language/arabic-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,676 +0,0 @@ -;;; arabic-util.el --- minor mode for editing Arabic. - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Keywords: multilingual, Arabic - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;;; Commentary: - -;; Synched up with: Mule 2.3. - -;;; Code: - -;;; 94.6.13 created for Mule Ver.1.1 by Takahashi N. <ntakahas@etl.go.jp> - -(require 'visual-mode) - -(defvar arabic-mode-indicator " ›2](3=a:GJ›0](B" - "String displayed in mode-line. -\" Arabic\" for Arabic keyboard input, \" ›2](3=a:GJ›0](B\".") - -(make-variable-buffer-local 'arabic-mode-indicator) - -;;;###autoload -(defvar arabic-mode nil - "Non-nil if in arabic-mode.") - -(make-variable-buffer-local 'arabic-mode) - -(if (not (assq 'arabic-mode minor-mode-alist)) - (setq minor-mode-alist - (cons '(arabic-mode arabic-mode-indicator) minor-mode-alist))) - -(define-key global-map [(meta \\)] 'arabic-mode) - -(defvar arabic-input-arabic-char t - "Non-nil if key input is Arabic. Nil if key input is ASCII.") - -(make-variable-buffer-local 'arabic-input-arabic-char) - -(defvar arabic-input-keymap 'arabic-keymap-0 - "Specify which input table is used for Arabic input. Should be on of: -arabic-keymap-0 (default), -arabic-keymap-1 (Farsi standard), or -arabic-keymap-2 (Microsoft Arabic).") - -(defvar arabic-translate-table - (cond - ((eq arabic-input-keymap 'arabic-keymap-0) - [?›2](3!›0](B ?›2](3"›0](B ?›2](3-›0](B nil nil nil nil ?' ?›2](3#›0](B ?›2](3$›0](B nil nil ?›2](3%›0](B nil ?›2](3&›0](B ?›2](49›0](B - ?(2!(B ?(2"(B ?(2#(B ?(2$(B ?(2%(B ?(2&(B ?(2'(B ?(2((B ?(2)(B ?(2*(B ?›2](3'›0](B ?›2](3(›0](B ?›2](3*›0](B nil ?›2](3+›0](B ?›2](3)›0](B - nil ?›2](4]›0](B nil ?›2](4g›0](B ?›2](4A›0](B nil nil ?›2](4O›0](B ?›2](4-›0](B nil nil ?›2](41›0](B nil nil nil nil - nil nil nil ?›2](4=›0](B ?›2](4E›0](B nil nil nil ?›2](3h›0](B nil ?›2](4I›0](B nil nil nil nil nil - ?›2](4M›0](B ?›2](38›0](B ?›2](4#›0](B ?›2](4'›0](B ?›2](3B›0](B nil ?›2](4Q›0](B ?›2](4k›0](B ?›2](3Z›0](B nil ?›2](4)›0](B ?›2](4U›0](B ?›2](4Y›0](B ?›2](3T›0](B ?›2](4[›0](B ?›2](3<›0](B - ?›2](4e›0](B ?›2](4S›0](B ?›2](3F›0](B ?›2](45›0](B ?›2](4%›0](B nil nil ?›2](3^›0](B ?›2](3D›0](B ?›2](4_›0](B ?›2](3H›0](B nil ?| nil nil]) - ((eq arabic-input-keymap 'arabic-keymap-1) - [?›2](3!›0](B ?›2](3"›0](B nil nil nil nil nil nil ?›2](3#›0](B ?›2](3$›0](B nil nil ?›2](3%›0](B nil ?›2](3&›0](B nil - ?(2!(B ?(2"(B ?(2#(B ?(2$(B ?(2%(B ?(2&(B ?(2'(B ?(2((B ?(2)(B ?(2*(B ?›2](3'›0](B ?›2](4U›0](B ?›2](3*›0](B nil ?›2](3+›0](B ?›2](3)›0](B - nil nil ?›2](3h›0](B nil nil nil ?›2](4e›0](B ?›2](3.›0](B nil nil nil nil nil nil nil nil - nil nil nil nil nil nil ?›2](30›0](B nil nil nil nil ?›2](4)›0](B nil ?›2](4g›0](B nil nil - nli ?›2](49›0](B ?›2](3H›0](B ?›2](3D›0](B ?›2](4_›0](B ?›2](4S›0](B ?›2](4#›0](B ?›2](38›0](B ?›2](4%›0](B nil ?›2](4Y›0](B ?›2](4[›0](B ?›2](3T›0](B ?›2](3^›0](B ?›2](3F›0](B ?›2](41›0](B - ?›2](4-›0](B ?›2](4A›0](B ?›2](4Q›0](B ?›2](45›0](B ?›2](4O›0](B ?›2](3Z›0](B ?›2](3B›0](B ?›2](4=›0](B ?›2](4E›0](B ?›2](4M›0](B ?›2](4I›0](B nil nli nil nil ]) - (t - [?›2](3!›0](B ?›2](3"›0](B ?\" ?# ?$ ?% ?& ?' ?›2](3#›0](B ?›2](3$›0](B ?* ?+ ?›2](3^›0](B ?- ?›2](3H›0](B ?›2](4I›0](B - ?(2!(B ?(2"(B ?(2#(B ?(2$(B ?(2%(B ?(2&(B ?(2'(B ?(2((B ?(2)(B ?(2*(B ?›2](3'›0](B ?›2](4U›0](B ?, ?= ?. ?›2](3)›0](B - ?@ nil ?›2](3b›0](B ?{ ?[ nil ?] ?›2](3c›0](B ?›2](30›0](B nil nil ?›2](3%›0](B ?/ ?` ?›2](3.›0](B nil - ?›2](3(›0](B nil nil nil ?›2](3d›0](B ?' ?} nil nil ?›2](34›0](B ?~ ?›2](4)›0](B ?\\ ?›2](3B›0](B ?^ ?_ - ?›2](3D›0](B ?›2](49›0](B ?›2](3e›0](B ?›2](32›0](B ?›2](4_›0](B ?›2](4'›0](B ?›2](4#›0](B ?›2](4Y›0](B ?›2](38›0](B ?›2](3Z›0](B ?›2](4%›0](B ?›2](4[›0](B ?›2](3T›0](B ?›2](3<›0](B ?›2](4]›0](B ?›2](41›0](B - ?›2](4-›0](B ?›2](4A›0](B ?›2](4S›0](B ?›2](45›0](B ?›2](4Q›0](B ?›2](4M›0](B ?›2](3F›0](B ?›2](4=›0](B ?›2](3-›0](B ?›2](4O›0](B ?›2](4!›0](B ?< ?| ?> nil ]))) - -(defvar arabic-mode-map - (let ((map (make-keymap))) - (substitute-key-definition 'self-insert-command - 'arabic-self-insert-command - map global-map) - - (define-key map [(control c) (control c)] 'arabic-mode) - (define-key map [(control d)] 'arabic-delete-char) - (define-key map [(control k)] 'arabic-kill-line) - (define-key map [(control m)] 'arabic-newline) - (define-key map [(control o)] 'arabic-open-line) - (define-key map [(control w)] 'arabic-kill-region) - (define-key map [(control y)] 'arabic-yank) - (define-key map [delete] 'arabic-backward-delete-char) - (define-key map [(meta d)] 'arabic-delete-word) - (define-key map [(meta y)] 'arabic-yank-pop) - (define-key map [(meta z)] 'arabic-help) - (define-key map [(meta \\)] 'arabic-toggle-input-char) - (define-key map [(meta delete)] 'arabic-backward-kill-word) - - (define-key map [(control n)] 'visual-next-line) - (define-key map [(control p)] 'visual-previous-line) - (define-key map [(meta <)] 'visual-beginning-of-buffer) - (define-key map [(meta >)] 'visual-end-of-buffer) - (define-key map [up] 'visual-previous-line) - (define-key map [down] 'visual-next-line) - (define-key map [home] 'visual-beginning-of-buffer) - (define-key map [end] 'visual-end-of-buffer) - (define-key map [left] 'visual-move-to-left-char) - (define-key map [right] 'visual-move-to-right-char) - (define-key map [(meta left)] 'visual-move-to-left-word) - (define-key map [(meta right)] 'visual-move-to-right-word) - - (if visual-use-lr-commands - (progn - (define-key map [(control a)] 'visual-left-end-of-line) - (define-key map [(control b)] 'visual-move-to-left-char) - (define-key map [(control e)] 'visual-right-end-of-line) - (define-key map [(control f)] 'visual-move-to-right-char) - (define-key map [(meta b)] 'visual-move-to-left-word) - (define-key map [(meta f)] 'visual-move-to-right-word)) - (define-key map [(control a)] 'visual-beginning-of-line) - (define-key map [(control b)] 'visual-backward-char) - (define-key map [(control e)] 'visual-end-of-line) - (define-key map [(control f)] 'visual-forward-char) - (define-key map [(meta b)] 'visual-backward-word) - (define-key map [(meta f)] 'visual-forward-word)) - - (cond - ((eq arabic-input-keymap 'arabic-keymap-0) - (define-key map [?~] 'arabic-insert-madda) - (define-key map [?'] 'arabic-insert-hamza) - (define-key map [?a] 'arabic-insert-alif) - (define-key map [?_] 'arabic-make-connection) - (define-key map [?|] 'arabic-cut-connection)) - ((eq arabic-input-keymap 'arabic-keymap-1) - (define-key map [?~] 'arabic-insert-madda) - (define-key map [?'] 'arabic-insert-hamza) - (define-key map [?a] 'arabic-insert-alif) - (define-key map [?_] 'arabic-make-connection) - (define-key map [?|] 'arabic-cut-connection) - (define-key map [(alt \;)] 'arabic-insert-gaaf) - (define-key map [(alt v)] 'arabic-insert-isolated-hamza)) - (t - (define-key map [(alt z)] 'arabic-insert-madda) - (define-key map [(alt x)] 'arabic-insert-hamza) - (define-key map [(alt h)] 'arabic-insert-alif) - (define-key map [(alt _)] 'arabic-make-connection) - (define-key map [(alt |)] 'arabic-cut-connection))) - - map) - "minor-mode-keymap for arabic-mode.") - - (if (not (assq 'arabic-mode minor-mode-map-alist)) - (setq minor-mode-map-alist - (cons (cons 'arabic-mode arabic-mode-map) minor-mode-map-alist))) - - (defvar arabic-help-string - (cond - ((eq arabic-input-keymap 'arabic-keymap-0) - "\ - Keymap in Arabic-mode - - +----------------------------------------------------------------+ - |! ›2](3"›0](B |@ |# |$ |% |^ |& |* |( ›2](3#›0](B |) ›2](3$›0](B |_ |+ |~ | - |1 (2"(B |2 (2#(B |3 (2$(B |4 (2%(B |5 (2&(B |6 (2'(B |7 (2((B |8 (2)(B |9 (2*(B |0 (2!(B |- |= |` ›2](4M›0](B| - +----------------------------------------------------------------+ - |Q |W |E |R |T ›2](4E›0](B|Y |U |I |O |P | - |q ›2](4S›0](B|w ›2](3^›0](B |e |r ›2](3F›0](B |t ›2](4%›0](B|y ›2](4_›0](B|u |i |o ›2](3<›0](B |p ›2](4e›0](B| - +--------------------------------------------------------+ - |A ›2](4]›0](B|S ›2](4=›0](B|D ›2](4A›0](B|F |G ›2](4O›0](B|H ›2](4-›0](B|J |K ›2](41›0](B|L |: ›2](3'›0](B |\" ›2](3-›0](B | - |a ›2](38›0](B |s ›2](45›0](B|d ›2](3B›0](B |f ›2](4Q›0](B|g ›2](4k›0](B|h ›2](3Z›0](B |j ›2](4)›0](B|k ›2](4U›0](B|l ›2](4Y›0](B|; ›2](3(›0](B |' | - +------------------------------------------------------+ - |Z ›2](4I›0](B|X ›2](3h›0](B |C ›2](4g›0](B|V |B |N |M |< ›2](3*›0](B |> ›2](3+›0](B |? ›2](3)›0](B | - |z ›2](3H›0](B |x ›2](3D›0](B |c ›2](4'›0](B|v |b ›2](4#›0](B|n ›2](4[›0](B|m ›2](3T›0](B |, ›2](3%›0](B |. ›2](3&›0](B |/ ›2](49›0](B| - +-------------------------------------------------+") - - ((eq arabic-input-keymap 'arabic-keymap-1) - "\ - Keymap in Arabic-mode +--------------+ - | ALT SHIFT| - +-------------------------------------------------+ |ASCII ARABIC| -| ›2](3"›0](B | | | | | | | | ›2](3#›0](B | ›2](3$›0](B | +--------------+ -|1 (2"(B |2 (2#(B |3 (2$(B |4 (2%(B |5 (2&(B |6 (2'(B |7 (2((B |8 (2)(B |9 (2*(B |0 (2!(B | -+-------------------------------------------------------------+ - | | | | | | | | | | | | | - |q ›2](4A›0](B|w ›2](4=›0](B|e ›2](4S›0](B|r ›2](4Q›0](B|t ›2](4O›0](B|y ›2](4M›0](B|u ›2](3Z›0](B |i |o ›2](41›0](B|p ›2](4-›0](B|[ ›2](4)›0](B|] ›2](4g›0](B| - +-----------------------------------------------------------+ - | | | | ›2](4e›0](B| ›2](3.›0](B | | | | |›2](4k›0](B ›2](3'›0](B| - |a ›2](49›0](B|s ›2](45›0](B|d ›2](4_›0](B|f ›2](4#›0](B|g ›2](38›0](B |h ›2](4%›0](B|j ›2](4Y›0](B|k ›2](4[›0](B|l ›2](3T›0](B |; ›2](4U›0](B| - +---------------------------------------------------+ - | | | |›2](3-›0](B ›2](30›0](B | ›2](3h›0](B | | | ›2](3*›0](B | ›2](3+›0](B | ›2](3)›0](B | - |z ›2](4I›0](B|x ›2](4E›0](B|c ›2](3D›0](B |v ›2](3B›0](B |b ›2](3H›0](B |n ›2](3F›0](B |m ›2](3^›0](B |, ›2](3%›0](B |. ›2](3&›0](B |/ | - +-------------------------------------------------+") - - (t - "\ - +-----------------+ - |S-ASCII S-Arabic| - | ASCII Arabic | +----+ - +-----------------+ || || - |\\ \\| -+-----------------------------------------------------------+ -|! ›2](3"›0](B|@ @|# #|$ $|% %|^ ^|& &|* *|( ›2](3#›0](B|) ›2](3$›0](B|_ _|+ +| -|1 (2"(B|2 (2#(B|3 (2$(B|4 (2%(B|5 (2&(B|6 (2'(B|7 (2((B|8 (2)(B|9 (2*(B|0 (2!(B|- -|= =| -+-------------------------------------------------------------+ - |Q |W |E |R |T ›2](3d›0](B|Y ›2](34›0](B|U '|I |O |P ›2](3(›0](B|{ <|} >| - | ›2](4A›0](B| ›2](4=›0](B| ›2](4'›0](B| ›2](4S›0](B| ›2](4Q›0](B| ›2](4O›0](B| ›2](4M›0](B| ›2](3Z›0](B| ›2](41›0](B| ›2](4-›0](B|[ ›2](4)›0](B|] ›2](3B›0](B| - +-------------------------------------------------------------+ - |A |S |D [|F ]|G ›2](3c›0](B|H ›2](30›0](B|J |K ›2](3%›0](B|L /|: ›2](3'›0](B|\" \" |~›2](3,›0](B | - | ›2](49›0](B| ›2](45›0](B| ›2](4_›0](B| ›2](4#›0](B| ›2](4Y›0](B| ›2](38›0](B| ›2](4%›0](B| ›2](4[›0](B| ›2](3T›0](B|\; ›2](4U›0](B|' ›2](4E›0](B|` ›2](3D›0](B| - +-----------------------------------------------------------+ - |Z ~|X |C {|V }|B ›2](3b›0](B|N ›2](3.›0](B|M `|< ,|> ›2](3&›0](B|? ›2](3)›0](B| - | ›2](4!›0](B| ›2](3-›0](B| ›2](32›0](B| ›2](3F›0](B| ›2](3e›0](B| ›2](4]›0](B| ›2](3<›0](B|, ›2](3^›0](B|. ›2](3H›0](B|/ ›2](4I›0](B| - +-------------------------------------------------+")) - - "Document shown by arabic-help (M-z).") - -;;;###autoload -(defun arabic-mode (&optional arg) - "Toggle arabic-mode. With ARG, turn arabic-mode on iff ARG is positive." - (interactive "P") - (if (null arg) - (if arabic-mode (exit-arabic-mode) (enter-arabic-mode)) - (if (> (prefix-numeric-value arg) 0) - (enter-arabic-mode) - (exit-arabic-mode)))) - -(defun enter-arabic-mode nil - "Enter arabic-mode." - (interactive) - (if (not arabic-mode) - (progn - (setq arabic-mode t - arabic-input-arabic-char t - arabic-mode-indicator " ›2](3=a:GJ›0](B") - (redraw-modeline t) - (message "M-z to display arabic keymap.") - (run-hooks 'arabic-mode-hooks)))) - -(defun exit-arabic-mode nil - "Exit arabic-mode." - (interactive) - (if arabic-mode - (progn - (setq arabic-mode nil) - (redraw-modeline t)))) - -(defconst *arabic-adding-connection-to-right* - '((?›2](3.›0](B . ?›2](3/›0](B ) (?›2](3/›0](B . ?›2](3/›0](B ) - (?›2](30›0](B . ?›2](31›0](B ) (?›2](31›0](B . ?›2](31›0](B ) - (?›2](32›0](B . ?›2](33›0](B ) (?›2](33›0](B . ?›2](33›0](B ) - (?›2](34›0](B . ?›2](35›0](B ) (?›2](35›0](B . ?›2](35›0](B ) - (?›2](4!›0](B . ?›2](4"›0](B) (?›2](36›0](B . ?›2](37›0](B ) (?›2](37›0](B . ?›2](37›0](B ) (?›2](4"›0](B . ?›2](4"›0](B) - (?›2](36›0](B . ?›2](37›0](B ) (?›2](37›0](B . ?›2](37›0](B ) - (?›2](38›0](B . ?›2](39›0](B ) (?›2](39›0](B . ?›2](39›0](B ) - (?›2](4#›0](B . ?›2](4$›0](B) (?›2](3:›0](B . ?›2](3;›0](B ) (?›2](3;›0](B . ?›2](3;›0](B ) (?›2](4$›0](B . ?›2](4$›0](B) - (?›2](3<›0](B . ?›2](3=›0](B ) (?›2](3=›0](B . ?›2](3=›0](B ) - (?›2](4%›0](B . ?›2](4&›0](B) (?›2](3>›0](B . ?›2](3?›0](B ) (?›2](3?›0](B . ?›2](3?›0](B ) (?›2](4&›0](B . ?›2](4&›0](B) - (?›2](4'›0](B . ?›2](4(›0](B) (?›2](3@›0](B . ?›2](3A›0](B ) (?›2](3A›0](B . ?›2](3A›0](B ) (?›2](4(›0](B . ?›2](4(›0](B) - (?›2](4)›0](B . ?›2](4,›0](B) (?›2](4*›0](B . ?›2](4+›0](B) (?›2](4+›0](B . ?›2](4+›0](B) (?›2](4,›0](B . ?›2](4,›0](B) - (?›2](4-›0](B . ?›2](40›0](B) (?›2](4.›0](B . ?›2](4/›0](B) (?›2](4/›0](B . ?›2](4/›0](B) (?›2](40›0](B . ?›2](40›0](B) - (?›2](41›0](B . ?›2](44›0](B) (?›2](42›0](B . ?›2](43›0](B) (?›2](43›0](B . ?›2](43›0](B) (?›2](44›0](B . ?›2](44›0](B) - (?›2](3B›0](B . ?›2](3C›0](B ) (?›2](3C›0](B . ?›2](3C›0](B ) - (?›2](3D›0](B . ?›2](3E›0](B ) (?›2](3E›0](B . ?›2](3E›0](B ) - (?›2](3F›0](B . ?›2](3G›0](B ) (?›2](3G›0](B . ?›2](3G›0](B ) - (?›2](3H›0](B . ?›2](3I›0](B ) (?›2](3I›0](B . ?›2](3I›0](B ) - (?›2](45›0](B . ?›2](48›0](B) (?›2](46›0](B . ?›2](47›0](B) (?›2](47›0](B . ?›2](47›0](B) (?›2](48›0](B . ?›2](48›0](B) - (?›2](49›0](B . ?›2](4<›0](B) (?›2](4:›0](B . ?›2](4;›0](B) (?›2](4;›0](B . ?›2](4;›0](B) (?›2](4<›0](B . ?›2](4<›0](B) - (?›2](4=›0](B . ?›2](4@›0](B) (?›2](4>›0](B . ?›2](4?›0](B) (?›2](4?›0](B . ?›2](4?›0](B) (?›2](4@›0](B . ?›2](4@›0](B) - (?›2](4A›0](B . ?›2](4D›0](B) (?›2](4B›0](B . ?›2](4C›0](B) (?›2](4C›0](B . ?›2](4C›0](B) (?›2](4D›0](B . ?›2](4D›0](B) - (?›2](4E›0](B . ?›2](4H›0](B) (?›2](4F›0](B . ?›2](4G›0](B) (?›2](4G›0](B . ?›2](4G›0](B) (?›2](4H›0](B . ?›2](4H›0](B) - (?›2](4I›0](B . ?›2](4L›0](B) (?›2](4J›0](B . ?›2](4K›0](B) (?›2](4K›0](B . ?›2](4K›0](B) (?›2](4L›0](B . ?›2](4L›0](B) - (?›2](4M›0](B . ?›2](4N›0](B) (?›2](3J›0](B . ?›2](3K›0](B ) (?›2](3K›0](B . ?›2](3K›0](B ) (?›2](4N›0](B . ?›2](4N›0](B) - (?›2](4O›0](B . ?›2](4P›0](B) (?›2](3L›0](B . ?›2](3M›0](B ) (?›2](3M›0](B . ?›2](3M›0](B ) (?›2](4P›0](B . ?›2](4P›0](B) - (?›2](4Q›0](B . ?›2](4R›0](B) (?›2](3N›0](B . ?›2](3O›0](B ) (?›2](3O›0](B . ?›2](3O›0](B ) (?›2](4R›0](B . ?›2](4R›0](B) - (?›2](4S›0](B . ?›2](4T›0](B) (?›2](3P›0](B . ?›2](3Q›0](B ) (?›2](3Q›0](B . ?›2](3Q›0](B ) (?›2](4T›0](B . ?›2](4T›0](B) - (?›2](4U›0](B . ?›2](4X›0](B) (?›2](4V›0](B . ?›2](4W›0](B) (?›2](4W›0](B . ?›2](4W›0](B) (?›2](4X›0](B . ?›2](4X›0](B) - (?›2](4Y›0](B . ?›2](4Z›0](B) (?›2](3R›0](B . ?›2](3S›0](B ) (?›2](3S›0](B . ?›2](3S›0](B ) (?›2](4Z›0](B . ?›2](4Z›0](B) - (?›2](3T›0](B . ?›2](3W›0](B ) (?›2](3U›0](B . ?›2](3V›0](B ) (?›2](3V›0](B . ?›2](3V›0](B ) (?›2](3W›0](B . ?›2](3W›0](B ) - (?›2](4[›0](B . ?›2](4\›0](B) (?›2](3X›0](B . ?›2](3Y›0](B ) (?›2](3Y›0](B . ?›2](3Y›0](B ) (?›2](4\›0](B . ?›2](4\›0](B) - (?›2](3Z›0](B . ?›2](3]›0](B ) (?›2](3[›0](B . ?›2](3\›0](B ) (?›2](3\›0](B . ?›2](3\›0](B ) (?›2](3]›0](B . ?›2](3]›0](B ) - (?›2](3^›0](B . ?›2](3_›0](B ) (?›2](3_›0](B . ?›2](3_›0](B ) - (?›2](4]›0](B . ?›2](4^›0](B) (?›2](4^›0](B . ?›2](4^›0](B) - (?›2](4_›0](B . ?›2](4`›0](B) (?›2](3`›0](B . ?›2](3a›0](B ) (?›2](3a›0](B . ?›2](3a›0](B ) (?›2](4`›0](B . ?›2](4`›0](B) - (?›2](3b›0](B . ?›2](4a›0](B) (?›2](4a›0](B . ?›2](4a›0](B) - (?›2](3c›0](B . ?›2](4b›0](B) (?›2](4b›0](B . ?›2](4b›0](B) - (?›2](3d›0](B . ?›2](4c›0](B) (?›2](4c›0](B . ?›2](4c›0](B) - (?›2](3e›0](B . ?›2](4d›0](B) (?›2](4d›0](B . ?›2](4d›0](B) - (?›2](4e›0](B . ?›2](4f›0](B) (?›2](3f›0](B . ?›2](3g›0](B ) (?›2](3g›0](B . ?›2](3g›0](B ) (?›2](4f›0](B . ?›2](4f›0](B) - (?›2](4g›0](B . ?›2](4j›0](B) (?›2](4h›0](B . ?›2](4i›0](B) (?›2](4i›0](B . ?›2](4i›0](B) (?›2](4j›0](B . ?›2](4j›0](B) - (?›2](3h›0](B . ?›2](3i›0](B ) (?›2](3i›0](B . ?›2](3i›0](B ) - (?›2](4k›0](B . ?›2](4n›0](B) (?›2](4l›0](B . ?›2](4m›0](B) (?›2](4m›0](B . ?›2](4m›0](B) (?›2](4n›0](B . ?›2](4n›0](B))) - -(defconst *arabic-adding-connection-to-left* - '((?›2](4!›0](B . ?›2](36›0](B ) (?›2](36›0](B . ?›2](36›0](B ) (?›2](37›0](B . ?›2](37›0](B ) (?›2](4"›0](B . ?›2](37›0](B) - (?›2](4#›0](B . ?›2](3:›0](B ) (?›2](3:›0](B . ?›2](3:›0](B ) (?›2](3;›0](B . ?›2](3;›0](B ) (?›2](4$›0](B . ?›2](3;›0](B ) - (?›2](4%›0](B . ?›2](3>›0](B ) (?›2](3>›0](B . ?›2](3>›0](B ) (?›2](3?›0](B . ?›2](3?›0](B ) (?›2](4&›0](B . ?›2](3?›0](B ) - (?›2](4'›0](B . ?›2](3@›0](B ) (?›2](3@›0](B . ?›2](3@›0](B ) (?›2](3A›0](B . ?›2](3A›0](B ) (?›2](4(›0](B . ?›2](3A›0](B ) - (?›2](4)›0](B . ?›2](4*›0](B) (?›2](4*›0](B . ?›2](4*›0](B) (?›2](4+›0](B . ?›2](4+›0](B) (?›2](4,›0](B . ?›2](4+›0](B) - (?›2](4-›0](B . ?›2](4.›0](B) (?›2](4.›0](B . ?›2](4.›0](B) (?›2](4/›0](B . ?›2](4/›0](B) (?›2](40›0](B . ?›2](4/›0](B) - (?›2](41›0](B . ?›2](42›0](B) (?›2](42›0](B . ?›2](42›0](B) (?›2](43›0](B . ?›2](43›0](B) (?›2](44›0](B . ?›2](43›0](B) - (?›2](45›0](B . ?›2](46›0](B) (?›2](46›0](B . ?›2](46›0](B) (?›2](47›0](B . ?›2](47›0](B) (?›2](48›0](B . ?›2](47›0](B) - (?›2](49›0](B . ?›2](4:›0](B) (?›2](4:›0](B . ?›2](4:›0](B) (?›2](4;›0](B . ?›2](4;›0](B) (?›2](4<›0](B . ?›2](4;›0](B) - (?›2](4=›0](B . ?›2](4>›0](B) (?›2](4>›0](B . ?›2](4>›0](B) (?›2](4?›0](B . ?›2](4?›0](B) (?›2](4@›0](B . ?›2](4?›0](B) - (?›2](4A›0](B . ?›2](4B›0](B) (?›2](4B›0](B . ?›2](4B›0](B) (?›2](4C›0](B . ?›2](4C›0](B) (?›2](4D›0](B . ?›2](4C›0](B) - (?›2](4E›0](B . ?›2](4F›0](B) (?›2](4F›0](B . ?›2](4F›0](B) (?›2](4G›0](B . ?›2](4G›0](B) (?›2](4H›0](B . ?›2](4G›0](B) - (?›2](4I›0](B . ?›2](4J›0](B) (?›2](4J›0](B . ?›2](4J›0](B) (?›2](4K›0](B . ?›2](4K›0](B) (?›2](4L›0](B . ?›2](4K›0](B) - (?›2](4M›0](B . ?›2](3J›0](B ) (?›2](3J›0](B . ?›2](3J›0](B ) (?›2](3K›0](B . ?›2](3K›0](B ) (?›2](4N›0](B . ?›2](3K›0](B ) - (?›2](4O›0](B . ?›2](3L›0](B ) (?›2](3L›0](B . ?›2](3L›0](B ) (?›2](3M›0](B . ?›2](3M›0](B ) (?›2](4P›0](B . ?›2](3M›0](B ) - (?›2](4Q›0](B . ?›2](3N›0](B ) (?›2](3N›0](B . ?›2](3N›0](B ) (?›2](3O›0](B . ?›2](3O›0](B ) (?›2](4R›0](B . ?›2](3O›0](B ) - (?›2](4S›0](B . ?›2](3P›0](B ) (?›2](3P›0](B . ?›2](3P›0](B ) (?›2](3Q›0](B . ?›2](3Q›0](B ) (?›2](4T›0](B . ?›2](3Q›0](B ) - (?›2](4U›0](B . ?›2](4V›0](B) (?›2](4V›0](B . ?›2](4V›0](B) (?›2](4W›0](B . ?›2](4W›0](B) (?›2](4X›0](B . ?›2](4W›0](B) - (?›2](4Y›0](B . ?›2](3R›0](B ) (?›2](3R›0](B . ?›2](3R›0](B ) (?›2](3S›0](B . ?›2](3S›0](B ) (?›2](4Z›0](B . ?›2](3S›0](B ) - (?›2](3T›0](B . ?›2](3U›0](B ) (?›2](3U›0](B . ?›2](3U›0](B ) (?›2](3V›0](B . ?›2](3V›0](B ) (?›2](3W›0](B . ?›2](3V›0](B ) - (?›2](4[›0](B . ?›2](3X›0](B ) (?›2](3X›0](B . ?›2](3X›0](B ) (?›2](3Y›0](B . ?›2](3Y›0](B ) (?›2](4\›0](B . ?›2](3Y›0](B ) - (?›2](3Z›0](B . ?›2](3[›0](B ) (?›2](3[›0](B . ?›2](3[›0](B ) (?›2](3\›0](B . ?›2](3\›0](B ) (?›2](3]›0](B . ?›2](3\›0](B ) - (?›2](4_›0](B . ?›2](3`›0](B ) (?›2](3`›0](B . ?›2](3`›0](B ) (?›2](3a›0](B . ?›2](3a›0](B ) (?›2](4`›0](B . ?›2](3a›0](B ) - (?›2](4e›0](B . ?›2](3f›0](B ) (?›2](3f›0](B . ?›2](3f›0](B ) (?›2](3g›0](B . ?›2](3g›0](B ) (?›2](4f›0](B . ?›2](3g›0](B) - (?›2](4g›0](B . ?›2](4h›0](B) (?›2](4h›0](B . ?›2](4h›0](B) (?›2](4i›0](B . ?›2](4i›0](B) (?›2](4j›0](B . ?›2](4i›0](B) - (?›2](4k›0](B . ?›2](4l›0](B) (?›2](4l›0](B . ?›2](4l›0](B) (?›2](4m›0](B . ?›2](4m›0](B) (?›2](4n›0](B . ?›2](4m›0](B))) - -(defconst *arabic-removing-connection-from-right* - '((?›2](3/›0](B . ?›2](3.›0](B ) - (?›2](31›0](B . ?›2](30›0](B ) - (?›2](33›0](B . ?›2](32›0](B ) - (?›2](35›0](B . ?›2](34›0](B ) - (?›2](4"›0](B . ?›2](4!›0](B) (?›2](37›0](B . ?›2](36›0](B ) - (?›2](39›0](B . ?›2](38›0](B ) - (?›2](4$›0](B . ?›2](4#›0](B) (?›2](3;›0](B . ?›2](3:›0](B ) - (?›2](3=›0](B . ?›2](3<›0](B ) - (?›2](4&›0](B . ?›2](4%›0](B) (?›2](3?›0](B . ?›2](3>›0](B ) - (?›2](4(›0](B . ?›2](4'›0](B) (?›2](3A›0](B . ?›2](3@›0](B ) - (?›2](4,›0](B . ?›2](4)›0](B) (?›2](4+›0](B . ?›2](4*›0](B) - (?›2](40›0](B . ?›2](4-›0](B) (?›2](4/›0](B . ?›2](4.›0](B) - (?›2](44›0](B . ?›2](41›0](B) (?›2](43›0](B . ?›2](42›0](B) - (?›2](3C›0](B . ?›2](3B›0](B ) - (?›2](3E›0](B . ?›2](3D›0](B ) - (?›2](3G›0](B . ?›2](3F›0](B ) - (?›2](3I›0](B . ?›2](3H›0](B ) - (?›2](48›0](B . ?›2](45›0](B) (?›2](47›0](B . ?›2](46›0](B) - (?›2](4<›0](B . ?›2](49›0](B) (?›2](4;›0](B . ?›2](4:›0](B) - (?›2](4@›0](B . ?›2](4=›0](B) (?›2](4?›0](B . ?›2](4>›0](B) - (?›2](4D›0](B . ?›2](4A›0](B) (?›2](4C›0](B . ?›2](4B›0](B) - (?›2](4H›0](B . ?›2](4E›0](B) (?›2](4G›0](B . ?›2](4F›0](B) - (?›2](4L›0](B . ?›2](4I›0](B) (?›2](4K›0](B . ?›2](4J›0](B) - (?›2](4N›0](B . ?›2](4M›0](B) (?›2](3K›0](B . ?›2](3J›0](B ) - (?›2](4P›0](B . ?›2](4O›0](B) (?›2](3M›0](B . ?›2](3L›0](B ) - (?›2](4R›0](B . ?›2](4Q›0](B) (?›2](3O›0](B . ?›2](3N›0](B ) - (?›2](4T›0](B . ?›2](4S›0](B) (?›2](3Q›0](B . ?›2](3P›0](B ) - (?›2](4X›0](B . ?›2](4U›0](B) (?›2](4W›0](B . ?›2](4V›0](B) - (?›2](4Z›0](B . ?›2](4Y›0](B) (?›2](3S›0](B . ?›2](3R›0](B ) - (?›2](3W›0](B . ?›2](3T›0](B ) (?›2](3V›0](B . ?›2](3U›0](B ) - (?›2](4\›0](B . ?›2](4[›0](B) (?›2](3Y›0](B . ?›2](3X›0](B ) - (?›2](3]›0](B . ?›2](3Z›0](B ) (?›2](3\›0](B . ?›2](3[›0](B ) - (?›2](3_›0](B . ?›2](3^›0](B ) - (?›2](4^›0](B . ?›2](4]›0](B) - (?›2](4`›0](B . ?›2](4_›0](B) (?›2](3a›0](B . ?›2](3`›0](B ) - (?›2](4a›0](B . ?›2](3b›0](B ) - (?›2](4b›0](B . ?›2](3c›0](B ) - (?›2](4c›0](B . ?›2](3d›0](B ) - (?›2](4d›0](B . ?›2](3e›0](B ) - (?›2](4f›0](B . ?›2](4e›0](B) (?›2](3g›0](B . ?›2](3f›0](B ) - (?›2](4j›0](B . ?›2](4g›0](B) (?›2](4i›0](B . ?›2](4h›0](B) - (?›2](3i›0](B . ?›2](3h›0](B) - (?›2](4n›0](B . ?›2](4k›0](B) (?›2](4m›0](B . ?›2](4l›0](B))) - -(defconst *arabic-removing-connection-from-left* - '((?›2](36›0](B . ?›2](4!›0](B) (?›2](37›0](B . ?›2](4"›0](B) - (?›2](3:›0](B . ?›2](4#›0](B) (?›2](3;›0](B . ?›2](4$›0](B) - (?›2](3>›0](B . ?›2](4%›0](B) (?›2](3?›0](B . ?›2](4&›0](B) - (?›2](3@›0](B . ?›2](4'›0](B) (?›2](3A›0](B . ?›2](4(›0](B) - (?›2](4*›0](B . ?›2](4)›0](B) (?›2](4+›0](B . ?›2](4,›0](B) - (?›2](4.›0](B . ?›2](4-›0](B) (?›2](4/›0](B . ?›2](40›0](B) - (?›2](42›0](B . ?›2](41›0](B) (?›2](43›0](B . ?›2](44›0](B) - (?›2](46›0](B . ?›2](45›0](B) (?›2](47›0](B . ?›2](48›0](B) - (?›2](4:›0](B . ?›2](49›0](B) (?›2](4;›0](B . ?›2](4<›0](B) - (?›2](4>›0](B . ?›2](4=›0](B) (?›2](4?›0](B . ?›2](4@›0](B) - (?›2](4D›0](B . ?›2](4A›0](B) (?›2](4C›0](B . ?›2](4A›0](B) - (?›2](4F›0](B . ?›2](4E›0](B) (?›2](4G›0](B . ?›2](4H›0](B) - (?›2](4J›0](B . ?›2](4I›0](B) (?›2](4K›0](B . ?›2](4L›0](B) - (?›2](3J›0](B . ?›2](4M›0](B) (?›2](3K›0](B . ?›2](4N›0](B) - (?›2](3L›0](B . ?›2](4O›0](B) (?›2](3M›0](B . ?›2](4P›0](B) - (?›2](3N›0](B . ?›2](4Q›0](B) (?›2](3O›0](B . ?›2](4R›0](B) - (?›2](3P›0](B . ?›2](4S›0](B) (?›2](3Q›0](B . ?›2](4T›0](B) - (?›2](4V›0](B . ?›2](4U›0](B) (?›2](4W›0](B . ?›2](4X›0](B) - (?›2](3R›0](B . ?›2](4Y›0](B) (?›2](3S›0](B . ?›2](4Z›0](B) - (?›2](3U›0](B . ?›2](3T›0](B ) (?›2](3V›0](B . ?›2](3W›0](B ) - (?›2](3X›0](B . ?›2](4[›0](B) (?›2](3Y›0](B . ?›2](4\›0](B) - (?›2](3[›0](B . ?›2](3Z›0](B ) (?›2](3\›0](B . ?›2](3]›0](B ) - (?›2](3`›0](B . ?›2](4_›0](B) (?›2](3a›0](B . ?›2](4`›0](B) - (?›2](4h›0](B . ?›2](4g›0](B) (?›2](4i›0](B . ?›2](4j›0](B) - (?›2](4l›0](B . ?›2](4k›0](B) (?›2](4m›0](B . ?›2](4n›0](B))) - -(defun arabic-make-connection nil - "If possible, tie the two characters around the cursor." - (interactive) - (let ((lch (assoc (visual-char-left) *arabic-adding-connection-to-right*)) - (rch (assoc (visual-char-right) *arabic-adding-connection-to-left*))) - (if (not (and lch rch)) - (arabic-cut-connection) - (visual-replace-left-1-char (cdr lch)) - (visual-replace-right-1-char (cdr rch))))) - -(defun arabic-cut-connection nil - "Remove the connection between the two characters around the cursor, if any." - (interactive) - (let - ((lch (assoc (visual-char-left) *arabic-removing-connection-from-right*)) - (rch (assoc (visual-char-right) *arabic-removing-connection-from-left*))) - (if lch - (visual-replace-left-1-char (cdr lch))) - (if rch - (visual-replace-right-1-char (cdr rch))))) - -(defun arabic-insert-char (ch arg) - "Insert ARG (2nd arg; > 0) number of CHs (1st arg; character) around -visual point. -If CH is l2r, inserted on the left. Otherwise, on the right." - (while (> arg 0) - (arabic-insert-1-char ch) - (setq arg (1- arg)))) - -(defun arabic-insert-1-char (ch) - "Insert CH (1st arg; character) around visual point. -If CH is l2r, inserted on the left. Otherwise, on the right." - (if (= (visual-char-direction ch) 0) - ; if visual-char-direction = 0, always disjoint. - (progn - (arabic-cut-connection) - (visual-insert-left-1-char ch)) - (visual-insert-left-1-char ch) - (arabic-make-connection) - (visual-move-to-left-1-char) - (arabic-make-connection))) - -(defun arabic-self-insert-command (arg) - "Self-insert-command for arabic-mode." - (interactive "*p") - (let ((ch last-command-char)) - (if arabic-input-arabic-char - (setq ch (aref arabic-translate-table (- ch 32)))) - (if (null ch) - (beep) - (while (> arg 0) - (arabic-keyboard-insert-1-char ch) - (setq arg (1- arg)))))) - -(defun arabic-keyboard-insert-1-char (ch) - "Insert CH (1st arg; Arabic character) at visual cursor position. -if last-command is arabic-cut-connection, CH will not connected to the -right adjacent character (but connected to the left, if possible)." - (let ((rch (visual-char-right))) - (cond - ((= (visual-char-direction ch) 0) - (arabic-cut-connection) - (visual-insert-left-1-char ch)) - ((eq last-command 'arabic-cut-connection) - (visual-insert-right-1-char ch) - (arabic-make-connection)) - (t - (arabic-insert-1-char ch))))) - -(defun arabic-insert-gaaf (arg) - "Insert gaaf as if it were typed from keyboard." - (interactive "*p") - (while (> arg 0) - (arabic-keyboard-insert-1-char ?›2](4k›0](B) - (setq arg (1- arg)))) - -(defun arabic-insert-isolated-hamza (arg) - "Insert an isolated hamza as if it were typed from keyboard." - (interactive "*p") - (while (> arg 0) - (arabic-keyboard-insert-1-char ?›2](3-›0](B) - (setq arg (1- arg)))) - -(defun arabic-insert-madda nil - "Put madda on the previous alif." - (interactive) - (let ((rch (visual-char-right))) - (cond - ((eq rch ?›2](38›0](B ) (visual-replace-right-1-char ?›2](3.›0](B )) - ((eq rch ?›2](39›0](B ) (visual-replace-right-1-char ?›2](3/›0](B )) - ((eq rch ?›2](3e›0](B ) (visual-replace-right-1-char ?›2](3b›0](B )) - ((eq rch ?›2](4d›0](B) (visual-replace-right-1-char ?›2](4a›0](B)) - (t (beep))))) - -(defun arabic-insert-alif (arg) - "Insert ARG number of alif's. -If the previous character is a laam, replace it with an alif+laam ligature." - (interactive "*p") - (let (rch) - (while (> arg 0) - (setq rch (visual-char-right)) - (cond - ((eq last-command 'arabic-cut-connection) - (visual-insert-right-1-char ?›2](38›0](B)) - ((or (eq rch ?›2](4Y›0](B) (eq rch ?›2](3R›0](B )) - (visual-replace-right-1-char ?›2](3e›0](B )) - ((or (eq rch ?›2](3S›0](B ) (eq rch ?›2](4Z›0](B)) - (visual-replace-right-1-char ?›2](4d›0](B)) - (t - (visual-insert-left-1-char ?›2](38›0](B ) - (arabic-make-connection) - (visual-move-to-left-1-char))) - (setq arg (1- arg))) - (arabic-cut-connection))) - -(defun arabic-insert-hamza (arg) - "Insert ARG number of hamza's. -Put it on/under previous characters, if possible." - (interactive "*p") - (let (rch) - (while (> arg 0) - (setq rch (visual-char-right)) - (cond - ((eq last-command 'arabic-cut-connection) - (visual-insert-right-1-char ?›2](3-›0](B)) - ((eq rch ?›2](38›0](B ) (visual-replace-right-1-char ?›2](30›0](B )) - ((eq rch ?›2](39›0](B ) (visual-replace-right-1-char ?›2](31›0](B )) - ((eq rch ?›2](30›0](B ) (visual-replace-right-1-char ?›2](34›0](B )) - ((eq rch ?›2](31›0](B ) (visual-replace-right-1-char ?›2](35›0](B )) - ((eq rch ?›2](3^›0](B ) (visual-replace-right-1-char ?›2](32›0](B )) - ((eq rch ?›2](3_›0](B ) (visual-replace-right-1-char ?›2](33›0](B )) - ((eq rch ?›2](4_›0](B) (visual-replace-right-1-char ?›2](4!›0](B)) - ((eq rch ?›2](3`›0](B ) (visual-replace-right-1-char ?›2](36›0](B )) - ((eq rch ?›2](3a›0](B ) (visual-replace-right-1-char ?›2](37›0](B )) - ((eq rch ?›2](4`›0](B) (visual-replace-right-1-char ?›2](4"›0](B)) - ((eq rch ?›2](4]›0](B) (visual-replace-right-1-char ?›2](4!›0](B)) - ((eq rch ?›2](4^›0](B) (visual-replace-right-1-char ?›2](4"›0](B)) - ((eq rch ?›2](3e›0](B ) (visual-replace-right-1-char ?›2](3c›0](B )) - ((eq rch ?›2](4d›0](B) (visual-replace-right-1-char ?›2](4b›0](B)) - ((eq rch ?›2](3c›0](B ) (visual-replace-right-1-char ?›2](3d›0](B )) - ((eq rch ?›2](4b›0](B) (visual-replace-right-1-char ?›2](4c›0](B)) - (t (arabic-cut-connection) - (visual-insert-right-1-char ?›2](3-›0](B))) - (setq arg (1- arg))))) - -(defun arabic-toggle-input-char nil - "Toggle Arabic key input and ASCII key input." - (interactive) - (if arabic-input-arabic-char - (setq arabic-input-arabic-char nil - arabic-mode-indicator " Arabic") - (setq arabic-input-arabic-char t - arabic-mode-indicator " ›2](3=a:GJ›0](B")) - (redraw-modeline t)) - -(defun arabic-newline (arg) - "Newline for arabic-mode." - (interactive "*p") - (arabic-insert-char ?\n arg)) - -(defun arabic-open-line (arg) - "Openline for arabic-mode." - (interactive "*p") - (arabic-insert-char ?\n arg) - (visual-backward-char arg)) - -(defun arabic-delete-char (arg) - "Delete ARG (1st arg; integer) chars visually after visual point. -After that, Arabic ligature is performed." - (interactive "*p") - (visual-delete-char arg) - (arabic-make-connection)) - -(defun arabic-backward-delete-char (arg) - "Delete ARG (1st arg; integer) chars visually before visual point. -After that, Arabic ligature is performed." - (interactive "*p") - (visual-backward-delete-char arg) - (arabic-make-connection)) - -(defun arabic-kill-region (beg end) - "Kill-region command for arabic-mode." - (interactive "r") - (if (or (and buffer-read-only (not inhibit-read-only)) - (text-property-not-all beg end 'read-only nil)) - (visual-kill-region beg end) - (visual-kill-region beg end) - (arabic-make-connection))) - -(defun arabic-kill-word (arg) - "Kill-word command for arabic-mode." - (interactive "*p") - (visual-kill-word arg) - (arabic-make-connection)) - -(defun arabic-backward-kill-word (arg) - "Backword-ill-word command for arabic-mode." - (interactive "*p") - (visual-backward-kill-word arg) - (arabic-make-connection)) - -(defun arabic-kill-line (&optional arg) - "Kill-line command for arabic-mode." - (interactive "*P") - (visual-kill-line arg) - (arabic-make-connection)) - -(defun arabic-yank (&optional arg) - "yank command for arabic-mode." - (interactive "*P") - (visual-yank arg) - (let ((p1 (point)) (p2 (mark t))) - (arabic-make-connection) - (goto-char p2) - (arabic-make-connection) - (goto-char p1) - (set-marker (mark-marker) p2 (current-buffer)) - nil)) - -(defun arabic-yank-pop (arg) - "yank-pop command for arabic-mode." - (interactive "*p") - (visual-yank-pop arg) - (let ((p1 (point)) (p2 (mark t))) - (arabic-make-connection) - (goto-char p2) - (arabic-make-connection) - (goto-char p1) - (set-marker (mark-marker) p2 (current-buffer)) - nil)) - -(defun arabic-help nil - "Display keymap in Arabic-mode." - (interactive) - (let ((arabic-help-buffer (get-buffer-create "*Help*"))) - (set-buffer arabic-help-buffer) - (erase-buffer) - (insert arabic-help-string) - (goto-char (point-min)) - (display-buffer (current-buffer)))) - - -;; arabic LR commands - -(defun arabic-delete-left-char (arg) - "Kill N (1st arg; integer) characters on the left of visual point." - (interactive "*p") - (if display-direction - (arabic-delete-char arg) - (arabic-backward-delete-char arg))) - -(defun arabic-delete-right-char (arg) - "Kill N (1st arg; integer) characters on the right of visual point." - (interactive "*p") - (if display-direction - (arabic-backward-delete-char arg) - (arabic-delete-char arg))) - -(defun arabic-kill-left-word (arg) - "Kill N (1st arg; integer) words on the left of visual point." - (interactive "*p") - (if display-direction - (arabic-kill-word arg) - (arabic-backward-kill-word arg))) - -(defun arabic-kill-right-word (arg) - "Kill N (1st arg; integer) words on the right of visual point." - (interactive "*p") - (if display-direction - (arabic-backward-kill-word arg) - (arabic-kill-word arg))) - -;;; -(provide 'language/arabic-util) - -;;; arabic-util.el ends here
--- a/lisp/language/arabic.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/arabic.el Mon Aug 13 10:03:52 2007 +0200 @@ -59,9 +59,9 @@ ;;; ARABIC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-language-environment 'arabic - "Arabic" - (lambda () - (require 'arabic))) +;; (define-language-environment 'arabic +;; "Arabic" +;; (lambda () +;; (require 'arabic))) ;;; arabic.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/language/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,107 @@ +;;; DO NOT MODIFY THIS FILE +(if (featurep 'language-autoloads) (error "Already loaded")) + +;;;### (autoloads (encode-hz-buffer encode-hz-region decode-hz-buffer decode-hz-region setup-chinese-big5-environment setup-chinese-gb-environment) "china-util" "language/china-util.el") + +(autoload 'setup-chinese-gb-environment "china-util" "\ +Setup multilingual environment (MULE) for Chinese GB2312 users." t nil) + +(autoload 'setup-chinese-big5-environment "china-util" "\ +Setup multilingual environment (MULE) for Chinese Big5 users." t nil) + +(autoload 'decode-hz-region "china-util" "\ +Decode HZ/ZW encoded text in the current region. +Return the length of resulting text." t nil) + +(autoload 'decode-hz-buffer "china-util" "\ +Decode HZ/ZW encoded text in the current buffer." t nil) + +(autoload 'encode-hz-region "china-util" "\ +Encode the text in the current region to HZ. +Return the length of resulting text." t nil) + +(autoload 'encode-hz-buffer "china-util" "\ +Encode the text in the current buffer to HZ." t nil) + +;;;*** + +;;;### (autoloads (standard-display-cyrillic-translit setup-cyrillic-alternativnyj-environment setup-cyrillic-koi8-environment setup-cyrillic-iso-environment) "cyril-util" "language/cyril-util.el") + +(autoload 'setup-cyrillic-iso-environment "cyril-util" "\ +Setup multilingual environment (MULE) for Cyrillic ISO-8859-5 users." t nil) + +(autoload 'setup-cyrillic-koi8-environment "cyril-util" "\ +Setup multilingual environment (MULE) for Cyrillic KOI8 users." t nil) + +(autoload 'setup-cyrillic-alternativnyj-environment "cyril-util" "\ +Setup multilingual environment (MULE) for Cyrillic ALTERNATIVNYJ users." t nil) + +(autoload 'standard-display-cyrillic-translit "cyril-util" "\ +Display a cyrillic buffer using a transliteration. +For readability, the table is slightly +different from the one used for the input method `cyrillic-translit'. + +The argument is a string which specifies which language you are using; +that affects the choice of transliterations slightly. +Possible values are listed in 'cyrillic-language-alist'. +If the argument is t, we use the default cyrillic transliteration. +If the argument is nil, we return the display table to its standard state." t nil) + +;;;*** + +;;;### (autoloads (read-hiragana-string japanese-zenkaku-region japanese-hankaku-region japanese-hiragana-region japanese-katakana-region japanese-zenkaku japanese-hankaku japanese-hiragana japanese-katakana setup-japanese-environment) "japan-util" "language/japan-util.el") + +(autoload 'setup-japanese-environment "japan-util" "\ +Setup multilingual environment (MULE) for Japanese." t nil) + +(autoload 'japanese-katakana "japan-util" "\ +Convert argument to Katakana and return that. +The argument may be a character or string. The result has the same type. +The argument object is not altered--the value is a copy. +Optional argument HANKAKU t means to convert to `hankaku' Katakana + (`japanese-jisx0201-kana'), in which case return value + may be a string even if OBJ is a character if two Katakanas are + necessary to represent OBJ." nil nil) + +(autoload 'japanese-hiragana "japan-util" "\ +Convert argument to Hiragana and return that. +The argument may be a character or string. The result has the same type. +The argument object is not altered--the value is a copy." nil nil) + +(autoload 'japanese-hankaku "japan-util" "\ +Convert argument to `hankaku' and return that. +The argument may be a character or string. The result has the same type. +The argument object is not altered--the value is a copy. +Optional argument ASCII-ONLY non-nil means to return only ASCII character." nil nil) + +(autoload 'japanese-zenkaku "japan-util" "\ +Convert argument to `zenkaku' and return that. +The argument may be a character or string. The result has the same type. +The argument object is not altered--the value is a copy." nil nil) + +(autoload 'japanese-katakana-region "japan-util" "\ +Convert Japanese `hiragana' chars in the region to `katakana' chars. +Optional argument HANKAKU t means to convert to `hankaku katakana' character +of which charset is `japanese-jisx0201-kana'." t nil) + +(autoload 'japanese-hiragana-region "japan-util" "\ +Convert Japanese `katakana' chars in the region to `hiragana' chars." t nil) + +(autoload 'japanese-hankaku-region "japan-util" "\ +Convert Japanese `zenkaku' chars in the region to `hankaku' chars. +`Zenkaku' chars belong to `japanese-jisx0208' +`Hankaku' chars belong to `ascii' or `japanese-jisx0201-kana'. +Optional argument ASCII-ONLY non-nil means to convert only to ASCII char." t nil) + +(autoload 'japanese-zenkaku-region "japan-util" "\ +Convert hankaku' chars in the region to Japanese `zenkaku' chars. +`Zenkaku' chars belong to `japanese-jisx0208' +`Hankaku' chars belong to `ascii' or `japanese-jisx0201-kana'." t nil) + +(autoload 'read-hiragana-string "japan-util" "\ +Read a Hiragana string from the minibuffer, prompting with string PROMPT. +If non-nil, second arg INITIAL-INPUT is a string to insert before reading." nil nil) + +;;;*** + +(provide 'language-autoloads)
--- a/lisp/language/china-util.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/china-util.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,29 +1,123 @@ ;;; china-util.el --- utilities for Chinese -;; Copyright (C) 1995 Free Software Foundation, Inc. ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko ;; Keywords: mule, multilingual, Chinese -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by +;; XEmacs 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. -;; GNU Emacs 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. +;; XEmacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; 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. ;;; Code: +;;;###autoload +(defun setup-chinese-gb-environment () + "Setup multilingual environment (MULE) for Chinese GB2312 users." + (interactive) + (setup-english-environment) + + (set-default-coding-systems 'cn-gb-2312) + ;; (setq coding-category-iso-8-2 'chinese-iso-8bit) + (set-coding-category-system 'iso-8-2 'cn-gb-2312) + ;; (setq coding-category-iso-7-else 'chinese-iso-7bit) + ;; (setq coding-category-big5 'chinese-big5) + + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-7-else + ;; coding-category-iso-8-2 + ;; coding-category-big5 + ;; coding-category-iso-8-1 + ;; coding-category-emacs-mule + ;; coding-category-iso-8-else)) + (set-coding-priority-list + '(iso-7 + iso-8-2 + big5 + iso-8-1 + no-conversion + iso-8-designate + iso-lock-shift + shift-jis)) + + ;; (when (eq 'x (device-type (selected-device))) + ;; (x-use-halfwidth-roman-font 'chinese-gb2312 "gb1988")))) + (when (featurep 'egg) + (setq-default its:*current-map* (its:get-mode-map "PinYin"))) + (setq default-input-method "chinese-py-punct") + ) + +;;;###autoload +(defun setup-chinese-big5-environment () + "Setup multilingual environment (MULE) for Chinese Big5 users." + (interactive) + (setup-english-environment) + + (set-default-coding-systems 'big5) + ;; (setq coding-category-iso-8-2 'chinese-big5) + (set-coding-category-system 'iso-8-2 'cn-gb-2312) + ;; (setq coding-category-iso-7-else 'chinese-iso-7bit) + ;; (setq coding-category-big5 'chinese-big5) + + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-7-else + ;; coding-category-big5 + ;; coding-category-iso-8-2 + ;; coding-category-emacs-mule + ;; coding-category-iso-8-else)) + (set-coding-priority-list + '(iso-7 + big5 + iso-8-2 + no-conversion + iso-8-1 + iso-8-designate + iso-lock-shift + shift-jis)) + + (setq default-input-method "chinese-py-punct-b5") + ) + +;; ;;;###autoload +;; (defun setup-chinese-cns-environment () +;; "Setup multilingual environment (MULE) for Chinese CNS11643 family users." +;; (interactive) +;; (setup-english-environment) +;; +;; (setq coding-category-iso-7-else 'chinese-iso-7bit) +;; (setq coding-category-big5 'chinese-big5) +;; (setq coding-category-iso-8-2 'chinese-big5) +;; (set-default-coding-systems 'chinese-iso-7bit) +;; +;; (set-coding-priority +;; '(coding-category-iso-7 +;; coding-category-iso-7-else +;; coding-category-iso-8-2 +;; coding-category-big5 +;; coding-category-iso-7-else)) +;; +;; (setq-default buffer-file-coding-system 'chinese-iso-7bit) +;; (setq default-terminal-coding-system 'chinese-iso-7bit) +;; (setq default-keyboard-coding-system 'chinese-iso-7bit) +;; +;; (setq default-input-method "chinese-quick-cns")) + ;; Hz/ZW encoding stuffs ;; HZ is an encoding method for Chinese character set GB2312 used @@ -61,7 +155,7 @@ (save-restriction (narrow-to-region beg end) - ;; We, at first, convert HZ/ZW to `iso-2022-7', + ;; We, at first, convert HZ/ZW to `iso-2022-7bit', ;; then decode it. ;; "~\n" -> "\n" @@ -76,13 +170,13 @@ (let ((chinese-found nil)) (while (re-search-forward hz/zw-start-gb nil t) (if (= (char-after (match-beginning 0)) ?z) - ;; ZW -> iso-20227-7 + ;; ZW -> iso-2022-7bit (progn (delete-char -2) (insert iso2022-gb-designation) (end-of-line) (insert iso2022-ascii-designation)) - ;; HZ -> iso-20227-7 + ;; HZ -> iso-2022-7bit (delete-char -2) (insert iso2022-gb-designation) (let ((pos (save-excursion (end-of-line) (point)))) @@ -97,7 +191,7 @@ ;; If any, we had better decode them also. (goto-char (point-min)) (re-search-forward "[\240-\377]" nil t))) - (decode-coding-region (point-min) (point-max) 'cn-gb-2312))) + (decode-coding-region (point-min) (point-max) 'euc-china))) ;; "~~" -> "~" (goto-char (point-min)) @@ -129,7 +223,7 @@ (let ((enable-multibyte-characters nil) pos) (goto-char (setq pos (match-beginning 0))) - (encode-coding-region pos (point-max) 'iso-2022-7) + (encode-coding-region pos (point-max) 'iso-2022-7bit) (goto-char pos) (while (search-forward iso2022-gb-designation nil t) (delete-char -3) @@ -147,9 +241,6 @@ (encode-hz-region (point-min) (point-max))) ;; -(provide 'language/china-util) +(provide 'china-util) -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: ;;; china-util.el ends here
--- a/lisp/language/chinese.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/chinese.el Mon Aug 13 10:03:52 2007 +0200 @@ -126,13 +126,6 @@ ;; (define-key-after setup-language-environment-map [Chinese] ;; '("Chinese" . setup-chinese-environment-map) ;; t) - -;; (defun describe-chinese-support () -;; "Describe how Emacs supports Chinese." -;; (interactive) -;; (with-output-to-temp-buffer "*Help*" -;; (princ (get-language-info "Chinese" 'documentation)) -;; (princ "\n"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Chinese GB2312 (simplified) @@ -195,41 +188,11 @@ (insert-buffer-substring buf from to)) (encode-hz-region 1 (point-max)) nil)) - -;; (defun setup-chinese-gb-environment () -;; "Setup multilingual environment (MULE) for Chinese GB2312 users." -;; (interactive) -;; (setq primary-language "Chinese-GB") -;; -;; (setq coding-category-iso-8-2 'cn-gb-2312) -;; (setq coding-category-iso-else 'iso-2022-cn) -;; (setq coding-category-big5 'cn-big5) -;; -;; (set-coding-priority -;; '(coding-category-iso-7 -;; coding-category-iso-else -;; coding-category-iso-8-2 -;; coding-category-big5 -;; coding-category-iso-8-1 -;; coding-category-internal -;; )) -;; -;; (setq-default buffer-file-coding-system 'cn-gb-2312) -;; (set-terminal-coding-system 'cn-gb-2312) -;; (set-keyboard-coding-system 'cn-gb-2312) -;; -;; (setq default-input-method '("Chinese-GB" . "quail-py")) -;; ) - -;; (defun describe-chinese-gb-support () -;; "Describe how Emacs supports Chinese for GB2312 users." -;; (interactive) -;; (describe-language-support-internal "Chinese-GB")) (set-language-info-alist "Chinese-GB" '((setup-function . (setup-chinese-gb-environment . setup-chinese-environment-map)) - (charset . (chinese-gb2312 chinese-sisheng)) + (charset . (chinese-gb2312 sisheng)) (coding-system . (cn-gb-2312 iso-2022-7bit hz-gb-2312)) (sample-text . "Chinese ($AVPND(B,$AFUM(;0(B,$A::So(B) $ADc:C(B") @@ -291,33 +254,6 @@ (set-charset-ccl-program 'chinese-big5-1 ccl-encode-big5-1-font) (set-charset-ccl-program 'chinese-big5-2 ccl-encode-big5-2-font) -;; (defun setup-chinese-big5-environment () -;; "Setup multilingual environment (MULE) for Chinese Big5 users." -;; (interactive) -;; (setq primary-language "Chinese-BIG5") -;; -;; (setq coding-category-big5 'cn-big5) -;; (setq coding-category-iso-else 'iso-2022-cn) -;; (setq coding-category-iso-8-2 'cn-gb-2312) -;; -;; (set-coding-priority -;; '(coding-category-iso-7 -;; coding-category-iso-else -;; coding-category-big5 -;; coding-category-iso-8-2)) -;; -;; (setq-default buffer-file-coding-system 'cn-big5) -;; (set-terminal-coding-system 'cn-big5) -;; (set-keyboard-coding-system 'cn-big5) -;; -;; (setq default-input-method '("Chinese-BIG5" . "quail-py-b5")) -;; ) - -;; (defun describe-chinese-big5-support () -;; "Describe how Emacs supports Chinese for Big5 users." -;; (interactive) -;; (describe-language-support-internal "Chinese-BIG5")) - (set-language-info-alist "Chinese-BIG5" '((setup-function . (setup-chinese-big5-environment . setup-chinese-environment-map)) @@ -332,73 +268,16 @@ ;; Chinese CNS11643 (traditional) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (defun setup-chinese-cns-environment () -;; "Setup multilingual environment (MULE) for Chinese CNS11643 family users." -;; (interactive) -;; (setq primary-language "Chinese-CNS") -;; -;; (setq coding-category-iso-else 'iso-2022-cn) -;; (setq coding-category-big5 'cn-big5) -;; (setq coding-category-iso-8-2 'cn-gb-2312) -;; -;; (set-coding-priority -;; '(coding-category-iso-7 -;; coding-category-iso-else -;; coding-category-iso-8-2 -;; coding-category-big5)) -;; -;; (setq-default buffer-file-coding-system 'iso-2022-cn) -;; (set-terminal-coding-system 'iso-2022-cn) -;; (set-keyboard-coding-system 'iso-2022-cn) -;; -;; (setq default-input-method '("Chinese-CNS" . "quail-py-cns")) -;; ) - -;; (defun describe-chinese-cns-support () -;; "Describe how Emacs supports Chinese for CNS11643 family users." -;; (interactive) -;; (describe-language-support-internal "Chinese-CNS")) - -(set-language-info-alist - "Chinese-CNS" '((setup-function . (setup-chinese-cns-environment - . setup-chinese-environment-map)) - (charset . (chinese-cns11643-1 chinese-cns11643-2 - chinese-cns11643-3 chinese-cns11643-4 - chinese-cns11643-5 chinese-cns11643-6 - chinese-cns11643-7)) - (coding-system . (iso-2022-7bit)) - (documentation . ("Support for Chinese CNS character sets." - . describe-chinese-environment-map)) - )) - -;;; for XEmacs (will be obsoleted) - -(define-language-environment 'chinese - "Chinese (includes GB, Big5, and CNS)" - (lambda () - (require 'chinese) - (set-coding-category-system 'iso-8-2 'cn-gb-2312) - (set-coding-priority-list '(iso-8-2 big5 iso-8-designate)) - (set-pathname-coding-system 'cn-gb-2312) - (set-default-buffer-file-coding-system 'cn-gb-2312) ; GB encoding - (setq terminal-coding-system 'cn-gb-2312) - (setq keyboard-coding-system 'cn-gb-2312) - (add-hook 'comint-exec-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-input-coding-system proc 'cn-gb-2312) - (set-process-output-coding-system proc 'cn-gb-2312)))) - (set-buffer-file-coding-system-for-read 'automatic-conversion) - (set-default-buffer-file-coding-system 'cn-gb-2312) - (setq keyboard-coding-system 'cn-gb-2312) - (setq terminal-coding-system 'cn-gb-2312) - (when (eq 'x (device-type (selected-device))) - (x-use-halfwidth-roman-font 'chinese-gb2312 "gb1988")))) -;; (when (featurep 'egg) -;; (setq-default its:*current-map* (its:get-mode-map "PinYin"))) -;; (setq-default quail-current-package (assoc "py" quail-package-alist)))) -;; )) - -(set-coding-category-system 'big5 'big5) +;; (set-language-info-alist +;; "Chinese-CNS" '((setup-function . (setup-chinese-cns-environment +;; . setup-chinese-environment-map)) +;; (charset . (chinese-cns11643-1 chinese-cns11643-2 +;; chinese-cns11643-3 chinese-cns11643-4 +;; chinese-cns11643-5 chinese-cns11643-6 +;; chinese-cns11643-7)) +;; (coding-system . (chinese-iso-7bit)) +;; (documentation . ("Support for Chinese CNS character sets." +;; . describe-chinese-environment-map)) +;; )) ;;; chinese.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/language/cyril-util.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,206 @@ +;;; cyril-util.el --- utilities for Cyrillic scripts + +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Keywords: mule, multilingual, Cyrillic + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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. + +;;; Code: + +;;;###autoload +(defun setup-cyrillic-iso-environment () + "Setup multilingual environment (MULE) for Cyrillic ISO-8859-5 users." + (interactive) + (setup-8-bit-environment "Cyrillic-ISO" 'cyrillic-iso8859-5 + 'iso-8859-5 "cyrillic-yawerty")) + +;;;###autoload +(defun setup-cyrillic-koi8-environment () + "Setup multilingual environment (MULE) for Cyrillic KOI8 users." + (interactive) + (setup-8-bit-environment "Cyrillic-KOI8" 'cyrillic-iso8859-5 'koi8-r + "cyrillic-yawerty")) + +;;;###autoload +(defun setup-cyrillic-alternativnyj-environment () + "Setup multilingual environment (MULE) for Cyrillic ALTERNATIVNYJ users." + (interactive) + (setup-8-bit-environment "Cyrillic" 'cyrillic-iso8859-5 + 'alternativnyj "cyrillic-yawerty") + ;; (setq coding-category-raw-text 'alternativnyj) + ) + + +;; Display + +;; Written by Valery Alexeev <valery@math.uga.edu>. + +(defvar cyrillic-language-alist + (list '("Belorussian") '("Bulgarian") '("Macedonian") + '("Russian") '("Serbian") '("Ukrainian")) + "*List of known cyrillic languages") + +;;;###autoload +(defun standard-display-cyrillic-translit (&optional cyrillic-language) + "Display a cyrillic buffer using a transliteration. +For readability, the table is slightly +different from the one used for the input method `cyrillic-translit'. + +The argument is a string which specifies which language you are using; +that affects the choice of transliterations slightly. +Possible values are listed in 'cyrillic-language-alist'. +If the argument is t, we use the default cyrillic transliteration. +If the argument is nil, we return the display table to its standard state." + (interactive + (list + (let* ((completion-ignore-case t)) + (completing-read + "Cyrillic language (default nil): " + cyrillic-language-alist nil t nil nil nil)))) + + (or standard-display-table + (setq standard-display-table (make-display-table))) + + (if (equal cyrillic-language "") + (setq cyrillic-language nil)) + + (if (null cyrillic-language) + (setq standard-display-table (make-display-table)) + (aset standard-display-table ?,LP(B [?a]) + (aset standard-display-table ?,LQ(B [?b]) + (aset standard-display-table ?,LR(B [?v]) + (aset standard-display-table ?,LS(B [?g]) + (aset standard-display-table ?,LT(B [?d]) + (aset standard-display-table ?,LU(B [?e]) + (aset standard-display-table ?,Lq(B [?y?o]) + (aset standard-display-table ?,LV(B [?z?h]) + (aset standard-display-table ?,LW(B [?z]) + (aset standard-display-table ?,LX(B [?i]) + (aset standard-display-table ?,LY(B [?j]) + (aset standard-display-table ?,LZ(B [?k]) + (aset standard-display-table ?,L[(B [?l]) + (aset standard-display-table ?,L\(B [?m]) + (aset standard-display-table ?,L](B [?n]) + (aset standard-display-table ?,L^(B [?o]) + (aset standard-display-table ?,L_(B [?p]) + (aset standard-display-table ?,L`(B [?r]) + (aset standard-display-table ?,La(B [?s]) + (aset standard-display-table ?,Lb(B [?t]) + (aset standard-display-table ?,Lc(B [?u]) + (aset standard-display-table ?,Ld(B [?f]) + (aset standard-display-table ?,Le(B [?k?h]) + (aset standard-display-table ?,Lf(B [?t?s]) + (aset standard-display-table ?,Lg(B [?c?h]) + (aset standard-display-table ?,Lh(B [?s?h]) + (aset standard-display-table ?,Li(B [?s?c?h]) + (aset standard-display-table ?,Lj(B [?~]) + (aset standard-display-table ?,Lk(B [?y]) + (aset standard-display-table ?,Ll(B [?']) + (aset standard-display-table ?,Lm(B [?e?']) + (aset standard-display-table ?,Ln(B [?y?u]) + (aset standard-display-table ?,Lo(B [?y?a]) + + (aset standard-display-table ?,L0(B [?A]) + (aset standard-display-table ?,L1(B [?B]) + (aset standard-display-table ?,L2(B [?V]) + (aset standard-display-table ?,L3(B [?G]) + (aset standard-display-table ?,L4(B [?D]) + (aset standard-display-table ?,L5(B [?E]) + (aset standard-display-table ?,L!(B [?Y?o]) + (aset standard-display-table ?,L6(B [?Z?h]) + (aset standard-display-table ?,L7(B [?Z]) + (aset standard-display-table ?,L8(B [?I]) + (aset standard-display-table ?,L9(B [?J]) + (aset standard-display-table ?,L:(B [?K]) + (aset standard-display-table ?,L;(B [?L]) + (aset standard-display-table ?,L<(B [?M]) + (aset standard-display-table ?,L=(B [?N]) + (aset standard-display-table ?,L>(B [?O]) + (aset standard-display-table ?,L?(B [?P]) + (aset standard-display-table ?,L@(B [?R]) + (aset standard-display-table ?,LA(B [?S]) + (aset standard-display-table ?,LB(B [?T]) + (aset standard-display-table ?,LC(B [?U]) + (aset standard-display-table ?,LD(B [?F]) + (aset standard-display-table ?,LE(B [?K?h]) + (aset standard-display-table ?,LF(B [?T?s]) + (aset standard-display-table ?,LG(B [?C?h]) + (aset standard-display-table ?,LH(B [?S?h]) + (aset standard-display-table ?,LI(B [?S?c?h]) + (aset standard-display-table ?,LJ(B [?~]) + (aset standard-display-table ?,LK(B [?Y]) + (aset standard-display-table ?,LL(B [?']) + (aset standard-display-table ?,LM(B [?E?']) + (aset standard-display-table ?,LN(B [?Y?u]) + (aset standard-display-table ?,LO(B [?Y?a]) + + (aset standard-display-table ?,Lt(B [?i?e]) + (aset standard-display-table ?,Lw(B [?i]) + (aset standard-display-table ?,L~(B [?u]) + (aset standard-display-table ?,Lr(B [?d?j]) + (aset standard-display-table ?,L{(B [?c?h?j]) + (aset standard-display-table ?,Ls(B [?g?j]) + (aset standard-display-table ?,Lu(B [?s]) + (aset standard-display-table ?,L|(B [?k]) + (aset standard-display-table ?,Lv(B [?i]) + (aset standard-display-table ?,Lx(B [?j]) + (aset standard-display-table ?,Ly(B [?l?j]) + (aset standard-display-table ?,Lz(B [?n?j]) + (aset standard-display-table ?,L(B [?d?z]) + + (aset standard-display-table ?,L$(B [?Y?e]) + (aset standard-display-table ?,L'(B [?Y?i]) + (aset standard-display-table ?,L.(B [?U]) + (aset standard-display-table ?,L"(B [?D?j]) + (aset standard-display-table ?,L+(B [?C?h?j]) + (aset standard-display-table ?,L#(B [?G?j]) + (aset standard-display-table ?,L%(B [?S]) + (aset standard-display-table ?,L,(B [?K]) + (aset standard-display-table ?,L&(B [?I]) + (aset standard-display-table ?,L((B [?J]) + (aset standard-display-table ?,L)(B [?L?j]) + (aset standard-display-table ?,L*(B [?N?j]) + (aset standard-display-table ?,L/(B [?D?j]) + + (when (equal cyrillic-language "Bulgarian") + (aset standard-display-table ?,Li(B [?s?h?t]) + (aset standard-display-table ?,LI(B [?S?h?t]) + (aset standard-display-table ?,Ln(B [?i?u]) + (aset standard-display-table ?,LN(B [?I?u]) + (aset standard-display-table ?,Lo(B [?i?a]) + (aset standard-display-table ?,LO(B [?I?a])) + + (when (equal cyrillic-language "Ukrainian") ; based on the official + ; transliteration table + (aset standard-display-table ?,LX(B [?y]) + (aset standard-display-table ?,L8(B [?Y]) + (aset standard-display-table ?,LY(B [?i]) + (aset standard-display-table ?,L9(B [?Y]) + (aset standard-display-table ?,Ln(B [?i?u]) + (aset standard-display-table ?,Lo(B [?i?a])))) + + +;; +(provide 'cyril-util) + +;;; cyril-util.el ends here + +;; Local Variables: +;; buffer-file-coding-system: iso-2022-7bit +;; End:
--- a/lisp/language/devanagari.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,533 +0,0 @@ -;;; devanagari.el --- Support for Devanagari Languages - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp> - -;; Keywords: multilingual, Indian, Devanagari - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; History: -;; 1996.10.18 written by KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp> -;; 1997.1.20 fixed some bugs. -;;; Code: - -(make-coding-system - 'in-is13194-devanagari 2 ?D - "Coding-system used for ASCII(MSB=0) & IS13194-Devanagari(MSB=1)." - '((ascii t) (indian-is13194 t) nil nil - nil ascii-eol)) -devanagari-compose-from-is13194-region -(put 'in-is13194-devanagari - 'post-read-conversion 'in-is13194-devanagari-post-read-conversion) -(put 'in-is13194-devanagari - 'pre-write-conversion 'in-is13194-devanagari-pre-write-conversion) - -(register-input-method - "Devanagari" '("quail-devanagari-transliteration" quail-use-package - "quail/devanagari")) - -(register-input-method - "Devanagari" '("quail-devanagari-keyboard-a" quail-use-package - "quail/devanagari")) - -(register-input-method - "Devanagari" '("quail-devanagari-itrans" quail-use-package - "quail/devanagari")) - -(register-input-method - "Devanagari" '("quail-devanagari-hindi-transliteration" quail-use-package - "quail/devanagari")) - -(defun setup-devanagari-environment () - "Setup multilingual environment (MULE) for languages using Devanagari." - (interactive) - (setq coding-category-iso-8-1 'in-is13194-devanagari) - - (set-coding-priority - '(coding-category-iso-7 - coding-category-iso-8-1)) - - (setq-default buffer-file-coding-system 'in-is13194-devanagari) - - (setq default-input-method '("Devanagari" . "quail-devanagari-itrans")) - ) - -(defun describe-devanagari-support () - "Describe how Emacs support languages using Devanagari script." - (interactive) - (describe-language-support-internal "Devanagari")) - -(set-language-info-alist - "Devanagari" '((setup-function . setup-devanagari-environment) - (describe-function . describe-devanagari-support) - (charset . (indian-is13194 indian-2-column indian-1-column)) - (coding-system . (in-is13194-devanagari)) - (documentation . nil))) - -;; -;; Devanagari Glyph List -;; -;; 0 1 2 3 4 5 6 7 8 9 a b c d e f -;;2120 $(5!!!"!#!$!%!&!'!(!)!*!+!,!-!.!/(B -;;2130 $(5!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?(B -;;2140 $(5!@!A!B!C!D!E!F!G!H!I!J!K!L!M!N!O(B -;;2150 $(5!P!Q!R!S!T!U!V!W!X!Y!Z![!\!]!^!_(B -;;2160 $(5!`!a!b!c!d!e!f!g!h!i!j!k!l!m!n!o(B -;;2170 $(5!p!q!r!s!t!u!v!w!x!y!z!{!|!}!~(B -;; -;; 0 1 2 3 4 5 6 7 8 9 a b c d e f -;;2220 $(5"!"""#"$"%"&"'"(")"*"+","-"."/(B -;;2230 $(5"0"1"2"3"4"5"6"7"8"9":";"<"=">"?(B -;;2240 $(5"@"A"B"C"D"E"F"G"H"I"J"K"L"M"N"O(B -;;2250 $(5"P"Q"R"S"T"U"V"W"X"Y"Z"["\"]"^"_(B -;;2260 $(5"`"a"b"c"d"e"f"g"h"i"j"k"l"m"n"o(B -;;2270 $(5"p"q"r"s"t"u"v"w"x"y"z"{"|"}"~(B -;; -;; 0 1 2 3 4 5 6 7 8 9 a b c d e f -;;2320 $(5#!#"###$#%#&#'#(#)#*#+#,#-#.#/(B -;;2330 $(5#0#1#2#3#4#5#6#7#8#9#:#;#<#=#>#?(B -;;2340 $(5#@#A#B#C#D#E#F#G#H#I#J#K#L#M#N#O(B -;;2350 $(5#P#Q#R#S#T#U#V#W#X#Y#Z#[#\#]#^#_(B -;;2360 $(5#`#a#b#c#d#e#f#g#h#i#j#k#l#m#n#o(B -;;2370 $(5#p#q#r#s#t#u#v#w#x#y#z#{#|#}#~(B -;; -;; 0 1 2 3 4 5 6 7 8 9 a b c d e f -;;2420 $(5$!$"$#$$$%$&$'$($)$*$+$,$-$.$/(B -;;2430 $(5$0$1$2$3$4$5$6$7$8$9$:$;$<$=$>$?(B -;;2440 $(5$@$A$B$C$D$E$F$G$H$I$J$K$L$M$N$O(B -;;2450 $(5$P$Q$R$S$T$U$V$W$X$Y$Z$[$\$]$^$_(B -;;2460 $(5$`$a$b$c$d$e$f$g$h$i$j$k$l$m$n$o(B -;;2470 $(5$p$q$r$s$t$u$v$w$x$y$z${$|$}$~(B -;; -;; 0123456789abcdef -;;2120 $(6!!!"!#!$!%!&!'!(!)!*!+!,!-!.!/(B -;;2130 $(6!0!1!2!3!4!5!6!7!8!9!:!;!<!=!>!?(B -;;2140 $(6!@!A!B!C!D!E!F!G!H!I!J!K!L!M!N!O(B -;;2150 $(6!P!Q!R!S!T!U!V!W!X!Y!Z![!\!]!^!_(B -;;2160 $(6!`!a!b!c!d!e!f!g!h!i!j!k!l!m!n!o(B -;;2170 $(6!p!q!r!s!t!u!v!w!x!y!z!{!|!}!~(B -;; -;; 0123456789abcdef -;;2220 $(6"!"""#"$"%"&"'"(")"*"+","-"."/(B -;;2230 $(6"0"1"2"3"4"5"6"7"8"9":";"<"=">"?(B -;;2240 $(6"@"A"B"C"D"E"F"G"H"I"J"K"L"M"N"O(B -;;2250 $(6"P"Q"R"S"T"U"V"W"X"Y"Z"["\"]"^"_(B -;;2260 $(6"`"a"b"c"d"e"f"g"h"i"j"k"l"m"n"o(B -;;2270 $(6"p"q"r"s"t"u"v"w"x"y"z"{"|"}"~(B -;;2320 $(6#!#"###$#%#&#'#(#)#*#+#,#-#.#/(B -;;2330 $(6#0#1#2#3#4#5#6#7#8#9#:#;#<#=#>#?(B -;;2340 $(6#@#A#B#C#D#E#F#G#H#I#J#K#L#M#N#O(B -;;2350 $(6#P#Q#R#S#T#U#V#W#X#Y#Z#[#\#]#^#_(B -;;2360 $(6#`#a#b#c#d#e#f#g#h#i#j#k#l#m#n#o(B -;;2370 $(6#p#q#r#s#t#u#v#w#x#y#z#{#|#}#~(B -;; -;; 0123456789abcdef -;;2320 $(6$!$"$#$$$%$&$'$($)$*$+$,$-$.$/(B -;;2430 $(6$0$1$2$3$4$5$6$7$8$9$:$;$<$=$>$?(B -;;2440 $(6$@$A$B$C$D$E$F$G$H$I$J$K$L$M$N$O(B -;;2450 $(6$P$Q$R$S$T$U$V$W$X$Y$Z$[$\$]$^$_(B -;;2460 $(6$`$a$b$c$d$e$f$g$h$i$j$k$l$m$n$o(B -;;2470 $(6$p$q$r$s$t$u$v$w$x$y$z${$|$}$~(B -;; -;; -;; Modify the following table if you change the set of 1-column font. -;; -(defconst devanagari-1-column-char - '((?$(5!!(B . ?$(6!!(B) - (?$(5!"(B . ?$(6!"(B) - (?$(5!#(B . ?$(6!#(B) - (?$(5!$(B . nil) - (?$(5!%(B . nil) - (?$(5!&(B . ?$(6!&(B) - (?$(5!'(B . ?$(6!'(B) - (?$(5!((B . ?$(6!((B) - (?$(5!)(B . nil) - (?$(5!*(B . nil) - (?$(5!+(B . nil) - (?$(5!,(B . nil) - (?$(5!-(B . nil) - (?$(5!.(B . nil) - (?$(5!/(B . nil) - (?$(5!0(B . nil) - (?$(5!1(B . nil) - (?$(5!2(B . nil) - (?$(5!3(B . nil) - (?$(5!4(B . nil) - (?$(5!5(B . ?$(6!5(B) - (?$(5!6(B . nil) - (?$(5!7(B . nil) - (?$(5!8(B . nil) - (?$(5!9(B . nil) - (?$(5!:(B . nil) - (?$(5!;(B . nil) - (?$(5!<(B . nil) - (?$(5!=(B . ?$(6!=(B) - (?$(5!>(B . ?$(6!>(B) - (?$(5!?(B . ?$(6!?(B) - (?$(5!@(B . ?$(6!@(B) - (?$(5!A(B . nil) - (?$(5!B(B . ?$(6!B(B) - (?$(5!C(B . ?$(6!C(B) - (?$(5!D(B . ?$(6!D(B) - (?$(5!E(B . ?$(6!E(B) - (?$(5!F(B . ?$(6!F(B) - (?$(5!G(B . ?$(6!G(B) - (?$(5!H(B . ?$(6!H(B) - (?$(5!I(B . nil) - (?$(5!J(B . ?$(6!J(B) - (?$(5!K(B . ?$(6!K(B) - (?$(5!L(B . ?$(6!L(B) - (?$(5!M(B . ?$(6!M(B) - (?$(5!N(B . ?$(6!N(B) - (?$(5!O(B . ?$(6!O(B) - (?$(5!P(B . ?$(6!P(B) - (?$(5!Q(B . nil) - (?$(5!R(B . nil) - (?$(5!S(B . nil) - (?$(5!T(B . ?$(6!T(B) - (?$(5!U(B . nil) - (?$(5!V(B . ?$(6!V(B) - (?$(5!W(B . ?$(6!W(B) - (?$(5!X(B . ?$(6!X(B) - (?$(5!Y(B . nil) - (?$(5!Z(B . ?$(6!Z(B) - (?$(5 - (?$(5!^(B . ?$(6!^(B) - (?$(5!_(B . ?$(6!_(B) - (?$(5!`(B . ?$(6!`(B) - (?$(5!a(B . ?$(6!a(B) - (?$(5!b(B . ?$(6!b(B) - (?$(5!c(B . ?$(6!c(B) - (?$(5!d(B . ?$(6!d(B) - (?$(5!e(B . ?$(6!e(B) - (?$(5!f(B . ?$(6!f(B) - (?$(5!g(B . ?$(6!g(B) - (?$(5!h(B . ?$(6!h(B) - (?$(5!i(B . ?$(6!i(B) - (?$(5!j(B . ?$(6!j(B) - (nil . nil) - (nil . nil) - (nil . nil) - (nil . nil) - (nil . nil) - (nil . nil) - (?$(5!q(B . ?$(6!q(B) - (?$(5!r(B . ?$(6!r(B) - (?$(5!s(B . ?$(6!s(B) - (?$(5!t(B . ?$(6!t(B) - (?$(5!u(B . ?$(6!u(B) - (?$(5!v(B . ?$(6!v(B) - (?$(5!w(B . ?$(6!w(B) - (?$(5!x(B . ?$(6!x(B) - (?$(5!y(B . ?$(6!y(B) - (?$(5!z(B . ?$(6!z(B) - (nil . nil) - (nil . nil) - (nil . nil) - (nil . nil) - (?$(5"!(B . nil) - (?$(5""(B . nil) - (?$(5"#(B . nil) - (?$(5"$(B . ?$(6"$(B) - (?$(5"%(B . ?$(6"%(B) - (?$(5"&(B . ?$(6"&(B) - (?$(5"'(B . nil) - (?$(5"((B . nil) - (?$(5")(B . nil) - (?$(5"*(B . nil) - (?$(5"+(B . nil) - (?$(5",(B . ?$(6",(B) - (?$(5"-(B . nil) - (?$(5".(B . ?$(6".(B) - (?$(5"/(B . nil) - (?$(5"0(B . nil) - (?$(5"1(B . nil) - (?$(5"2(B . nil) - (?$(5"3(B . ?$(6"3(B) - (?$(5"4(B . ?$(6"4(B) - (?$(5"5(B . ?$(6"5(B) - (?$(5"6(B . ?$(6"6(B) - (?$(5"7(B . nil) - (?$(5"8(B . ?$(6"8(B) - (?$(5"9(B . nil) - (?$(5":(B . ?$(6":(B) - (?$(5";(B . ?$(6";(B) - (?$(5"<(B . ?$(6"<(B) - (?$(5"=(B . nil) - (?$(5">(B . nil) - (?$(5"?(B . nil) - (?$(5"@(B . nil) - (?$(5"A(B . ?$(6"A(B) - (?$(5"B(B . ?$(6"B(B) - (?$(5"C(B . ?$(6"C(B) - (?$(5"D(B . nil) - (?$(5"E(B . ?$(6"E(B) - (?$(5"F(B . ?$(6"F(B) - (?$(5"G(B . ?$(6"G(B) - (?$(5"H(B . ?$(6"H(B) - (?$(5"I(B . ?$(6"I(B) - (?$(5"J(B . ?$(6"J(B) - (?$(5"K(B . ?$(6"K(B) - (?$(5"L(B . ?$(6"L(B) - (?$(5"M(B . ?$(6"M(B) - (?$(5"N(B . ?$(6"N(B) - (?$(5"O(B . nil) - (?$(5"P(B . nil) - (?$(5"Q(B . ?$(6"Q(B) - (?$(5"R(B . nil) - (?$(5"S(B . nil) - (?$(5"T(B . ?$(6"T(B) - (?$(5"U(B . ?$(6"U(B) - (?$(5"V(B . ?$(6"V(B) - (?$(5"W(B . ?$(6"W(B) - (?$(5"X(B . nil) - (?$(5"Y(B . nil) - (?$(5"Z(B . nil) - (?$(5"[(B . nil) - (?$(5"\(B . nil) - (?$(5"](B . ?$(6"](B) - (?$(5"^(B . nil) - (?$(5"_(B . nil) - (?$(5"`(B . ?$(6"`(B) - (?$(5"a(B . ?$(6"a(B) - (?$(5"b(B . ?$(6"b(B) - (?$(5"c(B . ?$(6"c(B) - (?$(5"d(B . ?$(6"d(B) - (?$(5"e(B . ?$(6"e(B) - (?$(5"f(B . ?$(6"f(B) - (?$(5"g(B . ?$(6"g(B) - (?$(5"h(B . ?$(6"h(B) - (?$(5"i(B . ?$(6"i(B) - (?$(5"j(B . ?$(6"j(B) - (?$(5"k(B . ?$(6"k(B) - (?$(5"l(B . ?$(6"l(B) - (?$(5"m(B . ?$(6"m(B) - (?$(5"n(B . nil) - (?$(5"o(B . nil) - (?$(5"p(B . ?$(6"p(B) - (?$(5"q(B . ?$(6"q(B) - (?$(5"r(B . ?$(6"r(B) - (?$(5"s(B . ?$(6"s(B) - (?$(5"t(B . ?$(6"t(B) - (?$(5"u(B . ?$(6"u(B) - (?$(5"v(B . nil) - (?$(5"w(B . nil) - (?$(5"x(B . nil) - (?$(5"y(B . ?$(6"y(B) - (?$(5"z(B . ?$(6"z(B) - (?$(5"{(B . nil) - (?$(5"|(B . nil) - (?$(5"}(B . nil) - (?$(5"~(B . nil) - (?$(5#!(B . nil) - (?$(5#"(B . nil) - (?$(5##(B . nil) - (?$(5#$(B . nil) - (?$(5#%(B . nil) - (?$(5#&(B . nil) - (?$(5#'(B . nil) - (?$(5#((B . nil) - (?$(5#)(B . nil) - (?$(5#*(B . nil) - (?$(5#+(B . nil) - (?$(5#,(B . nil) - (?$(5#-(B . nil) - (?$(5#.(B . nil) - (?$(5#/(B . nil) - (?$(5#0(B . nil) - (?$(5#1(B . nil) - (?$(5#2(B . nil) - (?$(5#3(B . nil) - (?$(5#4(B . nil) - (?$(5#5(B . ?$(6#5(B) - (?$(5#6(B . nil) - (?$(5#7(B . nil) - (?$(5#8(B . nil) - (?$(5#9(B . nil) - (?$(5#:(B . nil) - (?$(5#;(B . nil) - (?$(5#<(B . nil) - (?$(5#=(B . nil) - (?$(5#>(B . nil) - (?$(5#?(B . ?$(6#?(B) - (?$(5#@(B . ?$(6#@(B) - (?$(5#A(B . nil) - (?$(5#B(B . nil) - (?$(5#C(B . nil) - (?$(5#D(B . nil) - (?$(5#E(B . nil) - (?$(5#F(B . nil) - (?$(5#G(B . nil) - (?$(5#H(B . nil) - (?$(5#I(B . nil) - (?$(5#J(B . ?$(6#J(B) - (?$(5#K(B . ?$(6#K(B) - (?$(5#L(B . ?$(6#L(B) - (?$(5#M(B . ?$(6#M(B) - (?$(5#N(B . nil) - (?$(5#O(B . nil) - (?$(5#P(B . nil) - (?$(5#Q(B . nil) - (?$(5#R(B . ?$(6#R(B) - (?$(5#S(B . nil) - (?$(5#T(B . nil) - (?$(5#U(B . nil) - (?$(5#V(B . nil) - (?$(5#W(B . nil) - (?$(5#X(B . nil) - (?$(5#Y(B . nil) - (?$(5#Z(B . nil) - (?$(5#[(B . nil) - (?$(5#\(B . nil) - (?$(5#](B . nil) - (?$(5#^(B . nil) - (?$(5#_(B . nil) - (?$(5#`(B . nil) - (?$(5#a(B . ?$(6#a(B) - (?$(5#b(B . ?$(6#b(B) - (?$(5#c(B . nil) - (?$(5#d(B . nil) - (?$(5#e(B . nil) - (?$(5#f(B . nil) - (?$(5#g(B . nil) - (?$(5#h(B . nil) - (?$(5#i(B . nil) - (?$(5#j(B . ?$(6#j(B) - (?$(5#k(B . ?$(6#k(B) - (?$(5#l(B . ?$(6#l(B) - (?$(5#m(B . nil) - (?$(5#n(B . nil) - (?$(5#o(B . nil) - (?$(5#p(B . nil) - (?$(5#q(B . nil) - (?$(5#r(B . nil) - (?$(5#s(B . nil) - (?$(5#t(B . nil) - (?$(5#u(B . nil) - (?$(5#v(B . nil) - (?$(5#w(B . nil) - (?$(5#x(B . nil) - (?$(5#y(B . nil) - (?$(5#z(B . nil) - (?$(5#{(B . nil) - (?$(5#|(B . nil) - (?$(5#}(B . nil) - (?$(5#~(B . nil) - (?$(5$!(B . nil) - (?$(5$"(B . nil) - (?$(5$#(B . nil) - (?$(5$$(B . nil) - (?$(5$%(B . nil) - (?$(5$&(B . nil) - (?$(5$'(B . nil) - (?$(5$((B . nil) - (?$(5$)(B . nil) - (?$(5$*(B . nil) - (?$(5$+(B . nil) - (?$(5$,(B . nil) - (?$(5$-(B . nil) - (?$(5$.(B . nil) - (?$(5$/(B . nil) - (?$(5$0(B . nil) - (?$(5$1(B . nil) - (?$(5$2(B . nil) - (?$(5$3(B . nil) - (?$(5$4(B . nil) - (?$(5$5(B . nil) - (?$(5$6(B . nil) - (?$(5$7(B . nil) - (?$(5$8(B . nil) - (?$(5$9(B . nil) - (?$(5$:(B . nil) - (?$(5$;(B . nil) - (?$(5$<(B . nil) - (?$(5$=(B . nil) - (?$(5$>(B . nil) - (?$(5$?(B . nil) - (?$(5$@(B . nil) - (?$(5$A(B . ?$(6$A(B) - (?$(5$B(B . nil) - (?$(5$C(B . nil) - (?$(5$D(B . nil) - (?$(5$E(B . ?$(6$E(B) - (?$(5$F(B . nil) - (?$(5$G(B . nil) - (?$(5$H(B . ?$(6$H(B) - (?$(5$I(B . ?$(6$I(B) - (?$(5$J(B . ?$(6$J(B) - (?$(5$K(B . nil) - (?$(5$L(B . nil) - (?$(5$M(B . nil) - (?$(5$N(B . ?$(6$N(B) - (?$(5$O(B . nil) - (?$(5$P(B . ?$(6$P(B) - (?$(5$Q(B . ?$(6$Q(B) - (?$(5$R(B . ?$(6$R(B) - (?$(5$S(B . nil) - (?$(5$T(B . nil) - (?$(5$U(B . nil) - (?$(5$V(B . nil) - (?$(5$W(B . nil) - (?$(5$X(B . nil) - (?$(5$Y(B . nil) - (?$(5$Z(B . nil) - (?$(5$[(B . nil) - (?$(5$\(B . nil) - (?$(5$](B . nil) - (?$(5$^(B . nil) - (?$(5$_(B . nil) - (?$(5$`(B . nil) - (?$(5$a(B . nil) - (?$(5$b(B . nil) - (?$(5$c(B . nil) - (?$(5$d(B . nil) - (?$(5$e(B . nil) - (?$(5$f(B . nil) - (?$(5$g(B . nil) - (?$(5$h(B . ?$(6$h(B) - (?$(5$i(B . ?$(6$i(B) - (?$(5$j(B . ?$(6$j(B) - (?$(5$k(B . nil) - (?$(5$l(B . ?$(6$l(B) - (?$(5$m(B . ?$(6$m(B) - (?$(5$n(B . ?$(6$n(B) - (?$(5$o(B . nil) - (?$(5$p(B . ?$(6$p(B) - (?$(5$q(B . ?$(6$q(B) - (?$(5$r(B . ?$(6$r(B) - (?$(5$s(B . nil) - (?$(5$t(B . nil) - (?$(5$u(B . ?$(6$u(B) - (?$(5$v(B . ?$(6$v(B) - (?$(5$w(B . nil) - (?$(5$x(B . ?$(6$x(B) - (?$(5$y(B . ?$(6$y(B) - (?$(5$z(B . nil) - (?$(5${(B . nil) - (?$(5$|(B . nil) - (?$(5$}(B . nil) - (?$(5$~(B . nil) - )) - -;;; devanagari.el ends here
--- a/lisp/language/english.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/english.el Mon Aug 13 10:03:52 2007 +0200 @@ -58,30 +58,47 @@ coding-category-binarry no-conversion " (interactive) - (setq-default enable-multibyte-characters t) - - (setq coding-category-iso-7 'iso-2022-7bit - coding-category-iso-8-1 'iso-8859-1 - coding-category-iso-8-2 'iso-8859-1 - coding-category-iso-7-else 'iso-2022-7bit-lock - coding-category-iso-8-else 'iso-2022-8bit-ss2 - coding-category-emacs-mule 'no-conversion - coding-category-sjis 'japanese-shift-jis - coding-category-big5 'chinese-big5 - coding-category-binary 'binary) + ;; (setq-default enable-multibyte-characters t) - (set-coding-priority - '(coding-category-iso-7 - coding-category-iso-8-2 - coding-category-iso-8-1 - coding-category-iso-7-else - coding-category-iso-8-else - coding-category-emacs-mule - coding-category-raw-text - coding-category-sjis - coding-category-big5 - coding-category-binary)) - + ;; (setq coding-category-iso-7 'iso-2022-7bit + ;; coding-category-iso-8-1 'iso-8859-1 + ;; coding-category-iso-8-2 'iso-8859-1 + ;; coding-category-iso-7-else 'iso-2022-7bit-lock + ;; coding-category-iso-8-else 'iso-2022-8bit-ss2 + ;; coding-category-emacs-mule 'no-conversion + ;; coding-category-sjis 'japanese-shift-jis + ;; coding-category-big5 'chinese-big5 + ;; coding-category-binary 'binary) + (set-coding-category-system 'iso-7 'iso-2022-7bit) + (set-coding-category-system 'iso-8-1 'iso-8859-1) + (set-coding-category-system 'iso-8-2 'iso-8859-1) + (set-coding-category-system 'iso-lock-shift 'iso-2022-lock) + (set-coding-category-system 'iso-8-designate 'ctext) + (set-coding-category-system 'no-conversion 'no-conversion) + (set-coding-category-system 'shift-jis 'shift_jis) + (set-coding-category-system 'big5 'big5) + + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-8-2 + ;; coding-category-iso-8-1 + ;; coding-category-iso-7-else + ;; coding-category-iso-8-else + ;; coding-category-emacs-mule + ;; coding-category-raw-text + ;; coding-category-sjis + ;; coding-category-big5 + ;; coding-category-binary)) + (set-coding-priority-list + '(iso-7 + iso-8-2 + iso-8-1 + iso-8-designate + iso-lock-shift + no-conversion + shift-jis + big5)) + (set-default-coding-systems nil) ;; Don't alter the terminal and keyboard coding systems here. ;; The terminal still supports the same coding system @@ -89,7 +106,8 @@ ;;; (set-terminal-coding-system-internal nil) ;;; (set-keyboard-coding-system-internal nil) - (setq nonascii-insert-offset 0)) + ;;(setq nonascii-insert-offset 0) + ) (set-language-info-alist "English" '((setup-function . setup-english-environment)
--- a/lisp/language/ethio-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1842 +0,0 @@ -;;; ethio-util.el --- utilities for Ethiopic - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: mule, multilingual, Ethiopic - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;; Author: TAKAHASHI Naoto <ntakahas@etl.go.jp> -;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> for XEmacs. - -;;; Code: - -(eval-when-compile - (require 'rmail) - (require 'w3) - ) - -;; -;; ETHIOPIC UTILITY FUNCTIONS -;; - -;; If the filename ends in ".sera", editing is done in fidel -;; but file I/O is done in SERA. -;; -;; If the filename ends in ".java", editing is done in fidel -;; but file I/O is done in the \uXXXX style, where XXXX is -;; the Unicode codepoint for the Ethiopic character. -;; -;; If the filename ends in ".tex", editing is done in fidel -;; but file I/O is done in EthioTeX format. -;; -;; To automatically convert Ethiopic text to SERA format when sending mail, -;; (add-hook 'mail-send-hook 'ethio-fidel-to-sera-mail) -;; -;; To automatically convert SERA format to Ethiopic when receiving mail, -;; (add-hook 'rmail-show-message-hook 'ethio-sera-to-fidel-mail) -;; -;; To automatically convert Ethiopic text to SERA format when posting news, -;; (add-hook 'news-inews-hook 'ethio-fidel-to-sera-mail) - -;; -;; users' preference -;; - -(defvar ethio-primary-language 'tigrigna - "*Symbol that defines the primary language in SERA --> FIDEL conversion. -The value should be one of: `tigrigna', `amharic' or `english'.") - -(defvar ethio-secondary-language 'english - "*Symbol that defines the secondary language in SERA --> FIDEL conversion. -The value should be one of: `tigrigna', `amharic' or `english'.") - -(defvar ethio-use-colon-for-colon nil - "*Non-nil means associate ASCII colon with Ethiopic colon. -If nil, associate ASCII colon with Ethiopic word separator, i.e., two -vertically stacked dots. All SERA <--> FIDEL converters refer this -variable.") - -(defvar ethio-use-three-dot-question nil - "*Non-nil means associate ASCII question mark with Ethiopic old style question mark (three vertically stacked dots). -If nil, associate ASCII question mark with Ethiopic stylised question -mark. All SERA <--> FIDEL converters refer this variable.") - -(defvar ethio-quote-vowel-always nil - "*Non-nil means always put an apostrophe before an isolated vowel (except at word initial) in FIDEL --> SERA conversion. -If nil, put an apostrophe only between a sixth-form consonant and an -isolated vowel.") - -(defvar ethio-W-sixth-always nil - "*Non-nil means convert the Wu-form of a 12-form consonant to \"W'\" instead of \"Wu\" in FIDEL --> SERA conversion.") - -(defvar ethio-numeric-reduction 0 - "*Degree of reduction in converting Ethiopic digits into Arabic digits. -Should be 0, 1 or 2. -For example, ({10}{9}{100}{80}{7}) is converted into: - `10`9`100`80`7 if `ethio-numeric-reduction' is 0, - `109100807 if `ethio-numeric-reduction' is 1, - `10900807 if `ethio-numeric-reduction' is 2.") - -(defvar ethio-implicit-period-conversion t - "*Non-nil means replacing the Ethiopic dot at the end of an Ethiopic sentence -with an Ethiopic full stop.") - -(defvar ethio-java-save-lowercase nil - "*Non-nil means save Ethiopic characters in lowercase hex numbers to Java files. -If nil, use uppercases.") - -;; -;; SERA to FIDEL -;; - -(defconst ethio-sera-to-fidel-table - [ - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil -;;; SP - (" " - (?: (if ethio-use-colon-for-colon " $(3$l(B" "$(3$h(B") - (32 (if ethio-use-colon-for-colon " $(3$l(B " "$(3$h(B")) - (?- " $(3$m(B") - (?: " $(3$i(B") - (?| (if ethio-use-colon-for-colon " $(3$l(B|" " $(3$h(B|") - (?: " $(3$o(B")))) - -;;; ! " # $ % & ' - nil nil nil nil nil nil ("" (?' "$(3%s(B")) -;;; ( ) * + , - . - nil nil nil nil ("$(3$j(B") ("-" (?: "$(3$l(B")) ("$(3%u(B") -;;; / 0 1 2 3 4 5 6 7 8 9 - nil nil nil nil nil nil nil nil nil nil nil -;;; : - ((if ethio-use-colon-for-colon "$(3$l(B" "$(3$h(B") - (32 (if ethio-use-colon-for-colon "$(3$l(B " "$(3$h(B")) - (?- "$(3$m(B") - (?: "$(3$i(B") - (?| (if ethio-use-colon-for-colon "$(3$l(B|" "$(3$h(B|") - (?: "$(3$o(B"))) -;;; ; < = > - ("$(3$k(B") ("<" (?< "$(3%v(B")) nil (">" (?> "$(3%w(B")) -;;; ? - ((if ethio-use-three-dot-question "$(3$n(B" "$(3%x(B")) -;;; @ - nil -;;; A - ("$(3"f(B" (?2 "$(3#8(B")) -;;; B - ("$(3"((B" (?e "$(3"#(B") (?u "$(3"$(B") (?i "$(3"%(B") (?a "$(3"&(B") (?E "$(3"'(B") (?o "$(3")(B") - (?W "$(3%b(B" (?e "$(3%2(B") (?u "$(3%b(B") (?i "$(3%B(B") (?a "$(3"*(B") (?E "$(3%R(B"))) -;;; C - ("$(3$4(B" (?e "$(3$/(B") (?u "$(3$0(B") (?i "$(3$1(B") (?a "$(3$2(B") (?E "$(3$3(B") (?o "$(3$5(B") - (?W "$(3$6(B" (?a "$(3$6(B") - (?e "$(3$4%n(B") (?u "$(3$4%r(B") (?i "$(3$4%o(B") (?E "$(3$4%q(B"))) -;;; D - ("$(3#b(B" (?e "$(3#](B") (?u "$(3#^(B") (?i "$(3#_(B") (?a "$(3#`(B") (?E "$(3#a(B") (?o "$(3#c(B") - (?W "$(3#d(B" (?a "$(3#d(B") - (?e "$(3#b%n(B") (?u "$(3#b%r(B") (?i "$(3#b%o(B") (?E "$(3#b%q(B"))) -;;; E - ("$(3"g(B" (?2 "$(3#9(B")) -;;; F - ("$(3$T(B" (?e "$(3$O(B") (?u "$(3$P(B") (?i "$(3$Q(B") (?a "$(3$R(B") (?E "$(3$S(B") (?o "$(3$U(B") - (?W "$(3%d(B" (?e "$(3%4(B") (?u "$(3%d(B") (?i "$(3%D(B") (?a "$(3$V(B") (?E "$(3%T(B")) - (?Y "$(3$a(B" (?a "$(3$a(B"))) -;;; G - ("$(3$$(B" (?e "$(3#}(B") (?u "$(3#~(B") (?i "$(3$!(B") (?a "$(3$"(B") (?E "$(3$#(B") (?o "$(3$%(B") - (?W "$(3%c(B" (?e "$(3%3(B") (?u "$(3%c(B") (?i "$(3%C(B") (?a "$(3$&(B") (?E "$(3%S(B"))) -;;; H - ("$(3!6(B" (?e "$(3!1(B") (?u "$(3!2(B") (?i "$(3!3(B") (?a "$(3!4(B") (?E "$(3!5(B") (?o "$(3!7(B") - (?W "$(3!8(B" (?a "$(3!8(B") - (?e "$(3!6%n(B") (?u "$(3!6%r(B") (?i "$(3!6%o(B") (?E "$(3!6%q(B"))) -;;; I - ("$(3"h(B" (?2 "$(3#:(B")) -;;; J - ("$(3#j(B" (?e "$(3#e(B") (?u "$(3#f(B") (?i "$(3#g(B") (?a "$(3#h(B") (?E "$(3#i(B") (?o "$(3#k(B") - (?W "$(3#l(B" (?a "$(3#l(B") - (?e "$(3#j%n(B") (?u "$(3#j%r(B") (?i "$(3#j%o(B") (?E "$(3#j%q(B"))) -;;; K - ("$(3#"(B" (?e "$(3"{(B") (?u "$(3"|(B") (?i "$(3"}(B") (?a "$(3"~(B") (?E "$(3#!(B") (?o "$(3##(B") - (?W "$(3#*(B" (?e "$(3#%(B") (?u "$(3#*(B") (?i "$(3#'(B") (?a "$(3#((B") (?E "$(3#)(B"))) -;;; L - ("$(3!.(B" (?e "$(3!)(B") (?u "$(3!*(B") (?i "$(3!+(B") (?a "$(3!,(B") (?E "$(3!-(B") (?o "$(3!/(B") - (?W "$(3!0(B" (?a "$(3!0(B") - (?e "$(3!.%n(B") (?u "$(3!.%r(B") (?i "$(3!.%o(B") (?E "$(3!.%q(B"))) -;;; M - ("$(3!>(B" (?e "$(3!9(B") (?u "$(3!:(B") (?i "$(3!;(B") (?a "$(3!<(B") (?E "$(3!=(B") (?o "$(3!?(B") - (?W "$(3%a(B" (?e "$(3%1(B") (?u "$(3%a(B") (?i "$(3%A(B") (?a "$(3!@(B") (?E "$(3%Q(B")) - (?Y "$(3$_(B" (?a "$(3$_(B"))) -;;; N - ("$(3"`(B" (?e "$(3"[(B") (?u "$(3"\(B") (?i "$(3"](B") (?a "$(3"^(B") (?E "$(3"_(B") (?o "$(3"a(B") - (?W "$(3"b(B" (?a "$(3"b(B") - (?e "$(3"`%n(B") (?u "$(3"`%r(B") (?i "$(3"`%o(B") (?E "$(3"`%q(B"))) -;;; O - ("$(3"i(B" (?2 "$(3#;(B")) -;;; P - ("$(3$<(B" (?e "$(3$7(B") (?u "$(3$8(B") (?i "$(3$9(B") (?a "$(3$:(B") (?E "$(3$;(B") (?o "$(3$=(B") - (?W "$(3$>(B" (?a "$(3$>(B") - (?e "$(3$<%n(B") (?u "$(3$<%r(B") (?i "$(3$<%o(B") (?E "$(3$<%q(B"))) -;;; Q - ("$(3!v(B" (?e "$(3!q(B") (?u "$(3!r(B") (?i "$(3!s(B") (?a "$(3!t(B") (?E "$(3!u(B") (?o "$(3!w(B") - (?W "$(3!~(B" (?e "$(3!y(B") (?u "$(3!~(B") (?i "$(3!{(B") (?a "$(3!|(B") (?E "$(3!}(B"))) -;;; R - ("$(3!N(B" (?e "$(3!I(B") (?u "$(3!J(B") (?i "$(3!K(B") (?a "$(3!L(B") (?E "$(3!M(B") (?o "$(3!O(B") - (?W "$(3!P(B" (?a "$(3!P(B") - (?e "$(3!N%n(B") (?u "$(3!N%r(B") (?i "$(3!N%o(B") (?E "$(3!N%q(B")) - (?Y "$(3$`(B" (?a "$(3$`(B"))) -;;; S - ("$(3$D(B" (?e "$(3$?(B") (?u "$(3$@(B") (?i "$(3$A(B") (?a "$(3$B(B") (?E "$(3$C(B") (?o "$(3$E(B") - (?W "$(3$F(B" (?a "$(3$F(B") - (?e "$(3$D%n(B") (?u "$(3$D%r(B") (?i "$(3$D%o(B") (?E "$(3$D%q(B")) - (?2 "$(3$L(B" - (?e "$(3$G(B") (?u "$(3$H(B") (?i "$(3$I(B") (?a "$(3$J(B") (?E "$(3$K(B") (?o "$(3$M(B") - (?W "$(3$F(B" (?a "$(3$F(B") - (?e "$(3$L%n(B") (?u "$(3$L%r(B") (?i "$(3$L%o(B") (?E "$(3$L%q(B")))) -;;; T - ("$(3$,(B" (?e "$(3$'(B") (?u "$(3$((B") (?i "$(3$)(B") (?a "$(3$*(B") (?E "$(3$+(B") (?o "$(3$-(B") - (?W "$(3$.(B" (?a "$(3$.(B") - (?e "$(3$,%n(B") (?u "$(3$,%r(B") (?i "$(3$,%o(B") (?E "$(3$,%q(B"))) -;;; U - ("$(3"d(B" (?2 "$(3#6(B")) -;;; V - ("$(3"0(B" (?e "$(3"+(B") (?u "$(3",(B") (?i "$(3"-(B") (?a "$(3".(B") (?E "$(3"/(B") (?o "$(3"1(B") - (?W "$(3"2(B" (?a "$(3"2(B") - (?e "$(3"0%n(B") (?u "$(3"0%r(B") (?i "$(3"0%o(B") (?E "$(3"0%q(B"))) -;;; W - ("$(3%r(B" (?e "$(3%n(B") (?u "$(3%r(B") (?i "$(3%o(B") (?a "$(3%p(B") (?E "$(3%q(B")) -;;; X - ("$(3%N(B" (?e "$(3%I(B") (?u "$(3%J(B") (?i "$(3%K(B") (?a "$(3%L(B") (?E "$(3%M(B") (?o "$(3%O(B")) -;;; Y - ("$(3#R(B" (?e "$(3#M(B") (?u "$(3#N(B") (?i "$(3#O(B") (?a "$(3#P(B") (?E "$(3#Q(B") (?o "$(3#S(B") - (?W "$(3#T(B" (?a "$(3#T(B") - (?e "$(3#R%n(B") (?u "$(3#R%r(B") (?i "$(3#R%o(B") (?E "$(3#R%q(B"))) -;;; Z - ("$(3#J(B" (?e "$(3#E(B") (?u "$(3#F(B") (?i "$(3#G(B") (?a "$(3#H(B") (?E "$(3#I(B") (?o "$(3#K(B") - (?W "$(3#L(B" (?a "$(3#L(B") - (?e "$(3#J%n(B") (?u "$(3#J%r(B") (?i "$(3#J%o(B") (?E "$(3#J%q(B"))) -;;; [ \ ] ^ _ - nil nil nil nil nil -;;; ` - ("" - (?: "$(3$h(B") - (?? (if ethio-use-three-dot-question "$(3%x(B" "$(3$n(B")) - (?! "$(3%t(B") - (?e "$(3#5(B") (?u "$(3#6(B") (?U "$(3#6(B") (?i "$(3#7(B") (?a "$(3#8(B") (?A "$(3#8(B") - (?E "$(3#9(B") (?I "$(3#:(B") (?o "$(3#;(B") (?O "$(3#;(B") - (?g "$(3%^(B" - (?e "$(3%Y(B") (?u "$(3%Z(B") (?i "$(3%[(B") (?a "$(3%\(B") (?E "$(3%](B") (?o "$(3%_(B")) - (?h "$(3"H(B" - (?e "$(3"C(B") (?u "$(3"D(B") (?i "$(3"E(B") (?a "$(3"F(B") (?E "$(3"G(B") (?o "$(3"I(B") - (?W "$(3"P(B" (?e "$(3"K(B") (?u "$(3"P(B") (?i "$(3"M(B") (?a "$(3"N(B") (?E "$(3"O(B"))) - (?k "$(3%>(B" - (?e "$(3%9(B") (?u "$(3%:(B") (?i "$(3%;(B") (?a "$(3%<(B") (?E "$(3%=(B") (?o "$(3%?(B")) - (?s "$(3!F(B" - (?e "$(3!A(B") (?u "$(3!B(B") (?i "$(3!C(B") (?a "$(3!D(B") (?E "$(3!E(B") (?o "$(3!G(B") - (?W "$(3!H(B" (?a "$(3!H(B") - (?e "$(3!F%n(B") (?u "$(3!F%r(B") (?i "$(3!F%o(B") (?E "$(3!F%q(B"))) - (?S "$(3$L(B" - (?e "$(3$G(B") (?u "$(3$H(B") (?i "$(3$I(B") (?a "$(3$J(B") (?E "$(3$K(B") (?o "$(3$M(B") - (?W "$(3$F(B" (?a "$(3$F(B") - (?e "$(3$L%n(B") (?u "$(3$L%r(B") (?i "$(3$L%o(B") (?E "$(3$L%q(B"))) - (?q "$(3%.(B" (?e "$(3%)(B") (?u "$(3%*(B") (?i "$(3%+(B") (?a "$(3%,(B") (?E "$(3%-(B") (?o "$(3%/(B"))) -;;; a - ("$(3"f(B" (?2 "$(3#8(B")) -;;; b - ("$(3"((B" (?e "$(3"#(B") (?u "$(3"$(B") (?i "$(3"%(B") (?a "$(3"&(B") (?E "$(3"'(B") (?o "$(3")(B") - (?W "$(3%b(B" (?e "$(3%2(B") (?u "$(3%b(B") (?i "$(3%B(B") (?a "$(3"*(B") (?E "$(3%R(B"))) -;;; c - ("$(3"@(B" (?e "$(3";(B") (?u "$(3"<(B") (?i "$(3"=(B") (?a "$(3">(B") (?E "$(3"?(B") (?o "$(3"A(B") - (?W "$(3"B(B" (?a "$(3"B(B") - (?e "$(3"@%n(B") (?u "$(3"@%r(B") (?i "$(3"@%o(B") (?E "$(3"@%q(B"))) -;;; d - ("$(3#Z(B" (?e "$(3#U(B") (?u "$(3#V(B") (?i "$(3#W(B") (?a "$(3#X(B") (?E "$(3#Y(B") (?o "$(3#[(B") - (?W "$(3#\(B" (?a "$(3#\(B") - (?e "$(3#Z%o(B") (?u "$(3#Z%r(B") (?i "$(3#Z%p(B") (?E "$(3#Z%q(B"))) -;;; e - ("$(3"c(B" (?2 "$(3#5(B") (?a "$(3"j(B")) -;;; f - ("$(3$T(B" (?e "$(3$O(B") (?u "$(3$P(B") (?i "$(3$Q(B") (?a "$(3$R(B") (?E "$(3$S(B") (?o "$(3$U(B") - (?W "$(3%d(B" (?e "$(3%4(B") (?u "$(3%d(B") (?i "$(3%D(B") (?a "$(3$V(B") (?E "$(3%T(B")) - (?Y "$(3$a(B" (?a "$(3$a(B"))) -;;; g - ("$(3#r(B" (?e "$(3#m(B") (?u "$(3#n(B") (?i "$(3#o(B") (?a "$(3#p(B") (?E "$(3#q(B") (?o "$(3#s(B") - (?W "$(3#z(B" (?e "$(3#u(B") (?u "$(3#z(B") (?i "$(3#w(B") (?a "$(3#x(B") (?E "$(3#y(B")) - (?2 "$(3%^(B" (?e "$(3%Y(B") (?u "$(3%Z(B") (?i "$(3%[(B") (?a "$(3%\(B") (?E "$(3%](B") (?o "$(3%_(B"))) -;;; h - ("$(3!&(B" (?e "$(3!!(B") (?u "$(3!"(B") (?i "$(3!#(B") (?a "$(3!$(B") (?E "$(3!%(B") (?o "$(3!'(B") - (?W "$(3"P(B" (?e "$(3"K(B") (?u "$(3"P(B") (?i "$(3"M(B") (?a "$(3"N(B") (?E "$(3"O(B")) - (?2 "$(3"H(B" (?e "$(3"C(B") (?u "$(3"D(B") (?i "$(3"E(B") (?a "$(3"F(B") (?E "$(3"G(B") (?o "$(3"I(B") - (?W "$(3"P(B" (?e "$(3"K(B") (?u "$(3"P(B") (?i "$(3"M(B") (?a "$(3"N(B") (?E "$(3"O(B")))) -;;; i - ("$(3"e(B" (?2 "$(3#7(B")) -;;; j - ("$(3#j(B" (?e "$(3#e(B") (?u "$(3#f(B") (?i "$(3#g(B") (?a "$(3#h(B") (?E "$(3#i(B") (?o "$(3#k(B") - (?W "$(3#l(B" (?a "$(3#l(B") - (?e "$(3#j%n(B") (?u "$(3#j%r(B") (?i "$(3#j%o(B") (?E "$(3#j%q(B"))) -;;; k - ("$(3"p(B" (?e "$(3"k(B") (?u "$(3"l(B") (?i "$(3"m(B") (?a "$(3"n(B") (?E "$(3"o(B") (?o "$(3"q(B") - (?W "$(3"x(B" (?e "$(3"s(B") (?u "$(3"x(B") (?i "$(3"u(B") (?a "$(3"v(B") (?E "$(3"w(B")) - (?2 "$(3%>(B" (?e "$(3%9(B") (?u "$(3%:(B") (?i "$(3%;(B") (?a "$(3%<(B") (?E "$(3%=(B") (?o "$(3%?(B"))) -;;; l - ("$(3!.(B" (?e "$(3!)(B") (?u "$(3!*(B") (?i "$(3!+(B") (?a "$(3!,(B") (?E "$(3!-(B") (?o "$(3!/(B") - (?W "$(3!0(B" (?a "$(3!0(B") - (?e "$(3!.%n(B") (?u "$(3!.%r(B") (?i "$(3!.%o(B") (?E "$(3!.%q(B"))) -;;; m - ("$(3!>(B" (?e "$(3!9(B") (?u "$(3!:(B") (?i "$(3!;(B") (?a "$(3!<(B") (?E "$(3!=(B") (?o "$(3!?(B") - (?W "$(3%a(B" (?e "$(3%1(B") (?u "$(3%a(B") (?i "$(3%A(B") (?a "$(3!@(B") (?E "$(3%Q(B")) - (?Y "$(3$_(B" (?a "$(3$_(B"))) -;;; n - ("$(3"X(B" (?e "$(3"S(B") (?u "$(3"T(B") (?i "$(3"U(B") (?a "$(3"V(B") (?E "$(3"W(B") (?o "$(3"Y(B") - (?W "$(3"Z(B" (?a "$(3"Z(B") - (?e "$(3"X%n(B") (?u "$(3"X%r(B") (?i "$(3"X%o(B") (?E "$(3"X%q(B"))) -;;; o - ("$(3"i(B" (?2 "$(3#;(B")) -;;; p - ("$(3$\(B" (?e "$(3$W(B") (?u "$(3$X(B") (?i "$(3$Y(B") (?a "$(3$Z(B") (?E "$(3$[(B") (?o "$(3$](B") - (?W "$(3%e(B" (?e "$(3%5(B") (?u "$(3%e(B") (?i "$(3%E(B") (?a "$(3$^(B") (?E "$(3%U(B"))) -;;; q - ("$(3!f(B" (?e "$(3!a(B") (?u "$(3!b(B") (?i "$(3!c(B") (?a "$(3!d(B") (?E "$(3!e(B") (?o "$(3!g(B") - (?W "$(3!n(B" (?e "$(3!i(B") (?u "$(3!n(B") (?i "$(3!k(B") (?a "$(3!l(B") (?E "$(3!m(B")) - (?2 "$(3%.(B" (?e "$(3%)(B") (?u "$(3%*(B") (?i "$(3%+(B") (?a "$(3%,(B") (?E "$(3%-(B") (?o "$(3%/(B"))) -;;; r - ("$(3!N(B" (?e "$(3!I(B") (?u "$(3!J(B") (?i "$(3!K(B") (?a "$(3!L(B") (?E "$(3!M(B") (?o "$(3!O(B") - (?W "$(3!P(B" (?a "$(3!P(B") - (?e "$(3!N%n(B") (?u "$(3!N%r(B") (?i "$(3!N%o(B") (?E "$(3!N%q(B")) - (?Y "$(3$`(B" (?a "$(3$`(B"))) -;;; s - ("$(3!V(B" (?e "$(3!Q(B") (?u "$(3!R(B") (?i "$(3!S(B") (?a "$(3!T(B") (?E "$(3!U(B") (?o "$(3!W(B") - (?W "$(3!X(B" (?a "$(3!X(B") - (?e "$(3!V%n(B") (?u "$(3!V%r(B") (?i "$(3!V%o(B") (?E "$(3!V%q(B")) - (?2 "$(3!F(B" (?e "$(3!A(B") (?u "$(3!B(B") (?i "$(3!C(B") (?a "$(3!D(B") (?E "$(3!E(B") (?o "$(3!G(B") - (?W "$(3!H(B" (?a "$(3!H(B") - (?e "$(3!F%n(B") (?u "$(3!F%r(B") (?i "$(3!F%o(B") (?E "$(3!F%q(B")))) -;;; t - ("$(3"8(B" (?e "$(3"3(B") (?u "$(3"4(B") (?i "$(3"5(B") (?a "$(3"6(B") (?E "$(3"7(B") (?o "$(3"9(B") - (?W "$(3":(B" (?a "$(3":(B") - (?e "$(3"8%n(B") (?u "$(3"8%r(B") (?i "$(3"8%o(B") (?E "$(3"8%q(B"))) -;;; u - ("$(3"d(B" (?2 "$(3#6(B")) -;;; v - ("$(3"0(B" (?e "$(3"+(B") (?u "$(3",(B") (?i "$(3"-(B") (?a "$(3".(B") (?E "$(3"/(B") (?o "$(3"1(B") - (?W "$(3"2(B" (?a "$(3"2(B") - (?e "$(3"0%n(B") (?u "$(3"0%r(B") (?i "$(3"0%o(B") (?E "$(3"0%q(B"))) -;;; w - ("$(3#2(B" (?e "$(3#-(B") (?u "$(3#.(B") (?i "$(3#/(B") (?a "$(3#0(B") (?E "$(3#1(B") (?o "$(3#3(B") - (?W "$(3%p(B" (?e "$(3%n(B") (?u "$(3%r(B") (?i "$(3%o(B") (?a "$(3%p(B") (?E "$(3%q(B"))) -;;; x - ("$(3!^(B" (?e "$(3!Y(B") (?u "$(3!Z(B") (?i "$(3![(B") (?a "$(3!\(B") (?E "$(3!](B") (?o "$(3!_(B") - (?W "$(3!`(B" (?a "$(3!`(B") - (?e "$(3!^%n(B") (?u "$(3!^%r(B") (?i "$(3!^%o(B") (?E "$(3!^%q(B"))) -;;; y - ("$(3#R(B" (?e "$(3#M(B") (?u "$(3#N(B") (?i "$(3#O(B") (?a "$(3#P(B") (?E "$(3#Q(B") (?o "$(3#S(B") - (?W "$(3#T(B" (?a "$(3#T(B") - (?e "$(3#R%n(B") (?u "$(3#R%r(B") (?i "$(3#R%o(B") (?E "$(3#R%q(B"))) -;;; z - ("$(3#B(B" (?e "$(3#=(B") (?u "$(3#>(B") (?i "$(3#?(B") (?a "$(3#@(B") (?E "$(3#A(B") (?o "$(3#C(B") - (?W "$(3#D(B" (?a "$(3#D(B") - (?e "$(3#B%n(B") (?u "$(3#B%r(B") (?i "$(3#B%o(B") (?E "$(3#B%q(B"))) -;;; { | } ~ DEL - nil nil nil nil nil - ]) - -;;;###autoload -(defun ethio-sera-to-fidel-region (beg end &optional secondary force) - "Convert the characters in region from SERA to FIDEL. -The variable `ethio-primary-language' specifies the primary language -and `ethio-secondary-language' specifies the secondary. - -If the 3rd parameter SECONDARY is given and non-nil, assume the region -begins begins with the secondary language; otherwise with the primary -language. - -If the 4th parameter FORCE is given and non-nil, perform conversion -even if the buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon' and -`ethio-use-three-dot-question'." - - (interactive "r\nP") - (save-restriction - (narrow-to-region beg end) - (ethio-sera-to-fidel-buffer secondary force))) - -;;;###autoload -(defun ethio-sera-to-fidel-buffer (&optional secondary force) - "Convert the current buffer from SERA to FIDEL. - -The variable `ethio-primary-language' specifies the primary -language and `ethio-secondary-language' specifies the secondary. - -If the 1st optional parameter SECONDARY is non-nil, assume the buffer -begins with the secondary language; otherwise with the primary -language. - -If the 2nd optional parametr FORCE is non-nil, perform conversion even if the -buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon' and -`ethio-use-three-dot-question'." - - (interactive "P") - - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - - (let ((ethio-primary-language ethio-primary-language) - (ethio-secondary-language ethio-secondary-language) - (ethio-use-colon-for-colon ethio-use-colon-for-colon) - (ethio-use-three-dot-question ethio-use-three-dot-question) - ;; The above four variables may be changed temporary - ;; by tilde escapes during conversion. So we bind them to other - ;; variables but of the same names. - (buffer-read-only nil) - (case-fold-search nil) - current-language - next-language) - - (setq current-language - (if secondary - ethio-secondary-language - ethio-primary-language)) - - (goto-char (point-min)) - - (while (not (eobp)) - (setq next-language - (cond - ((eq current-language 'english) - (ethio-sera-to-fidel-english)) - ((eq current-language 'amharic) - (ethio-sera-to-fidel-ethio 'amharic)) - ((eq current-language 'tigrigna) - (ethio-sera-to-fidel-ethio 'tigrigna)) - (t ; we don't know what to do - (ethio-sera-to-fidel-english)))) - - (setq current-language - (cond - - ;; when language tag is explicitly specified - ((not (eq next-language 'toggle)) - next-language) - - ;; found a toggle in a primary language section - ((eq current-language ethio-primary-language) - ethio-secondary-language) - - ;; found a toggle in a secondary, third, fourth, ... - ;; language section - (t - ethio-primary-language)))) - - ;; If ethio-implicit-period-conversion is non-nil, the - ;; Ethiopic dot "$(3%u(B" at the end of an Ethiopic sentence is - ;; replaced with the Ethiopic full stop "$(3$i(B". - (if ethio-implicit-period-conversion - (progn - (goto-char (point-min)) - (while (re-search-forward "\\([$(3!!(B-$(3$a%)(B-$(3%e%n(B-$(3%r%s(B]\\)$(3%u(B\\([ \t]\\)" - nil t) - (replace-match "\\1$(3$i(B\\2")) - (goto-char (point-min)) - (while (re-search-forward "\\([$(3!!(B-$(3$a%)(B-$(3%e%n(B-$(3%r%s(B]\\)$(3%u(B$" nil t) - (replace-match "\\1$(3$i(B")))) - - ;; gemination - (goto-char (point-min)) - (while (re-search-forward "\\ce$(3%s(B" nil 0) - (compose-region - (save-excursion (backward-char 2) (point)) - (point))) - )) - -(defun ethio-sera-to-fidel-english nil - "Handle English section in SERA to FIDEL conversion. -Conversion stops when a language switch is found. Then delete that -switch and return the name of the new language as a symbol." - (let ((new-language nil)) - - (while (and (not (eobp)) (null new-language)) - (cond - - ;; if no more "\", nothing to do. - ((not (search-forward "\\" nil 0))) - - ;; hereafter point is put after a "\". - ;; first delete that "\", then check the following chars - - ;; "\\" : leave the second "\" - ((progn - (delete-backward-char 1) - (= (following-char) ?\\ )) - (forward-char 1)) - - ;; "\ " : delete the following " " - ((= (following-char) 32) - (delete-char 1) - (setq new-language 'toggle)) - - ;; a language flag - ((setq new-language (ethio-process-language-flag))) - - ;; just a "\" : not special sequence. - (t - (setq new-language 'toggle)))) - - new-language)) - -(defun ethio-sera-to-fidel-ethio (lang) - "Handle Ethiopic section in SERA to FIDEL conversion. -Conversion stops when a language switch is found. Then delete that -switch and return the name of the new language as a symbol. - -The parameter LANG (symbol, either `amharic' or `tigrigna') affects -the conversion of \"a\"." - - (let ((new-language nil) - (verbatim nil) - start table table2 ch) - - (setcar (aref ethio-sera-to-fidel-table ?a) - (if (eq lang 'tigrigna) "$(3"f(B" "$(3"c(B")) - - (while (and (not (eobp)) (null new-language)) - (setq ch (following-char)) - (cond - - ;; skip from "<" to ">" (or from "&" to ";") if in w3-mode - ((and (boundp 'sera-being-called-by-w3) - sera-being-called-by-w3 - (or (= ch ?<) (= ch ?&))) - (search-forward (if (= ch ?<) ">" ";") - nil 0)) - - ;; leave non-ASCII characters as they are - ((>= ch 128) - (forward-char 1)) - - ;; ethiopic digits - ((looking-at "`[1-9][0-9]*") - (delete-char 1) - (ethio-convert-digit)) - - ;; if not seeing a "\", do sera to fidel conversion - ((/= ch ?\\ ) - (setq start (point)) - (forward-char 1) - (setq table (aref ethio-sera-to-fidel-table ch)) - (while (setq table2 (cdr (assoc (following-char) table))) - (setq table table2) - (forward-char 1)) - (if (setq ch (car table)) - (progn - (delete-region start (point)) - (if (stringp ch) - (insert ch) - (insert (eval ch)))))) - - ;; if control reaches here, we must be looking at a "\" - - ;; verbatim mode - (verbatim - (if (looking-at "\\\\~! ?") - - ;; "\~!" or "\~! ". switch to non-verbatim mode - (progn - (replace-match "") - (setq verbatim nil)) - - ;; "\" but not "\~!" nor "\~! ". skip the current "\". - (forward-char 1))) - - ;; hereafter, non-verbatim mode and looking at a "\" - ;; first delete that "\", then check the following chars. - - ;; "\ " : delete the following " " - ((progn - (delete-char 1) - (setq ch (following-char)) - (= ch 32)) - (delete-char 1) - (setq new-language 'toggle)) - - ;; "\~!" or "\~! " : switch to verbatim mode - ((looking-at "~! ?") - (replace-match "") - (setq verbatim t)) - - ;; a language flag - ((setq new-language (ethio-process-language-flag))) - - ;; "\~" but not "\~!" nor a language flag - ((= ch ?~) - (delete-char 1) - (ethio-tilde-escape)) - - ;; ASCII punctuation escape. skip - ((looking-at "\\(,\\|\\.\\|;\\|:\\|'\\|`\\|\?\\|\\\\\\)+") - (goto-char (match-end 0))) - - ;; "\", but not special sequence - (t - (setq new-language 'toggle)))) - - new-language)) - -(defun ethio-process-language-flag nil - "Process a language flag of the form \"~lang\" or \"~lang1~lang2\". - -If looking at \"~lang1~lang2\", set `ethio-primary-language' and -`ethio-une-secondary-language' based on \"lang1\" and \"lang2\". -Then delete the language flag \"~lang1~lang2\" from the buffer. -Return value is the new primary language. - -If looking at \"~lang\", delete that language flag \"~lang\" from the -buffer and return that language. In this case -`ethio-primary-language' and `ethio-uni-secondary-language' -are left unchanged. - -If an unsupported language flag is found, just return nil without -changing anything." - - (let (lang1 lang2) - (cond - - ;; ~lang1~lang2 - ((and (looking-at - "~\\([a-z][a-z][a-z]?\\)~\\([a-z][a-z][a-z]?\\)[ \t\n\\]") - (setq lang1 - (ethio-flag-to-language - (buffer-substring (match-beginning 1) (match-end 1)))) - (setq lang2 - (ethio-flag-to-language - (buffer-substring (match-beginning 2) (match-end 2))))) - (setq ethio-primary-language lang1 - ethio-secondary-language lang2) - (delete-region (point) (match-end 2)) - (if (= (following-char) 32) - (delete-char 1)) - ethio-primary-language) - - ;; ~lang - ((and (looking-at "~\\([a-z][a-z][a-z]?\\)[ \t\n\\]") - (setq lang1 - (ethio-flag-to-language - (buffer-substring (match-beginning 1) (match-end 1))))) - (delete-region (point) (match-end 1)) - (if (= (following-char) 32) - (delete-char 1)) - lang1) - - ;; otherwise - (t - nil)))) - -(defun ethio-tilde-escape nil - "Handle a SERA tilde escape in Ethiopic section and delete it. -Delete the escape even it is not recognised." - - (let ((p (point)) command) - (skip-chars-forward "^ \t\n\\\\") - (setq command (buffer-substring p (point))) - (delete-region p (point)) - (if (= (following-char) 32) - (delete-char 1)) - - (cond - - ;; \~-: - ((string= command "-:") - (setq ethio-use-colon-for-colon t)) - - ;; \~`: - ((string= command "`:") - (setq ethio-use-colon-for-colon nil)) - - ;; \~? - ((string= command "?") - (setq ethio-use-three-dot-question nil)) - - ;; \~`| - ((string= command "`|") - (setq ethio-use-three-dot-question t)) - - ;; \~e - ((string= command "e") - (insert "$(3%j(B")) - - ;; \~E - ((string= command "E") - (insert "$(3%k(B")) - - ;; \~a - ((string= command "a") - (insert "$(3%l(B")) - - ;; \~A - ((string= command "A") - (insert "$(3%m(B")) - - ;; \~X - ((string= command "X") - (insert "$(3%i(B")) - - ;; unsupported tilde escape - (t - nil)))) - -(defun ethio-flag-to-language (flag) - (cond - ((or (string= flag "en") (string= flag "eng")) 'english) - ((or (string= flag "ti") (string= flag "tir")) 'tigrigna) - ((or (string= flag "am") (string= flag "amh")) 'amharic) - (t nil))) - -(defun ethio-convert-digit nil - "Convert Arabic digits to Ethiopic digits." - (let (ch z) - (while (and (>= (setq ch (following-char)) ?1) - (<= ch ?9)) - (delete-char 1) - - ;; count up following zeros - (setq z 0) - (while (= (following-char) ?0) - (delete-char 1) - (setq z (1+ z))) - - (cond - - ;; first digit is 10, 20, ..., or 90 - ((= (mod z 2) 1) - (insert (aref [?$(3$y(B ?$(3$z(B ?$(3${(B ?$(3$|(B ?$(3$}(B ?$(3$~(B ?$(3%!(B ?$(3%"(B ?$(3%#(B] (- ch ?1))) - (setq z (1- z))) - - ;; first digit is 2, 3, ..., or 9 - ((/= ch ?1) - (insert (aref [?$(3$q(B ?$(3$r(B ?$(3$s(B ?$(3$t(B ?$(3$u(B ?$(3$v(B ?$(3$w(B ?$(3$x(B] (- ch ?2)))) - - ;; single 1 - ((= z 0) - (insert "$(3$p(B"))) - - ;; 100 - (if (= (mod z 4) 2) - (insert "$(3%$(B")) - - ;; 10000 - (insert-char ?$(3%%(B (/ z 4))))) - -;;;###autoload -(defun ethio-sera-to-fidel-mail (&optional arg) - "Convert SERA to FIDEL to read/write mail and news. - -If the buffer contains the markers \"<sera>\" and \"</sera>\", -convert the segments between them into FIDEL. - -If invoked interactively and there is no marker, convert the subject field -and the body into FIDEL using `ethio-sera-to-fidel-region'." - - (interactive "p") - (let ((buffer-read-only nil) - border) - (save-excursion - - ;; look for the header-body separator - (goto-char (point-min)) - (if (search-forward - (if (eq major-mode 'rmail-mode) - "\n\n" (concat "\n" mail-header-separator "\n")) - nil t) - (setq border (point)) - (error "header separator not found")) - - ;; note that the point is placed at the border - (if (or (re-search-forward "^<sera>$" nil t) - (progn - (goto-char (point-min)) - (re-search-forward "^Subject: <sera>" border t))) - - ;; there are markers - (progn - ;; we start with the body so that the border will not change - ;; use "^<sera>\n" instead of "^<sera>$" not to leave a blank line - (goto-char border) - (while (re-search-forward "^<sera>\n" nil t) - (replace-match "") - (ethio-sera-to-fidel-region - (point) - (progn - (if (re-search-forward "^</sera>\n" nil 0) - (replace-match "")) - (point)))) - ;; now process the subject - (goto-char (point-min)) - (if (re-search-forward "^Subject: <sera>" border t) - (ethio-sera-to-fidel-region - (progn (delete-backward-char 6) (point)) - (progn - (if (re-search-forward "</sera>$" (line-end-position) 0) - (replace-match "")) - (point))))) - - ;; in case there are no marks but invoked interactively - (if arg - (progn - (ethio-sera-to-fidel-region border (point-max)) - (goto-char (point-min)) - (if (re-search-forward "^Subject: " border t) - (ethio-sera-to-fidel-region (point) (line-end-position)))))) - - ;; adjust the rmail marker - (if (eq major-mode 'rmail-mode) - (set-marker - (aref rmail-message-vector (1+ rmail-current-message)) - (point-max)))))) - -;;;###autoload -(defun ethio-sera-to-fidel-marker (&optional force) - "Convert the regions surrounded by \"<sera>\" and \"</sera>\" from SERA to FIDEL. -Assume that each region begins with `ethio-primary-language'. -The markers \"<sera>\" and \"</sera>\" themselves are not deleted." - (interactive "P") - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "<sera>" nil t) - (ethio-sera-to-fidel-region - (point) - (if (re-search-forward "</sera>" nil t) - (match-beginning 0) - (point-max)) - nil - 'force)))) - -;; -;; FIDEL to SERA -;; - -(defconst ethio-fidel-to-sera-map - [ "he" "hu" "hi" "ha" "hE" "h" "ho" "" ;; 0 - 7 - "le" "lu" "li" "la" "lE" "l" "lo" "lWa" ;; 8 - "He" "Hu" "Hi" "Ha" "HE" "H" "Ho" "HWa" ;; 16 - "me" "mu" "mi" "ma" "mE" "m" "mo" "mWa" ;; 24 - "`se" "`su" "`si" "`sa" "`sE" "`s" "`so" "`sWa" ;; 32 - "re" "ru" "ri" "ra" "rE" "r" "ro" "rWa" ;; 40 - "se" "su" "si" "sa" "sE" "s" "so" "sWa" ;; 48 - "xe" "xu" "xi" "xa" "xE" "x" "xo" "xWa" ;; 56 - "qe" "qu" "qi" "qa" "qE" "q" "qo" "" ;; 64 - "qWe" "" "qWi" "qWa" "qWE" "qW'" "" "" ;; 72 - "Qe" "Qu" "Qi" "Qa" "QE" "Q" "Qo" "" ;; 80 - "QWe" "" "QWi" "QWa" "QWE" "QW'" "" "" ;; 88 - "be" "bu" "bi" "ba" "bE" "b" "bo" "bWa" ;; 96 - "ve" "vu" "vi" "va" "vE" "v" "vo" "vWa" ;; 104 - "te" "tu" "ti" "ta" "tE" "t" "to" "tWa" ;; 112 - "ce" "cu" "ci" "ca" "cE" "c" "co" "cWa" ;; 120 - "`he" "`hu" "`hi" "`ha" "`hE" "`h" "`ho" "" ;; 128 - "hWe" "" "hWi" "hWa" "hWE" "hW'" "" "" ;; 136 - "ne" "nu" "ni" "na" "nE" "n" "no" "nWa" ;; 144 - "Ne" "Nu" "Ni" "Na" "NE" "N" "No" "NWa" ;; 152 - "e" "u" "i" "A" "E" "I" "o" "ea" ;; 160 - "ke" "ku" "ki" "ka" "kE" "k" "ko" "" ;; 168 - "kWe" "" "kWi" "kWa" "kWE" "kW'" "" "" ;; 176 - "Ke" "Ku" "Ki" "Ka" "KE" "K" "Ko" "" ;; 184 - "KWe" "" "KWi" "KWa" "KWE" "KW'" "" "" ;; 192 - "we" "wu" "wi" "wa" "wE" "w" "wo" "" ;; 200 - "`e" "`u" "`i" "`a" "`E" "`I" "`o" "" ;; 208 - "ze" "zu" "zi" "za" "zE" "z" "zo" "zWa" ;; 216 - "Ze" "Zu" "Zi" "Za" "ZE" "Z" "Zo" "ZWa" ;; 224 - "ye" "yu" "yi" "ya" "yE" "y" "yo" "yWa" ;; 232 - "de" "du" "di" "da" "dE" "d" "do" "dWa" ;; 240 - "De" "Du" "Di" "Da" "DE" "D" "Do" "DWa" ;; 248 - "je" "ju" "ji" "ja" "jE" "j" "jo" "jWa" ;; 256 - "ge" "gu" "gi" "ga" "gE" "g" "go" "" ;; 264 - "gWe" "" "gWi" "gWa" "gWE" "gW'" "" "" ;; 272 - "Ge" "Gu" "Gi" "Ga" "GE" "G" "Go" "GWa" ;; 280 - "Te" "Tu" "Ti" "Ta" "TE" "T" "To" "TWa" ;; 288 - "Ce" "Cu" "Ci" "Ca" "CE" "C" "Co" "CWa" ;; 296 - "Pe" "Pu" "Pi" "Pa" "PE" "P" "Po" "PWa" ;; 304 - "Se" "Su" "Si" "Sa" "SE" "S" "So" "SWa" ;; 312 - "`Se" "`Su" "`Si" "`Sa" "`SE" "`S" "`So" "" ;; 320 - "fe" "fu" "fi" "fa" "fE" "f" "fo" "fWa" ;; 328 - "pe" "pu" "pi" "pa" "pE" "p" "po" "pWa" ;; 336 - "mYa" "rYa" "fYa" "" "" "" "" "" ;; 344 - " " " : " "::" "," ";" "-:" ":-" "`?" ;; 352 - ":|:" "1" "2" "3" "4" "5" "6" "7" ;; 360 - "8" "9" "10" "20" "30" "40" "50" "60" ;; 368 - "70" "80" "90" "100" "10000" "" "" "" ;; 376 - "`qe" "`qu" "`qi" "`qa" "`qE" "`q" "`qo" "" ;; 384 - "mWe" "bWe" "GWe" "fWe" "pWe" "" "" "" ;; 392 - "`ke" "`ku" "`ki" "`ka" "`kE" "`k" "`ko" "" ;; 400 - "mWi" "bWi" "GWi" "fWi" "pWi" "" "" "" ;; 408 - "Xe" "Xu" "Xi" "Xa" "XE" "X" "Xo" "" ;; 416 - "mWE" "bWE" "GWE" "fWE" "pWE" "" "" "" ;; 424 - "`ge" "`gu" "`gi" "`ga" "`gE" "`g" "`go" "" ;; 432 - "mW'" "bW'" "GW'" "fW'" "pW'" "" "" "" ;; 440 - "\\~X " "\\~e " "\\~E " "\\~a " "\\~A " "wWe" "wWi" "wWa" ;; 448 - "wWE" "wW'" "''" "`!" "." "<<" ">>" "?" ]) ;; 456 - -(defun ethio-prefer-amharic-p nil - (or (eq ethio-primary-language 'amharic) - (and (not (eq ethio-primary-language 'tigrigna)) - (eq ethio-secondary-language 'amharic)))) - -(defun ethio-language-to-flag (lang) - (cond - ((eq lang 'english) "eng") - ((eq lang 'tigrigna) "tir") - ((eq lang 'amharic) "amh") - (t ""))) - -;;;###autoload -(defun ethio-fidel-to-sera-region (begin end &optional secondary force) - "Replace all the FIDEL characters in the region to the SERA format. -The variable `ethio-primary-language' specifies the primary -language and `ethio-secondary-language' specifies the secondary. - -If the 3dr parameter SECONDARY is given and non-nil, try to convert -the region so that it begins in the secondary language; otherwise with -the primary language. - -If the 4th parameter FORCE is given and non-nil, convert even if the -buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon', `ethio-use-three-dot-question', -`ethio-quote-vowel-always' and `ethio-numeric-reduction'." - - (interactive "r\nP") - (save-restriction - (narrow-to-region begin end) - (ethio-fidel-to-sera-buffer secondary force))) - -;;;###autoload -(defun ethio-fidel-to-sera-buffer (&optional secondary force) - "Replace all the FIDEL characters in the current buffer to the SERA format. -The variable `ethio-primary-language' specifies the primary -language and `ethio-secondary-language' specifies the secondary. - -If the 1st optional parameter SECONDARY is non-nil, try to convert the -region so that it begins in the secondary language; otherwise with the -primary language. - -If the 2nd optional parameter FORCE is non-nil, convert even if the -buffer is read-only. - -See also the descriptions of the variables -`ethio-use-colen-for-colon', `ethio-use-three-dot-question', -`ethio-quote-vowel-always' and `ethio-numeric-reduction'." - - (interactive "P") - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - - (let ((buffer-read-only nil) - (case-fold-search nil) - (lonec nil) ;; t means previous char was a lone consonant - (fidel nil) ;; t means previous char was a FIDEL - (digit nil) ;; t means previous char was an Ethiopic digit - (flag (if (ethio-prefer-amharic-p) "\\~amh " "\\~tir ")) - mode ch) - - ;; user's preference in transcription - (if ethio-use-colon-for-colon - (progn - (aset ethio-fidel-to-sera-map 353 "`:") - (aset ethio-fidel-to-sera-map 357 ":")) - (aset ethio-fidel-to-sera-map 353 " : ") - (aset ethio-fidel-to-sera-map 357 "-:")) - - (if ethio-use-three-dot-question - (progn - (aset ethio-fidel-to-sera-map 359 "?") - (aset ethio-fidel-to-sera-map 463 "`?")) - (aset ethio-fidel-to-sera-map 359 "`?") - (aset ethio-fidel-to-sera-map 463 "?")) - - (mapcar - '(lambda (x) - (aset (aref ethio-fidel-to-sera-map x) - 2 - (if ethio-W-sixth-always ?' ?u))) - '(77 93 141 181 197 277 440 441 442 443 444 457)) - - (if (ethio-prefer-amharic-p) - (aset ethio-fidel-to-sera-map 160 "a") - (aset ethio-fidel-to-sera-map 160 "e")) - ;; end of user's preference - - ;; first, decompose geminated characters - (decompose-region (point-min) (point-max)) - - ;; main conversion routine - (goto-char (point-min)) - (while (not (eobp)) - (setq ch (following-char)) - - (cond ; ethiopic, english, neutral - - ;; ethiopic character. must go to ethiopic mode, if not in it. - ((eq (char-charset ch) 'ethiopic) - (setq ch (ethio-char-to-ethiocode ch)) - (delete-char 1) - (if (not (eq mode 'ethiopic)) - (progn - (insert flag) - (setq mode 'ethiopic))) - - (cond ; fidel, punc, digit - - ;; fidels - ((or (<= ch 346) ; he - fYa - (and (>= ch 384) (<= ch 444)) ; `qe - pw - (and (>= ch 453) (<= ch 457))) ; wWe - wW - (if (and (memq ch '(160 161 162 163 164 166 167)) ; (e - ea) - (or lonec - (and ethio-quote-vowel-always - fidel))) - (insert "'")) - (insert (aref ethio-fidel-to-sera-map ch)) - (setq lonec (ethio-lone-consonant-p ch) - fidel t - digit nil)) - - ;; punctuations or icons - ((or (and (>= ch 353) (<= ch 360)) ; : - :|: - (>= ch 458) ; '' - ? - (and (>= ch 448) (<= ch 452))) ; \~X \~e \~E \~a \~A - (insert (aref ethio-fidel-to-sera-map ch)) - (setq lonec nil - fidel nil - digit nil)) - - ;; now CH must be an ethiopic digit - - ;; reduction = 0 or not preceded by Ethiopic number(s) - ((or (= ethio-numeric-reduction 0) - (not digit)) - (insert "`" (aref ethio-fidel-to-sera-map ch)) - (setq lonec nil - fidel nil - digit t)) - - ;; reduction = 2 and following 10s, 100s, 10000s - ((and (= ethio-numeric-reduction 2) - (memq ch '(370 379 380))) - (insert (substring (aref ethio-fidel-to-sera-map ch) 1)) - (setq lonec nil - fidel nil - digit t)) - - ;; ordinary following digits - (t - (insert (aref ethio-fidel-to-sera-map ch)) - (setq lonec nil - fidel nil - digit t)))) - - ;; english character. must go to english mode, if not in it. - ((or (and (>= ch ?a) (<= ch ?z)) - (and (>= ch ?A) (<= ch ?Z))) - (if (not (eq mode 'english)) - (insert "\\~eng ")) - (forward-char 1) - (setq mode 'english - lonec nil - fidel nil - digit nil)) - - ;; ch can appear both in ethiopic section and in english section. - (t - - ;; we must decide the mode, if not decided yet - (if (null mode) - (progn - (setq mode - (if secondary - ethio-secondary-language - ethio-primary-language)) - (if (eq mode 'english) - (insert "\\~eng ") - (insert flag) - (setq mode 'ethiopic)))) ; tigrigna & amharic --> ethiopic - - (cond ; \ , eng-mode , punc , w3 , other - - ;; backslash is always quoted - ((= ch ?\\ ) - (insert "\\") - (forward-char 1)) - - ;; nothing to do if in english mode - ((eq mode 'english) - (forward-char 1)) - - ;; now we must be in ethiopic mode and seeing a non-"\" - - ;; ascii punctuations in ethiopic mode - ((looking-at "[,.;:'`?]+") - (insert "\\") - (goto-char (1+ (match-end 0)))) ; because we inserted one byte (\) - - ;; skip from "<" to ">" (or from "&" to ";") if called from w3 - ((and (boundp 'sera-being-called-by-w3) - sera-being-called-by-w3 - (or (= ch ?<) (= ch ?&))) - (search-forward (if (= ch ?<) ">" ";") - nil 0)) - - ;; neutral character. no need to quote. just skip it. - (t - (forward-char 1))) - - (setq lonec nil - fidel nil - digit nil))) - ;; end of main conversion routine - ))) - -(defun ethio-lone-consonant-p (ethiocode) - "If ETHIOCODE is an Ethiopic lone consonant, return t." - (or (and (< ethiocode 344) (= (% ethiocode 8) 5)) - - ;; `q `k X `g mW bW GW fW pW wW - (memq ethiocode '(389 405 421 437 440 441 442 443 444 457)))) - -;;;###autoload -(defun ethio-fidel-to-sera-mail nil - "Convert FIDEL to SERA to read/write mail and news. - -If the body contains at least one Ethiopic character, - 1) insert the string \"<sera>\" at the beginning of the body, - 2) insert \"</sera>\" at the end of the body, and - 3) convert the body into SERA. - -The very same procedure applies to the subject field, too." - - (interactive) - (let ((buffer-read-only nil) - border) - (save-excursion - - ;; look for the header-body separator - (goto-char (point-min)) - (if (search-forward - (if (eq major-mode 'rmail-mode) - "\n\n" (concat "\n" mail-header-separator "\n")) - nil t) - (setq border (point)) - (error "header separator not found")) - - ;; process body first not to change the border - ;; note that the point is already at the border - (if (re-search-forward "\\ce" nil t) - (progn - (ethio-fidel-to-sera-region border (point-max)) - (goto-char border) - (insert "<sera>") - (goto-char (point-max)) - (insert "</sera>"))) - - ;; process subject - (goto-char (point-min)) - (if (re-search-forward "^Subject: " border t) - (let ((beg (point)) - (end (line-end-position))) - (if (re-search-forward "\\ce" end t) - (progn - (ethio-fidel-to-sera-region beg end) - (goto-char beg) - (insert "<sera>") - (end-of-line) - (insert "</sera>"))))) - - ;; adjust the rmail marker - (if (eq major-mode 'rmail-mode) - (set-marker - (aref rmail-message-vector (1+ rmail-current-message)) - (point-max)))))) - -;;;###autoload -(defun ethio-fidel-to-sera-marker (&optional force) - "Convert the regions surrounded by \"<sera>\" and \"</sera>\" from FIDEL to SERA. -The markers \"<sera>\" and \"</sera>\" themselves are not deleted." - - (interactive "P") - (if (and buffer-read-only - (not force) - (not (y-or-n-p "Buffer is read-only. Force to convert? "))) - (error "")) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "<sera>" nil t) - (ethio-fidel-to-sera-region - (point) - (if (re-search-forward "</sera>" nil t) - (match-beginning 0) - (point-max)) - nil - 'force)))) - -;; -;; vowel modification -;; - -;;;###autoload -(defun ethio-modify-vowel nil - "Modify the vowel of the FIDEL that is under the cursor." - (interactive) - (let ((ch (following-char)) - (composite nil) ; geminated or not - newch base vowel modulo) - - (cond - ;; in case of gemination - ((eq (char-charset ch) 'composition) - (setq ch (string-to-char (decompose-composite-char ch)) - composite t)) - ;; neither gemination nor fidel - ((not (eq (char-charset ch) 'ethiopic)) - (error "Not a valid character."))) - - ;; set frequently referred character features - (setq ch (ethio-char-to-ethiocode ch) - base (* (/ ch 8) 8) - modulo (% ch 8)) - - (if (or (and (>= ch 344) (<= ch 380)) ;; mYa - `10000 - (and (>= ch 448) (<= ch 452)) ;; \~X - \~A - (>= ch 458)) ;; private punctuations - (error "Not a valid character.")) - - (setq - newch - (cond - - ;; first standalone vowels - ((= base 160) - (if (ethio-prefer-amharic-p) - (message "Modify vowel to: [auiAEIoW\"] ") - (message "Modify vowel to: [euiAEIoW\"] ")) - (setq vowel (read-char)) - (cond - ((= vowel ?e) 160) - ((= vowel ?u) 161) - ((= vowel ?i) 162) - ((= vowel ?A) 163) - ((= vowel ?E) 164) - ((= vowel ?I) 165) - ((= vowel ?o) 166) - ((= vowel ?W) 167) - ((= vowel ?a) (if (ethio-prefer-amharic-p) 160 163)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; second standalone vowels - ((= base 208) - (message "Modify vowel to: [euiaEIo\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 208) - ((= vowel ?u) 209) - ((= vowel ?i) 210) - ((= vowel ?a) 211) - ((= vowel ?E) 212) - ((= vowel ?I) 213) - ((= vowel ?o) 214) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; 12-form consonants, *W* form - ((memq base '(72 88 136 176 192 272)) ; qW QW hW kW KW gW - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) base) - ((= vowel ?u) (+ base 5)) - ((= vowel ?i) (+ base 2)) - ((= vowel ?a) (+ base 3)) - ((= vowel ?E) (+ base 4)) - ((= vowel ?') (+ base 5)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; extended 12-form consonants, mWa bWa GWa fWa pWa - ((= ch 31) ; mWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 392) - ((= vowel ?u) 440) - ((= vowel ?i) 408) - ((= vowel ?a) ch) - ((= vowel ?E) 424) - ((= vowel ?') 440) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 103) ; bWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 393) - ((= vowel ?u) 441) - ((= vowel ?i) 409) - ((= vowel ?a) ch) - ((= vowel ?E) 425) - ((= vowel ?') 441) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 287) ; GWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 394) - ((= vowel ?u) 442) - ((= vowel ?i) 410) - ((= vowel ?a) ch) - ((= vowel ?E) 426) - ((= vowel ?') 442) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 335) ; fWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 395) - ((= vowel ?u) 443) - ((= vowel ?i) 411) - ((= vowel ?a) ch) - ((= vowel ?E) 427) - ((= vowel ?') 443) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - ((= ch 343) ; pWa - (message "Modify vowel to: [euiaE'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 396) - ((= vowel ?u) 444) - ((= vowel ?i) 412) - ((= vowel ?a) ch) - ((= vowel ?E) 428) - ((= vowel ?') 444) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; extended 12-form consonatns, mW* bW* GW* fW* pW* - ((memq base '(392 408 424 440)) ; *We *Wi *WE *W - (message "Modify vowel to: [eiEau'\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) (+ 392 modulo)) - ((= vowel ?i) (+ 408 modulo)) - ((= vowel ?E) (+ 424 modulo)) - ((= vowel ?a) (cond - ((= modulo 0) 31) ; mWa - ((= modulo 1) 103) ; bWa - ((= modulo 2) 287) ; GWa - ((= modulo 3) 335) ; fWa - ((= modulo 4) 343) ; pWa - (t nil))) ; never reach here - ((= vowel ?') (+ 440 modulo)) - ((= vowel ?u) (+ 440 modulo)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ((and (>= ch 453) (<= ch 457)) ; wWe wWi wWa wWE wW - (message "Modify vowel to: [eiaE'u\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) 453) - ((= vowel ?i) 454) - ((= vowel ?a) 455) - ((= vowel ?E) 456) - ((= vowel ?') 457) - ((= vowel ?u) 457) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; 7-form consonants, or - ;; first 7 of 8-form consonants - ((<= modulo 6) - (message "Modify vowel to: [euiaE'o\"] ") - (setq vowel (read-char)) - (cond - ((= vowel ?e) base) - ((= vowel ?u) (+ base 1)) - ((= vowel ?i) (+ base 2)) - ((= vowel ?a) (+ base 3)) - ((= vowel ?E) (+ base 4)) - ((= vowel ?') (+ base 5)) - ((= vowel ?o) (+ base 6)) - ((= vowel ?\") (setq composite t) ch) - (t nil))) - - ;; otherwise - (t - nil))) - - (cond - - ;; could not get new character - ((null newch) - (error "Invalid vowel")) - - ;; vowel changed on a composite Fidel - (composite - (delete-char 1) - (insert - (compose-string - (concat (char-to-string (ethio-ethiocode-to-char newch)) "$(3%s(B")))) - - ;; simple vowel modification - (t - (delete-char 1) - (insert (ethio-ethiocode-to-char newch)))))) - -(defun ethio-ethiocode-to-char (ethiocode) - (make-char - 'ethiopic - (+ (/ ethiocode 94) 33) - (+ (mod ethiocode 94) 33))) - -(defun ethio-char-to-ethiocode (ch) - (and (eq (char-charset ch) 'ethiopic) - (let ((char-components (split-char ch))) - (+ (* (- (nth 1 char-components) 33) 94) - (- (nth 2 char-components) 33))))) - -;; -;; space replacement -;; - -;;;###autoload -(defun ethio-replace-space (ch begin end) - "Replace ASCII spaces with Ethiopic word separators in the region. - -In the specified region, replace word separators surrounded by two -Ethiopic characters, depending on the first parameter CH, which should -be 1, 2, or 3. - -If CH = 1, word separator will be replaced with an ASCII space. -If CH = 2, with two ASCII spaces. -If CH = 3, with the Ethiopic colon-like word separator. - -The second and third parameters BEGIN and END specify the region." - - (interactive "*cReplace spaces to: 1 (sg col), 2 (dbl col), 3 (Ethiopic)\nr") - (if (not (memq ch '(?1 ?2 ?3))) - (error "")) - (save-excursion - (save-restriction - (narrow-to-region begin end) - - (cond - ((= ch ?1) - ;; an Ethiopic word separator --> an ASCII space - (goto-char (point-min)) - (while (search-forward "$(3$h(B" nil t) - (replace-match " " nil t)) - - ;; two ASCII spaces between Ethiopic characters --> an ASCII space - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) \\(\\ce\\)" nil t) - (replace-match "\\1 \\2") - (goto-char (match-beginning 2)))) - - ((= ch ?2) - ;; An Ethiopic word separator --> two ASCII spaces - (goto-char (point-min)) - (while (search-forward "$(3$h(B" nil t) - (replace-match " ")) - - ;; An ASCII space between Ethiopic characters --> two ASCII spaces - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) \\(\\ce\\)" nil t) - (replace-match "\\1 \\2") - (goto-char (match-beginning 2)))) - - (t - ;; One or two ASCII spaces between Ethiopic characters - ;; --> An Ethiopic word separator - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) ?\\(\\ce\\)" nil t) - (replace-match "\\1$(3$h(B\\2") - (goto-char (match-beginning 2))) - - ;; Three or more ASCII spaces between Ethiopic characters - ;; --> An Ethiopic word separator + (N - 2) ASCII spaces - (goto-char (point-min)) - (while (re-search-forward "\\(\\ce\\) \\( *\\ce\\)" nil t) - (replace-match "\\1$(3$h(B\\2") - (goto-char (match-beginning 2)))))))) - -;; -;; special icons -;; - -;;;###autoload -(defun ethio-input-special-character (arg) - "Allow the user to input special characters." - (interactive "*cInput number: 1.$(3%j(B 2.$(3%k(B 3.$(3%l(B 4.$(3%m(B 5.$(3%i(B") - (cond - ((= arg ?1) - (insert "$(3%j(B")) - ((= arg ?2) - (insert "$(3%k(B")) - ((= arg ?3) - (insert "$(3%l(B")) - ((= arg ?4) - (insert "$(3%m(B")) - ((= arg ?5) - (insert "$(3%i(B")) - (t - (error "")))) - -;; -;; TeX support -;; - -(defconst ethio-fidel-to-tex-map - [ "heG" "huG" "hiG" "haG" "hEG" "hG" "hoG" "" ;; 0 - 7 - "leG" "luG" "liG" "laG" "lEG" "lG" "loG" "lWaG" ;; 8 - "HeG" "HuG" "HiG" "HaG" "HEG" "HG" "HoG" "HWaG" ;; 16 - "meG" "muG" "miG" "maG" "mEG" "mG" "moG" "mWaG" ;; 24 - "sseG" "ssuG" "ssiG" "ssaG" "ssEG" "ssG" "ssoG" "ssWaG" ;; 32 - "reG" "ruG" "riG" "raG" "rEG" "rG" "roG" "rWaG" ;; 40 - "seG" "suG" "siG" "saG" "sEG" "sG" "soG" "sWaG" ;; 48 - "xeG" "xuG" "xiG" "xaG" "xEG" "xG" "xoG" "xWaG" ;; 56 - "qeG" "quG" "qiG" "qaG" "qE" "qG" "qoG" "" ;; 64 - "qWeG" "" "qWi" "qWaG" "qWEG" "qWG" "" "" ;; 72 - "QeG" "QuG" "QiG" "QaG" "QEG" "QG" "QoG" "" ;; 80 - "QWeG" "" "QWiG" "QWaG" "QWEG" "QWG" "" "" ;; 88 - "beG" "buG" "biG" "baG" "bEG" "bG" "boG" "bWaG" ;; 96 - "veG" "vuG" "viG" "vaG" "vEG" "vG" "voG" "vWaG" ;; 104 - "teG" "tuG" "tiG" "taG" "tEG" "tG" "toG" "tWaG" ;; 112 - "ceG" "cuG" "ciG" "caG" "cEG" "cG" "coG" "cWaG" ;; 120 - "hheG" "hhuG" "hhiG" "hhaG" "hhEG" "hhG" "hhoG" "" ;; 128 - "hWeG" "" "hWiG" "hWaG" "hWEG" "hWG" "" "" ;; 136 - "neG" "nuG" "niG" "naG" "nEG" "nG" "noG" "nWaG" ;; 144 - "NeG" "NuG" "NiG" "NaG" "NEG" "NG" "NoG" "NWaG" ;; 152 - "eG" "uG" "iG" "AG" "EG" "IG" "oGG" "eaG" ;; 160 - "keG" "kuG" "kiG" "kaG" "kEG" "kG" "koG" "" ;; 168 - "kWeG" "" "kWiG" "kWa" "kWEG" "kWG" "" "" ;; 176 - "KeG" "KuG" "KiG" "KaG" "KEG" "KG" "KoG" "" ;; 184 - "KWeG" "" "KWiG" "KWa" "KWEG" "KWG" "" "" ;; 192 - "weG" "wuG" "wiG" "waG" "wEG" "wG" "woG" "" ;; 200 - "eeG" "uuG" "iiG" "aaG" "EEG" "IIG" "ooG" "" ;; 208 - "zeG" "zuG" "ziG" "zaG" "zEG" "zG" "zoG" "zWaG" ;; 216 - "ZeG" "ZuG" "ZiG" "ZaG" "ZEG" "ZG" "ZoG" "ZWaG" ;; 224 - "yeG" "yuG" "yiG" "yaG" "yEG" "yG" "yoG" "yWaG" ;; 232 - "deG" "duG" "diG" "daG" "dEG" "dG" "doG" "dWaG" ;; 240 - "DeG" "DuG" "DiG" "DaG" "DEG" "DG" "DoG" "DWaG" ;; 248 - "jeG" "juG" "jiG" "jaG" "jEG" "jG" "joG" "jWaG" ;; 256 - "geG" "guG" "giG" "gaG" "gEG" "gG" "goG" "" ;; 264 - "gWeG" "" "gWiG" "gWaG" "gWEG" "gWG" "" "" ;; 272 - "GeG" "GuG" "GiG" "GaG" "GEG" "GG" "GoG" "GWaG" ;; 280 - "TeG" "TuG" "TiG" "TaG" "TEG" "TG" "ToG" "TWaG" ;; 288 - "CeG" "CuG" "CiG" "CaG" "CEG" "CG" "CoG" "CWaG" ;; 296 - "PeG" "PuG" "PiG" "PaG" "PEG" "PG" "PoG" "PWaG" ;; 304 - "SeG" "SuG" "SiG" "SaG" "SEG" "SG" "SoG" "SWaG" ;; 312 - "SSeG" "SSuG" "SSiG" "SSaG" "SSEG" "SSG" "SSoG" "" ;; 320 - "feG" "fuG" "fiG" "faG" "fEG" "fG" "foG" "fWaG" ;; 328 - "peG" "puG" "piG" "paG" "pEG" "pG" "poG" "pWaG" ;; 336 - "mYaG" "rYaG" "fYaG" "" "" "" "" "" ;; 344 - "" "spaceG" "periodG" "commaG" ;; 352 - "semicolonG" "colonG" "precolonG" "oldqmarkG" ;; 356 - "pbreakG" "andG" "huletG" "sostG" "aratG" "amstG" "sadstG" "sabatG" ;; 360 - "smntG" "zeteNG" "asrG" "heyaG" "selasaG" "arbaG" "hemsaG" "slsaG" ;; 368 - "sebaG" "semanyaG" "zeTanaG" "metoG" "asrxiG" "" "" "" ;; 376 - "qqeG" "qquG" "qqiG" "qqaG" "qqEG" "qqG" "qqoG" "" ;; 384 - "mWeG" "bWeG" "GWeG" "fWeG" "pWeG" "" "" "" ;; 392 - "kkeG" "kkuG" "kkiG" "kkaG" "kkEG" "kkG" "kkoG" "" ;; 400 - "mWiG" "bWiG" "GWiG" "fWiG" "pWiG" "" "" "" ;; 408 - "XeG" "XuG" "GXiG" "XaG" "XEG" "XG" "XoG" "" ;; 416 - "mWEG" "bWEG" "GWEG" "fWEG" "pWEG" "" "" "" ;; 424 - "ggeG" "gguG" "ggiG" "ggaG" "ggEG" "ggG" "ggoG" "" ;; 432 - "mWG" "bWG" "GWG" "fWG" "pWG" "" "" "" ;; 440 - "ornamentG" "flandG" "iflandG" "africaG" ;; 448 - "iafricaG" "wWeG" "wWiG" "wWaG" ;; 452 - "wWEG" "wWG" "" "slaqG" "dotG" "lquoteG" "rquoteG" "qmarkG" ]) ;; 456 - -;; -;; To make tex-to-fidel mapping. -;; The following code makes -;; (get 'ethio-tex-command-he 'ethio-fidel-char) ==> ?$(3!!(B -;; etc. -;; - -(let ((i 0) str) - (while (< i (length ethio-fidel-to-tex-map)) - (setq str (aref ethio-fidel-to-tex-map i)) - (if (not (string= str "")) - (put - (intern (concat "ethio-tex-command-" (aref ethio-fidel-to-tex-map i))) - 'ethio-fidel-char - (ethio-ethiocode-to-char i))) - (setq i (1+ i)))) - -;;;###autoload -(defun ethio-fidel-to-tex-buffer nil - "Convert each fidel characters in the current buffer into a fidel-tex command. -Each command is always surrounded by braces." - (interactive) - (let ((buffer-read-only nil)) - - ;; Isolated gemination marks need special treatement - (goto-char (point-min)) - (while (search-forward "$(3%s(B" nil t) - (replace-match "\\geminateG{}" t t)) - - ;; First, decompose geminations - ;; Here we assume that each composed character consists of - ;; one Ethiopic character and the Ethiopic gemination mark. - (decompose-region (point-min) (point-max)) - - ;; Special treatment for geminated characters - ;; The geminated character (la'') will be "\geminateG{\la}". - (goto-char (point-min)) - (while (search-forward "$(3%s(B" nil t) - (delete-backward-char 1) - (backward-char 1) - (insert "\\geminateG") - (forward-char 1)) - - ;; Ethiopic characters to TeX macros - (goto-char (point-min)) - (while (re-search-forward "\\ce" nil t) - (insert - "{\\" - (aref ethio-fidel-to-tex-map - (prog1 (ethio-char-to-ethiocode (preceding-char)) - (backward-delete-char 1))) - "}")) - (goto-char (point-min)) - (set-buffer-modified-p nil))) - -;;;###autoload -(defun ethio-tex-to-fidel-buffer nil - "Convert fidel-tex commands in the current buffer into fidel chars." - (interactive) - (let ((buffer-read-only nil) - (p) (ch)) - - ;; Special treatment for gemination - ;; "\geminateG{\la}" or "\geminateG{{\la}}" will be "\la$(3%s(B" - ;; "\geminateG{}" remains unchanged. - (goto-char (point-min)) - (while (re-search-forward "\\\\geminateG{\\(\\\\[a-zA-Z]+\\)}" nil t) - (replace-match "\\1$(3%s(B")) - - ;; TeX macros to Ethiopic characters - (goto-char (point-min)) - (while (search-forward "\\" nil t) - (setq p (point)) - (skip-chars-forward "a-zA-Z") - (setq ch - (get (intern (concat "ethio-tex-command-" - (buffer-substring p (point)))) - 'ethio-fidel-char)) - (if ch - (progn - (delete-region (1- p) (point)) ; don't forget the preceding "\" - (if (and (= (preceding-char) ?{) - (= (following-char) ?})) - (progn - (backward-delete-char 1) - (delete-char 1))) - (insert ch)))) - - ;; compose geminated characters - (goto-char (point-min)) - (while (re-search-forward "\\ce$(3%s(B" nil 0) - (compose-region - (save-excursion (backward-char 2) (point)) - (point))) - - ;; Now it's time to convert isolated gemination marks. - (goto-char (point-min)) - (while (search-forward "\\geminateG{}" nil t) - (replace-match "$(3%s(B")) - - (goto-char (point-min)) - (set-buffer-modified-p nil))) - -;; -;; Java support -;; - -;;;###autoload -(defun ethio-fidel-to-java-buffer nil - "Convert Ethiopic characters into the Java escape sequences. - -Each escape sequence is of the form \uXXXX, where XXXX is the -character's codepoint (in hex) in Unicode. - -If `ethio-java-save-lowercase' is non-nil, use [0-9a-f]. -Otherwise, [0-9A-F]." - (let ((ucode)) - - ;; first, decompose geminations - (decompose-region (point-min) (point-max)) - - (goto-char (point-min)) - (while (re-search-forward "\\ce" nil t) - (setq ucode (+ ?\x1200 (ethio-char-to-ethiocode (preceding-char)))) - (if (> ucode ?\x13bc) - (setq ucode (+ ucode 59952))) - (delete-backward-char 1) - (if ethio-java-save-lowercase - (insert (format "\\u%4x" ucode)) - (insert (upcase (format "\\u%4x" ucode))))))) - -;;;###autoload -(defun ethio-java-to-fidel-buffer nil - "Convert the Java escape sequences into corresponding Ethiopic characters." - (let ((ucode)) - (goto-char (point-min)) - (while (re-search-forward "\\\\u\\([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]\\)" nil t) - (setq ucode - (read - (concat - "?\\x" - (buffer-substring (match-beginning 1) (match-end 1))))) - (cond - ((and (>= ucode ?\x1200) (<= ucode ?\x13bc)) - (replace-match "") - (insert (ethio-ethiocode-to-char (- ucode ?\x1200)))) - ((and (>= ucode ?\xfdf1) (<= ucode ?\xfdff)) - (replace-match "") - (insert (ethio-ethiocode-to-char (- ucode 64560)))) - (t - nil))) - - ;; gemination - (goto-char (point-min)) - (while (re-search-forward "\\ce$(3%s(B" nil 0) - (compose-region - (save-excursion (backward-char 2) (point)) - (point))) - )) - -;; -;; file I/O hooks -;; - -;;;###autoload -(defun ethio-find-file nil - "Transcribe file content into Ethiopic dependig on filename suffix." - (cond - - ((string-match "\\.sera$" (buffer-file-name)) - (save-excursion - (ethio-sera-to-fidel-buffer nil 'force) - (set-buffer-modified-p nil))) - - ((string-match "\\.html$" (buffer-file-name)) - (let ((sera-being-called-by-w3 t)) - (save-excursion - (ethio-sera-to-fidel-marker 'force) - (goto-char (point-min)) - (while (re-search-forward "&[lr]aquote;" nil t) - (if (= (char-after (1+ (match-beginning 0))) ?l) - (replace-match "$(3%v(B") - (replace-match "$(3%w(B"))) - (set-buffer-modified-p nil)))) - - ((string-match "\\.tex$" (buffer-file-name)) - (save-excursion - (ethio-tex-to-fidel-buffer) - (set-buffer-modified-p nil))) - - ((string-match "\\.java$" (buffer-file-name)) - (save-excursion - (ethio-java-to-fidel-buffer) - (set-buffer-modified-p nil))) - - (t - nil))) - -;;;###autoload -(defun ethio-write-file nil - "Transcribe Ethiopic characters in ASCII depending on the file extension." - (cond - - ((string-match "\\.sera$" (buffer-file-name)) - (save-excursion - (ethio-fidel-to-sera-buffer nil 'force) - (goto-char (point-min)) - (ethio-record-user-preference) - (set-buffer-modified-p nil))) - - ((string-match "\\.html$" (buffer-file-name)) - (save-excursion - (let ((sera-being-called-by-w3 t) - (lq (aref ethio-fidel-to-sera-map 461)) - (rq (aref ethio-fidel-to-sera-map 462))) - (aset ethio-fidel-to-sera-map 461 "«te;") - (aset ethio-fidel-to-sera-map 462 "»te;") - (ethio-fidel-to-sera-marker 'force) - (goto-char (point-min)) - (if (search-forward "<sera>" nil t) - (ethio-record-user-preference)) - (aset ethio-fidel-to-sera-map 461 lq) - (aset ethio-fidel-to-sera-map 462 rq) - (set-buffer-modified-p nil)))) - - ((string-match "\\.tex$" (buffer-file-name)) - (save-excursion - (ethio-fidel-to-tex-buffer) - (set-buffer-modified-p nil))) - - ((string-match "\\.java$" (buffer-file-name)) - (save-excursion - (ethio-fidel-to-java-buffer) - (set-buffer-modified-p nil))) - - (t - nil))) - -(defun ethio-record-user-preference nil - (if (looking-at "\\\\~\\(tir?\\|amh?\\) ") - (goto-char (match-end 0)) - (insert (if (ethio-prefer-amharic-p) "\\~amh " "\\~tir "))) - (insert (if ethio-use-colon-for-colon "\\~-: " "\\~`: ") - (if ethio-use-three-dot-question "\\~`| " "\\~`? "))) - -(add-hook 'find-file-hooks 'ethio-find-file) -(add-hook 'write-file-hooks 'ethio-write-file) -(add-hook 'after-save-hook 'ethio-find-file) - -;; -(provide 'language/ethio-util) - -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: -;;; ethio-util.el ends here
--- a/lisp/language/ethiopic.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -;;; ethiopic.el --- Support for Ethiopic - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: multilingual, Ethiopic - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;; Author: TAKAHASHI Naoto <ntakahas@etl.go.jp> -;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> for XEmacs. - -;;; Code: - -;; Ethiopic -(make-charset 'ethiopic "Ethiopic" - '(registry "Ethio" - dimension 2 - chars 94 - final ?3 - graphic 0 - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ETHIOPIC -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-category ?E "Ethiopic (Ge'ez) character.") -(modify-category-entry 'ethiopic ?E) - -;; (define-ccl-program ccl-encode-ethio-font -;; '(0 -;; ;; In: R0:ethiopic (not checked) -;; ;; R1:position code 1 -;; ;; R2:position code 2 -;; ;; Out: R1:font code point 1 -;; ;; R2:font code point 2 -;; ((r1 -= 33) -;; (r2 -= 33) -;; (r1 *= 94) -;; (r2 += r1) -;; (if (r2 < 256) -;; (r1 = ?\x12) -;; (if (r2 < 448) -;; ((r1 = ?\x13) (r2 -= 256)) -;; ((r1 = ?\xfd) (r2 -= 208)) -;; )))) -;; "CCL program to encode an Ehitopic code to code point of Ehitopic font.") -(define-ccl-program ccl-encode-ethio-font - '(((r0 -= #x21) - (r1 -= #x21) - (r0 *= 94) - (r1 += r0) - (if (r1 < 256) (r0 = 0) ((r1 -= 256) (r0 = 1)))))) - -;; (setq font-ccl-encoder-alist -;; (cons (cons "ethiopic" ccl-encode-ethio-font) font-ccl-encoder-alist)) -(set-charset-ccl-program 'ethiopic ccl-encode-ethio-font) - -(register-input-method - "Ethiopic" '("quail-ethio" quail-use-package "quail/ethiopic")) - -(defun setup-ethiopic-environment () - "Setup multilingual environment for Ethiopic." - (interactive) - (setq primary-language "Ethiopic") - - (setq default-input-method '("Ethiopic" . "quail-ethio")) - - ;; - ;; key bindings - ;; - (define-key global-map [f4] 'sera-to-fidel-buffer) - (define-key global-map [S-f4] 'sera-to-fidel-region) - (define-key global-map [C-f4] 'sera-to-fidel-marker) - (define-key global-map [f5] 'fidel-to-sera-buffer) - (define-key global-map [S-f5] 'fidel-to-sera-region) - (define-key global-map [C-f5] 'fidel-to-sera-marker) - (define-key global-map [f6] 'ethio-modify-vowel) - (define-key global-map [f7] 'ethio-replace-space) - (define-key global-map [f8] 'ethio-input-special-character) - (define-key global-map [S-f2] 'ethio-replace-space) ; as requested - - (add-hook - 'rmail-mode-hook - '(lambda () - (define-key rmail-mode-map [C-f4] 'sera-to-fidel-mail) - (define-key rmail-mode-map [C-f5] 'fidel-to-sera-mail))) - - (add-hook - 'mail-mode-hook - '(lambda () - (define-key mail-mode-map [C-f4] 'sera-to-fidel-mail) - (define-key mail-mode-map [C-f5] 'fidel-to-sera-mail))) - ) - -(defun describe-ethiopic-support () - "Describe how Emacs supports Ethiopic." - (interactive) - (describe-language-support-internal "Ethiopic")) - -(set-language-info-alist - "Ethiopic" '((setup-function . setup-ethiopic-environment) - (describe-function . describe-ethiopic-support) - (charset . (ethiopic)) - (sample-text . "$(3$O#U!.(B") - (documentation . nil))) - -;; for XEmacs (will be obsoleted) -(define-language-environment 'ethiopic - "Ethiopic" - #'(lambda () - (setq-default quail-current-package - (assoc "ethio" quail-package-alist)))) - -;;; ethiopic.el ends here
--- a/lisp/language/european.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/european.el Mon Aug 13 10:03:52 2007 +0200 @@ -67,14 +67,16 @@ (defun setup-8-bit-environment (language charset coding-system input-method) (setup-english-environment) (set-default-coding-systems coding-system) - (setq coding-category-iso-8-1 coding-system - coding-category-iso-8-2 coding-system) + ;; (setq coding-category-iso-8-1 coding-system + ;; coding-category-iso-8-2 coding-system) + (set-coding-category-system 'iso-8-1 coding-system) + (set-coding-category-system 'iso-8-2 coding-system) - (if charset - (let ((nonascii-offset (- (make-char charset) 128))) - ;; Set up for insertion of characters in this character set - ;; when codes 0200 - 0377 are typed in. - (setq nonascii-insert-offset nonascii-offset))) + ;; (if charset + ;; (let ((nonascii-offset (- (make-char charset) 128))) + ;; ;; Set up for insertion of characters in this character set + ;; ;; when codes 0200 - 0377 are typed in. + ;; (setq nonascii-insert-offset nonascii-offset))) (if input-method (setq default-input-method input-method)) @@ -82,22 +84,9 @@ ;; If this is a Latin-N character set, set up syntax for it in ;; single-byte mode. We can't use require because the file ;; must be eval'd each time in case we change from one Latin-N to another. - (if (string-match "^Latin-\\([1-9]\\)$" language) - (load (downcase language) nil t))) - -;; (define-language-environment 'european -;; "European (for Latin-1 through Latin-5)" -;; (lambda () -;; (set-coding-category-system 'iso-8-designate 'iso-8859-1) -;; (set-coding-priority-list '(iso-8-designate iso-8-1)) -;; ;;(setq locale-coding-system 'no-conversion) ; iso-8859-1 -;; (set-default-buffer-file-coding-system 'no-conversion) ; iso-8859-1 -;; ;;(set-buffer-file-coding-system-for-read 'no-conversion) ; iso-8859-1 -;; ;;(setq display-coding-system 'iso-8859-1) -;; ;;(setq keyboard-coding-system 'iso-8859-1) -;; ;; (setq-default quail-current-package -;; ;; (assoc "latin-1" quail-package-alist)) -;; )) + ;; (if (string-match "^Latin-\\([1-9]\\)$" language) + ;; (load (downcase language) nil t)) + ) ;; Latin-1 (ISO-8859-1) @@ -130,6 +119,51 @@ Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. " . describe-european-environment-map)) )) + +(set-language-info-alist + "German" '((setup-function . (setup-latin1-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-1)) + (coding-system . (iso-8859-1)) + (tutorial . "TUTORIAL.de") + (sample-text + . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!") + (documentation . ("\ +These languages are supported with the Latin-1 (ISO-8859-1) character set: + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. +" . describe-european-environment-map)) + )) + +(set-language-info-alist + "French" '((setup-function . (setup-latin1-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-1)) + (coding-system . (iso-8859-1)) + (tutorial . "TUTORIAL.fr") + (sample-text + . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!") + (documentation . ("\ +These languages are supported with the Latin-1 (ISO-8859-1) character set: + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. +" . describe-european-environment-map)) + )) + +(set-language-info-alist + "Norwegian" '((setup-function . (setup-latin1-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-1)) + (coding-system . (iso-8859-1)) + (tutorial . "TUTORIAL.no") + (sample-text + . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!") + (documentation . ("\ +These languages are supported with the Latin-1 (ISO-8859-1) character set: + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish, and Swedish. +" . describe-european-environment-map)) + )) ;; Latin-2 (ISO-8859-2) @@ -165,9 +199,22 @@ (documentation . ("\ These languages are supported with the Latin-2 (ISO-8859-2) character set: Albanian, Czech, English, German, Hungarian, Polish, Romanian, - Serbo-Croatian or Croatian, Slovak, Slovene, and Swedish. + Serbian or Croatian, Slovak, Slovene, and Swedish. " . describe-european-environment-map)) )) + +(set-language-info-alist + "Croatian" '((setup-function . (setup-latin2-environment + . setup-european-environment-map)) + (charset . (ascii latin-iso8859-2)) + (tutorial . "TUTORIAL.hr") + (coding-system . (iso-8859-2)) + (documentation . ("\ +These languages are supported with the Latin-2 (ISO-8859-2) character set: + Albanian, Czech, English, German, Hungarian, Polish, Romanian, + Serbian or Croatian, Slovak, Slovene, and Swedish. +" . describe-european-environment-map)) + )) ;; Latin-3 (ISO-8859-3)
--- a/lisp/language/greek.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/greek.el Mon Aug 13 10:03:52 2007 +0200 @@ -71,8 +71,8 @@ (defun setup-greek-environment () "Setup multilingual environment (MULE) for Greek." (interactive) - (setup-8-bit-environment "Greek" 'greek-iso8859-7 'greek-iso-8bit - "greek")) + (setup-8-bit-environment "Greek" 'greek-iso8859-7 'iso-8859-7 "greek") + ) (set-language-info-alist "Greek" '((setup-function . setup-greek-environment)
--- a/lisp/language/hebrew.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/hebrew.el Mon Aug 13 10:03:52 2007 +0200 @@ -28,26 +28,64 @@ ;;; Code: +;; Syntax of Hebrew characters +(loop for c from 96 to 122 + do (modify-syntax-entry (make-char 'hebrew-iso8859-8 c) "w")) +(modify-syntax-entry (make-char 'hebrew-iso8859-8 32) "w") ; no-break space + + +;; (make-coding-system +;; 'hebrew-iso-8bit 2 ?8 +;; "ISO 2022 based 8-bit encoding for Hebrew (MIME:ISO-8859-8)" +;; '((ascii t) (hebrew-iso8859-8 t) nil nil +;; nil ascii-eol ascii-cntl nil nil nil nil nil t)) + +;; (define-coding-system-alias 'iso-8859-8 'hebrew-iso-8bit) + (make-coding-system - 'hebrew-iso-8bit 2 ?8 - "ISO 2022 based 8-bit encoding for Hebrew (MIME:ISO-8859-8)" - '((ascii t) (hebrew-iso8859-8 t) nil nil - nil ascii-eol ascii-cntl nil nil nil nil nil t)) + 'iso-8859-8 'iso2022 + "MIME ISO-8859-8" + '(charset-g0 ascii + charset-g1 hebrew-iso8859-8 + charset-g2 t + charset-g3 t + no-iso6429 t + mnemonic "MIME/Hbrw" +)) -(define-coding-system-alias 'iso-8859-8 'hebrew-iso-8bit) +(make-coding-system + 'ctext-hebrew 'iso2022 + "Coding-system of Hebrew." + '(charset-g0 ascii + charset-g1 hebrew-iso8859-8 + charset-g2 t + charset-g3 t + mnemonic "CText/Hbrw" + )) (defun setup-hebrew-environment () "Setup multilingual environment (MULE) for Hebrew. But, please note that right-to-left writing is not yet supported." (interactive) - (setup-8-bit-environment "Hebrew" 'hebrew-iso8859-8 'hebrew-iso-8bit - "hebrew")) + (setup-8-bit-environment "Hebrew" 'hebrew-iso8859-8 'iso-8859-8 + "hebrew") + (set-coding-category-system 'iso-8-designate 'iso-8859-8) + (set-coding-priority-list + '(iso-8-designate + iso-8-1 + iso-7 + iso-8-2 + iso-lock-shift + no-conversion + shift-jis + big5)) + ) (set-language-info-alist "Hebrew" '((setup-function . setup-hebrew-environment) (describe-function . describe-hebrew-support) (charset . (hebrew-iso8859-8)) - (coding-system . (hebrew-iso-8bit)) + (coding-system . (iso-8859-8)) (sample-text . "Hebrew ,Hylem(B") (documentation . "Right-to-left writing is not yet supported.") ))
--- a/lisp/language/indian.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,357 +0,0 @@ -;;; indian.el --- Support for Indian Languages - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp> - -;; Keywords: multilingual, Indian - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; History: -;; 1996.10.18 written by KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp> - -;; For Indian, the character set IS 13194 is supported. -;; -;; IS 13194 does not specifically assign glyphs for each characters. -;; Following code is not specific to each Indian language. -;; -;; Eventually, this code will support generic information about -;; following scripts. -;; -;; Devanagari -;; Bengali -;; Gurmukhi -;; Gujarati -;; Oriya -;; Tamil -;; Telgu -;; Kannada -;; Malayalam -;; -;; In this file, charsets other than charset-ascii and charset-indian-is13194 -;; should not be used except in the comment. - -;;; Code: - -(defun describe-indian-support () - "Describe how Emacs support Indian languages." - (interactive) - (describe-language-support-internal "Indian")) - -(set-language-info-alist - "Indian" '((describe-function . describe-indian-support) - (charset . (indian-is13194)) - (documentation . "\ -Among Indian languages, such languages using Devanagari scripts as -Hindi and Marathi are supproted. For them, please specify Devanagari -for more detail.") - )) - -;; Followings are what you see when you refer to the Emacs -;; representations of IS 13194 charcters. However, this is merely -;; tentative apperance, and you must convert them by -;; indian-to-xxxxxx(specific script) function to use them. -;; Devanagari is not an exception of this rule. - -;; 0xa0 //(5!"#$%&'()*+,-./(B -;; 0xb0 (50123456789:;<=>?(B -;; 0xc0 (5@ABCDEFGHIJKLMNO(B -;; 0xd0 (5PQRSTUVWXYZ[\]^_(B -;; 0xe0 (5`abcdefghijklmno(B -;; 0xf0 (5pqrstuvwxyz{|}~(B// - -;; Note - In IS 13194, several symbols are obtained by special -;; combination of several characters and Nukta sign. -;; -;; Sanskrit Vowel R -> (5*(B + (5i(B -;; Sanskrit Vowel L -> (5&(B + (5i(B -;; Sanskrit Vowel LL -> (5'(B + (5i(B -;; Sanskrit Avagrah -> (5j(B + (5i(B -;; OM -> (5!(B + (5i(B -;; -;; Note - IS 13194 defines ATR(0xEF) and EXT(0xF0), but they are -;; not used in Emacs. -;; -;; Note - the above characters DO NOT represent any script. For -;; example, if you want to obtain Devanagari character, you must do -;; something like the following. -;; -;; (char-to-string (indian-to-devanagari ?(5$(B)) -;; "$(5!$(B" - -(let ((deflist - '(;; chars syntax category - ("(5!"#(B" "w" ?7) ; vowel-modifying diacritical mark - ; chandrabindu, anuswar, visarga - ("(5$(B-(52(B" "w" ?5) ; independent vowel - ("(53(B-(5X(B" "w" ?0) ; consonant - ("(5Z(B-(5g(B" "w" ?8) ; matra - ("(5q(B-(5z(B" "w" ?6) ; digit - )) - elm chars len syntax category to ch i) - (while deflist - (setq elm (car deflist)) - (setq chars (car elm) - len (length chars) - syntax (nth 1 elm) - category (nth 2 elm) - i 0) - (while (< i len) - (if (= (aref chars i) ?-) - (setq i (1+ i) - to (sref chars i)) - (setq ch (sref chars i) - to ch)) - (while (<= ch to) - (modify-syntax-entry ch syntax) - (modify-category-entry ch category) - (setq ch (1+ ch))) - (setq i (+ i (char-bytes to)))) - (setq deflist (cdr deflist)))) - - -;;; ITRANS -;; -;; ITRANS is one of the most popular method to exchange indian scripts -;; electronically. Here is the table to convert between ITRANS code and -;; IS 13194 code. - -(defvar indian-itrans-consonant-alist - '( - ("k" . "(53(B") - ("kh" . "(54(B") - ("g" . "(55(B") - ("gh" . "(56(B") - ("N^" . "(57(B") - ("ch" . "(58(B") - ("chh" . "(59(B") - ("j" . "(5:(B") - ("jh" . "(5;(B") - ("JN" . "(5<(B") - ("T" . "(5=(B") - ("Th" . "(5>(B") - ("D" . "(5?(B") - ("Dh" . "(5@(B") - ("N" . "(5A(B") - ("t" . "(5B(B") - ("th" . "(5C(B") - ("d" . "(5D(B") - ("dh" . "(5E(B") - ("n" . "(5F(B") - ("nh" . "(5G(B") ; For transcription of non-Devanagari Languages. - ("p" . "(5H(B") - ("ph" . "(5I(B") - ("b" . "(5J(B") - ("bh" . "(5K(B") - ("m" . "(5L(B") - ("y" . "(5M(B") - ("yh" . "(5N(B") ; For transcription of non-Devanagari Languages. - ("r" . "(5O(B") - ("rh" . "(5P(B") ; For transcription of non-Devanagari Languages. - ("l" . "(5Q(B") - ("v" . "(5T(B") - ("sh" . "(5U(B") - ("shh" . "(5V(B") - ("s" . "(5W(B") - ("h" . "(5X(B") - ("ld" . "(5R(B") - ("L" . "(5R(B") - ("ksh" . "$(5!3!h!V(B") - ("GY" . "***GY***") ; Must check out later. - ;; special consonants - ("q" . "(53i(B") - ("K" . "(54i(B") - ("G" . "(55i(B") - ("z" . "(5:i(B") - ("f" . "(5Ii(B") - (".D" . "(5?i(B") - (".Dh" . "(5@i(B") - )) - -(defvar indian-itrans-vowel-sign-alist - '( - ;; Special treatment unique to IS 13194 Transliteration - ("" . "(5h(B") - ("a" . "") - ;; Matra (Vowel Sign) - ("aa" . "(5Z(B") - ("A" . "(5Z(B") - ("i" . "(5[(B") - ("ii" . "(5\(B") - ("I" . "(5\(B") - ("u" . "(5](B") - ("uu" . "(5^(B") - ("U" . "(5^(B") - ("R^i" . "(5_(B") ; These must be checked out later. - ("R^I" . "(5_i(B") - ("L^i" . "(5[i(B") - ("L^I" . "(5\i(B") - ("E" . "(5`(B") ; For transcription of non-Devanangri Languages. - ("e" . "(5a(B") - ("ai" . "(5b(B") - ;; ("e.c" . "(5c(B") ; Tentatively suppressed. - ("O" . "(5d(B") ; For transcription of non-Devanagari Languages. - ("o" . "(5e(B") - ("au" . "(5f(B") - ;; ("o.c" . "(5g(B") ; Tentatively suppressed. - )) - -;; -;; Independent vowels and other signs. -;; - -(defvar indian-itrans-other-letters-alist - '( - ("a" . "(5$(B") - ("aa" . "(5%(B") - ("A" . "(5%(B") - ("i" . "(5&(B") - ("ii" . "(5'(B") - ("I" . "(5'(B") - ("u" . "(5((B") - ("uu" . "(5)(B") - ("U" . "(5)(B") - ("R^i" . "(5*(B") - ("R^I" . "(5*i(B") - ("L^i" . "(5&i(B") - ("L^I" . "(5'i(B") - ("E" . "(5+(B") ; For transcription of non-Devanagari Languages. - ("e" . "(5,(B") - ("ai" . "(5-(B") - ;; ("e.c" . "(5.(B") ; Candra E - ("O" . "(5/(B") ; For transcription of non-Devanagari Languages. - ("o" . "(50(B") - ("au" . "(51(B") - ;; ("o.c" . "(52(B") ; Candra O - ("M" . "(5$(B") - ("H" . "(5#(B") - ("AUM" . "(5!i(B") - ("OM" . "(5!i(B") - (".r" . "(5Oh(B") - (".n" . "(5"(B") - (".N" . "(5!(B") - (".h" . "(5h(B") ; Halant - (".." . "(5j(B") - (".a" . "(5ji(B") ; Avagrah - ("0" . "(5q(B") - ("1" . "(5r(B") - ("2" . "(5s(B") - ("3" . "(5t(B") - ("4" . "(5u(B") - ("5" . "(5v(B") - ("6" . "(5w(B") - ("7" . "(5x(B") - ("8" . "(5y(B") - ("9" . "(5z(B") - )) - -;; Regular expression matching single Indian character represented -;; by ITRANS. - -(defvar indian-itrans-regexp - (let ((consonant "\\([cs]hh?\\)\\|[kgjTDnpbyr]h?\\|\\(N\\^?\\)\\|\\(jN\\)\\|[mvqKGzfs]\\|\\(ld?\\)\\|\\(ksh\\)\\|\\(GY\\)\\|\\(\\.Dh?\\)") - (vowel "\\(a[aiu]\\)\\|\\(ii\\)\\|\\(uu\\)\\|\\([RL]\\^[iI]\\)\\|[AIEOeoaiu]") - (misc "[MH0-9]\\|\\(AUM\\)\\|\\(OM\\)\\|\\(\\.[rnNh\\.a]\\)") - (lpre "\\(") (rpre "\\)") (orre "\\|")) - (concat lpre misc rpre orre - lpre lpre consonant rpre "?" lpre vowel rpre rpre orre - lpre consonant rpre ))) - -;; -;; Regular expression matching single ITRANS unit for IS 13194 characters. -;; - -(defvar itrans-indian-regexp - (let ((vowel "[(5$(B-(52(B]") - (consonant "[(53(B-(5X(B]") - (matra "[(5Z(B-(5g(B]") - (misc "[(5q(B-(5z(B]") - (lpre "\\(") (rpre "\\)") (orre "\\|")) - (concat misc orre - lpre consonant matra "?" rpre orre - vowel))) - -;; -;; IS13194 - ITRANS conversion table for string matching above regexp. -;; - -(defvar indian-itrans-alist - (let ((cl indian-itrans-consonant-alist) - (ml indian-itrans-other-letters-alist) rules) - (while cl - (let ((vl indian-itrans-vowel-sign-alist)) - (while vl - (setq rules - (cons (cons (concat (car (car cl)) (car (car vl))) - (concat (cdr (car cl)) (cdr (car vl)))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (cons (car (car ml)) - (cdr (car ml))) - rules)) - (setq ml (cdr ml))) - rules)) - -;; -;; Utility program to convert from ITRANS to IS 13194 in specified region. -;; - -(defun indian-decode-itrans-region (from to) - "Convert `ITRANS' mnemonics of the current region to Indian characters. -When called from a program, expects two arguments, -positions (integers or markers) specifying the stretch of the region." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward indian-itrans-regexp nil t) - (let* ((itrans (buffer-substring (match-beginning 0) (match-end 0))) - (ch (cdr (assoc itrans indian-itrans-alist)))) - (if ch - (progn - (delete-region (match-beginning 0) (match-end 0)) - (insert ch))))) - (goto-char (point-min)) - (while (re-search-forward "\\((5h(B\\)[^\\c0]" nil t) - (delete-region (match-beginning 1) (match-end 1))))) - -;; -;; Utility program to convert from IS 13194 to ITRANS in specified region. -;; - -(defun indian-encode-itrans-region (from to) - "Convert indian region to ITRANS mnemonics." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward itrans-indian-regexp nil t) - (let* ((indian (buffer-substring (match-beginning 0) (match-end 0))) - (ch (car (rassoc indian indian-itrans-alist)))) - (if ch - (progn - (delete-region (match-beginning 0) (match-end 0)) - (insert ch))))) - (goto-char (point-min)))) - -;;; indian.el ends here
--- a/lisp/language/japan-util.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/japan-util.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,29 +1,69 @@ ;;; japan-util.el --- utilities for Japanese -;; Copyright (C) 1995 Free Software Foundation, Inc. ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko ;; Keywords: mule, multilingual, Japanese -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by +;; XEmacs 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. -;; GNU Emacs 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. +;; XEmacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; 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. ;;; Code: +;;;###autoload +(defun setup-japanese-environment () + "Setup multilingual environment (MULE) for Japanese." + (interactive) + (setup-english-environment) + + ;; (setq coding-category-iso-8-2 'japanese-iso-8bit) + (set-coding-category-system 'iso-8-2 'euc-jp) + ;; (setq coding-category-iso-8-else 'japanese-iso-8bit) + + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-8-2 + ;; coding-category-sjis + ;; coding-category-iso-8-1 + ;; coding-category-iso-7-else + ;; coding-category-iso-8-else + ;; coding-category-emacs-mule)) + (set-coding-priority-list + '(iso-7 + iso-8-2 + shift-jis + iso-8-1 + iso-lock-shift + iso-8-designate + no-conversion + big5)) + + (set-default-coding-systems + (if (eq system-type 'ms-dos) + 'japanese-shift-jis + 'iso-2022-jp)) + + ;; (when (eq 'x (device-type (selected-device))) + ;; (x-use-halfwidth-roman-font 'japanese-jisx0208 "jisx0201")) + + ;; (setq default-input-method "japanese") + ) + (defconst japanese-kana-table '((?$B$"(B ?$B%"(B ?(I1(B) (?$B$$(B ?$B%$(B ?(I2(B) (?$B$&(B ?$B%&(B ?(I3(B) (?$B$((B ?$B%((B ?(I4(B) (?$B$*(B ?$B%*(B ?(I5(B) (?$B$+(B ?$B%+(B ?(I6(B) (?$B$-(B ?$B%-(B ?(I7(B) (?$B$/(B ?$B%/(B ?(I8(B) (?$B$1(B ?$B%1(B ?(I9(B) (?$B$3(B ?$B%3(B ?(I:(B) @@ -261,13 +301,9 @@ (defun read-hiragana-string (prompt &optional initial-input) "Read a Hiragana string from the minibuffer, prompting with string PROMPT. If non-nil, second arg INITIAL-INPUT is a string to insert before reading." - (read-multilingual-string prompt initial-input - "Japanese" "quail-ja-hiragana")) + (read-multilingual-string prompt initial-input "japanese-hiragana")) ;; -(provide 'language/japan-util) +(provide 'japan-util) -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: ;;; japan-util.el ends here
--- a/lisp/language/japanese.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/japanese.el Mon Aug 13 10:03:52 2007 +0200 @@ -227,42 +227,4 @@ (sample-text . "Japanese ($BF|K\8l(B) $B$3$s$K$A$O(B, (I:]FAJ(B") (documentation . t))) -;; for XEmacs (will be obsoleted) - -(define-language-environment 'japanese - "Japanese (includes JIS and EUC)" - (lambda () - (set-coding-category-system 'iso-7 'iso-2022-jp) - (set-coding-category-system 'iso-8-2 'euc-jp) - (set-coding-priority-list '(iso-7 iso-8-2 shift-jis no-conversion)) - ;;'(iso-8-2 iso-8-designate iso-8-1 shift-jis big5) - - ;; Added by mrb, who doesn't speak japanese - so be sceptical... - ;; (when (string-match "solaris\\|sunos" system-configuration) - ;;(set-native-coding-system 'euc-japan) ; someday - (set-pathname-coding-system 'euc-jp) - (add-hook 'comint-exec-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-input-coding-system proc 'euc-jp) - (set-process-output-coding-system proc 'euc-jp)))) - ;;(set-buffer-file-coding-system-for-read 'automatic-conversion) - (set-default-buffer-file-coding-system 'euc-jp) - (setq keyboard-coding-system 'euc-jp) - (setq terminal-coding-system 'euc-jp) - (when (eq 'x (device-type (selected-device))) - (x-use-halfwidth-roman-font 'japanese-jisx0208 "jisx0201")) - - (when (eq system-type 'ms-dos) - ;; Shift-JIS is the standard coding system under Japanese MS-DOS - ;; This isn't really code - just a hint to future implementors - (setq keyboard-coding-system 'shift_jis-dos) - (setq terminal-coding-system 'shift_jis-dos) - (set-default-buffer-file-coding-system 'shift_jis-dos) - ;;(set-default-process-coding-system 'shift_jis-dos 'shift_jis-dos) - ) - )) - -(set-coding-category-system 'shift-jis 'shift_jis) - ;;; japanese.el ends here
--- a/lisp/language/korean.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/korean.el Mon Aug 13 10:03:52 2007 +0200 @@ -105,15 +105,37 @@ "Setup multilingual environment (MULE) for Korean." (interactive) (setup-english-environment) - (setq coding-category-iso-8-2 'euc-kr) + ;; (setq coding-category-iso-8-2 'euc-kr) + (set-coding-category-system 'iso-8-2 'euc-kr) - (set-coding-priority - '(coding-category-iso-7 - coding-category-iso-8-2 - coding-category-iso-8-1)) + ;; (set-coding-priority + ;; '(coding-category-iso-7 + ;; coding-category-iso-8-2 + ;; coding-category-iso-8-1)) + (set-coding-priority-list + '(iso-8-2 + iso-7 + iso-8-1 + iso-8-designate + iso-lock-shift + no-conversion + shift-jis + big5)) (set-default-coding-systems 'euc-kr) + ;; (when (eq 'x (device-type (selected-device))) + ;; (x-use-halfwidth-roman-font 'korean-ksc5601 "ksc5636")) + + ;; EGG specific setup 97.02.05 jhod + (when (featurep 'egg) + (when (not (featurep 'egg-kor)) + (provide 'egg-kor) + (load "its/its-hangul") + (setq its:*standard-modes* + (cons (its:get-mode-map "hangul") its:*standard-modes*))) + (setq-default its:*current-map* (its:get-mode-map "hangul"))) + (setq default-input-method "korean-hangul")) (set-language-info-alist @@ -124,37 +146,4 @@ (sample-text . "Hangul ($(CGQ1[(B) $(C>H3gGO<<?d(B, $(C>H3gGO=J4O1n(B") (documentation . t))) -;;; for XEmacs (will be obsoleted) - -(define-language-environment 'korean - "Korean" - (lambda () - (set-coding-category-system 'iso-8-2 'euc-kr) - (set-coding-priority-list '(iso-8-2 iso-7 iso-8-designate)) - (set-pathname-coding-system 'euc-kr) - (add-hook 'comint-exec-hook - (lambda () - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-input-coding-system proc 'euc-kr) - (set-process-output-coding-system proc 'euc-kr)))) - (set-buffer-file-coding-system-for-read 'automatic-conversion) - (set-default-buffer-file-coding-system 'euc-kr) - (setq keyboard-coding-system 'euc-kr) - (setq terminal-coding-system 'euc-kr) - (when (eq 'x (device-type (selected-device))) - (x-use-halfwidth-roman-font 'korean-ksc5601 "ksc5636")) - - ;; EGG specific setup 97.02.05 jhod - (when (featurep 'egg) - (when (not (featurep 'egg-kor)) - (provide 'egg-kor) - (load "its/its-hangul") - (setq its:*standard-modes* - (cons (its:get-mode-map "hangul") its:*standard-modes*))) - (setq-default its:*current-map* (its:get-mode-map "hangul"))) - -;; ;; (setq-default quail-current-package -;; ;; (assoc "hangul" quail-package-alist)) - )) - ;;; korean.el ends here
--- a/lisp/language/lao-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -;;; lao-util.el --- utilities for Lao - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Lao - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;;###autoload -(defun setup-lao-environment () - "Setup multilingual environment (MULE) for Lao." - (interactive) - (setup-8-bit-environment "Lao" 'lao 'iso-2022-7bit - "lao")) - -(let ((l '((?(1!(B consonant "LETTER KOR KAI'" "CHICKEN") - (?(1"(B consonant "LETTER KHOR KHAI'" "EGG") - (?(1#(B invalid nil) - (?(1$(B consonant "LETTER QHOR QHWARGN" "BUFFALO") - (?(1%(B invalid nil) - (? invalid nil) - (?(1'(B consonant "LETTER NGOR NGUU" "SNAKE") - (?(1((B consonant "LETTER JOR JUA" "BUDDHIST NOVICE") - (?(1)(B invalid nil) - (?(1*(B consonant "LETTER XOR X\"ARNG" "ELEPHANT") - (?(1+(B invalid nil) - (?(1,(B invalid nil) - (?(1-(B consonant "LETTER YOR YUNG" "MOSQUITO") - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(1.(B invalid nil) - (?(14(B consonant "LETTER DOR DANG" "NOSE") - (?(15(B consonant "LETTER TOR TAR" "EYE") - (?(16(B consonant "LETTER THOR THUNG" "TO ASK,QUESTION") - (?(17(B consonant "LETTER DHOR DHARM" "FLAG") - (?(18(B invalid nil) - (?(19(B consonant "LETTER NOR NOK" "BIRD") - (?(1:(B consonant "LETTER BOR BED" "FISHHOOK") - (?(1;(B consonant "LETTER POR PAR" "FISH") - (?(1<(B consonant "LETTER HPOR HPER\"" "BEE") - (?(1=(B consonant "LETTER FHOR FHAR" "WALL") - (?(1>(B consonant "LETTER PHOR PHUU" "MOUNTAIN") - (?(1?(B consonant "LETTER FOR FAI" "FIRE") - (?(1@(B invalid nil) - (?(1A(B consonant "LETTER MOR MAR\"" "HORSE") - (?(1B(B consonant "LETTER GNOR GNAR" "MEDICINE") - (?(1C(B consonant "LETTER ROR ROD" "CAR") - (?(1D(B invalid nil) - (?(1E(B consonant "LETTER LOR LIING" "MONKEY") - (?(1F(B invalid nil) - (?(1G(B consonant "LETTER WOR WII" "HAND FAN") - (?(1H(B invalid nil) - (?(1I(B invalid nil) - (?(1J(B consonant "LETTER SOR SEA" "TIGER") - (?(1K(B consonant "LETTER HHOR HHAI" "JAR") - (?(1L(B invalid nil) - (?(1M(B consonant "LETTER OR OOW" "TAKE") - (?(1N(B consonant "LETTER HOR HEA" "BOAT") - (?(1O(B special "ELLIPSIS") - (?(1P(B vowel-base "VOWEL SIGN SARA A") - (?(1Q(B vowel-upper "VOWEL SIGN MAI KAN") - (?(1R(B vowel-base "VOWEL SIGN SARA AR") - (?(1S(B vowel-base "VOWEL SIGN SARA AM") - (?(1T(B vowel-upper "VOWEL SIGN SARA I") - (?(1U(B vowel-upper "VOWEL SIGN SARA II") - (?(1V(B vowel-upper "VOWEL SIGN SARA EU") - (?(1W(B vowel-upper "VOWEL SIGN SARA UR") - (?(1X(B vowel-lower "VOWEL SIGN SARA U") - (?(1Y(B vowel-lower "VOWEL SIGN SARA UU") - (?(1Z(B invalid nil) - (?(1[(B vowel-upper "VOWEL SIGN MAI KONG") - (?(1\(B semivowel-lower "SEMIVOWEL SIGN LO") - (?(1](B vowel-base "SEMIVOWEL SIGN SARA IA") - (?(1^(B invalid nil) - (?(1_(B invalid nil) - (?(1`(B vowel-base "VOWEL SIGN SARA EE") - (?(1a(B vowel-base "VOWEL SIGN SARA AA") - (?(1b(B vowel-base "VOWEL SIGN SARA OO") - (?(1c(B vowel-base "VOWEL SIGN SARA EI MAI MUAN\"") - (?(1d(B vowel-base "VOWEL SIGN SARA AI MAI MAY") - (?(1e(B invalid nil) - (?(1f(B special "KO LA (REPETITION)") - (?(1g(B invalid nil) - (?(1h(B tone "TONE MAI EK") - (?(1i(B tone "TONE MAI THO") - (?(1j(B tone "TONE MAI TI") - (?(1k(B tone "TONE MAI JADTAWAR") - (?(1l(B tone "CANCELLATION MARK") - (?(1m(B vowel-upper "VOWEL SIGN SARA OR") - (?(1n(B invalid nil) - (?(1o(B invalid nil) - (?(1p(B special "DIGIT ZERO") - (?(1q(B special "DIGIT ONE") - (?(1r(B special "DIGIT TWO") - (?(1s(B special "DIGIT THREE") - (?(1t(B special "DIGIT FOUR") - (?(1u(B special "DIGIT FIVE") - (?(1v(B special "DIGIT SIX") - (?(1w(B special "DIGIT SEVEN") - (?(1x(B special "DIGIT EIGHT") - (?(1y(B special "DIGIT NINE") - (?(1z(B invalid nil) - (?(1{(B invalid nil) - (?(1|(B consonant "LETTER NHOR NHUU" "MOUSE") - (?(1}(B consonant "LETTER MHOR MHAR" "DOG") - (?(1~(B invalid nil) - )) - elm) - (while l - (setq elm (car l)) - (put-char-code-property (car elm) 'phonetic-type (car (cdr elm))) - (put-char-code-property (car elm) 'name (nth 2 elm)) - (put-char-code-property (car elm) 'meaning (nth 3 elm)) - (setq l (cdr l)))) - -;; -(provide 'lao-util) - -;;; lao-util.el ends here
--- a/lisp/language/lao.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -;;; lao.el --- Support for Lao - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Lao - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(make-coding-system - 'lao 2 ?L - "8-bit encoding for ASCII (MSB=0) and LAO (MSB=1)" - '((ascii t) (lao t) nil nil - nil ascii-eol)) - -(set-language-info-alist - "Lao" '((setup-function . setup-lao-environment) - (charset . (lao)) - (coding-system . (lao)) - (sample-text . "Lao((1>RJRERG(B) (1JP:R-04U1(B, 0(1"i1M-`0;Q190$[19ERG(B") - (documentation . t))) - -(aset use-default-ascent ?(1;(B t) -(aset use-default-ascent ?(1=(B t) -(aset use-default-ascent ?(1?(B t) -(aset use-default-ascent ?(1B(B t) -(aset ignore-relative-composition ?(1\(B t) - -;;; lao.el ends here
--- a/lisp/language/thai-util.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/thai-util.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,324 +0,0 @@ -;;; thai-util.el --- utilities for Thai - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: mule, multilingual, thai - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;;; Code: - -;; Setting information of Thai characters. - -;; (let ((l '((?,T!(B consonant "LETTER KO KAI") ; 0xA1 -;; (?,T"(B consonant "LETTER KHO KHAI") ; 0xA2 -;; (?,T#(B consonant "LETTER KHO KHUAT") ; 0xA3 -;; (?,T$(B consonant "LETTER KHO KHWAI") ; 0xA4 -;; (?,T%(B consonant "LETTER KHO KHON") ; 0xA5 -;; (?,T&(B consonant "LETTER KHO RAKHANG") ; 0xA6 -;; (?,T'(B consonant "LETTER NGO NGU") ; 0xA7 -;; (?,T((B consonant "LETTER CHO CHAN") ; 0xA8 -;; (?,T)(B consonant "LETTER CHO CHING") ; 0xA9 -;; (?,T*(B consonant "LETTER CHO CHANG") ; 0xAA -;; (?,T+(B consonant "LETTER SO SO") ; 0xAB -;; (?,T,(B consonant "LETTER CHO CHOE") ; 0xAC -;; (?,T-(B consonant "LETTER YO YING") ; 0xAD -;; (?,T.(B consonant "LETTER DO CHADA") ; 0xAE -;; (?,T/(B consonant "LETTER TO PATAK") ; 0xAF -;; (?,T0(B consonant "LETTER THO THAN") ; 0xB0 -;; (?,T1(B consonant "LETTER THO NANGMONTHO") ; 0xB1 -;; (?,T2(B consonant "LETTER THO PHUTHAO") ; 0xB2 -;; (?,T3(B consonant "LETTER NO NEN") ; 0xB3 -;; (?,T4(B consonant "LETTER DO DEK") ; 0xB4 -;; (?,T5(B consonant "LETTER TO TAO") ; 0xB5 -;; (?,T6(B consonant "LETTER THO THUNG") ; 0xB6 -;; (?,T7(B consonant "LETTER THO THAHAN") ; 0xB7 -;; (?,T8(B consonant "LETTER THO THONG") ; 0xB8 -;; (?,T9(B consonant "LETTER NO NU") ; 0xB9 -;; (?,T:(B consonant "LETTER BO BAIMAI") ; 0xBA -;; (?,T;(B consonant "LETTER PO PLA") ; 0xBB -;; (?,T<(B consonant "LETTER PHO PHUNG") ; 0xBC -;; (?,T=(B consonant "LETTER FO FA") ; 0xBD -;; (?,T>(B consonant "LETTER PHO PHAN") ; 0xBE -;; (?,T?(B consonant "LETTER FO FAN") ; 0xBF -;; (?,T@(B consonant "LETTER PHO SAMPHAO") ; 0xC0 -;; (?,TA(B consonant "LETTER MO MA") ; 0xC1 -;; (?,TB(B consonant "LETTER YO YAK") ; 0xC2 -;; (?,TC(B consonant "LETTER RO RUA") ; 0xC3 -;; (?,TD(B vowel-base "LETTER RU (Pali vowel letter)") ; 0xC4 -;; (?,TE(B consonant "LETTER LO LING") ; 0xC5 -;; (?,TF(B vowel-base "LETTER LU (Pali vowel letter)") ; 0xC6 -;; (?,TG(B consonant "LETTER WO WAEN") ; 0xC7 -;; (?,TH(B consonant "LETTER SO SALA") ; 0xC8 -;; (?,TI(B consonant "LETTER SO RUSI") ; 0xC9 -;; (?,TJ(B consonant "LETTER SO SUA") ; 0xCA -;; (?,TK(B consonant "LETTER HO HIP") ; 0xCB -;; (?,TL(B consonant "LETTER LO CHULA") ; 0xCC -;; (?,TM(B consonant "LETTER O ANG") ; 0xCD -;; (?,TN(B consonant "LETTER HO NOK HUK") ; 0xCE -;; (?,TO(B special "PAI YAN NOI (abbreviation)") ; 0xCF -;; (?,TP(B vowel-base "VOWEL SIGN SARA A") ; 0xD0 -;; (?,TQ(B vowel-upper "VOWEL SIGN MAI HAN-AKAT N/S-T") ; 0xD1 -;; (?,TR(B vowel-base "VOWEL SIGN SARA AA") ; 0xD2 -;; (?,TS(B vowel-base "VOWEL SIGN SARA AM") ; 0xD3 -;; (?,TT(B vowel-upper "VOWEL SIGN SARA I N/S-T") ; 0xD4 -;; (?,TU(B vowel-upper "VOWEL SIGN SARA II N/S-T") ; 0xD5 -;; (?,TV(B vowel-upper "VOWEL SIGN SARA UE N/S-T") ; 0xD6 -;; (?,TW(B vowel-upper "VOWEL SIGN SARA UEE N/S-T") ; 0xD7 -;; (?,TX(B vowel-lower "VOWEL SIGN SARA U N/S-B") ; 0xD8 -;; (?,TY(B vowel-lower "VOWEL SIGN SARA UU N/S-B") ; 0xD9 -;; (?,TZ(B vowel-lower "VOWEL SIGN PHINTHU N/S-B (Pali virama)") ; 0xDA -;; (?,T[(B invalid nil) ; 0xDA -;; (?,T\(B invalid nil) ; 0xDC -;; (?,T](B invalid nil) ; 0xDC -;; (?,T^(B invalid nil) ; 0xDC -;; (?,T_(B special "BAHT SIGN (currency symbol)") ; 0xDF -;; (?,T`(B vowel-base "VOWEL SIGN SARA E") ; 0xE0 -;; (?,Ta(B vowel-base "VOWEL SIGN SARA AE") ; 0xE1 -;; (?,Tb(B vowel-base "VOWEL SIGN SARA O") ; 0xE2 -;; (?,Tc(B vowel-base "VOWEL SIGN SARA MAI MUAN") ; 0xE3 -;; (?,Td(B vowel-base "VOWEL SIGN SARA MAI MALAI") ; 0xE4 -;; (?,Te(B vowel-base "LAK KHANG YAO") ; 0xE5 -;; (?,Tf(B special "MAI YAMOK (repetion)") ; 0xE6 -;; (?,Tg(B vowel-upper "VOWEL SIGN MAI TAI KHU N/S-T") ; 0xE7 -;; (?,Th(B tone "TONE MAI EK N/S-T") ; 0xE8 -;; (?,Ti(B tone "TONE MAI THO N/S-T") ; 0xE9 -;; (?,Tj(B tone "TONE MAI TRI N/S-T") ; 0xEA -;; (?,Tk(B tone "TONE MAI CHATTAWA N/S-T") ; 0xEB -;; (?,Tl(B tone "THANTHAKHAT N/S-T (cancellation mark)") ; 0xEC -;; (?,Tm(B tone "NIKKHAHIT N/S-T (final nasal)") ; 0xED -;; (?,Tn(B vowel-upper "YAMAKKAN N/S-T") ; 0xEE -;; (?,To(B special "FONRMAN") ; 0xEF -;; (?,Tp(B special "DIGIT ZERO") ; 0xF0 -;; (?,Tq(B special "DIGIT ONE") ; 0xF1 -;; (?,Tr(B special "DIGIT TWO") ; 0xF2 -;; (?,Ts(B special "DIGIT THREE") ; 0xF3 -;; (?,Tt(B special "DIGIT FOUR") ; 0xF4 -;; (?,Tu(B special "DIGIT FIVE") ; 0xF5 -;; (?,Tv(B special "DIGIT SIX") ; 0xF6 -;; (?,Tw(B special "DIGIT SEVEN") ; 0xF7 -;; (?,Tx(B special "DIGIT EIGHT") ; 0xF8 -;; (?,Ty(B special "DIGIT NINE") ; 0xF9 -;; (?,Tz(B special "ANGKHANKHU (ellipsis)") ; 0xFA -;; (?,T{(B special "KHOMUT (beginning of religious texts)") ; 0xFB -;; (?,T|(B invalid nil) ; 0xFC -;; (?,T}(B invalid nil) ; 0xFD -;; (?,T~(B invalid nil) ; 0xFE -;; )) -;; elm) -;; (while l -;; (setq elm (car l)) -;; (put-char-code-property (car elm) 'phonetic-type (car (cdr elm))) -;; (put-char-code-property (car elm) 'name (nth 2 elm)) -;; (setq l (cdr l)))) - -(defconst thai-character-alist - '((?,T!(B . consonant) ; 0xA1: LETTER KO KAI - (?,T"(B . consonant) ; 0xA2: LETTER KHO KHAI - (?,T#(B . consonant) ; 0xA3: LETTER KHO KHUAT (obsolete) - (?,T$(B . consonant) ; 0xA4: LETTER KHO KHWAI - (?,T%(B . consonant) ; 0xA5: LETTER KHO KHON (obsolete) - (?,T&(B . consonant) ; 0xA6: LETTER KHO RAKHANG - (?,T'(B . consonant) ; 0xA7: LETTER NGO NGU - (?,T((B . consonant) ; 0xA8: LETTER CHO CHAN - (?,T)(B . consonant) ; 0xA9: LETTER CHO CHING - (?,T*(B . consonant) ; 0xAA: LETTER CHO CHANG - (?,T+(B . consonant) ; 0xAB: LETTER SO SO - (?,T,(B . consonant) ; 0xAC: LETTER CHO CHOE - (?,T-(B . consonant) ; 0xAD: LETTER YO YING - (?,T.(B . consonant) ; 0xAE: LETTER DO CHADA - (?,T/(B . consonant) ; 0xAF: LETTER TO PATAK - (?,T0(B . consonant) ; 0xB0: LETTER THO THAN - (?,T1(B . consonant) ; 0xB1: LETTER THO NANGMONTHO - (?,T2(B . consonant) ; 0xB2: LETTER THO PHUTHAO - (?,T3(B . consonant) ; 0xB3: LETTER NO NEN - (?,T4(B . consonant) ; 0xB4: LETTER DO DEK - (?,T5(B . consonant) ; 0xB5: LETTER TO TAO - (?,T6(B . consonant) ; 0xB6: LETTER THO THUNG - (?,T7(B . consonant) ; 0xB7: LETTER THO THAHAN - (?,T8(B . consonant) ; 0xB8: LETTER THO THONG - (?,T9(B . consonant) ; 0xB9: LETTER NO NU - (?,T:(B . consonant) ; 0xBA: LETTER BO BAIMAI - (?,T;(B . consonant) ; 0xBB: LETTER PO PLA - (?,T<(B . consonant) ; 0xBC: LETTER PHO PHUNG - (?,T=(B . consonant) ; 0xBD: LETTER FO FA - (?,T>(B . consonant) ; 0xBE: LETTER PHO PHAN - (?,T?(B . consonant) ; 0xBF: LETTER FO FAN - (?,T@(B . consonant) ; 0xC0: LETTER PHO SAMPHAO - (?,TA(B . consonant) ; 0xC1: LETTER MO MA - (?,TB(B . consonant) ; 0xC2: LETTER YO YAK - (?,TC(B . consonant) ; 0xC3: LETTER RO RUA - (?,TD(B . vowel-base) ; 0xC4: LETTER RU (vowel letter used to write Pali) - (?,TE(B . consonant) ; 0xC5: LETTER LO LING - (?,TF(B . vowel-base) ; 0xC6: LETTER LU (vowel letter used to write Pali) - (?,TG(B . consonant) ; 0xC7: LETTER WO WAEN - (?,TH(B . consonant) ; 0xC8: LETTER SO SALA - (?,TI(B . consonant) ; 0xC9: LETTER SO RUSI - (?,TJ(B . consonant) ; 0xCA: LETTER SO SUA - (?,TK(B . consonant) ; 0xCB: LETTER HO HIP - (?,TL(B . consonant) ; 0xCC: LETTER LO CHULA - (?,TM(B . consonant) ; 0xCD: LETTER O ANG - (?,TN(B . consonant) ; 0xCE: LETTER HO NOK HUK - (?,TO(B . special) ; 0xCF: PAI YAN NOI (abbreviation) - (?,TP(B . vowel-base) ; 0xD0: VOWEL SIGN SARA A - (?,TQ(B . vowel-upper) ; 0xD1: VOWEL SIGN MAI HAN-AKAT N/S-T - (?,TR(B . vowel-base) ; 0xD2: VOWEL SIGN SARA AA - (?,TS(B . vowel-base) ; 0xD3: VOWEL SIGN SARA AM - (?,TT(B . vowel-upper) ; 0xD4: VOWEL SIGN SARA I N/S-T - (?,TU(B . vowel-upper) ; 0xD5: VOWEL SIGN SARA II N/S-T - (?,TV(B . vowel-upper) ; 0xD6: VOWEL SIGN SARA UE N/S-T - (?,TW(B . vowel-upper) ; 0xD7: VOWEL SIGN SARA UEE N/S-T - (?,TX(B . vowel-lower) ; 0xD8: VOWEL SIGN SARA U N/S-B - (?,TY(B . vowel-lower) ; 0xD9: VOWEL SIGN SARA UU N/S-B - (?,TZ(B . vowel-lower) ; 0xDA: VOWEL SIGN PHINTHU N/S-B (Pali virama) - (?,T[(B . not-used) ; 0xDA: - (?,T\(B . not-used) ; 0xDC: - (?,T](B . not-used) ; 0xDC: - (?,T^(B . not-used) ; 0xDC: - (?,T_(B . special) ; 0xDF: BAHT SIGN (currency symbol) - (?,T`(B . vowel-base) ; 0xE0: VOWEL SIGN SARA E - (?,Ta(B . vowel-base) ; 0xE1: VOWEL SIGN SARA AE - (?,Tb(B . vowel-base) ; 0xE2: VOWEL SIGN SARA O - (?,Tc(B . vowel-base) ; 0xE3: VOWEL SIGN SARA MAI MUAN - (?,Td(B . vowel-base) ; 0xE4: VOWEL SIGN SARA MAI MALAI - (?,Te(B . vowel-base) ; 0xE5: LAK KHANG YAO - (?,Tf(B . special) ; 0xE6: MAI YAMOK (repetion) - (?,Tg(B . vowel-upper) ; 0xE7: VOWEL SIGN MAI TAI KHU N/S-T - (?,Th(B . tone) ; 0xE8: TONE MAI EK N/S-T - (?,Ti(B . tone) ; 0xE9: TONE MAI THO N/S-T - (?,Tj(B . tone) ; 0xEA: TONE MAI TRI N/S-T - (?,Tk(B . tone) ; 0xEB: TONE MAI CHATTAWA N/S-T - (?,Tl(B . tone) ; 0xEC: THANTHAKHAT N/S-T (cancellation mark) - (?,Tm(B . tone) ; 0xED: NIKKHAHIT N/S-T (final nasal) - (?,Tn(B . vowel-upper) ; 0xEE: YAMAKKAN N/S-T - (?,To(B . special) ; 0xEF: FONRMAN - (?,Tp(B . special) ; 0xF0: DIGIT ZERO - (?,Tq(B . special) ; 0xF1: DIGIT ONE - (?,Tr(B . special) ; 0xF2: DIGIT TWO - (?,Ts(B . special) ; 0xF3: DIGIT THREE - (?,Tt(B . special) ; 0xF4: DIGIT FOUR - (?,Tu(B . special) ; 0xF5: DIGIT FIVE - (?,Tv(B . special) ; 0xF6: DIGIT SIX - (?,Tw(B . special) ; 0xF7: DIGIT SEVEN - (?,Tx(B . special) ; 0xF8: DIGIT EIGHT - (?,Ty(B . special) ; 0xF9: DIGIT NINE - (?,Tz(B . special) ; 0xFA: ANGKHANKHU (ellipsis) - (?,T{(B . special) ; 0xFB: KHOMUT (beginning of religious texts) - (?,T|(B . not-used) ; 0xFC: - (?,T}(B . not-used) ; 0xFD: - (?,T~(B . not-used) ; 0xFE: - ) - "Association list of thai-character and property.") -(setq thai-character-alist - (cons (cons (string-to-char "0,TQi1(B") 'vowel-upper-tone) - thai-character-alist)) - -(defconst thai-category-table - (copy-category-table (standard-category-table)) - "Category table for Thai.") -(define-category-mnemonic ?0 "Thai consonants" - thai-category-table) -(define-category-mnemonic ?1 "Thai upper/lower vowel or tone mark." - thai-category-table) -(define-category-mnemonic ?2 "Thai base vowel or special characters." - thai-category-table) - -(let ((chars thai-character-alist) - ch prop) - (while chars - (setq ch (car (car chars)) - prop (cdr (car chars))) - (cond ((eq prop 'consonant) - (modify-category-entry ch ?0 thai-category-table)) - ((or (eq prop 'vowel-upper) - (eq prop 'vowel-lower) - (eq prop 'tone)) - (modify-category-entry ch ?1 thai-category-table)) - ((null (eq prop 'vowel-upper-tone)) - (modify-category-entry ch ?2 thai-category-table))) - (setq chars (cdr chars)))) - -;; ;;;###autoload -;; (defun thai-compose-region (beg end) -;; "Compose Thai characters in the region. -;; When called from a program, expects two arguments, -;; positions (integers or markers) specifying the region." -;; (interactive "r") -;; (save-restriction -;; (narrow-to-region beg end) -;; (decompose-region (point-min) (point-max)) -;; (goto-char (point-min)) -;; (while (re-search-forward "\\c0\\(\\c2\\|\\c3\\|\\c4\\)+" nil t) -;; (if (aref (char-category-set (char-after (match-beginning 0))) ?t) -;; (compose-region (match-beginning 0) (match-end 0)))))) - -;;;###autoload -(defun thai-compose-region (beg end) - "Compose Thai characters in the region." - (interactive "r") - (save-restriction - (narrow-to-region beg end) - (decompose-region (point-min) (point-max)) - (goto-char (point-min)) - (let ((ctbl (category-table)) - str) - (unwind-protect - (progn - (set-category-table thai-category-table) - (while (re-search-forward "\\c0\\c1+" nil t) - (compose-region (match-beginning 0) (match-end 0)))) - (set-category-table ctbl))))) - -;;;###autoload -(defun thai-compose-buffer () - "Compose Thai characters in the current buffer." - (interactive) - (thai-compose-region (point-min) (point-max))) - -;; ;;;###autoload -;; (defun thai-post-read-conversion (len) -;; (save-excursion -;; (save-restriction -;; (let ((buffer-modified-p (buffer-modified-p))) -;; (narrow-to-region (point) (+ (point) len)) -;; (thai-compose-region (point-min) (point-max)) -;; (set-buffer-modified-p buffer-modified-p) -;; (- (point-max) (point-min)))))) - -;; ;;;###autoload -;; (defun thai-pre-write-conversion (from to) -;; (let ((old-buf (current-buffer)) -;; (work-buf (get-buffer-create " *thai-work*"))) -;; (set-buffer work-buf) -;; (erase-buffer) -;; (if (stringp from) -;; (insert from) -;; (insert-buffer-substring old-buf from to)) -;; (decompose-region (point-min) (point-max)) -;; ;; Should return nil as annotations. -;; nil)) - -;; -(provide 'language/thai-util) - -;;; Local Variables: -;;; generated-autoload-file: "../loaddefs.el" -;;; End: -;;; thai-util.el ends here
--- a/lisp/language/thai.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/thai.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,70 +0,0 @@ -;;; thai.el --- Support for Thai - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Keywords: multilingual, Thai - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;;; Commentary: - -;; For Thai, the character set TIS620 is supported. - -;;; Code: - -(define-language-environment 'thai - "Thai" - (lambda () - (set-coding-category-system 'iso-8-designate 'tis620) - (set-coding-priority-list '(iso-8-designate iso-8-1)) - (set-default-buffer-file-coding-system 'tis620) - ;; (setq-default quail-current-package (assoc "thai" quail-package-alist)) - )) - -;; (make-coding-system -;; 'th-tis620 2 ?T -;; "Coding-system used for ASCII(MSB=0) & TIS620(MSB=1)." -;; '((ascii t) (thai-tis620 t) nil nil -;; nil ascii-eol)) -;; (put 'th-tis620 'post-read-conversion 'thai-post-read-conversion) -;; (put 'th-tis620 'pre-write-conversion 'thai-pre-write-conversion) - -(make-coding-system - 'tis620 'iso2022 - "Coding-system used for ASCII(MSB=0) & TIS620(MSB=1)." - '(charset-g0 ascii - charset-g1 thai-tis620 - no-ascii-cntl t - mnemonic "TIS620" - post-read-conversion thai-compose-region - pre-write-conversion decompose-region - )) - -;;(define-coding-system-alias 'th-tis620 'tis620) - -(set-language-info-alist - "Thai" '((tutorial . "TUTORIAL.th") - (setup-function . setup-thai-environment) - (charset . (thai-tis620)) - (coding-system . (tis620)) - (sample-text . "Thai (,T@RIRd7B(B) ,TJ0GQ1J04U1$0CQ1:(B, ,TJ0GQ1J04U10$h1P(B") - (documentation . t))) - -;;; thai.el ends here
--- a/lisp/language/tibet-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,468 +0,0 @@ -;;; tibet-util.el --- Support for inputting Tibetan characters - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Tibetan - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch> - -;; Created: Feb. 17. 1997 - -;; History: -;; 1997.03.13 Modification in treatment of text properties; -;; Support for some special signs and punctuations. - -;;; Code: - -;;;###autoload -(defun setup-tibetan-environment () - (interactive) - (setup-english-environment) - (setq coding-category-iso-8-2 'tibetan) - - (setq-default buffer-file-coding-system 'iso-2022-7bit) - - (setq default-input-method "tibetan-wylie")) - -;;; This function makes a transcription string for -;;; re-composing a character. - -;;;###autoload -(defun tibetan-tibetan-to-transcription (ch) - "Return a transcription string of Tibetan character CH" - (let ((char ch) - (l (append tibetan-consonant-transcription-alist - tibetan-vowel-transcription-alist - tibetan-precomposed-transcription-alist - tibetan-subjoined-transcription-alist)) - decomp-l t-char trans str result) - (if (eq (char-charset char) 'composition) - (setq decomp-l (decompose-composite-char char 'list nil)) - (setq decomp-l (cons char nil))) - (setq str "") - (while decomp-l - (setq t-char (char-to-string (car decomp-l))) - (setq trans (car (rassoc t-char l))) - (setq str (concat str trans)) - (setq decomp-l (cdr decomp-l))) - (setq result str))) - -;;; This function translates transcription string into a string of -;;; Tibetan characters. - -;;;###autoload -(defun tibetan-transcription-to-tibetan (transcription) - "Translate Roman transcription into a sequence of Tibetan components." - (let ((trans transcription) - (lp tibetan-precomposed-transcription-alist) - (l (append tibetan-consonant-transcription-alist - tibetan-vowel-transcription-alist - tibetan-subjoined-transcription-alist)) - (case-fold-search nil) - substr t-char p-str t-str result) - (setq substr "") - (setq p-str "") - (setq t-str "") - (cond ((string-match tibetan-precomposed-regexp trans) - (setq substr (substring trans (match-beginning 0) (match-end 0))) - (setq trans (substring trans (match-end 0))) - (setq t-char (cdr (assoc substr lp))) - (setq p-str t-char))) - (while (string-match tibetan-regexp trans) - (setq substr (substring trans (match-beginning 0) (match-end 0))) - (setq trans (substring trans 0 (match-beginning 0))) - (setq t-char - (cdr (assoc substr l))) - (setq t-str (concat t-char t-str))) - (setq result (concat p-str t-str)))) - - -;;; -;;; Functions for composing Tibetan character. -;;; -;;; A Tibetan syllable is typically structured as follows: -;;; -;;; [Prefix] C [C+] V [M] [Suffix [Post suffix]] -;;; -;;; where C's are all vertically stacked, V appears below or above -;;; consonant cluster and M is always put above the C[C+]V combination. -;;; (Sanskrit visarga, though it is a vowel modifier, is considered -;;; to be a punctuation.) -;;; -;;; Here are examples of the words "bsgrubs" and "h'uM" -;;; -;;; $(7"72%q`"U1"7"G(B 2$(7"H`#A`"U0"_1(B -;;; -;;; M -;;; b s b s h -;;; g ' -;;; r u -;;; u -;;; -;;; Consonants ''', 'w', 'y', 'r' take special forms when they are used -;;; as subjoined consonant. Consonant 'r' takes another special form -;;; when used as superjoined as in "rka", and so on, while it does not -;;; change its form when conjoined with subjoined ''', 'w' or 'y' -;;; as in "rwa", "rya". -;;; -;;; -;;; As a Tibetan input method should avoid using conversion key, -;;; we use a "Tibetan glyph -> transcription -> Tibetan glyph" -;;; translation at each key input. -;;; -;;; 1st stage - Check the preceding char. -;;; If the preceding char is Tibetan and composable, then -;;; -;;; 2nd stage - Translate the preceding char into transcription -;;; -;;; 3rd stage - Concatenate the transcription of preceding char -;;; and the current input key. -;;; -;;; 4th stage - Re-translate the concatenated transcription into -;;; a sequence of Tibetan letters. -;;; -;;; 5th stage - Convert leading consonants into one single precomposed char -;;; if possible. -;;; -;;; 6th stage - Compose the consonants into one composite glyph. -;;; -;;; (If the current input is a vowel sign or a vowel modifier, -;;; then it is composed with preceding char without checking -;;; except when the preceding char is a punctuation or a digit.) -;;; -;;; - -;;; This function is used to avoid composition -;;; between Tibetan and non-Tibetan chars. - -;;;###autoload -(defun tibetan-char-examin (ch) - "Check if char CH is Tibetan character. -Returns non-nil if CH is Tibetan. Otherwise, returns nil." - (let ((chr ch)) - (if (eq (char-charset chr) 'composition) - (string-match "\\cq+" (decompose-composite-char chr)) - (string-match "\\cq" (char-to-string chr))))) - -;;; This is used to avoid composition between digits, signs, punctuations -;;; and word constituents. - -;;;###autoload -(defun tibetan-composable-examin (ch) - "Check if Tibetan char CH is composable. -Returns t if CH is a composable char \(i.e. neither punctuation nor digit)." - (let ((chr ch) - chstr) - (if (eq (char-charset chr) 'composition) - (setq chstr (decompose-composite-char chr)) - (setq chstr (char-to-string chr))) - (not (string-match "[$(7!1(B-$(7!o"f$(8!;!=!?!@!A!D"`(B]" chstr)))) - - -;;; This checks if a character to be composed contains already -;;; one or more vowels / vowel modifiers. If the character contains -;;; them, then no more consonant should be added. - -;;;###autoload -(defun tibetan-complete-char-examin (ch) - "Check if composite char CH contains one or more vowel/vowel modifiers. -Returns non-nil, if CH contains vowel/vowel modifiers." - (let ((chr ch) - chstr) - (if (eq (char-charset chr) 'composition) - (setq chstr (decompose-composite-char chr)) - (setq chstr (char-to-string chr))) - (string-match "[$(7!g!e"Q(B-$(7"^"_(B-$(7"l(B]" chstr))) - -;;; This function makes a composite character consisting of two characters -;;; vertically stacked. - -;;;###autoload -(defun tibetan-vertical-stacking (first second upward) - "Return a vertically stacked composite char consisting of FIRST and SECOND. -If UPWARD is non-nil, then SECOND is put above FIRST." - (if upward - (compose-chars first '(tc . bc) second) - (compose-chars first '(bc . tc) second))) - -;;; This function makes a composite char from a string. -;;; Note that this function returns a string, not a char. - -;;;###autoload -(defun tibetan-compose-string (str) - "Compose a sequence of Tibetan character components into a composite character. -Returns a string containing a composite character." - (let ((t-str str) - f-str s-str f-ch s-ch rest composed result) - ;;Make sure no redundant vowel sign is present. - (if (string-match - "^\\(.+\\)\\($(7"Q(B\\)\\([$(7!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)" t-str) - (setq t-str (concat - (match-string 1 t-str) - (match-string 3 t-str)))) - (if (string-match - "^\\(.+\\)\\([$(7!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)\\($(7"Q(B\\)" t-str) - (setq t-str (concat - (match-string 1 t-str) - (match-string 2 t-str)))) - ;;Start conversion. - (setq result "") - ;; Consecutive base/precomposed consonants are reduced to the last one. - (while (string-match "^\\([$(7"!(B-$(7"J$!(B-$(7%u(B]\\)\\([$(7"!(B-$(7"@"B(B-$(7"J$!(B-$(7%u(B].*\\)" t-str) - (setq result (concat result (match-string 1 t-str))) - (setq t-str (match-string 2 t-str))) - ;; Vowel/vowel modifier, subjoined consonants are added one by one - ;; to the preceding element. - (while - (string-match "^\\(.\\)\\([$(7"A#!(B-$(7#J!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]\\)\\(.*\\)" t-str) - (setq f-str (match-string 1 t-str)) - (setq f-ch (string-to-char f-str)) - (setq s-str (match-string 2 t-str)) - ;;Special treatment for 'a chung. - ;;If 'a follows a consonant, then turned into its subjoined form. - (if (and (string-match "$(7"A(B" s-str) - (not (tibetan-complete-char-examin f-ch))) - (setq s-str "$(7#A(B")) - (setq s-ch (string-to-char s-str)) - (setq rest (match-string 3 t-str)) - (cond ((string-match "\\c2" s-str);; upper vowel sign - (setq composed - (tibetan-vertical-stacking f-ch s-ch t))) - ((string-match "\\c3" s-str);; lower vowel sign - (setq composed - (tibetan-vertical-stacking f-ch s-ch nil))) - ;;Automatic conversion of ra-mgo (superscribed r). - ;;'r' is converted if followed by a subjoined consonant - ;;other than w, ', y, r. - ((and (string-match "$(7"C(B" f-str) - (not (string-match "[$(7#>#A#B#C(B]" s-str))) - (setq f-ch ?$(7#P(B) - (setq composed - (tibetan-vertical-stacking f-ch s-ch nil))) - ((not (tibetan-complete-char-examin f-ch)) - ;;Initial base consonant is tranformed, if followed by - ;;a subjoined consonant, except when it is followed - ;;by a subscribed 'a. - (if (and (string-match "[$(7"!(B-$(7"="?"@"D(B-$(7"J(B]" f-str) - (not (string-match "$(7#A(B" s-str))) - (setq f-ch - (string-to-char - (cdr (assoc f-str tibetan-base-to-subjoined-alist))))) - (setq composed - (tibetan-vertical-stacking f-ch s-ch nil))) - (t - (setq composed s-str) - (setq result (concat result f-str)))) - (setq t-str (concat composed rest))) - (setq result (concat result t-str)))) - -;;; quail <-> conversion interface. - -;;;###autoload -(defun tibetan-composition (pc key) - "Interface to quail input method. -Takes two arguments: char PC and string KEY, where PC is the preceding -character to be composed with current input KEY. -Returns a string which is the result of composition." - (let (trans cur-ch t-str result) - ;; Make a tibetan character corresponding to current input key. - (setq cur-ch (tibetan-transcription-to-tibetan key)) - ;; Check if the preceding character is Tibetan and composable. - (cond ((and (tibetan-char-examin pc) - (tibetan-composable-examin pc)) - ;;If Tibetan char corresponding to the current input key exists, - (cond (cur-ch - ;; Then, - ;; Convert the preceding character into transcription, - ;; and concatenate it with the current input key, - (setq trans (tibetan-tibetan-to-transcription pc)) - (setq trans (concat trans key)) - ;; Concatenated transcription is converted to - ;; a sequence of Tibetan characters, - (setq t-str (tibetan-transcription-to-tibetan trans)) - ;; And it is composed into a composite character. - (setq result (tibetan-compose-string t-str))) - ;; Else, - (t - ;; Simply concatenate the preceding character and - ;; the current input key. - (setq result (char-to-string pc)) - (setq result (concat result key))))) - ;; If the preceding char is not Tibetan or not composable, - (t - ;; pc = 0 means the point is at the beginning of buffer. - (if (not (eq pc 0)) - (setq result (char-to-string pc))) - (if cur-ch - (setq result (concat result cur-ch)) - (setq result (concat result key)))) - ))) - - -;;;###autoload -(defun tibetan-decompose-region (beg end) - "Decompose Tibetan characters in the region BEG END into their components. -Components are: base and subjoined consonants, vowel signs, vowel modifiers. -One column punctuations are converted to their 2 column equivalents." - (interactive "r") - (let (ch-str ch-beg ch-end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - ;; \\cq = Tibetan character - (while (re-search-forward "\\cq" nil t) - (setq ch-str (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - ;; Save the points. Maybe, using save-match-data is preferable. - ;; But in order not to lose the trace(because the body is too long), - ;; we save the points in variables. - (setq ch-beg (match-beginning 0)) - (setq ch-end (match-end 0)) - ;; Here starts the decomposition. - (cond - ;; 1 column punctuations -> 2 column equivalent - ((string-match "[$(8!D!;!=!?!@!A"`(B]" ch-str) - (setq ch-str - (car (rassoc ch-str tibetan-precomposition-rule-alist)))) - ;; Decomposition of composite character. - ((eq (char-charset (string-to-char ch-str)) 'composition) - ;; Make a string which consists of a sequence of - ;; components. - (setq ch-str (decompose-composite-char (string-to-char ch-str))) - ;; Converts nyi zla into base elements. - (cond ((string= ch-str "$(7#R#S#S#S(B") - (setq ch-str "$(7!4!5!5(B")) - ((string= ch-str "$(7#R#S#S(B") - (setq ch-str "$(7!4!5(B")) - ((string= ch-str "$(7#R#S!I(B") - (setq ch-str "$(7!6(B")) - ((string= ch-str "$(7#R#S(B") - (setq ch-str "$(7!4(B"))))) - ;; If the sequence of components starts with a subjoined consonants, - (if (string-match "^\\([$(7#!(B-$(7#J(B]\\)\\(.*\\)$" ch-str) - ;; then the first components is converted to its base form. - (setq ch-str - (concat (car (rassoc (match-string 1 ch-str) - tibetan-base-to-subjoined-alist)) - (match-string 2 ch-str)))) - ;; If the sequence of components starts with a precomposed character, - (if (string-match "^\\([$(7$!(B-$(7%u(B]\\)\\(.*\\)$" ch-str) - ;; then it is converted into a sequence of components. - (setq ch-str - (concat (car (rassoc (match-string 1 ch-str) - tibetan-precomposition-rule-alist)) - (match-string 2 ch-str)))) - ;; Special treatment for superscribed r. - (if (string-match "^$(7#P(B\\(.*\\)$" ch-str) - (setq ch-str (concat "$(7"C(B" (match-string 1 ch-str)))) - ;; Finally, the result of decomposition is inserted, and - ;; the composite character is deleted. - (insert-and-inherit ch-str) - (delete-region ch-beg ch-end)))))) - -;;;###autoload -(defun tibetan-compose-region (beg end) - "Make composite chars from Tibetan character components in the region BEG END. -Two column punctuations are converted to their 1 column equivalents." - (interactive "r") - (let (str result) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - ;; First, sequence of components which has a precomposed equivalent - ;; is converted. - (while (re-search-forward - tibetan-precomposition-rule-regexp nil t) - (setq str (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (save-match-data - (insert-and-inherit - (cdr (assoc str tibetan-precomposition-rule-alist)))) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - ;; Then, composable elements are put into a composite character. - (while (re-search-forward - "[$(7"!(B-$(7"J$!(B-$(7%u(B]+[$(7#!(B-$(7#J!I!g!e"Q(B-$(7"^"_(B-$(7"l(B]+" - nil t) - (setq str (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (save-match-data - (setq result (tibetan-compose-string str)) - (insert-and-inherit result)) - (delete-region (match-beginning 0) (match-end 0))))))) - -;;; -;;; This variable is used to avoid repeated decomposition. -;;; -(setq-default tibetan-decomposed nil) - -;;;###autoload -(defun tibetan-decompose-buffer () - "Decomposes Tibetan characters in the buffer into their components. -See also docstring of the function tibetan-decompose-region." - (interactive) - (make-local-variable 'tibetan-decomposed) - (cond ((not tibetan-decomposed) - (tibetan-decompose-region (point-min) (point-max)) - (setq tibetan-decomposed t)))) - -;;;###autoload -(defun tibetan-compose-buffer () - "Composes Tibetan character components in the buffer. -See also docstring of the function tibetan-compose-region." - (interactive) - (make-local-variable 'tibetan-decomposed) - (tibetan-compose-region (point-min) (point-max)) - (setq tibetan-decomposed nil)) - -;;;###autoload -(defun tibetan-post-read-conversion (len) - (save-excursion - (save-restriction - (let ((buffer-modified-p (buffer-modified-p))) - (narrow-to-region (point) (+ (point) len)) - (tibetan-compose-region (point-min) (point-max)) - (set-buffer-modified-p buffer-modified-p) - (point-max)))) - (make-local-variable 'tibetan-decomposed) - (setq tibetan-decomposed nil)) - - -;;;###autoload -(defun tibetan-pre-write-conversion (from to) - (setq tibetan-decomposed-temp tibetan-decomposed) - (let ((old-buf (current-buffer)) - (work-buf (get-buffer-create " *tibetan-work*"))) - (set-buffer work-buf) - (erase-buffer) - (if (stringp from) - (insert from) - (insert-buffer-substring old-buf from to)) - (if (not tibetan-decomposed-temp) - (tibetan-decompose-region (point-min) (point-max))) - ;; Should return nil as annotations. - nil)) - -(provide 'tibet-util) - -;;; language/tibet-util.el ends here.
--- a/lisp/language/tibetan.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,555 +0,0 @@ -;;; tibetan.el --- Support for Tibetan language - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, Tibetan - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch> - -;; Created: Feb. 17. 1997 - -;; History: -;; 1997.03.13 Modification for special signs and punctuations. - -;;; Code: - -;;; Tibetan Character set. -;;; \x2130 -- \x234a is a subset of Unicode v.2 \x0f00 - \x0fb9 -;;; with a slight modification. And there are some subjoined -;;; consonants which are not specified in Unicode. -;;; I hope I can add missing characters later. -;;; -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2120 // $(7!!(B $(7!"(B $(7!#(B $(7!$(B $(7!%(B $(7!&(B $(7!'(B $(7!((B $(7!)(B $(7!*(B $(7!+(B $(7!,(B $(7!-(B $(7!.(B $(7!/(B ; -;;;2130 $(7!0(B $(7!1(B $(7!2(B $(7!3(B $(7!4(B $(7!5(B $(7!6(B $(7!7(B $(7!8(B $(7!9(B $(7!:(B $(7!;(B $(7!<(B $(7!=(B $(7!>(B $(7!?(B ; Punctuations, -;;;2140 $(7!@(B $(7!A(B $(7!B(B $(7!C(B $(7!D(B $(7!E(B $(7!F(B $(7!G(B $(7!H(B $(7!I(B $(7!J(B $(7!K(B $(7!L(B $(7!M(B $(7!N(B $(7!O(B ; Digits and -;;;2150 $(7!P(B $(7!Q(B $(7!R(B $(7!S(B $(7!T(B $(7!U(B $(7!V(B $(7!W(B $(7!X(B $(7!Y(B $(7!Z(B $(7![(B $(7!\(B $(7!](B $(7!^(B $(7!_(B ; Special signs. -;;;2160 $(7!`(B $(7!a(B $(7!b(B $(7!c(B $(7!d(B $(7!e(B $(7!f(B $(7!g(B $(7!h(B $(7!i(B $(7!j(B $(7!k(B $(7!l(B $(7!m(B $(7!n(B $(7!o(B ; -;;;2170 $(7!p(B $(7!q(B $(7!r(B $(7!s(B $(7!t(B $(7!u(B $(7!v(B $(7!w(B $(7!x(B $(7!y(B $(7!z(B $(7!{(B $(7!|(B $(7!}(B $(7!~(B // ; -;;; -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2220 // $(7"!(B $(7""(B $(7"#(B $(7"$(B $(7"%(B $(7"&(B $(7"'(B $(7"((B $(7")(B $(7"*(B $(7"+(B $(7",(B $(7"-(B $(7".(B $(7"/(B ; Base consonants -;;;2230 $(7"0(B $(7"1(B $(7"2(B $(7"3(B $(7"4(B $(7"5(B $(7"6(B $(7"7(B $(7"8(B $(7"9(B $(7":(B $(7";(B $(7"<(B $(7"=(B $(7">(B $(7"?(B ; and -;;;2240 $(7"@(B $(7"A(B $(7"B(B $(7"C(B $(7"D(B $(7"E(B $(7"F(B $(7"G(B $(7"H(B $(7"I(B $(7"J(B $(7"K(B $(7"L(B $(7"M(B $(7"N(B $(7"O(B ; Vowel signs. -;;;2250 $(7"P(B $(7"Q(B $(7"R(B $(7"S(B $(7"T(B $(7"U(B $(7"V(B $(7"W(B $(7"X(B $(7"Y(B $(7"Z(B $(7"[(B $(7"\(B $(7"](B $(7"^(B $(7"_(B ; (\x2251 = vowel a) -;;;2260 $(7"`(B $(7"a(B $(7"b(B $(7"c(B $(7"d(B $(7"e(B $(7"f(B $(7"g(B $(7"h(B $(7"i(B $(7"j(B $(7"k(B $(7"l(B $(7"m(B $(7"n(B $(7"o(B ; Long vowels and -;;;2270 $(7"p(B $(7"q(B $(7"r(B $(7"s(B $(7"t(B $(7"u(B $(7"v(B $(7"w(B $(7"x(B $(7"y(B $(7"z(B $(7"{(B $(7"|(B $(7"}(B $(7"~(B // ; vocalic r, l are -;;; ; not atomically -;;; ; encoded. -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2320 // $(7#!(B $(7#"(B $(7##(B $(7#$(B $(7#%(B $(7#&(B $(7#'(B $(7#((B $(7#)(B $(7#*(B $(7#+(B $(7#,(B $(7#-(B $(7#.(B $(7#/(B ; Subjoined consonants -;;;2330 $(7#0(B $(7#1(B $(7#2(B $(7#3(B $(7#4(B $(7#5(B $(7#6(B $(7#7(B $(7#8(B $(7#9(B $(7#:(B $(7#;(B $(7#<(B $(7#=(B $(7#>(B $(7#?(B ; -;;;2340 $(7#@(B $(7#A(B $(7#B(B $(7#C(B $(7#D(B $(7#E(B $(7#F(B $(7#G(B $(7#H(B $(7#I(B $(7#J(B $(7#K(B $(7#L(B $(7#M(B $(7#N(B $(7#O(B ; 'a chung (\x2341)is -;;; ; here, -;;; ; while in Unicode -;;; ; it is classified -;;; ; as a vowel sign -;;; ; (\x0f71). -;;; -;;;2350 $(7#P(B $(7#Q(B $(7#R(B $(7#S(B $(7#T(B $(7#U(B $(7#V(B $(7#W(B $(7#X(B $(7#Y(B $(7#Z(B $(7#[(B $(7#\(B $(7#](B $(7#^(B $(7#_(B ; Hereafter, the chars -;;;2360 $(7#`(B $(7#a(B $(7#b(B $(7#c(B $(7#d(B $(7#e(B $(7#f(B $(7#g(B $(7#h(B $(7#i(B $(7#j(B $(7#k(B $(7#l(B $(7#m(B $(7#n(B $(7#o(B ; are not specified -;;;2370 $(7#p(B $(7#q(B $(7#r(B $(7#s(B $(7#t(B $(7#u(B $(7#v(B $(7#w(B $(7#x(B $(7#y(B $(7#z(B $(7#{(B $(7#|(B $(7#}(B $(7#~(B // ; in Unicode. -;;; ; The character \x2351 -;;; ; is not used in our -;;; ; implementation. -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F -;;;2420 // $(7$!(B $(7$"(B $(7$#(B $(7$$(B $(7$%(B $(7$&(B $(7$'(B $(7$((B $(7$)(B $(7$*(B $(7$+(B $(7$,(B $(7$-(B $(7$.(B $(7$/(B ; Precomposed -;;;2430 $(7$0(B $(7$1(B $(7$2(B $(7$3(B $(7$4(B $(7$5(B $(7$6(B $(7$7(B $(7$8(B $(7$9(B $(7$:(B $(7$;(B $(7$<(B $(7$=(B $(7$>(B $(7$?(B ; consonants for -;;;2440 $(7$@(B $(7$A(B $(7$B(B $(7$C(B $(7$D(B $(7$E(B $(7$F(B $(7$G(B $(7$H(B $(7$I(B $(7$J(B $(7$K(B $(7$L(B $(7$M(B $(7$N(B $(7$O(B ; ordinary Tibetan. -;;;2450 $(7$P(B $(7$Q(B $(7$R(B $(7$S(B $(7$T(B $(7$U(B $(7$V(B $(7$W(B $(7$X(B $(7$Y(B $(7$Z(B $(7$[(B $(7$\(B $(7$](B $(7$^(B $(7$_(B ; They are decomposed -;;;2460 $(7$`(B $(7$a(B $(7$b(B $(7$c(B $(7$d(B $(7$e(B $(7$f(B $(7$g(B $(7$h(B $(7$i(B $(7$j(B $(7$k(B $(7$l(B $(7$m(B $(7$n(B $(7$o(B ; into base and -;;;2470 $(7$p(B $(7$q(B $(7$r(B $(7$s(B $(7$t(B $(7$u(B $(7$v(B $(7$w(B $(7$x(B $(7$y(B $(7$z(B $(7${(B $(7$|(B $(7$}(B $(7$~(B // ; subjoined consonants -;;; ; when written on a -;;; 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ; file in Tibetan -;;;2520 // $(7%!(B $(7%"(B $(7%#(B $(7%$(B $(7%%(B $(7%&(B $(7%'(B $(7%((B $(7%)(B $(7%*(B $(7%+(B $(7%,(B $(7%-(B $(7%.(B $(7%/(B ; coding system. -;;;2530 $(7%0(B $(7%1(B $(7%2(B $(7%3(B $(7%4(B $(7%5(B $(7%6(B $(7%7(B $(7%8(B $(7%9(B $(7%:(B $(7%;(B $(7%<(B $(7%=(B $(7%>(B $(7%?(B ; -;;;2540 $(7%@(B $(7%A(B $(7%B(B $(7%C(B $(7%D(B $(7%E(B $(7%F(B $(7%G(B $(7%H(B $(7%I(B $(7%J(B $(7%K(B $(7%L(B $(7%M(B $(7%N(B $(7%O(B ; -;;;2550 $(7%P(B $(7%Q(B $(7%R(B $(7%S(B $(7%T(B $(7%U(B $(7%V(B $(7%W(B $(7%X(B $(7%Y(B $(7%Z(B $(7%[(B $(7%\(B $(7%](B $(7%^(B $(7%_(B ; -;;;2560 $(7%`(B $(7%a(B $(7%b(B $(7%c(B $(7%d(B $(7%e(B $(7%f(B $(7%g(B $(7%h(B $(7%i(B $(7%j(B $(7%k(B $(7%l(B $(7%m(B $(7%n(B $(7%o(B ; -;;;2570 $(7%p(B $(7%q(B $(7%r(B $(7%s(B $(7%t(B $(7%u(B $(7%v(B $(7%w(B $(7%x(B $(7%y(B $(7%z(B $(7%{(B $(7%|(B $(7%}(B $(7%~(B // ; -;;; - - -(make-coding-system - 'tibetan 2 ?Q - "8-bit encoding for ASCII (MSB=0) and TIBETAN (MSB=1)" - '((ascii t) (tibetan t) nil nil - nil ascii-eol)) - -(put 'tibetan 'post-read-conversion 'tibetan-post-read-conversion) -(put 'tibetan 'pre-write-conversion 'tibetan-pre-write-conversion) - -(set-language-info-alist - "Tibetan" '((setup-function . setup-tibetan-environment) - (charset . (tibetan tibetan-1-column)) - (coding-system . (tibetan)) - (documentation . t) - (sample-text . -"Tibetan (2$(7"70"]1"2$(8!;2$(7%P`"Q1"2$(8!;(B) 2$(7#RP#SP#S1!>"72$P`"Q1$(8!;2$(7"E0"S1"G$(8!;$(7"72"20"[1$(8!;2$(7"D0"[1"#"G!>2"I0"]0"_1$(8!;2$(7"9`"Q1$(8!;2$(7"/0"S1$(8!;2$(7"5`"Q12#2`#90"[1$(8!;2$(7"H`#A`"U0"c1!>(B"))) - - -;;; -;;; Definitions of conversion data. -;;; - - -;;; alists for tibetan char <-> transcription conversion -;;; longer transcription should come first -(defconst tibetan-consonant-transcription-alist - '(("tsh" . "$(7";(B") - ("dzh" . "$(7"=(B") - ("kSH" . "$(7"J(B") - ("kh" . "$(7""(B") - ("gh" . "$(7"$(B") - ("ng" . "$(7"%(B") - ("ch" . "$(7"'(B") - ("ny" . "$(7"*(B") - ("TH" . "$(7",(B") - ("DH" . "$(7".(B") - ("th" . "$(7"1(B") - ("dh" . "$(7"3(B") - ("ph" . "$(7"6(B") - ("bh" . "$(7"8(B") - ("ts" . "$(7":(B") - ("dz" . "$(7"<(B") - ("zh" . "$(7"?(B") - ("sh" . "$(7"E(B") - ("SH" . "$(7"F(B") - ("k" . "$(7"!(B") - ("g" . "$(7"#(B") - ("c" . "$(7"&(B") - ("j" . "$(7"((B") - ("T" . "$(7"+(B") - ("D" . "$(7"-(B") - ("N" . "$(7"/(B") - ("t" . "$(7"0(B") - ("d" . "$(7"2(B") - ("n" . "$(7"4(B") - ("p" . "$(7"5(B") - ("b" . "$(7"7(B") - ("m" . "$(7"9(B") - ("w" . "$(7">(B") - ("z" . "$(7"@(B") - ("'" . "$(7"A(B") - ("y" . "$(7"B(B") - ("r" . "$(7"C(B") - ("l" . "$(7"D(B") - ("s" . "$(7"G(B") - ("h" . "$(7"H(B") - ("H" . "$(7"H(B") - ("A" . "$(7"I(B"))) - - -(defconst tibetan-vowel-transcription-alist - '(("ai" . "$(7"\(B") - ("au" . "$(7"^(B") - ("ee" . "$(7"\(B") - ("oo" . "$(7"^(B") - ("a" . "$(7"Q(B") ; invisible vowel sign (\x2251) - ("i" . "$(7"S(B") - ("u" . "$(7"U(B") - ("e" . "$(7"[(B") - ("o" . "$(7"](B") - ("E" . "$(7"\(B") - ("O" . "$(7"^(B") - ("I" . "$(7"a(B") - ("M" . "$(7"_(B") - ("~" . "$(7"c(B") ; not specified in Ext.wylie - ("`" . "$(7"d(B") ; idem. - ("," . "$(7"e(B") ; idem. - ("v" . "$(7"g(B") ; idem. - ("V" . "$(7"h(B") ; idem. - ("x" . "$(7"i(B") ; idem. - ("X" . "$(7"j(B") ; idem. - ("q" . "$(7"k(B") ; idem. - ("Q" . "$(7"l(B") ; idem. - ("_o" . "$(7!g(B") ; idem. - ("_O" . "$(7!e(B") ; idem. - ("_/" . "$(7!I(B") ; idem. - )) - -(defconst tibetan-precomposed-transcription-alist - '(("phyw" . "$(7$G(B") - ("tshw" . "$(7$)(B") - ("rtsw" . "$(7%.(B") - ("khw" . "$(7$"(B") - ("nyw" . "$(7$%(B") - ("tsw" . "$(7$((B") - ("zhw" . "$(7$*(B") - ("shw" . "$(7$.(B") - ("khy" . "$(7$A(B") - ("phy" . "$(7$D(B") - ("khr" . "$(7$Q(B") - ("thr" . "$(7$T(B") - ("phr" . "$(7$W(B") - ("shr" . "$(7$Z(B") - ("dzr" . "$(7$^(B") - ("grw" . "$(7$_(B") - ("rng" . "$(7%#(B") - ("rny" . "$(7%%(B") - ("rts" . "$(7%+(B") - ("rdz" . "$(7%,(B") - ("rgw" . "$(7%-(B") - ("rky" . "$(7%0(B") - ("rgy" . "$(7%1(B") - ("rmy" . "$(7%2(B") - ("lng" . "$(7%B(B") - ("sng" . "$(7%R(B") - ("sny" . "$(7%S(B") - ("sts" . "$(7%Z(B") - ("sky" . "$(7%`(B") - ("sgy" . "$(7%a(B") - ("spy" . "$(7%b(B") - ("sby" . "$(7%c(B") - ("smy" . "$(7%d(B") - ("skr" . "$(7%p(B") - ("sgr" . "$(7%q(B") - ("snr" . "$(7%r(B") - ("spr" . "$(7%s(B") - ("sbr" . "$(7%t(B") - ("smr" . "$(7%u(B") - ("kw" . "$(7$!(B") - ("gw" . "$(7$#(B") - ("cw" . "$(7$$(B") - ("tw" . "$(7$&(B") - ("dw" . "$(7$'(B") - ("zw" . "$(7$+(B") - ("rw" . "$(7$,(B") - ("lw" . "$(7$-(B") - ("sw" . "$(7$/(B") - ("hw" . "$(7$0(B") - ("ky" . "$(7$@(B") - ("gy" . "$(7$B(B") - ("py" . "$(7$C(B") - ("by" . "$(7$E(B") - ("my" . "$(7$F(B") - ("kr" . "$(7$P(B") - ("gr" . "$(7$R(B") - ("tr" . "$(7$S(B") - ("dr" . "$(7$U(B") - ("pr" . "$(7$V(B") - ("brk" . "$(7"7%!(B") - ("brg" . "$(7"7%"(B") - ("brng" . "$(7"7%#(B") - ("brj" . "$(7"7%$(B") - ("brny" . "$(7"7%%(B") - ("brt" . "$(7"7%&(B") - ("brd" . "$(7"7%'(B") - ("brn" . "$(7"7%((B") - ("brts" . "$(7"7%+(B") - ("brdz" . "$(7"7%,(B") - ("brl" . "$(7"7$d(B") - ("br" . "$(7$X(B") - ("mr" . "$(7$Y(B") - ("sr" . "$(7$[(B") - ("hr" . "$(7$\(B") - ("jr" . "$(7$](B") - ("kl" . "$(7$`(B") - ("gl" . "$(7$a(B") - ("blt" . "$(7"7%E(B") - ("bld" . "$(7"7%F(B") - ("bl" . "$(7$b(B") - ("zl" . "$(7$c(B") - ("rl" . "$(7$d(B") - ("sl" . "$(7$e(B") - ("rk" . "$(7%!(B") - ("rg" . "$(7%"(B") - ("rj" . "$(7%$(B") - ("rt" . "$(7%&(B") - ("rd" . "$(7%'(B") - ("rn" . "$(7%((B") - ("rb" . "$(7%)(B") - ("rm" . "$(7%*(B") - ("lk" . "$(7%@(B") - ("lg" . "$(7%A(B") - ("lc" . "$(7%C(B") - ("lj" . "$(7%D(B") - ("lt" . "$(7%E(B") - ("ld" . "$(7%F(B") - ("ln" . "$(7!!(B") ; dummy \x2121 - ("lp" . "$(7%G(B") - ("lb" . "$(7%H(B") - ("lh" . "$(7%I(B") - ("sk" . "$(7%P(B") - ("sg" . "$(7%Q(B") - ("st" . "$(7%T(B") - ("sd" . "$(7%U(B") - ("sn" . "$(7%V(B") - ("sp" . "$(7%W(B") - ("sb" . "$(7%X(B") - ("sm" . "$(7%Y(B"))) - -(defconst tibetan-subjoined-transcription-alist - '(("+k" . "$(7#!(B") - ("+kh" . "$(7#"(B") - ("+g" . "$(7##(B") - ("+gh" . "$(7#$(B") - ("+ng" . "$(7#%(B") - ("+c" . "$(7#&(B") - ("+ch" . "$(7#'(B") - ("+j" . "$(7#((B") - ("+ny" . "$(7#*(B") - ("+T" . "$(7#+(B") - ("+TH" . "$(7#,(B") - ("+D" . "$(7#-(B") - ("+DH" . "$(7#.(B") - ("+N" . "$(7#/(B") - ("+t" . "$(7#0(B") - ("+th" . "$(7#1(B") - ("+d" . "$(7#2(B") - ("+dh" . "$(7#3(B") - ("+n" . "$(7#4(B") - ("+p" . "$(7#5(B") - ("+ph" . "$(7#6(B") - ("+b" . "$(7#7(B") - ("+bh" . "$(7#8(B") - ("+m" . "$(7#9(B") - ("+ts" . "$(7#:(B") - ("+tsh" . "$(7#;(B") - ("+dz" . "$(7#<(B") - ("+dzh" . "$(7#=(B") - ("+w" . "$(7#>(B") - ("+zh" . "$(7#?(B") - ("+z" . "$(7#@(B") - ("+'" . "$(7#A(B") - ("+y" . "$(7#B(B") - ("+r" . "$(7#C(B") - ("+l" . "$(7#D(B") - ("+sh" . "$(7#E(B") - ("+SH" . "$(7#F(B") - ("+s" . "$(7#G(B") - ("+h" . "$(7#H(B") - ("+A" . "$(7#I(B") - ("+kSH" . "$(7#J(B") - ("R" . "$(7#P(B"))) - -;;; -;;; alist for Tibetan base consonant <-> subjoined consonant conversion. -;;; -(defconst tibetan-base-to-subjoined-alist - '(("$(7"!(B" . "$(7#!(B") - ("$(7""(B" . "$(7#"(B") - ("$(7"#(B" . "$(7##(B") - ("$(7"$(B" . "$(7#$(B") - ("$(7"%(B" . "$(7#%(B") - ("$(7"&(B" . "$(7#&(B") - ("$(7"'(B" . "$(7#'(B") - ("$(7"((B" . "$(7#((B") - ("$(7"*(B" . "$(7#*(B") - ("$(7"+(B" . "$(7#+(B") - ("$(7",(B" . "$(7#,(B") - ("$(7"-(B" . "$(7#-(B") - ("$(7".(B" . "$(7#.(B") - ("$(7"/(B" . "$(7#/(B") - ("$(7"0(B" . "$(7#0(B") - ("$(7"1(B" . "$(7#1(B") - ("$(7"2(B" . "$(7#2(B") - ("$(7"3(B" . "$(7#3(B") - ("$(7"4(B" . "$(7#4(B") - ("$(7"5(B" . "$(7#5(B") - ("$(7"6(B" . "$(7#6(B") - ("$(7"7(B" . "$(7#7(B") - ("$(7"8(B" . "$(7#8(B") - ("$(7"9(B" . "$(7#9(B") - ("$(7":(B" . "$(7#:(B") - ("$(7";(B" . "$(7#;(B") - ("$(7"<(B" . "$(7#<(B") - ("$(7"=(B" . "$(7#=(B") - ("$(7">(B" . "$(7#>(B") - ("$(7"?(B" . "$(7#?(B") - ("$(7"@(B" . "$(7#@(B") - ("$(7"A(B" . "$(7#A(B") - ("$(7"B(B" . "$(7#B(B") - ("$(7"C(B" . "$(7#C(B") - ("$(7"D(B" . "$(7#D(B") - ("$(7"E(B" . "$(7#E(B") - ("$(7"F(B" . "$(7#F(B") - ("$(7"G(B" . "$(7#G(B") - ("$(7"H(B" . "$(7#H(B") - ("$(7"I(B" . "$(7#I(B") - ("$(7"J(B" . "$(7#J(B"))) - -;;; -;;; alist for Tibetan consonantic components <-> precomposed glyph conversion. -;;; (includes some punctuation conversion rules) -;;; -(defconst tibetan-precomposition-rule-alist - '(("$(7"6#B#>(B" . "$(7$G(B") - ("$(7"##C#>(B" . "$(7$_(B") - ("$(7";#>(B" . "$(7$)(B") - ("$(7"C#:#>(B" . "$(7%.(B") - ("$(7"C###>(B" . "$(7%-(B") - ("$(7"C#!#B(B" . "$(7%0(B") - ("$(7"C###B(B" . "$(7%1(B") - ("$(7"C#9#B(B" . "$(7%2(B") - ("$(7"G#!#B(B" . "$(7%`(B") - ("$(7"G###B(B" . "$(7%a(B") - ("$(7"G#5#B(B" . "$(7%b(B") - ("$(7"G#7#B(B" . "$(7%c(B") - ("$(7"G#9#B(B" . "$(7%d(B") - ("$(7"G#!#C(B" . "$(7%p(B") - ("$(7"G###C(B" . "$(7%q(B") - ("$(7"G#4#C(B" . "$(7%r(B") - ("$(7"G#5#C(B" . "$(7%s(B") - ("$(7"G#7#C(B" . "$(7%t(B") - ("$(7"G#9#C(B" . "$(7%u(B") - ("$(7""#>(B" . "$(7$"(B") - ("$(7"*#>(B" . "$(7$%(B") - ("$(7":#>(B" . "$(7$((B") - ("$(7"?#>(B" . "$(7$*(B") - ("$(7"E#>(B" . "$(7$.(B") - ("$(7""#B(B" . "$(7$A(B") - ("$(7"6#B(B" . "$(7$D(B") - ("$(7""#C(B" . "$(7$Q(B") - ("$(7"1#C(B" . "$(7$T(B") - ("$(7"6#C(B" . "$(7$W(B") - ("$(7"E#C(B" . "$(7$Z(B") - ("$(7"<#C(B" . "$(7$^(B") - ("$(7"C#%(B" . "$(7%#(B") - ("$(7"C#*(B" . "$(7%%(B") - ("$(7"C#:(B" . "$(7%+(B") - ("$(7"C#<(B" . "$(7%,(B") - ("$(7"D#%(B" . "$(7%B(B") - ("$(7"G#%(B" . "$(7%R(B") - ("$(7"G#*(B" . "$(7%S(B") - ("$(7"G#:(B" . "$(7%Z(B") - ("$(7"!#>(B" . "$(7$!(B") - ("$(7"##>(B" . "$(7$#(B") - ("$(7"&#>(B" . "$(7$$(B") - ("$(7"0#>(B" . "$(7$&(B") - ("$(7"2#>(B" . "$(7$'(B") - ("$(7"@#>(B" . "$(7$+(B") - ("$(7"C#>(B" . "$(7$,(B") - ("$(7"D#>(B" . "$(7$-(B") - ("$(7"G#>(B" . "$(7$/(B") - ("$(7"H#>(B" . "$(7$0(B") - ("$(7"!#B(B" . "$(7$@(B") - ("$(7"##B(B" . "$(7$B(B") - ("$(7"5#B(B" . "$(7$C(B") - ("$(7"7#B(B" . "$(7$E(B") - ("$(7"9#B(B" . "$(7$F(B") - ("$(7"!#C(B" . "$(7$P(B") - ("$(7"##C(B" . "$(7$R(B") - ("$(7"0#C(B" . "$(7$S(B") - ("$(7"2#C(B" . "$(7$U(B") - ("$(7"5#C(B" . "$(7$V(B") - ("$(7"7#C(B" . "$(7$X(B") - ("$(7"9#C(B" . "$(7$Y(B") - ("$(7"G#C(B" . "$(7$[(B") - ("$(7"H#C(B" . "$(7$\(B") - ("$(7"(#C(B" . "$(7$](B") - ("$(7"!#D(B" . "$(7$`(B") - ("$(7"##D(B" . "$(7$a(B") - ("$(7"7#D(B" . "$(7$b(B") - ("$(7"@#D(B" . "$(7$c(B") - ("$(7"C#D(B" . "$(7$d(B") - ("$(7"G#D(B" . "$(7$e(B") - ("$(7"C#!(B" . "$(7%!(B") - ("$(7"C##(B" . "$(7%"(B") - ("$(7"C#((B" . "$(7%$(B") - ("$(7"C#0(B" . "$(7%&(B") - ("$(7"C#2(B" . "$(7%'(B") - ("$(7"C#4(B" . "$(7%((B") - ("$(7"C#7(B" . "$(7%)(B") - ("$(7"C#9(B" . "$(7%*(B") - ("$(7"D#!(B" . "$(7%@(B") - ("$(7"D##(B" . "$(7%A(B") - ("$(7"D#&(B" . "$(7%C(B") - ("$(7"D#((B" . "$(7%D(B") - ("$(7"D#0(B" . "$(7%E(B") - ("$(7"D#2(B" . "$(7%F(B") - ("$(7"D#5(B" . "$(7%G(B") - ("$(7"D#7(B" . "$(7%H(B") - ("$(7"D#H(B" . "$(7%I(B") - ("$(7"G#!(B" . "$(7%P(B") - ("$(7"G##(B" . "$(7%Q(B") - ("$(7"G#0(B" . "$(7%T(B") - ("$(7"G#2(B" . "$(7%U(B") - ("$(7"G#4(B" . "$(7%V(B") - ("$(7"G#5(B" . "$(7%W(B") - ("$(7"G#7(B" . "$(7%X(B") - ("$(7"G#9(B" . "$(7%Y(B") - ("$(7!=(B" . "$(8!=(B") ; 2 col <-> 1 col - ("$(7!?(B" . "$(8!?(B") - ("$(7!@(B" . "$(8!@(B") - ("$(7!A(B" . "$(8!A(B") - ("$(7"`(B" . "$(8"`(B") - ("$(7!;(B" . "$(8!;(B") - ("$(7!D(B" . "$(8!D(B") - ("$(7!>(B $(7!>(B" . "2$(7!>P(B P$(7!>1(B") ; Yes this is dirty. But ... - ("$(7!4!5!5(B" . "2$(7#RP#SP#SP#S1(B") - ("$(7!4!5(B" . "2$(7#RP#SP#S1(B") - ("$(7!6(B" . "2$(7#RP#S_!I1(B") - ("$(7!4(B" . "2$(7#RP#S1(B"))) - -(defvar tibetan-regexp - (let ((l (append tibetan-consonant-transcription-alist - tibetan-vowel-transcription-alist - tibetan-subjoined-transcription-alist)) - temp) - (setq temp "\\(") - (setq temp (concat temp (car (car l)))) - (setq l (cdr l)) - (while l - (setq temp (concat temp "\\|" (car (car l)))) - (setq l (cdr l))) - (concat temp "\\)$")) - "Regexp string to match a romanized Tibetan character component, i.e., -base and subjoined consonant, vowel and vowel modifier. The result of matching -is to be used for indexing alists at conversion from a roman transcription to -the corresponding Tibetan character.") - -(defvar tibetan-precomposed-regexp - (let ((l tibetan-precomposed-transcription-alist) - temp) - (setq temp "^\\(") - (setq temp - (concat temp (car (car l)))) - (setq l (cdr l)) - (while l - (setq temp - (concat temp "\\|" (car (car l)))) - (setq l (cdr l))) - (concat temp "\\)")) - "Regexp string to match a romanized Tibetan complex consonant. -The result of matching is to be used for indexing alists when the input key -from an input method is converted to the corresponding precomposed glyph.") - -(defvar tibetan-precomposition-rule-regexp - (let ((l tibetan-precomposition-rule-alist) - temp) - (setq temp "\\(") - (setq temp (concat temp (car (car l)))) - (setq l (cdr l)) - (while l - (setq temp (concat temp "\\|" (car (car l)))) - (setq l (cdr l))) - (concat temp "\\)")) - "Regexp string to match a sequence of Tibetan consonantic components, i.e., -one base consonant and one or more subjoined consonants. -The result of matching is to be used for indexing alist when the component -sequence is converted to the corresponding precomposed glyph. -This also matches some punctuation characters which need conversion.") - -(defvar tibetan-decomposed nil) -(defvar tibetan-decomposed-temp nil) - -;;; language/tibetan.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/language/viet-chars.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,57 @@ +;;; vietnamese-chars.el --- pre-loaded support for Vietnamese, part 1. + +;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. +;; Copyright (C) 1995 Amdahl Corporation. +;; Copyright (C) 1995 Sun Microsystems. + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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: Mule 2.3. + +;; We have to split up the Vietnamese stuff into two files because +;; we are registering new charsets and then immediately using characters +;; from those sets. We cannot reliably expect this to work if they +;; are in the same file because of the buffering that happens while +;; reading -- the place where we use the newly-defined sets may be +;; read in before the code that creates those sets is evaluated. + +;; Vietnamese VISCII with two tables. +(make-charset 'vietnamese-viscii-lower "VISCII lower (Vietnamese)" + '(registry "VISCII1.1" + dimension 1 + chars 96 + final ?1 + graphic 1 + )) + +(make-charset 'vietnamese-viscii-upper "VISCII upper (Vietnamese)" + '(registry "VISCII1.1" + dimension 1 + chars 96 + final ?2 + graphic 1 + )) + +(modify-syntax-entry 'vietnamese-viscii-lower "w") +(modify-syntax-entry 'vietnamese-viscii-upper "w") + +(define-category ?v "Vietnamese character.") +(modify-category-entry 'vietnamese-viscii-lower ?v) +(modify-category-entry 'vietnamese-viscii-upper ?v) + +;;; vietnamese-chars.el ends here
--- a/lisp/language/viet-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,296 +0,0 @@ -;;; viet-util.el --- utilities for Vietnamese - -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: mule, multilingual, Vietnamese - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Vietnamese uses ASCII characters and additional 134 unique -;; characters (these are Latin alphabets with various diacritical and -;; tone marks). As far as I know, Vietnamese now has 4 different ways -;; for representing these characters: VISCII, VSCII, VIQR, and -;; Unicode. VISCII and VSCII are simple 1-byte code which assigns 134 -;; unique characters in control-code area (0x00..0x1F) and right half -;; area (0x80..0xFF). VIQR is a menmonic encoding specification -;; representing diacritical marks by following ASCII characters. - -;;; Code: - -;;;###autoload -(defun setup-vietnamese-environment () - "Setup multilingual environment (MULE) for Vietnamese VISCII users." - (interactive) - (setup-8-bit-environment "Vietnamese" nil 'vietnamese-viscii - "vietnamese-viqr") - (setq coding-category-raw-text 'vietnamese-viscii)) - -;; VIQR is a menmonic encoding specification for Vietnamese. -;; It represents diacritical marks by ASCII characters as follows: -;; ------------+----------+-------- -;; mark | mnemonic | example -;; ------------+----------+--------- -;; breve | ( | a( -> ,1e(B -;; circumflex | ^ | a^ -> ,1b(B -;; horn | + | o+ -> ,1=(B -;; ------------+----------+--------- -;; acute | ' | a' -> ,1a(B -;; grave | ` | a` -> ,1`(B -;; hook above | ? | a? -> ,1d(B -;; tilde | ~ | a~ -> ,1c(B -;; dot below | . | a. -> ,1U(B -;; ------------+----------+--------- -;; d bar | dd | dd -> ,1p(B -;; ------------+----------+--------- - -(defvar viet-viqr-alist - '(;; lowercase - (?,1!(B . "a('") ; 161 - (?,1"(B . "a(`") ; 162 - (?,1#(B . "a(.") ; 163 - (?,1$(B . "a^'") ; 164 - (?,1%(B . "a^`") ; 165 - (?,1&(B . "a^?") ; 166 - (?,1'(B . "a^.") ; 167 - (?,1((B . "e~") ; 168 - (?,1)(B . "e.") ; 169 - (?,1*(B . "e^'") ; 170 - (?,1+(B . "e^`") ; 171 - (?,1,(B . "e^?") ; 172 - (?,1-(B . "e^~") ; 173 - (?,1.(B . "e^.") ; 174 - (?,1/(B . "o^'") ; 175 - (?,10(B . "o^`") ; 176 - (?,11(B . "o^?") ; 177 - (?,12(B . "o^~") ; 178 - (?,15(B . "o^.") ; 181 - (?,16(B . "o+`") ; 182 - (?,17(B . "o+?") ; 183 - (?,18(B . "i.") ; 184 - (?,1=(B . "o+") ; 189 - (?,1>(B . "o+'") ; 190 - (?,1F(B . "a(?") ; 198 - (?,1G(B . "a(~") ; 199 - (?,1O(B . "y`") ; 207 - (?,1Q(B . "u+'") ; 209 - (?,1U(B . "a.") ; 213 - (?,1V(B . "y?") ; 214 - (?,1W(B . "u+`") ; 215 - (?,1X(B . "u+?") ; 216 - (?,1[(B . "y~") ; 219 - (?,1\(B . "y.") ; 220 - (?,1^(B . "o+~") ; 222 - (?,1_(B . "u+") ; 223 - (?,1`(B . "a`") ; 224 - (?,1a(B . "a'") ; 225 - (?,1b(B . "a^") ; 226 - (?,1c(B . "a~") ; 227 - (?,1d(B . "a?") ; 228 - (?,1e(B . "a(") ; 229 - (?,1f(B . "u+~") ; 230 - (?,1g(B . "a^~") ; 231 - (?,1h(B . "e`") ; 232 - (?,1i(B . "e'") ; 233 - (?,1j(B . "e^") ; 234 - (?,1k(B . "e?") ; 235 - (?,1l(B . "i`") ; 236 - (?,1m(B . "i'") ; 237 - (?,1n(B . "i~") ; 238 - (?,1o(B . "i?") ; 239 - (?,1p(B . "dd") ; 240 - (?,1q(B . "u+.") ; 241 - (?,1r(B . "o`") ; 242 - (?,1s(B . "o'") ; 243 - (?,1t(B . "o^") ; 244 - (?,1u(B . "o~") ; 245 - (?,1v(B . "o?") ; 246 - (?,1w(B . "o.") ; 247 - (?,1x(B . "u.") ; 248 - (?,1y(B . "u`") ; 249 - (?,1z(B . "u'") ; 250 - (?,1{(B . "u~") ; 251 - (?,1|(B . "u?") ; 252 - (?,1}(B . "y'") ; 253 - (?,1~(B . "o+.") ; 254 - - ;; upper case - (?,2!(B . "A('") ; 161 - (?,2"(B . "A(`") ; 162 - (?,2#(B . "A(.") ; 163 - (?,2$(B . "A^'") ; 164 - (?,2%(B . "A^`") ; 165 - (?,2&(B . "A^?") ; 166 - (?,2'(B . "A^.") ; 167 - (?,2((B . "E~") ; 168 - (?,2)(B . "E.") ; 169 - (?,2*(B . "E^'") ; 170 - (?,2+(B . "E^`") ; 171 - (?,2,(B . "E^?") ; 172 - (?,2-(B . "E^~") ; 173 - (?,2.(B . "E^.") ; 174 - (?,2/(B . "O^'") ; 175 - (?,20(B . "O^`") ; 176 - (?,21(B . "O^?") ; 177 - (?,22(B . "O^~") ; 178 - (?,25(B . "O^.") ; 181 - (?,26(B . "O+`") ; 182 - (?,27(B . "O+?") ; 183 - (?,28(B . "I.") ; 184 - (?,2=(B . "O+") ; 189 - (?,2>(B . "O+'") ; 190 - (?,2F(B . "A(?") ; 198 - (?,2G(B . "A(~") ; 199 - (?,2O(B . "Y`") ; 207 - (?,2Q(B . "U+'") ; 209 - (?,2U(B . "A.") ; 213 - (?,2V(B . "Y?") ; 214 - (?,2W(B . "U+`") ; 215 - (?,2X(B . "U+?") ; 216 - (?,2[(B . "Y~") ; 219 - (?,2\(B . "Y.") ; 220 - (?,2^(B . "O+~") ; 222 - (?,2_(B . "U+") ; 223 - (?,2`(B . "A`") ; 224 - (?,2a(B . "A'") ; 225 - (?,2b(B . "A^") ; 226 - (?,2c(B . "A~") ; 227 - (?,2d(B . "A?") ; 228 - (?,2e(B . "A(") ; 229 - (?,2f(B . "U+~") ; 230 - (?,2g(B . "A^~") ; 231 - (?,2h(B . "E`") ; 232 - (?,2i(B . "E'") ; 233 - (?,2j(B . "E^") ; 234 - (?,2k(B . "E?") ; 235 - (?,2l(B . "I`") ; 236 - (?,2m(B . "I'") ; 237 - (?,2n(B . "I~") ; 238 - (?,2o(B . "I?") ; 239 - (?,2p(B . "DD") ; 240 - (?,2p(B . "dD") ; 240 - (?,2p(B . "Dd") ; 240 - (?,2q(B . "U+.") ; 241 - (?,2r(B . "O`") ; 242 - (?,2s(B . "O'") ; 243 - (?,2t(B . "O^") ; 244 - (?,2u(B . "O~") ; 245 - (?,2v(B . "O?") ; 246 - (?,2w(B . "O.") ; 247 - (?,2x(B . "U.") ; 248 - (?,2y(B . "U`") ; 249 - (?,2z(B . "U'") ; 250 - (?,2{(B . "U~") ; 251 - (?,2|(B . "U?") ; 252 - (?,2}(B . "Y'") ; 253 - (?,2~(B . "O+.") ; 254 - - ;; escape from composition - (?\( . "\\(") ; breve (left parenthesis) - (?^ . "\\^") ; circumflex (caret) - (?+ . "\\+") ; horn (plus sign) - (?' . "\\'") ; acute (apostrophe) - (?` . "\\`") ; grave (backquote) - (?? . "\\?") ; hook above (question mark) - (?~ . "\\~") ; tilde (tilde) - (?. . "\\.") ; dot below (period) - (?d . "\\d") ; d-bar (d) - (?\\ . "\\\\") ; literal backslash - ) - "Alist of Vietnamese characters vs corresponding `VIQR' string.") - -;; Regular expression matching single Vietnamese character represented -;; by VIQR. -(defconst viqr-regexp - "[aeiouyAEIOUY]\\([(^+]?['`?~.]\\|[(^+]\\)\\|[Dd][Dd]") - -;;;###autoload -(defun viet-decode-viqr-region (from to) - "Convert `VIQR' mnemonics of the current region to Vietnamese characaters. -When called from a program, expects two arguments, -positions (integers or markers) specifying the stretch of the region." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward viqr-regexp nil t) - (let* ((viqr (buffer-substring (match-beginning 0) (match-end 0))) - (ch (car (rassoc viqr viet-viqr-alist)))) - (if ch - (progn - (delete-region (match-beginning 0) (match-end 0)) - (insert ch))))))) - -;;;###autoload -(defun viet-decode-viqr-buffer () - "Convert `VIQR' mnemonics of the current buffer to Vietnamese characaters." - (interactive) - (viet-decode-viqr-region (point-min) (point-max))) - -;;;###autoload -(defun viet-encode-viqr-region (from to) - "Convert Vietnamese characaters of the current region to `VIQR' mnemonics. -When called from a program, expects two arguments, -positions (integers or markers) specifying the stretch of the region." - (interactive "r") - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward "\\cv" nil t) - (let* ((ch (preceding-char)) - (viqr (cdr (assq ch viet-viqr-alist)))) - (if viqr - (progn - (delete-char -1) - (insert viqr))))))) - -;;;###autoload -(defun viet-encode-viqr-buffer () - "Convert Vietnamese characaters of the current buffer to `VIQR' mnemonics." - (interactive) - (viet-encode-viqr-region (point-min) (point-max))) - -;;;###autoload -(defun viqr-post-read-conversion (len) - (save-excursion - (save-restriction - (narrow-to-region (point) (+ (point) len)) - (let ((buffer-modified-p (buffer-modified-p))) - (viet-decode-viqr-region (point-min) (point-max)) - (set-buffer-modified-p buffer-modified-p) - (- (point-max) (point-min)))))) - -;;;###autoload -(defun viqr-pre-write-conversion (from to) - (let ((old-buf (current-buffer)) - (work-buf (get-buffer-create " *viet-work*"))) - (set-buffer work-buf) - (erase-buffer) - (if (stringp from) - (insert from) - (insert-buffer-substring old-buf from to)) - (viet-encode-viqr-region (point-min) (point-max)) - ;; Should return nil as annotations. - nil)) - -;;; -(provide 'viet-util) - -;;; viet-util.el ends here
--- a/lisp/language/vietnamese.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/language/vietnamese.el Mon Aug 13 10:03:52 2007 +0200 @@ -2,25 +2,26 @@ ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. ;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko ;; Keywords: multilingual, Vietnamese -;; This file is part of GNU Emacs. +;; This file is part of XEmacs. -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by +;; XEmacs 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. -;; GNU Emacs 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. +;; XEmacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; 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. ;;; Commentary: @@ -106,135 +107,268 @@ ) -(define-ccl-program ccl-decode-viscii - `(3 - ((read r0) +(define-ccl-program ccl-read-viscii + `(((read r0) (loop - (write-read-repeat r0 ,viet-viscii-decode-table)) + (write-read-repeat r0 ,viet-viscii-decode-table)) )) - "CCL program to decode VISCII 1.1") + "CCL program to read VISCII 1.1") + +;; (define-ccl-program ccl-decode-viscii +;; `(3 +;; ((read r0) +;; (loop +;; (write-read-repeat r0 ,viet-viscii-decode-table)) +;; )) +;; "CCL program to decode VISCII 1.1") ;; Multibyte form of a Vietnamese character is as follows (3-byte): ;; LEADING-CODE-PRIVATE-11 LEADING-CODE-EXTENDED-11 POSITION-CODE ;; where LEADING-CODE-EXTENDED-11 for Vietnamese is ;; `vietnamese-viscii-lower' or `vietnamese-viscii-upper'. -(define-ccl-program ccl-encode-viscii - `(1 - ((read r0) - (loop +(define-ccl-program ccl-write-viscii + `(((read r0) + (loop (if (r0 < 128) - ;; ASCII (write-read-repeat r0) - ;; not ASCII - (if (r0 != ,leading-code-private-11) - ;; not Vietnamese + (if (r0 != 154) (write-read-repeat r0) - ((read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (;; Vietnamese lower - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(car viet-viscii-encode-table))) - (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) - (;; Vietnamese upper - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) - ;; not Vietnamese - (write-read-repeat r0))))))))) - "CCL program to encode VISCII 1.1") + ((read-if (r0 == 163) + ((read r0) + (r0 -= 160) + (write-read-repeat r0 ,(car viet-viscii-encode-table)) + (if (r0 == 164) + ((read r0) + (r0 -= 160) + (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) + (write-read-repeat r0)))))))))) + "CCL program to write VISCII 1.1") + +;; (define-ccl-program ccl-encode-viscii +;; `(1 +;; ((read r0) +;; (loop +;; (if (r0 < 128) +;; ;; ASCII +;; (write-read-repeat r0) +;; ;; not ASCII +;; (if (r0 != ,leading-code-private-11) +;; ;; not Vietnamese +;; (write-read-repeat r0) +;; ((read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (;; Vietnamese lower +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(car viet-viscii-encode-table))) +;; (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) +;; (;; Vietnamese upper +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) +;; ;; not Vietnamese +;; (write-read-repeat r0))))))))) +;; "CCL program to encode VISCII 1.1") -(define-ccl-program ccl-encode-viscii-font - `(0 - ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper - ;; R1:position code - ;; Out: R1:font code point - (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (r1 = r1 ,(car viet-viscii-encode-table)) - (r1 = r1 ,(cdr viet-viscii-encode-table))) - ) - "CCL program to encode Vietnamese chars to VISCII 1.1 font") +(define-ccl-program ccl-vietnamese-lower-to-viscii + `(((r1 = r1 + ,(car viet-viscii-encode-table)))) + "CCL program to convert chars of 'vietnamese-lower to VISCII 1.1 font") + +(define-ccl-program ccl-vietnamese-upper-to-viscii + `(((r1 = r1 + ,(cdr viet-viscii-encode-table)))) + "CCL program to convert chars of 'vietnamese-upper to VISCII 1.1 font") -(define-ccl-program ccl-decode-vscii - `(3 - ((read r0) +;; (define-ccl-program ccl-encode-viscii-font +;; `(0 +;; ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper +;; ;; R1:position code +;; ;; Out: R1:font code point +;; (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (r1 = r1 ,(car viet-viscii-encode-table)) +;; (r1 = r1 ,(cdr viet-viscii-encode-table))) +;; ) +;; "CCL program to encode Vietnamese chars to VISCII 1.1 font") + +(define-ccl-program ccl-read-vscii + `(((read r0) + (loop + (write-read-repeat r0 ,viet-vscii-decode-table)) + )) + "CCL program to read VSCII-1.") + +;; (define-ccl-program ccl-decode-vscii +;; `(3 +;; ((read r0) +;; (loop +;; (write-read-repeat r0 ,viet-vscii-decode-table)) +;; )) +;; "CCL program to decode VSCII-1.") + +(define-ccl-program ccl-write-vscii + `(((read r0) (loop - (write-read-repeat r0 ,viet-vscii-decode-table)) - )) - "CCL program to decode VSCII-1.") + (if (r0 < 128) + (write-read-repeat r0) + (if (r0 != 154) + (write-read-repeat r0) + (read-if (r0 == 163) + ((read r0) + (r0 -= 160) + (write-read-repeat r0 ,(car viet-vscii-encode-table))) + (if (r0 == 164) + ((read r0) + (r0 -= 160) + (write-read-repeat + r0 ,(cdr viet-viscii-encode-table))) + (write-read-repeat r0)))))))) + "CCL program to write VSCII-1.") + +;; (define-ccl-program ccl-encode-vscii +;; `(1 +;; ((read r0) +;; (loop +;; (if (r0 < 128) +;; ;; ASCII +;; (write-read-repeat r0) +;; ;; not ASCII +;; (if (r0 != ,leading-code-private-11) +;; ;; not Vietnamese +;; (write-read-repeat r0) +;; (read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (;; Vietnamese lower +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(car viet-vscii-encode-table))) +;; (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) +;; (;; Vietnamese upper +;; (read r0) +;; (r0 -= 128) +;; (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) +;; ;; not Vietnamese +;; (write-read-repeat r0)))))))) +;; "CCL program to encode VSCII-1.") -(define-ccl-program ccl-encode-vscii - `(1 - ((read r0) - (loop - (if (r0 < 128) - ;; ASCII - (write-read-repeat r0) - ;; not ASCII - (if (r0 != ,leading-code-private-11) - ;; not Vietnamese - (write-read-repeat r0) - (read-if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (;; Vietnamese lower - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(car viet-vscii-encode-table))) - (if (r0 == ,(charset-id 'vietnamese-viscii-upper)) - (;; Vietnamese upper - (read r0) - (r0 -= 128) - (write-read-repeat r0 ,(cdr viet-viscii-encode-table))) - ;; not Vietnamese - (write-read-repeat r0)))))))) - "CCL program to encode VSCII-1.") +(define-ccl-program ccl-vietnamese-lower-to-vscii + '(((r1 = r1 + [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 190 187 198 202 199 200 203 207 209 213 210 211 212 214 232 + 229 230 231 0 0 233 234 235 222 0 0 0 0 0 237 0 + 0 0 0 0 0 0 188 189 0 0 0 0 0 0 0 250 + 0 248 0 0 0 185 251 245 246 0 0 252 254 0 236 0 + 181 184 169 183 182 168 247 201 204 208 170 206 215 221 220 216 + 174 249 223 227 171 226 225 228 244 239 243 242 241 253 238 0 + ]))) + "CCL program to convert chars of 'vietnamese-lower to VSCII-1 font.") -(define-ccl-program ccl-encode-vscii-font - `(0 - ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper - ;; R1:position code - ;; Out: R1:font code point - (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) - (r1 = r1 ,(car viet-vscii-encode-table)) - (r1 = r1 ,(cdr viet-vscii-encode-table))) - ) - "CCL program to encode Vietnamese chars to VSCII-1 font.") +(define-ccl-program ccl-vietnamese-upper-to-vscii + '(((r1 = r1 + [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 192 175 133 0 196 194 134 137 139 218 197 205 217 140 255 + 219 224 240 0 0 151 152 153 145 0 0 0 0 165 155 0 + 0 0 0 0 0 0 186 191 0 0 0 0 0 0 0 19 + 0 17 0 0 0 132 20 4 5 0 0 21 23 0 154 166 + 128 131 162 130 129 161 6 195 135 138 163 136 141 144 143 142 + 167 0 146 149 164 148 147 150 2 157 1 159 158 22 156 0 + ]))) + "CCL program to convert chars of 'vietnamese-upper to VSCII-1 font.") + +;; (define-ccl-program ccl-encode-vscii-font +;; `(0 +;; ;; In: R0:vietnamese-viscii-lower/vietnamese-viscii-upper +;; ;; R1:position code +;; ;; Out: R1:font code point +;; (if (r0 == ,(charset-id 'vietnamese-viscii-lower)) +;; (r1 = r1 ,(car viet-vscii-encode-table)) +;; (r1 = r1 ,(cdr viet-vscii-encode-table))) +;; ) +;; "CCL program to encode Vietnamese chars to VSCII-1 font.") (make-coding-system - 'vietnamese-viscii 4 ?V - "8-bit encoding for Vietnamese VISCII 1.1 (MIME:VISCII)" - (cons ccl-decode-viscii ccl-encode-viscii)) + 'viscii 'ccl + "Coding-system used for VISCII 1.1." + `(mnemonic "VISCII" + decode ,ccl-read-viscii + encode ,ccl-write-viscii)) -(define-coding-system-alias 'viscii 'vietnamese-viscii) +;; (make-coding-system +;; 'vietnamese-viscii 4 ?V +;; "8-bit encoding for Vietnamese VISCII 1.1 (MIME:VISCII)" +;; (cons ccl-decode-viscii ccl-encode-viscii)) + +;; (define-coding-system-alias 'viscii 'vietnamese-viscii) (make-coding-system - 'vietnamese-vscii 4 ?v - "8-bit encoding for Vietnamese VSCII-1" - (cons ccl-decode-vscii ccl-encode-vscii)) + 'vscii 'ccl + "Coding-system used for VSCII 1.1." + `(mnemonic "VSCII" + decode ,ccl-read-vscii + encode ,ccl-write-vscii)) -(define-coding-system-alias 'vscii 'vietnamese-vscii) +;; (make-coding-system +;; 'vietnamese-vscii 4 ?v +;; "8-bit encoding for Vietnamese VSCII-1" +;; (cons ccl-decode-vscii ccl-encode-vscii)) + +;; (define-coding-system-alias 'vscii 'vietnamese-vscii) (make-coding-system - 'vietnamese-viqr 0 ?q - "Vietnamese latin transcription (VIQR)" - nil) -(put 'vietnamese-viqr 'post-read-conversion 'viqr-post-read-conversion) -(put 'vietnamese-viqr 'pre-write-conversion 'viqr-pre-write-conversion) + 'viqr 'no-conversion + "Coding-system used for VIQR." + '(mnemonic "VIQR" + eol-type lf + post-read-conversion viqr-post-read-conversion + pre-write-conversion viqr-pre-write-conversion)) + +;; (make-coding-system +;; 'vietnamese-viqr 0 ?q +;; "Vietnamese latin transcription (VIQR)" +;; nil) +;; (put 'vietnamese-viqr 'post-read-conversion 'viqr-post-read-conversion) +;; (put 'vietnamese-viqr 'pre-write-conversion 'viqr-pre-write-conversion) -(define-coding-system-alias 'viqr 'vietnamese-viqr) +;; (define-coding-system-alias 'viqr 'vietnamese-viqr) -(setq font-ccl-encoder-alist - (cons (cons "viscii" ccl-encode-viscii-font) font-ccl-encoder-alist)) +;; For VISCII users +(set-charset-ccl-program 'vietnamese-viscii-lower + ccl-vietnamese-lower-to-viscii) +(set-charset-ccl-program 'vietnamese-viscii-upper + ccl-vietnamese-upper-to-viscii) +;; For VSCII users +;; (set-charset-ccl-program 'vietnamese-lower ccl-vietnamese-lower-to-vscii) +;; (set-charset-ccl-program 'vietnamese-upper ccl-vietnamese-upper-to-vscii) -(setq font-ccl-encoder-alist - (cons (cons "vscii" ccl-encode-vscii-font) font-ccl-encoder-alist)) +;; (setq font-ccl-encoder-alist +;; (cons (cons "viscii" ccl-encode-viscii-font) font-ccl-encoder-alist)) + +;; (setq font-ccl-encoder-alist +;; (cons (cons "vscii" ccl-encode-vscii-font) font-ccl-encoder-alist)) (set-language-info-alist "Vietnamese" '((setup-function . setup-vietnamese-environment) (charset . (vietnamese-viscii-lower vietnamese-viscii-upper)) - (coding-system . (vietnamese-viscii vietnamese-vscii - vietnamese-viqr)) + (coding-system . (viscii vscii viqr)) (sample-text . "Vietnamese (Ti,1*(Bng Vi,1.(Bt) Ch,1`(Bo b,1U(Bn") (documentation . "\ For Vietnamese, Emacs uses special charasets internally.
--- a/lisp/language/visual-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1176 +0,0 @@ -;; visual.el -- cursor motion, insertion, deletion, etc. in visual order -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;;; 94.5.15 created for Mule Ver.1.1 by Takahashi N. <ntakahas@etl.go.jp> - -;;;###autoload -(defvar visual-mode nil "non-nil if in visual-mode.") - -(make-variable-buffer-local 'visual-mode) - -(defvar visual-use-lr-commands nil - "If non-nil, use visual-left-* and visual-right-* commands instead of -visual-forward-* and visual-backward-* commands.") - -(defvar visual-mode-map - (let ((map (make-keymap))) - (substitute-key-definition 'self-insert-command - 'visual-self-insert-command - map global-map) - ; visual basic commands - (define-key map [(control d)] 'visual-delete-char) - (define-key map [(control k)] 'visual-kill-line) - (define-key map [(control m)] 'visual-newline) - (define-key map [(control o)] 'visual-open-line) - (define-key map [(control p)] 'visual-previous-line) - (define-key map [(control w)] 'visual-kill-region) - (define-key map [(control y)] 'visual-yank) - (define-key map [delete] 'visual-backward-delete-char) - (define-key map [(meta <)] 'visual-beginning-of-buffer) - (define-key map [(meta >)] 'visual-end-of-buffer) - (define-key map [(meta d)] 'visual-kill-word) - (define-key map [(meta w)] 'visual-kill-ring-save) - (define-key map [(meta y)] 'visual-yank-pop) - (define-key map [(meta delete)] 'visual-backward-kill-word) - (define-key map [up] 'visual-previous-line) - (define-key map [down] 'visual-next-line) - (define-key map [home] 'visual-beginning-of-buffer) - (define-key map [end] 'visual-end-of-buffer) - (define-key map [left] 'visual-move-to-left-char) - (define-key map [right] 'visual-move-to-right-char) - (define-key map [(meta left)] 'visual-move-to-left-word) - (define-key map [(meta right)] 'visual-move-to-right-word) - (define-key map [(control c) (control c)] 'exit-visual-mode) - (define-key map [(control c) <] 'l2r-mode) - (define-key map [(control c) >] 'r2l-mode) - ; LR commands - (if visual-use-lr-commands - (progn - (define-key map [(control a)] 'visual-left-end-of-line) - (define-key map [(control b)] 'visual-move-to-left-char) - (define-key map [(control e)] 'visual-right-end-of-line) - (define-key map [(control f)] 'visual-move-to-right-char) - (define-key map [(meta b)] 'visual-move-to-left-word) - (define-key map [(meta f)] 'visual-move-to-right-word)) - (define-key map [(control a)] 'visual-beginning-of-line) - (define-key map [(control b)] 'visual-backward-char) - (define-key map [(control e)] 'visual-end-of-line) - (define-key map [(control f)] 'visual-forward-char) - (define-key map [(meta b)] 'visual-backward-word) - (define-key map [(meta f)] 'visual-forward-word)) - map) - "minor-mode-keymap for visual-mode.") - -(if (not (assq 'visual-mode minor-mode-map-alist)) - (setq minor-mode-map-alist - (cons (cons 'visual-mode visual-mode-map) - minor-mode-map-alist))) - -(defvar visual-mode-indicator nil - "string displayed in mode line. \" l2r\" or \" r2l\".") -(make-variable-buffer-local 'visual-mode-indicator) - -(if (not (assq 'visual-mode minor-mode-alist)) - (setq minor-mode-alist - (cons '(visual-mode visual-mode-indicator) - minor-mode-alist))) - -(setq auto-mode-alist - (append '(("\\.l2r$" . l2r-mode) ("\\.r2l$" . r2l-mode)) - auto-mode-alist)) - -(defvar visual-mode-hooks nil) - -;;;###autoload -(defun visual-mode (&optional arg) - "Toggle visual-mode. With ARG, turn visual-mode on iff ARG is positive." - (interactive "P") - (if (null arg) - (if visual-mode (exit-visual-mode) (enter-visual-mode)) - (if (> (prefix-numeric-value arg) 0) - (enter-visual-mode) - (exit-visual-mode)))) - -(defun enter-visual-mode nil - "Enter visual-mode. Cursor moves in visual order." - (interactive) - (if (not visual-mode) - (progn - (setq visual-mode t - visual-mode-indicator (if display-direction " r2l" " l2r")) - (redraw-display) - (run-hooks 'visual-mode-hooks)))) - -(defun exit-visual-mode nil - "Exit visual-mode. Cursor moves in logical order." - (interactive) - (if visual-mode - (progn - (setq visual-mode nil) - (redraw-modeline t)))) - -(defun l2r-mode nil - "Set display-direction left to right." - (interactive) - (if (not visual-mode) - (enter-visual-mode)) - (setq display-direction nil) - (setq visual-mode-indicator " l2r") - (redraw-display)) - -(defun r2l-mode nil - "Set display-direction right to left." - (interactive) - (if (not visual-mode) - (enter-visual-mode)) - (setq display-direction t) - (setq visual-mode-indicator " r2l") - (redraw-display)) - - -;; cursor motion - -(defun visual-forward-char (arg) - "Move the cursor visually forward by ARG (integer) characters. -if ARG is negative, move backward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-backward-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-forward-1-char) - (setq arg (1- arg))))) - -(defun visual-forward-1-char nil - "Move the cursor visually forward by 1 character." - (let ((r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point))) - - ; symbols used in the following comments - ; ^ : point in here - ; ~ : point will be there - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (cond - ((null a-dir) - ; ... nil - ; ^ - (error "end of buffer")) - - ((eq a-dir r-dir) - (if (eq b-dir r-dir) - - ; ... r r ... - ; ~ ^ - (backward-char 1) - - ; ... !r r r* ... - ; ^ ~ - (skip-direction-forward r-dir))) - - ((eq aa-dir r-dir) - ; ... d r* r ... - ; ^ ~ - (forward-char 1) - (skip-direction-forward r-dir) - (backward-char 1)) - - (t - ; ... d !r ... - ; ^ ~ - (forward-char 1))))) - -(defun visual-backward-char (arg) - "Move the cursor visually backward by ARG (integer) characters. -if ARG is negative, move forward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-forward-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-backward-1-char) - (setq arg (1- arg))))) - -(defun visual-backward-1-char nil - "Move the cursor visually backward by 1 character." - (let ((r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point))) - - ; symbols used in the following comments - ; ^ : point in here - ; ~ : point will be there - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (cond - ((eq a-dir r-dir) - (if (eq aa-dir r-dir) - ; ... r r ... - ; ^ ~ - (forward-char 1) - - ; ... !r r* !r ... - ; ~ ^ - (skip-direction-backward r-dir) - (if (visual-char-direction-before-point) - (backward-char 1) - (skip-direction-forward r-dir) - (backward-char 1) - (error "beginning of buffer")))) - - ((null b-dir) - ; nil !r ... - ; ^ - (error "beginning of buffer")) - - ((eq b-dir r-dir) - ; ... r* r !r - ; ~ ^ - (skip-direction-backward r-dir)) - - (t - ; ... d !r ... - ; ~ ^ - (backward-char 1))))) - -(defun visual-char-direction (ch) - "Return the direction of CH (character). -Newline's direction will be same as display-direction." - (cond - ((null ch) nil) - ((= ch ?\n) (if display-direction 1 0)) - (t (char-direction ch)))) - -(defun visual-char-direction-after-point nil - "Return the direction of after-point-character. -0: left-to-right, 1: right-to-left" - (visual-char-direction (char-after (point)))) - -(defun visual-char-direction-after-after-point nil - "Return the direction of after-after-point-character. -0: left-to-right, 1: right-to-left" - (if (= (point) (point-max)) - nil - (save-excursion - (forward-char 1) - (visual-char-direction (char-after (point)))))) - -(defun visual-char-direction-before-point nil - "Return the direction of before-point-character. -0: left-to-right, 1: right-to-left" - (visual-char-direction (char-before (point)))) - -(defun skip-direction-forward (dir) - "Move point forward as long as DIR-direction characters continue." - (while (eq (visual-char-direction-after-point) dir) - (forward-char 1))) - -(defun skip-direction-backward (dir) - "Move point backward as long as DIR-direction characters continue." - (while (eq (visual-char-direction-before-point) dir) - (backward-char 1))) - -(defvar *visual-punctuations* - '(? ?. ?, ?: ?; ?? ?! ?- ?_ ?' ?\" ?/ ?( ?) ?[ ?] ?{ ?} ?\n ?\t ; ASCII - ? ?. ?, ?: ?; ?? ?! ?- ?_ ?' ?" ?( ?) ?[ ?] ; Hebrew - ?[2](3[0](B ?[2](3"[0](B ?[2](3'[0](B ?[2](3([0](B ?[2](3#[0](B ?[2](3$[0](B ?[2](3*[0](B ?[2](3+[0](B )) ; Arabic - -(defun visual-forward-word (arg) - "Move the cursor visually forward by ARG (integer) words. -If ARG is negative, move the cursor backward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-backward-1-word) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-forward-1-word) - (setq arg (1- arg))))) - -(defun visual-backward-word (arg) - "Move the cursor visually backward by ARG (integer) words. -If ARG is negative, move the cursor forward." - (interactive "p") - (if (< arg 0) - (while (< arg 0) - (visual-forward-1-word) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-backward-1-word) - (setq arg (1- arg))))) - -(defun visual-forward-1-word nil - "Move the cursor visually forward by one word." - (while (memq (visual-char-after) *visual-punctuations*) - (visual-forward-1-char)) - (while (not (memq (visual-char-after) *visual-punctuations*)) - (visual-forward-1-char))) - -(defun visual-backward-1-word nil - "Move the cursor visually backward by one word." - (while (memq (visual-char-before) *visual-punctuations*) - (visual-backward-1-char)) - (while (not (memq (visual-char-before) *visual-punctuations*)) - (visual-backward-1-char))) - -(defun visual-char-before nil - "Return the character visually before the cursor. -If such position is out of range, returns nil." - ; almost same as visual-backward-1-char - (save-excursion - (let ((r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point))) - (cond - ((eq a-dir r-dir) - (if (eq aa-dir r-dir) - (progn - (forward-char 1) - (char-after (point))) - (skip-direction-backward r-dir) - (if (visual-char-direction-before-point) - (progn - (backward-char 1) - (char-after (point))) - nil))) - ((null b-dir) - nil) - ((eq b-dir r-dir) - (skip-direction-backward r-dir) - (char-after (point))) - (t - (backward-char 1) - (char-after (point))))))) - -(defun visual-char-after nil - "Return the character under the cursor. -If such position is out of range, returns nil." - (char-after (point))) - -(defun visual-beginning-of-line (&optional arg) - "Move the cursor to the visual beginning of line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (beginning-of-line arg) - (let ((a-dir (visual-char-direction-after-point)) - (d-dir (if display-direction 1 0))) - (if (and a-dir (/= a-dir d-dir)) - (progn (skip-direction-forward a-dir) - (backward-char 1))))) - -(fset 'visual-end-of-line 'end-of-line) - -(defun visual-beginning-of-buffer nil - "Move the cursor to the visual beginning of current buffer." - (interactive) - (beginning-of-buffer) - (visual-beginning-of-line)) - -(fset 'visual-end-of-buffer 'end-of-buffer) - -(defvar visual-temporary-goal-column 0 - "temporary-goal-column command for visual-mode.") - -(defun visual-next-line (arg) - "next-line command for visual-mode." - (interactive "p") - (if (and (not (eq last-command 'visual-next-line)) - (not (eq last-command 'visual-previous-line))) - (setq visual-temporary-goal-column (visual-current-column))) - (next-line arg) - (visual-goto-column visual-temporary-goal-column)) - -(defun visual-previous-line (arg) - "previous-line command for visual-mode." - (interactive "p") - (if (and (not (eq last-command 'visual-next-line)) - (not (eq last-command 'visual-previous-line))) - (setq visual-temporary-goal-column (visual-current-column))) - (previous-line arg) - (visual-goto-column visual-temporary-goal-column)) - -(defun visual-current-column nil - "Return the current column counted in visual order." - (let ((c 0) (p (point))) - (visual-beginning-of-line) - (while (/= (point) p) - (setq c (+ c (char-width (visual-char-after)))) - (visual-forward-1-char)) - c)) - -(defun visual-goto-column (col) - "Move the cursor to visual column N (integer) in the current line. -If it is impossible to go to column N, the cursor is put on the nearest column -M (M < N). Returns N - M." - (if (< col 0) - (error "argument must be positive.")) - (let ((c 0)) - (visual-beginning-of-line) - (while (and (< c col) (not (eolp))) - (setq c (+ c (char-width (visual-char-after)))) - (visual-forward-1-char)) - (if (> c col) - (progn - (visual-backward-1-char) - (setq c (- c (char-width (visual-char-after)))))) - (- col c))) - - -;; insertion - -(defun visual-insert-char (ch arg) - "Insert character CH visually before the cursor. -With ARG (integer) insert that many characters." - (if (< arg 0) - (error "arg must be >= 0.")) - (while (> arg 0) - (visual-insert-1-char ch) - (setq arg (1- arg)))) - -(defun visual-insert-1-char (ch) - "Insert character CH visually before the cursor. -The cursor moves visually forward." - (let ((c-dir (visual-char-direction ch)) - (r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (tmp)) - - ; symbols used in the following comments - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; ^d : point is here and the character to be inserted is d - ; ^r : point is here and the character to be inserted is d - - (if (eq c-dir r-dir) - (if (eq a-dir r-dir) - - ; ... r ... - ; ^r - (progn - (forward-char 1) - (insert ch) - (backward-char 2)) - - ; ... !r ... - ; ^r - (skip-direction-backward c-dir) - (insert ch) - (skip-direction-forward c-dir)) - - (if (or (eq a-dir nil) - (eq a-dir c-dir)) - - ; ... !r ... - ; ^d - (insert ch) - - ; ... r ... - ; ^d - (forward-char 1) - (setq tmp (delete-direction-backward r-dir)) - (skip-direction-forward r-dir) - (insert ch tmp) - (backward-char 1))))) - -(defun delete-direction-forward (dir) - "From current point, delete DIR-direction characters forward. -Returns the deleted string." - (let ((p (point))) - (skip-direction-forward dir) - (prog1 - (buffer-substring (point) p) - (delete-region (point) p)))) - -(defun delete-direction-backward (dir) - "From current point, delete DIR-direction characters backward. -Return the deleted string." - (let ((p (point))) - (skip-direction-backward dir) - (prog1 - (buffer-substring (point) p) - (delete-region (point) p)))) - -(defun visual-self-insert-command (arg) - "Insert this character (32 <= CH < 127). -With ARG (integer), insert that many characters. -If display-direction is non-nil, the cursor stays at the same position." - (interactive "*p") - (visual-insert-char last-command-char arg) - (if display-direction - (visual-backward-char arg))) - -;; wire us into pending-delete -(put 'visual-self-insert-command 'pending-delete t) - -(defun visual-newline (arg) - "newline command for visual-mode. -With ARG (integer), insert that many newlines." - (interactive "*p") - (visual-insert-char ?\n arg)) - -(defun visual-open-line (arg) - "open-line command for visual-mode. -With arg (integer), insert that many newlines." - (interactive "*p") - (visual-insert-char ?\n arg) - (visual-backward-char arg)) - - -;; deletion - -(defun visual-delete-char (arg) - "Delete ARG (integer) characters visually forward. -If ARG is negative, delete backward." - (interactive "*p") - (if (< arg 0) - (while (< arg 0) - (visual-backward-delete-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-delete-1-char) - (setq arg (1- arg))))) - -(defun visual-backward-delete-char (arg) - "Delete ARG (integer) characters visually backward. -If arg is negative, delete forward." - (interactive "*p") - (if (< arg 0) - (while (< arg 0) - (visual-delete-1-char) - (setq arg (1+ arg))) - (while (> arg 0) - (visual-backward-delete-1-char) - (setq arg (1- arg))))) - -(fset 'visual-delete-backward-char 'visual-backward-delete-char) - -(defun visual-backward-delete-1-char nil - "Delete a character visually before the cursor. -Ther cursor moves visually backward." - (let ((d-dir (if display-direction 1 0)) - (r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point)) - (tmp)) - - ; symbols used in the following comments - ; ^ : point in here - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (if (eq a-dir r-dir) - (cond - ((eq aa-dir r-dir) - ; ... r r ... - ; ^ - (forward-char 1) - (delete-char 1) - (backward-char 1)) - - ((save-excursion - (skip-direction-backward r-dir) - (backward-char 1) - (and (eq (visual-char-direction-after-point) d-dir) - (eq (visual-char-direction-before-point) r-dir))) - ; ... r d r* r !r ... - ; ^ - (forward-char 1) - (setq tmp (delete-direction-backward r-dir)) - (delete-backward-char 1) - (skip-direction-backward r-dir) - (insert tmp) - (backward-char 1)) - - (t - ; .....!r d r* r !r ... - ; ^ - (skip-direction-backward r-dir) - (delete-backward-char 1) - (skip-direction-forward r-dir) - (backward-char 1))) - - (cond - ((null b-dir) - ; nil !r ... - ; ^ - (error "beginning of buffer")) - - ((eq b-dir r-dir) - ; ... r !r ... - ; ^ - (skip-direction-backward r-dir) - (delete-char 1) - (skip-direction-forward r-dir)) - - (t - ; ... !r !r ... - ; ^ - (delete-backward-char 1)))))) - -(fset 'visual-delete-backward-1-char 'visual-backward-delete-1-char) - -(defun visual-delete-1-char nil - "Delete a character under the cursor. -Visually, the cursor stays at the same position." - (let ((d-dir (if display-direction 1 0)) - (r-dir (if display-direction 0 1)) - (a-dir (visual-char-direction-after-point)) - (aa-dir (visual-char-direction-after-after-point)) - (b-dir (visual-char-direction-before-point)) - (tmp)) - - ; symbols used in the following comments - ; ^ : point in here - ; d : character whose direction is the same as display-direction - ; r : character whose direction is opposite to display-direction - ; !d : r or nil - ; !r : d or nil - ; r* : 0 or more r's - ; d* : 0 or more d's - - (cond - ((null a-dir) - ; ... nil - ; ^ - (error "end of buffer")) - - ((eq a-dir r-dir) - (if (eq b-dir r-dir) - - ; ... r r ... - ; ^ - (progn (delete-char 1) - (backward-char 1)) - - ; ... !r r ... - ; ^ - (delete-char 1) - (skip-direction-forward r-dir))) - - ((not (eq aa-dir r-dir)) - ; ... d !r ... - ; ^ - (delete-char 1)) - - ((eq b-dir r-dir) - ; ... r d r ... - ; ^ - (delete-char 1) - (setq tmp (delete-direction-forward r-dir)) - (skip-direction-backward r-dir) - (insert tmp) - (backward-char 1)) - - (t - ; ...!r d r ... - ; ^ - (delete-char 1) - (skip-direction-forward r-dir) - (backward-char 1))))) - -(defun visual-delete-region (beg end) - "delete-region command for visual-mode." - (interactive "*r") - (let ((begl) (begc) (endl) (endc) (l)) - - ; swap beg & end if necessary - (goto-char beg) - (setq begl (current-line) - begc (visual-current-column)) - (goto-char end) - (setq endl (current-line) - endc (visual-current-column)) - (if (or (> begl endl) - (and (= begl endl) - (> begc endc))) - (progn - (setq beg (prog1 end (setq end beg)) - begl (prog1 endl (setq endl begl)) - begc (prog1 endc (setq endc begc))) - (goto-char end))) - - ; insert a newline visually at END - (visual-insert-1-char ?\n) - (visual-backward-1-char) - (setq l (current-line)) - - ; insert a newline visually at BEG - (goto-line begl) - (visual-goto-column begc) - (visual-insert-1-char ?\n) - (beginning-of-line) - - (delete-region - (point) - (progn - (goto-line (1+ l)) - (end-of-line) - (point))) - (backward-char 1) - (visual-delete-char 2))) - -(defun current-line nil - "Return the current line number (in the buffer) of point." - (interactive) - (save-excursion - (beginning-of-line) - (1+ (count-lines 1 (point))))) - - -;; kill - -(defun visual-kill-region (beg end) - "kill-region command for visual-mode." - (interactive "r") - (let ((begl) (begc) (endl) (endc) (l)) - - ; swap beg & end if necessary - (goto-char beg) - (setq begl (current-line) - begc (visual-current-column)) - (goto-char end) - (setq endl (current-line) - endc (visual-current-column)) - (if (or (> begl endl) - (and (= begl endl) (> begc endc))) - (progn - (setq beg (prog1 end (setq end beg)) - begl (prog1 endl (setq endl begl)) - begc (prog1 endc (setq endc begc))) - (goto-char end))) - - (if (or (and buffer-read-only (not inhibit-read-only)) - (text-property-not-all beg end 'read-only nil)) - (progn - (visual-copy-region-as-kill beg end) - (if kill-read-only-ok - (message "Read only text copied to kill ring") - (barf-if-buffer-read-only))) - - ; insert a newline visually at END - (visual-insert-1-char ?\n) - (visual-backward-1-char) - (setq l (current-line)) - - ; insert a newline visually at BEG - (goto-line begl) - (visual-goto-column begc) - (visual-insert-1-char ?\n) - (beginning-of-line) - - (kill-region - (point) - (progn - (goto-line (1+ l)) - (end-of-line) - (point))) - (backward-char 1) - (visual-delete-char 2))) - - (setq this-command 'kill-region)) - -(defun visual-kill-word (arg) - "Kill ARG (integer) words visually forward. -If ARG is negative, kill backward." - (interactive "*p") - (visual-kill-region - (point) - (progn - (visual-forward-word arg) - (point)))) - -(defun visual-backward-kill-word (arg) - "Kill ARG (integer) words visually backward. -If ARG is negative, kill forward." - (interactive "*p") - (visual-kill-region - (point) - (progn - (visual-backward-word arg) - (point)))) - -(defun visual-kill-line (&optional arg) - "kill-line command for visual-mode." - (interactive "*P") - (visual-kill-region - (point) - (progn - (if arg - (progn - (forward-line (prefix-numeric-value arg)) - (visual-beginning-of-line)) - (if (eobp) - (signal 'end-of-buffer nil)) - (if (not (eolp)) - (visual-end-of-line) - (forward-line 1) - (visual-beginning-of-line))) - (point)))) - -(defun visual-copy-region-as-kill (beg end) - "copy-region-as-kill command for visual-mode." - (interactive "r") - (let ((buffer-read-only nil) - (auto-save-mode 0) - (p (point))) - (visual-kill-region beg end) - (visual-yank 1) - (if (/= (point) p) - (exchange-point-and-mark))) - nil) - -(defun visual-kill-ring-save (beg end) - "kill-ring-save command for visual-mode." - (interactive "r") - (visual-copy-region-as-kill beg end) - (if (interactive-p) - (let ((other-end (if (= (point) beg) end beg)) - (opoint (point)) - (inhibit-quit t)) - (if (pos-visible-in-window-p other-end (selected-window)) - (progn - (set-marker (mark-marker) (point) (current-buffer)) - (goto-char other-end) - (sit-for 1) - (set-marker (mark-marker) other-end (current-buffer)) - (goto-char opoint) - (and quit-flag mark-active - (deactivate-mark))) - (let* ((killed-text (current-kill 0)) - (message-len (min (length killed-text) 40))) - (if (= (point) beg) - (message "Saved text until \"%s\"" - (substring killed-text (- message-len))) - (message "Saved text from \"%s\"" - (substring killed-text 0 message-len)))))))) - - -;; yank - -(defun visual-yank (&optional arg) - "yank command for visual-mode." - (interactive "*P") - (setq this-command t) - - (let ((l1 (current-line)) (c1 (visual-current-column)) l2 c2) - - ;; Insert a newline both before and after current point. - (visual-insert-char ?\n 2) - (visual-backward-1-char) - - ;; Reinsert killed string between the two newlines. - (insert (current-kill (cond - ((listp arg) 0) - ((eq arg '-) -1) - (t (1- arg))))) - - ;; Delete the latter newline visually. - (visual-delete-1-char) - (setq l2 (current-line) - c2 (visual-current-column)) - - ;; Delete the former newline visually. - (goto-line l1) - (end-of-line) - (visual-delete-1-char) - (push-mark (point)) - - ;; Go back to the end of yanked string. - (if (= (- l2 l1) 1) - (visual-goto-column (+ c1 c2)) - (goto-line (1- l2)) - (visual-goto-column c2)) - - ;; Exchange point and mark if necessary. - (if (consp arg) - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer)))))) - - (setq this-command 'yank) - nil) - -(defun visual-yank-pop (arg) - "yank-pop command for visual-mode." - (interactive "*p") - (if (not (eq last-command 'yank)) - (error "Previous command was not a yank")) - (setq this-command 'yank) - (let (l1 c1 l2 c2 before) - - (save-excursion - (setq l2 (current-line) - c2 (visual-current-column)) - (goto-char (mark t)) - (setq l1 (current-line) - c1 (visual-current-column)) - (if (or (> l1 l2) - (and (= l1 l2) (> c1 c2))) - (setq before t))) - - (visual-delete-region (point) (mark t)) - (setq l1 (current-line) - c1 (visual-current-column)) - - ;; Insert a newline both before and after current point. - (visual-insert-char ?\n 2) - (visual-backward-1-char) - - ;; Reinsert killed string between the two newlines. - (insert (current-kill arg)) - - ;; Delete the latter newline visually. - (visual-delete-1-char) - (setq l2 (current-line) - c2 (visual-current-column)) - - ;; Delete the former newline visually. - (goto-line l1) - (end-of-line) - (visual-delete-1-char) - (set-marker (mark-marker) (point) (current-buffer)) - - ;; Go back to the end of yanked string. - (if (= (- l2 l1) 1) - (visual-goto-column (+ c1 c2)) - (goto-line (1- l2)) - (visual-goto-column c2)) - - ;; Exchange point and mark if necessary. - (if before - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer)))))) - - nil) - - -;; misc - -(defun visual-reverse-direction-word nil - "Reverse the char order of the word before point." - (interactive "*") - (goto-char - (prog1 - (point) - (reverse-region - (point) - (progn (skip-direction-backward (visual-char-direction-before-point)) - (point)))))) - -(defun visual-reverse-region (begin end) - "Reverse the order of chars between BEGIN and END." - (interactive "*r") - (apply 'insert - (nreverse - (string-to-char-list - (prog1 (buffer-substring begin end) (delete-region begin end)))))) - - -;; LR commands - -(defun visual-char-left nil - "Return the character on the left of visual point." - (if display-direction - (visual-char-after) - (visual-char-before))) - -(defun visual-char-right nil - "Return the character on the right of visual point." - (if display-direction - (visual-char-before) - (visual-char-after))) - -(defun visual-move-to-left-char (arg) - "Move the cursor visually left by ARG (integer) characters. -If ARG is negative, move the cursor right." - (interactive "p") - (if display-direction - (visual-forward-char arg) - (visual-backward-char arg))) - -(defun visual-move-to-left-1-char nil - "Move the cursor visually left by 1 character." - (interactive "p") - (if display-direction - (visual-forward-1-char) - (visual-backward-1-char))) - -(defun visual-move-to-right-char (arg) - "Move the cursor visually right by ARG (integer) characters. -If ARG is negative, move the cursor left." - (interactive "p") - (if display-direction - (visual-backward-char arg) - (visual-forward-char arg))) - -(defun visual-move-to-right-1-char nil - "Move the cursor visually right by 1 character." - (interactive "p") - (if display-direction - (visual-backward-1-char) - (visual-forward-1-char))) - -(defun visual-move-to-left-word (arg) - "Move the cursor visually left by ARG (integer) words. -If ARG is negative, move the cursor right." - (interactive "p") - (if display-direction - (visual-forward-word arg) - (visual-backward-word arg))) - -(defun visual-move-to-right-word (arg) - "Move the cursor visually right by ARG (integer) words. -If ARG is negative, move the cursor left." - (interactive "p") - (if display-direction - (visual-backward-word arg) - (visual-forward-word arg))) - -(defun visual-left-end-of-line (arg) - "Move the line cursor to the left-end of line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (if display-direction - (visual-end-of-line arg) - (visual-beginning-of-line arg))) - -(defun visual-right-end-of-line (arg) - "Move the line cursor to the right-end of line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (if display-direction - (visual-beginning-of-line arg) - (visual-end-of-line arg))) - -(defun visual-insert-char-left (ch arg) - "Insert CH (character) on the left of visual point as many as -ARG (integer)." - (if (< arg 0) - (error "ARG must be >= 0.")) - (visual-insert-char ch arg) - (and display-direction - (visual-backward-char arg))) - -(defun visual-insert-left-1-char (ch) - "Insert CH (character) on the left of visual point." - (visual-insert-1-char ch) - (and display-direction - (visual-backward-1-char))) - -(defun visual-insert-char-right (ch arg) - "Insert CH (character) on the right of visual point as many as -ARG (integer)." - (if (< arg 0) - (error "ARG must be >= 0.")) - (visual-insert-char ch arg) - (or display-direction - (visual-backward-char arg))) - -(defun visual-insert-right-1-char (ch) - "Insert CH (character) on the right of visual point." - (visual-insert-1-char ch) - (or display-direction - (visual-backward-1-char))) - -(defun visual-delete-left-char (arg) - "Delete ARG (integer) characters on the left of visual point. -If ARG is negative, on the right." - (interactive "*p") - (if display-direction - (visual-delete-char arg) - (visual-backward-delete-char arg))) - -(defun visual-delete-left-1-char nil - "Delete 1 character on the left of visual point." - (interactive "*p") - (if display-direction - (visual-delete-1-char) - (visual-backward-delete-1-char))) - -(defun visual-delete-right-char (arg) - "Delete ARG (integer) characters on the right of visual point. -If ARG is negative, on the left." - (interactive "*p") - (if display-direction - (visual-backward-delete-char arg) - (visual-delete-char arg))) - -(defun visual-delete-right-1-char nil - "Delete 1 character on the right of visual point." - (interactive "*p") - (if display-direction - (visual-backward-delete-1-char) - (visual-delete-1-char))) - -(defmacro visual-replace-left-1-char (ch) - (list - 'progn - '(visual-delete-left-1-char) - (list 'visual-insert-left-1-char ch))) - -(defmacro visual-replace-right-1-char (ch) - (list - 'progn - '(visual-delete-right-1-char) - (list 'visual-insert-right-1-char ch))) - -(defun visual-kill-left-word (arg) - "Kill ARG (integer) words on the left of visual pointer. -If ARG is negative, kill on the right." - (interactive "*p") - (if display-direction - (visual-kill-word arg) - (visual-backward-kill-word arg))) - -(defun visual-kill-right-word (arg) - "Kill ARG (integer) words on the right of visual point. -If ARG is negative, kill on the left." - (interactive "*p") - (if display-direction - (visual-backward-kill-word arg) - (visual-kill-word arg))) - -;;; -(provide 'visual-mode)
--- a/lisp/leim/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sun Sep 28 14:03:16 1997 - -;;; Code: - - -;;; custom-load.el ends here
--- a/lisp/leim/leim-list.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/leim/leim-list.el Mon Aug 13 10:03:52 2007 +0200 @@ -15,241 +15,85 @@ ;; loads this file at startup time. (register-input-method - "chinese-4corner" "Chinese-BIG5" 'quail-use-package - "$(0(?-F(B" "$(0(?-FHAP#(B:: " - "quail/4Corner") -(register-input-method - "chinese-array30" "Chinese-BIG5" 'quail-use-package - "$(0#R#O(B" "$(0&d'G!J*h)E#R#O!K(B " - "quail/ARRAY30") -(register-input-method - "chinese-ccdospy" "Chinese-GB" 'quail-use-package - "$AKuF4(B" "$A::WVJdHk!KKuP4F4Rt!K(B# " - "quail/CCDOSPY") + "vietnamese-viqr" "Vietnamese" 'quail-use-package + "VQ" "Vietnamese input method with VIQR mnemonic system" + "quail/viqr") (register-input-method - "chinese-ctlau" "Chinese-GB" 'quail-use-package - "$AAuTA(B" "$A::WVJdHk!KAuN}OiJ=TARt!K(B" - "quail/CTLau") -(register-input-method - "chinese-ctlaub" "Chinese-BIG5" 'quail-use-package - "$(0N,Gn(B" "$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B" - "quail/CTLauB") -(register-input-method - "chinese-ecdict" "Chinese-BIG5" 'quail-use-package - "$(05CKH(B" "$(0&d'GTT&,!J5CKH[0.)!K(B" - "quail/ECDICT") -(register-input-method - "chinese-etzy" "Chinese-BIG5" 'quail-use-package - "$(06/0D(B" "$(0&d'GTT&,!J6/'30D5x!K(B" - "quail/ETZY") + "chinese-cns-tsangchi" "Chinese-CNS" 'quail-use-package + "$(GT?(BC" "$(GDcEFrSD+!JT?on!K(BCNS" + "quail/tsang-cns") (register-input-method - "chinese-py-b5" "Chinese-BIG5" 'quail-use-package - "$(03<(BB" "$(0&d'GTT&,!J3<5x!K(B" - "quail/PY-b5") -(register-input-method - "chinese-py" "Chinese-GB" 'quail-use-package - "$AF4(BG" "$A::WVJdHk!KF4Rt!K(B# " - "quail/PY") -(register-input-method - "chinese-punct-b5" "Chinese-BIG5" 'quail-use-package - "$(0O:(BB" "$(0&d'GTT&,!JO:X5>KHA!K(B" - "quail/Punct-b5") + "chinese-b5-tsangchi" "Chinese-BIG5" 'quail-use-package + "$(06A(BB" "$(0&d'GTT&,!J6AQo!K(BBIG5" + "quail/tsang-b5") (register-input-method - "chinese-punct" "Chinese-GB" 'quail-use-package - "$A1j(BG" "$A::WVJdHk!K1j5c7{:E!K(B# " - "quail/Punct") -(register-input-method - "chinese-qj-b5" "Chinese-BIG5" 'quail-use-package - "$(0)A(BB" "$(0&d'GTT&,!J)A,1!K(B" - "quail/QJ-b5") + "thai-kesmanee" "Thai" 'quail-use-package + ",T!!(B>" "Thai Kesmanee input method with TIS620 keyboard layout" + "quail/thai") (register-input-method - "chinese-qj" "Chinese-GB" 'quail-use-package - "$AH+(BG" "$A::WVJdHk!KH+=G!K(B# " - "quail/QJ") -(register-input-method - "chinese-sw" "Chinese-GB" 'quail-use-package - "$AJWN2(B" "$A::WVJdHk!KJWN2!K(B# " - "quail/SW") + "thai-pattachote" "Thai" 'quail-use-package + ",T!;(B>" "Thai Pattachote input method with TIS620 keyboard layout" + "quail/thai") (register-input-method - "chinese-tonepy" "Chinese-GB" 'quail-use-package - "$A5wF4(B" "$A::WVJdHk!K4x5wF4Rt!K(B# " - "quail/TONEPY") -(register-input-method - "chinese-ziranma" "Chinese-GB" 'quail-use-package - "$AK+F4(B" "$A::WVJdHk!KWTH;K+F4!K(B " - "quail/ZIRANMA") -(register-input-method - "chinese-zozy" "Chinese-BIG5" 'quail-use-package - "$(0I\0D(B" "$(0&d'GTT&,!JI\@c0D5x!K(B" - "quail/ZOZY") + "korean-symbol" "Korean" 'quail-use-package + "$(CGQ1[=I9z@T7BG%(B" "$(CGQ1[=I9z@T7BG%(B:" + "quail/symbol-ksc") (register-input-method - "cyrillic-jis-russian" "Cyrillic" 'quail-use-package - "$B'('+(B" "$B'+'8'5','&'/(B keyboard layout same as JCUKEN (JIS X0208.1983 encoding)" - "quail/cyril-jis") -(register-input-method - "cyrillic-jcuken" "Cyrillic" 'quail-use-package - ",L69(B" ",L9FC:5=(B keyboard layout widely used in Russia (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-macedonian" "Cyrillic" 'quail-use-package - ",L6(BM" ",L)*5@B7(B-,L#,(B keyboard layout based on JUS.I.K1.004 (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-serbian" "Cyrillic" 'quail-use-package - ",L6(BS" ",L)*5@B7(B-,L"+(B keyboard layout based on JUS.I.K1.005 (ISO 8859-5 encoding)" - "quail/cyrillic") + "chinese-cns-quick" "Chinese-CNS" 'quail-use-package + "$(Gv|(BC" "$(GDcEFrSD+!Jv|Mx!K(BCNS" + "quail/quick-cns") (register-input-method - "cyrillic-beylorussian" "Cyrillic" 'quail-use-package - ",L6(BB" ",L)*5@B7(B-,L&.(B BEYLORUSSIAN (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-ukrainian" "Cyrillic" 'quail-use-package - ",L6(BU" ",L$'5@B7(B-,L&.(B UKRAINIAN (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-yawerty" "Cyrillic" 'quail-use-package - ",L6O(B" ",LO25@BK(B Roman transcription (ISO 8859-5 encoding)" - "quail/cyrillic") -(register-input-method - "cyrillic-translit" "Cyrillic" 'quail-use-package - ",L6(Bt" "Intuitively transliterated keyboard layout." - "quail/cyrillic") + "chinese-b5-quick" "Chinese-BIG5" 'quail-use-package + "$(0X|(BB" "$(0&d'GTT&,!JX|/y!K(BBIG5" + "quail/quick-b5") (register-input-method - "cyrillic-translit-bulgarian" "Cyrillic" 'quail-use-package - ",L6(Btb" "Intuitively transliterated keyboard layout optimized for Bulgarian." - "quail/cyrillic") -(register-input-method - "devanagari-keyboard-a" "Devanagari" 'quail-use-package - "DevK" "Devanagari input method with ISCII format" - "quail/devanagari") + "chinese-py-punct-b5" "Chinese-BIG5" 'quail-use-package + "$AF47{(B" "$(0&d'GTT&,!J3<5x!K(B and `v' for $(0O:X5>KHATT&,(B" + "quail/pypunct-b5") (register-input-method - "ethiopic" "Ethiopic" 'quail-use-package - (quote ("$(3$O#U!.(B " (ethio-prefer-ascii-space "_" "$(3$h(B") (ethio-prefer-ascii-punctuation "." "$(3$i(B"))) " QUAIL PACKAGE FOR ETHIOPIC (TIGRIGNA AND AMHARIC)" - "quail/ethiopic") -(register-input-method - "greek-jis" "Greek" 'quail-use-package - "$B&8(B" "$B&%&K&K&G&M&I&J&A(B: Greek keyboard layout (JIS X0208.1983)" - "quail/greek") + "chinese-py-punct" "Chinese-GB" 'quail-use-package + "$AF47{(B" "$A::WVJdHk(B $AF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B" + "quail/py-punct") (register-input-method - "greek" "Greek" 'quail-use-package - ",FY(B" ",FEkkgmij\(B: Greek keyboard layout (ISO 8859-7)" - "quail/greek") -(register-input-method - "korean-hangul" "Korean" 'quail-use-package - "$(CGQ(B2" "$(CGQ1[(B 2$(C9z=D(B: Hangul input method with Hangul keyboard layout (KSC5601)" - "quail/hangul") -(register-input-method - "korean-hangul3" "Korean" 'quail-use-package - "$(CGQ(B3" "$(CGQ1[(B 3$(C9z=D(B: Hangul input method" - "quail/hangul3") + "latin-1-prefix" "Latin-1" 'quail-use-package + "1>" "Latin-1 characters input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "korean-hanja-jis" "Korean" 'quail-use-package - "$(C9z$B4A(B" "2$(C9z=D(BJIS$B4A;z(B: $B3:aD$(CGO4B(B $B4A;z$(C@G(B $B1$$(C@;(B $(CGQ1[(B2$(C9z$B<0$(C@87N(B $B8F=P$(CGO?)(B $BA*Z$(B" - "quail/hanja-jis") -(register-input-method - "korean-hanja" "Korean" 'quail-use-package - "$(C9zyS(B" "2$(C9z=D(BKSC$(CySm.(B: $(Cz1SWGO4B(B $(CySm.@G(B $(Cj$@;(B $(CGQ1[(B2$(C9zcR@87N(B $(C{<usGO?)(B $(C`TwI(B" - "quail/hanja") -(register-input-method - "ipa" "IPA" 'quail-use-package - "IPA" "International Phonetic Alphabet for English, French, German and Italian" - "quail/ipa") -(register-input-method - "japanese" "Japanese" 'quail-use-package - "A$B$"(B" "Romaji -> Hiragana -> Kanji&Kana" - "quail/japanese") + "catalan-prefix" "Latin-1" 'quail-use-package + "CA>" "Catalan and Spanish input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "japanese-ascii" "Japanese" 'quail-use-package - "Aa" "Temporary ASCII input mode while using Quail package `japanese'" - "quail/japanese") -(register-input-method - "japanese-zenkaku" "Japanese" 'quail-use-package - "$B#A(B" "Japanese zenkaku alpha numeric character input method" - "quail/japanese") -(register-input-method - "japanese-hankaku-kana" "Japanese" 'quail-use-package - "(I1(B" "Japanese hankaku katakana input method by Roman transliteration" - "quail/japanese") -(register-input-method - "japanese-hiragana" "Japanese" 'quail-use-package - "$B$"(B" "Japanese hiragana input method by Roman transliteration" - "quail/japanese") + "esperanto-prefix" "Latin-1" 'quail-use-package + "EO>" "Esperanto input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "japanese-katakana" "Japanese" 'quail-use-package - "$B%"(B" "Japanese katakana input method by Roman transliteration" - "quail/japanese") -(register-input-method - "lao" "Lao" 'quail-use-package - "(1E(B" "Lao input method simulating Lao keyboard layout based on Thai TIS620" - "quail/lao") + "french-prefix" "Latin-1" 'quail-use-package + "FR>" "French (Fran,Ag(Bais) input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "latin-1-alt-postfix" "Latin-1" 'quail-use-package - "1<" "Latin-1 character input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "latin-2-alt-postfix" "Latin-2" 'quail-use-package - "2<" "Latin-2 character input method with postfix modifiers" - "quail/latin-alt") + "german-prefix" "Latin-1" 'quail-use-package + "DE>" "German (Deutsch) input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "latin-3-alt-postfix" "Latin-3" 'quail-use-package - "3<" "Latin-3 character input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "latin-4-alt-postfix" "Latin-4" 'quail-use-package - "4<" "Latin-4 characters input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "latin-5-alt-postfix" "Latin-5" 'quail-use-package - "5<" "Latin-5 characters input method with postfix modifiers" - "quail/latin-alt") + "irish-prefix" "Latin-1" 'quail-use-package + "GA>" "Irish input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "danish-alt-postfix" "Latin-1" 'quail-use-package - "DA<" "Danish input method (rule: AE -> ,AF(B, OE -> ,AX(B, AA -> ,AE(B, E' -> ,AI(B)" - "quail/latin-alt") -(register-input-method - "esperanto-alt-postfix" "Latin-3" 'quail-use-package - "EO<" "Esperanto input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "finnish-alt-postfix" "Latin-1" 'quail-use-package - "FI<" "Finnish (Suomi) input method" - "quail/latin-alt") -(register-input-method - "french-alt-postfix" "Latin-1" 'quail-use-package - "FR<" "French (Fran,Ag(Bais) input method with postfix modifiers" - "quail/latin-alt") + "portuguese-prefix" "Latin-1" 'quail-use-package + "PT>" "Portuguese input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "german-alt-postfix" "Latin-1" 'quail-use-package - "DE<" "German (Deutsch) input method" - "quail/latin-alt") -(register-input-method - "icelandic-alt-postfix" "Latin-1" 'quail-use-package - "IS<" "Icelandic (,AM(Bslenska) input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "italian-alt-postfix" "Latin-1" 'quail-use-package - "IT<" "Italian (Italiano) input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "norwegian-alt-postfix" "Latin-1" 'quail-use-package - "NO<" "Norwegian (Norsk) input method (rule: AE->,AF(B, OE->,AX(B, AA->,AE(B, E'->,AI(B)" - "quail/latin-alt") + "spanish-prefix" "Latin-1" 'quail-use-package + "ES>" "Spanish (Espa,Aq(Bol) input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "scandinavian-alt-postfix" "Latin-1" 'quail-use-package - "SC<" "Scandinavian input method with postfix modifiers" - "quail/latin-alt") -(register-input-method - "spanish-alt-postfix" "Latin-1" 'quail-use-package - "ES<" "Spanish (Espa,Aq(Bol) input method with postfix modifiers" - "quail/latin-alt") + "latin-2-prefix" "Latin-2" 'quail-use-package + "2>" "Latin-2 characters input method with prefix modifiers" + "quail/latin-pre") (register-input-method - "swedish-alt-postfix" "Latin-1" 'quail-use-package - "SV<" "Swedish (Svenska) input method (rule: AA -> ,AE(B, AE -> ,AD(B, OE -> ,AV(B, E' -> ,AI(B)" - "quail/latin-alt") -(register-input-method - "turkish-alt-postfix" "Latin-3" 'quail-use-package - "TR<" "Turkish (T,C|(Brk,Cg(Be) input method with postfix modifiers" - "quail/latin-alt") + "latin-3-prefix" "Latin-3" 'quail-use-package + "3>" "Latin-3 characters input method with prefix modifiers" + "quail/latin-pre") (register-input-method "latin-1-postfix" "Latin-1" 'quail-use-package "1<" "Latin-1 character input method with postfix modifiers" @@ -367,86 +211,202 @@ "DV@" "English (ASCII) input method simulating Dvorak keyboard" "quail/latin-post") (register-input-method - "latin-1-prefix" "Latin-1" 'quail-use-package - "1>" "Latin-1 characters input method with prefix modifiers" - "quail/latin-pre") + "latin-1-alt-postfix" "Latin-1" 'quail-use-package + "1<" "Latin-1 character input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "latin-2-alt-postfix" "Latin-2" 'quail-use-package + "2<" "Latin-2 character input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "latin-3-alt-postfix" "Latin-3" 'quail-use-package + "3<" "Latin-3 character input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "catalan-prefix" "Latin-1" 'quail-use-package - "CA>" "Catalan and Spanish input method with prefix modifiers" - "quail/latin-pre") + "latin-4-alt-postfix" "Latin-4" 'quail-use-package + "4<" "Latin-4 characters input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "latin-5-alt-postfix" "Latin-5" 'quail-use-package + "5<" "Latin-5 characters input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "danish-alt-postfix" "Latin-1" 'quail-use-package + "DA<" "Danish input method (rule: AE -> ,AF(B, OE -> ,AX(B, AA -> ,AE(B, E' -> ,AI(B)" + "quail/latin-alt") (register-input-method - "esperanto-prefix" "Latin-1" 'quail-use-package - "EO>" "Esperanto input method with prefix modifiers" - "quail/latin-pre") + "esperanto-alt-postfix" "Latin-3" 'quail-use-package + "EO<" "Esperanto input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "finnish-alt-postfix" "Latin-1" 'quail-use-package + "FI<" "Finnish (Suomi) input method" + "quail/latin-alt") +(register-input-method + "french-alt-postfix" "Latin-1" 'quail-use-package + "FR<" "French (Fran,Ag(Bais) input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "french-prefix" "Latin-1" 'quail-use-package - "FR>" "French (Fran,Ag(Bais) input method with prefix modifiers" - "quail/latin-pre") + "german-alt-postfix" "Latin-1" 'quail-use-package + "DE<" "German (Deutsch) input method" + "quail/latin-alt") (register-input-method - "german-prefix" "Latin-1" 'quail-use-package - "DE>" "German (Deutsch) input method with prefix modifiers" - "quail/latin-pre") + "icelandic-alt-postfix" "Latin-1" 'quail-use-package + "IS<" "Icelandic (,AM(Bslenska) input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "italian-alt-postfix" "Latin-1" 'quail-use-package + "IT<" "Italian (Italiano) input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "irish-prefix" "Latin-1" 'quail-use-package - "GA>" "Irish input method with prefix modifiers" - "quail/latin-pre") + "norwegian-alt-postfix" "Latin-1" 'quail-use-package + "NO<" "Norwegian (Norsk) input method (rule: AE->,AF(B, OE->,AX(B, AA->,AE(B, E'->,AI(B)" + "quail/latin-alt") +(register-input-method + "scandinavian-alt-postfix" "Latin-1" 'quail-use-package + "SC<" "Scandinavian input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "spanish-alt-postfix" "Latin-1" 'quail-use-package + "ES<" "Spanish (Espa,Aq(Bol) input method with postfix modifiers" + "quail/latin-alt") (register-input-method - "portuguese-prefix" "Latin-1" 'quail-use-package - "PT>" "Portuguese input method with prefix modifiers" - "quail/latin-pre") + "swedish-alt-postfix" "Latin-1" 'quail-use-package + "SV<" "Swedish (Svenska) input method (rule: AA -> ,AE(B, AE -> ,AD(B, OE -> ,AV(B, E' -> ,AI(B)" + "quail/latin-alt") +(register-input-method + "turkish-alt-postfix" "Latin-3" 'quail-use-package + "TR<" "Turkish (T,C|(Brk,Cg(Be) input method with postfix modifiers" + "quail/latin-alt") +(register-input-method + "ipa" "IPA" 'quail-use-package + "IPA" "International Phonetic Alphabet for English, French, German and Italian" + "quail/ipa") (register-input-method - "spanish-prefix" "Latin-1" 'quail-use-package - "ES>" "Spanish (Espa,Aq(Bol) input method with prefix modifiers" - "quail/latin-pre") + "korean-hanja" "Korean" 'quail-use-package + "$(C9zyS(B" "2$(C9z=D(BKSC$(CySm.(B: $(Cz1SWGO4B(B $(CySm.@G(B $(Cj$@;(B $(CGQ1[(B2$(C9zcR@87N(B $(C{<usGO?)(B $(C`TwI(B" + "quail/hanja") +(register-input-method + "korean-hanja-jis" "Korean" 'quail-use-package + "$(C9z$B4A(B" "2$(C9z=D(BJIS$B4A;z(B: $B3:aD$(CGO4B(B $B4A;z$(C@G(B $B1$$(C@;(B $(CGQ1[(B2$(C9z$B<0$(C@87N(B $B8F=P$(CGO?)(B $BA*Z$(B" + "quail/hanja-jis") +(register-input-method + "korean-hangul3" "Korean" 'quail-use-package + "$(CGQ(B3" "$(CGQ1[(B 3$(C9z=D(B: Hangul input method" + "quail/hangul3") (register-input-method - "latin-2-prefix" "Latin-2" 'quail-use-package - "2>" "Latin-2 characters input method with prefix modifiers" - "quail/latin-pre") + "korean-hangul" "Korean" 'quail-use-package + "$(CGQ(B2" "$(CGQ1[(B 2$(C9z=D(B: Hangul input method with Hangul keyboard layout (KSC5601)" + "quail/hangul") +(register-input-method + "greek-jis" "Greek" 'quail-use-package + "$B&8(B" "$B&%&K&K&G&M&I&J&A(B: Greek keyboard layout (JIS X0208.1983)" + "quail/greek") (register-input-method - "latin-3-prefix" "Latin-3" 'quail-use-package - "3>" "Latin-3 characters input method with prefix modifiers" - "quail/latin-pre") + "greek" "Greek" 'quail-use-package + ",FY(B" ",FEkkgmij\(B: Greek keyboard layout (ISO 8859-7)" + "quail/greek") +(register-input-method + "cyrillic-jcuken" "Cyrillic" 'quail-use-package + ",L69(B" ",L9FC:5=(B keyboard layout widely used in Russia (ISO 8859-5 encoding)" + "quail/cyrillic") (register-input-method - "lao-lrt" "Lao" 'quail-use-package - "(1E(BR" "Lao input method using LRT (Lao Roman Transcription)." - "quail/lrt") + "cyrillic-macedonian" "Cyrillic" 'quail-use-package + ",L6(BM" ",L)*5@B7(B-,L#,(B keyboard layout based on JUS.I.K1.004 (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-serbian" "Cyrillic" 'quail-use-package + ",L6(BS" ",L)*5@B7(B-,L"+(B keyboard layout based on JUS.I.K1.005 (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-beylorussian" "Cyrillic" 'quail-use-package + ",L6(BB" ",L)*5@B7(B-,L&.(B BEYLORUSSIAN (ISO 8859-5 encoding)" + "quail/cyrillic") (register-input-method - "chinese-py-punct" "Chinese-GB" 'quail-use-package - "$AF47{(B" "$A::WVJdHk(B $AF4Rt7=08(B and `v' for $A1j5c7{:EJdHk(B" - "quail/py-punct") + "cyrillic-ukrainian" "Cyrillic" 'quail-use-package + ",L6(BU" ",L$'5@B7(B-,L&.(B UKRAINIAN (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-yawerty" "Cyrillic" 'quail-use-package + ",L6O(B" ",LO25@BK(B Roman transcription (ISO 8859-5 encoding)" + "quail/cyrillic") +(register-input-method + "cyrillic-translit" "Cyrillic" 'quail-use-package + ",L6(Bt" "Intuitively transliterated keyboard layout." + "quail/cyrillic") (register-input-method - "chinese-py-punct-b5" "Chinese-BIG5" 'quail-use-package - "$AF47{(B" "$(0&d'GTT&,!J3<5x!K(B and `v' for $(0O:X5>KHATT&,(B" - "quail/pypunct-b5") + "cyrillic-translit-bulgarian" "Cyrillic" 'quail-use-package + ",L6(Btb" "Intuitively transliterated keyboard layout optimized for Bulgarian." + "quail/cyrillic") +(register-input-method + "cyrillic-jis-russian" "Cyrillic" 'quail-use-package + "$B'('+(B" "$B'+'8'5','&'/(B keyboard layout same as JCUKEN (JIS X0208.1983 encoding)" + "quail/cyril-jis") +(register-input-method + "chinese-zozy" "Chinese-BIG5" 'quail-use-package + "$(0I\0D(B" "$(0&d'GTT&,!JI\@c0D5x!K(B" + "quail/ZOZY") (register-input-method - "chinese-b5-quick" "Chinese-BIG5" 'quail-use-package - "$(0X|(BB" "$(0&d'GTT&,!JX|/y!K(BBIG5" - "quail/quick-b5") + "chinese-ziranma" "Chinese-GB" 'quail-use-package + "$AK+F4(B" "$A::WVJdHk!KWTH;K+F4!K(B " + "quail/ZIRANMA") (register-input-method - "chinese-cns-quick" "Chinese-CNS" 'quail-use-package - "$(Gv|(BC" "$(GDcEFrSD+!Jv|Mx!K(BCNS" - "quail/quick-cns") + "chinese-tonepy" "Chinese-GB" 'quail-use-package + "$A5wF4(B" "$A::WVJdHk!K4x5wF4Rt!K# (B" + "quail/TONEPY") +(register-input-method + "chinese-sw" "Chinese-GB" 'quail-use-package + "$AJWN2(B" "$A::WVJdHk!KJWN2!K# (B" + "quail/SW") (register-input-method - "korean-symbol" "Korean" 'quail-use-package - "$(CGQ1[=I9z@T7BG%(B" "$(CGQ1[=I9z@T7BG%(B:" - "quail/symbol-ksc") + "chinese-qj" "Chinese-GB" 'quail-use-package + "$AH+(BG" "$A::WVJdHk!KH+=G!K# (B" + "quail/QJ") +(register-input-method + "chinese-qj-b5" "Chinese-BIG5" 'quail-use-package + "$(0)A(BB" "$(0&d'GTT&,!J)A,1!K(B" + "quail/QJ-b5") +(register-input-method + "chinese-punct" "Chinese-GB" 'quail-use-package + "$A1j(BG" "$A::WVJdHk!K1j5c7{:E!K# (B" + "quail/Punct") (register-input-method - "thai-kesmanee" "Thai" 'quail-use-package - ",T!!(B>" "Thai Kesmanee input method with TIS620 keyboard layout" - "quail/thai") + "chinese-punct-b5" "Chinese-BIG5" 'quail-use-package + "$(0O:(BB" "$(0&d'GTT&,!JO:X5>KHA!K(B" + "quail/Punct-b5") (register-input-method - "thai-pattachote" "Thai" 'quail-use-package - ",T!;(B>" "Thai Pattachote input method with TIS620 keyboard layout" - "quail/thai") + "chinese-py" "Chinese-GB" 'quail-use-package + "$AF4(BG" "$A::WVJdHk!KF4Rt!K# (B" + "quail/PY") +(register-input-method + "chinese-py-b5" "Chinese-BIG5" 'quail-use-package + "$(03<(BB" "$(0&d'GTT&,!J3<5x!K(B" + "quail/PY-b5") (register-input-method - "chinese-b5-tsangchi" "Chinese-BIG5" 'quail-use-package - "$(06A(BB" "$(0&d'GTT&,!J6AQo!K(BBIG5" - "quail/tsang-b5") + "chinese-etzy" "Chinese-BIG5" 'quail-use-package + "$(06/0D(B" "$(0&d'GTT&,!J6/'30D5x!K(B" + "quail/ETZY") +(register-input-method + "chinese-ecdict" "Chinese-BIG5" 'quail-use-package + "$(05CKH(B" "$(0&d'GTT&,!J5CKH[0.)!K(B" + "quail/ECDICT") +(register-input-method + "chinese-ctlaub" "Chinese-BIG5" 'quail-use-package + "$(0N,Gn(B" "$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B" + "quail/CTLauB") (register-input-method - "chinese-cns-tsangchi" "Chinese-CNS" 'quail-use-package - "$(GT?(BC" "$(GDcEFrSD+!JT?on!K(BCNS" - "quail/tsang-cns") + "chinese-ctlau" "Chinese-GB" 'quail-use-package + "$AAuTA(B" "$A::WVJdHk!KAuN}OiJ=TARt!K(B" + "quail/CTLau") +(register-input-method + "chinese-ccdospy" "Chinese-GB" 'quail-use-package + "$AKuF4(B" "$A::WVJdHk!KKuP4F4Rt!K# (B" + "quail/CCDOSPY") (register-input-method - "vietnamese-viqr" "Vietnamese" 'quail-use-package - "VQ" "Vietnamese input method with VIQR mnemonic system" - "quail/viqr") + "chinese-array30" "Chinese-BIG5" 'quail-use-package + "$(0#R#O(B" "$(0&d'G!J*h)E#R#O!K(B " + "quail/ARRAY30") +(register-input-method + "chinese-4corner" "Chinese-BIG5" 'quail-use-package + "$(0(?-F(B" "$(0(?-FHAP#(B:: " + "quail/4Corner")
--- a/lisp/leim/quail/cyrillic.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/leim/quail/cyrillic.el Mon Aug 13 10:03:52 2007 +0200 @@ -741,7 +741,7 @@ Also included are Ukrainian ,Lt(B (YE) = \"/e\" and ,Lw(B (YI) = \"yi\", Belorussian ,L~(B (SHORT U) = \"u'\", -Serbo-Croatian ,Lr(B (DJE) = \"/d\", ,L{(B (CHJE)= \"/ch\", +Serbian ,Lr(B (DJE) = \"/d\", ,L{(B (CHJE)= \"/ch\", Macedonian ,Ls(B (GJE) = \"/g\", ,Lu(B (DZE) = \"/s\", ,L|(B (KJE) = \"/k\", cyrillic ,Lv(B (I DECIMAL) = \"/i\", ,Lx(B (JE) = \"/j\", ,Ly(B (LJE) = \"/l\", ,Lz(B (NJE) = \"/n\" and ,L(B (DZE) =\"/z\"."
--- a/lisp/leim/quail/devanagari.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,675 +0,0 @@ -;; quail/devanagari.el -- Quail packages for inputting Devanagari - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp> - -;; Keywords: multilingual, input method, Indian, Devanagari - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; History: -;; 1996.10.10 written by KAWABATA, Taichi <kawabata@is.s.u-tokyo.ac.jp> -;; 1997.03.21 fixed by KAWABATA, Taichi - -;; I'm not sure if this keyboard layout is REALLY an ISCII keyboard layout. -;; Please let me know if it is not. - -;;; Code: - -(require 'quail) -(require 'devan-util) - -;; This function does nothing for now. For future use. -(defun quail-devanagari-update-translation (control-flag) - (cond ((eq control-flag t) ; terminate translation with the whole key. - (insert quail-current-str) - (quail-terminate-translation)) - ((null control-flag) ; proceed translation with more keys. - (insert (or quail-current-str quail-current-key))) - (t ; control-flag is the number of keys to be translated. - (insert (aref quail-current-key 0)) - (setq unread-command-events - (list (aref quail-current-key control-flag)))))) - -(defun quail-devanagari-compose-characters () - (interactive) - (if (quail-point-in-conversion-region) - (let* ((from (overlay-start quail-conv-overlay)) - (to (overlay-end quail-conv-overlay)) - (dstr (buffer-substring from to))) - (delete-overlay quail-overlay) - (delete-overlay quail-conv-overlay) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (delete-region (point-min) (point-max)) - (insert (devanagari-compose-string dstr 'sanskrit)) - (goto-char (point-max))) - (setq overriding-terminal-local-map nil))) - (setq unread-command-events (list last-command-event))) - -(quail-define-package - "devanagari-keyboard-a" "Devanagari" "DevK" t - "Devanagari input method with ISCII format - - `$(5!\(B !$(5!.(B @$(5!c(B #x $x %x ^x &$(5")(B *$(5"((B ( ) _$(5!#(B +$(5!*(B - ~$(5!/(B 1$(5!r(B 2$(5!s(B 3$(5!t(B 4$(5!u(B 5$(5!v(B 6$(5!w(B 7$(5!x(B 8$(5!y(B 9$(5!z(B 0$(5!q(B - =$(5!_(B - - Q$(5!f(B W$(5!-(B E$(5!%(B R$(5!'(B T$(5!)(B Y$(5!K(B U$(5!7(B I$(5!E(B O$(5!C(B P$(5!;(B {$(5!@(B }$(5!<(B |$(5!2(B - q$(5!f(B w$(5!b(B e$(5!Z(B r$(5!\(B t$(5!^(B y$(5!J(B u$(5!X(B i$(5!5(B o$(5!D(B p$(5!:(B [$(5!?(B ]$(5!i(B \\$(5!g(B - - A$(5!0(B S$(5!,(B D$(5!$(B F$(5!&(B G$(5!((B H$(5!I(B J$(5!P(B K$(5!4(B l$(5!C(B :$(5!8(B \"$(5!>(B - a$(5!e(B s$(5!a(B d$(5!h(B f$(5![(B g$(5!](B h$(5!H(B j$(5!O(B k$(5!3(B l$(5!B(B ;$(5!9(B '$(5!=(B - - Z$(5!+(B X$(5!!(B C$(5!A(B V$(5!G(B B$(5!S(B N$(5!R(B M$(5!U(B <$(5!V(B >$(5!j(B ?$(5!N(B - z$(5!`(B x$(5!"(B c$(5!L(B v$(5!F(B b$(5!T(B n$(5!Q(B m$(5!W(B , . /$(5!M(B -" - nil t t nil nil nil nil nil - ;;'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-compose-characters) - ("-" . quail-devanagari-compose-characters) - ("," . quail-devanagari-compose-characters) - ("\C-m" . quail-devanagari-compose-characters) - ([return] . quail-devanagari-compose-characters)) - ) - -;; ..... (not prepared yet) -;; I forgot where I got this keymap from. -;; Please let me know if you know what this keymap is. - -(quail-define-rules - ("`" ?$(5!\(B) - ("~" ?$(5!/(B) - ("1" ?$(5!r(B) - ("!" ?$(5!.(B) - ("2" ?$(5!s(B) - ("@" ?$(5!c(B) - ("3" ?$(5!t(B) - ("#" ?# ) ; following "r" in keymap... - ("4" ?$(5!u(B) - ("$" ?$ ) ; preceding "r" in keymap... - ("5" ?$(5!v(B) - ("%" ?x ) ; ?? - ("6" ?$(5!w(B) - ("^" ?x ) ; %tra - ("7" ?$(5!x(B) - ("&" ?$(5")(B) ; % special - ("8" ?$(5!y(B) - ("*" ?$(5"((B) ; % special - ("9" ?$(5!z(B) - ("(" ?\() - ("0" ?$(5!q(B) - (")" ?\)) - ("-" ?-) - ("_" ?$(5!#(B) - ("=" ?$(5!_(B) - ("+" ?$(5!*(B) - ("q" ?$(5!f(B) - ("Q" ?$(5!1(B) - ("w" ?$(5!b(B) - ("W" ?$(5!-(B) - ("e" ?$(5!Z(B) - ("E" ?$(5!%(B) - ("r" ?$(5!\(B) - ("R" ?$(5!'(B) - ("t" ?$(5!^(B) - ("T" ?$(5!)(B) - ("y" ?$(5!J(B) - ("Y" ?$(5!K(B) - ("u" ?$(5!X(B) - ("U" ?$(5!7(B) - ("i" ?$(5!5(B) - ("I" ?$(5!E(B) - ("o" ?$(5!D(B) - ("O" ?$(5!C(B) - ("p" ?$(5!:(B) - ("P" ?$(5!;(B) - ("[" ?$(5!?(B) - ("{" ?$(5!@(B) - ("]" ?$(5!i(B) - ("}" ?$(5!<(B) - ("\\" ?$(5!g(B) - ("|" ?$(5!2(B) - ("a" ?$(5!e(B) - ("A" ?$(5!0(B) - ("s" ?$(5!a(B) - ("S" ?$(5!,(B) - ("d" ?$(5!h(B) - ("D" ?$(5!$(B) - ("f" ?$(5 - ("G" ?$(5!((B) - ("h" ?$(5!H(B) - ("H" ?$(5!I(B) - ("j" ?$(5!O(B) - ("J" ?$(5!P(B) - ("k" ?$(5!3(B) - ("K" ?$(5!4(B) - ("l" ?$(5!B(B) - ("L" ?$(5!C(B) - (";" ?$(5!8(B) - (":" ?$(5!9(B) - ("'" ?$(5!=(B) - ("\"" ?$(5!>(B) - ("z" ?$(5!`(B) - ("Z" ?$(5!+(B) - ("x" ?$(5!"(B) - ("X" ?$(5!!(B) - ("c" ?$(5!L(B) - ("C" ?$(5!A(B) - ("v" ?$(5!F(B) - ("V" ?$(5!G(B) - ("b" ?$(5!T(B) - ("B" ?$(5!S(B) - ("n" ?$(5!Q(B) - ("N" ?$(5!R(B) - ("m" ?$(5!W(B) - ("M" ?$(5!U(B) - ;; ("," ?,) - ("<" ?$(5!V(B) - ;; ("." ?.) - (">" ?$(5!j(B) - ("/" ?$(5!M(B) - ("?" ?$(5!N(B) - ) - - -;; -;; Quail Devanagari Input By Transliteration -;; - -(eval-when-compile - -(defvar devanagari-consonant-transliteration-alist - '( - ; GUTTURALS - ("k" . "$(5!3(B") - ("k." . "$(5!3!i(B") - ("kh" . "$(5!4(B") - ("kh." . "$(5!4!i(B") - ("g" . "$(5!5(B") - ("g." . "$(5!5!i(B") - ("gh" . "$(5!6(B") - ("G" . "$(5!7(B") - ; PALATALS - ("c" . "$(5!8(B") - ("ch" . "$(5!9(B") - ("j" . "$(5!:(B") - ("j." . "$(5!:!i(B") - ("Z" . "$(5!:!i(B") - ("jh" . "$(5!;(B") - ("J" . "$(5!<(B") - ; CEREBRALS - ("T" . "$(5!=(B") - ("Th" . "$(5!>(B") - ("D" . "$(5!?(B") - ("D." . "$(5!?!i(B") - ("Dh" . "$(5!@(B") - ("Dh." . "$(5!@!i(B") - ("N" . "$(5!A(B") - ; DENTALS - ("t" . "$(5!B(B") - ("th" . "$(5!C(B") - ("d" . "$(5!D(B") - ("dh" . "$(5!E(B") - ("n" . "$(5!F(B") - ("N." . "$(5!G(B") - ; LABIALS - ("p" . "$(5!H(B") - ("ph" . "$(5!I(B") - ("ph." . "$(5!I!i(B") - ("f" . "$(5!I(B") - ("f." . "$(5!I!i(B") - ("b" . "$(5!J(B") - ("bh" . "$(5!K(B") - ("m" . "$(5!L(B") - ; SEMIVOWELS - ("y" . "$(5!M(B") - ("y." . "$(5!N(B") - ("Y" . "$(5!N(B") - ("r" . "$(5!O(B") - ("r." . "$(5!P(B") - ("l" . "$(5!Q(B") - ("W" . "$(5!R(B") - ("W." . "$(5!S(B") - ("v" . "$(5!T(B") - ("w" . "$(5!T(B") - ; SIBILANTS - ("z" . "$(5!U(B") - ("S" . "$(5!V(B") - ("s" . "$(5!W(B") - ("h" . "$(5!X(B") - )) - -(defvar devanagari-vowel-transliteration-alist - '( - ;; Special treatment unique to IS 13194 Transliteration - ("" . "$(5!h(B") - ("a" . "") - ; Matra (Vowel Sign) - ("A" . "$(5!Z(B") - ("i" . "$(5![(B") - ("I" . "$(5!\(B") - ("u" . "$(5!](B") - ("U" . "$(5!^(B") - ("R" . "$(5!_(B") - ;; ("RR" . "x") ; not specified in ordinary IS 13194.(but in Unicode??) - ("q" . "$(5#K(B") ; "$(5#K(B" = "$(5!_!i(B" in IS 13194. - ("L" . "$(5#L(B") ; "$(5#L(B" = "$(5![!i(B" in IS 13194. - ("E" . "$(5#M(B") ; "$(5#M(B" = "$(5!\!i(B" in IS 13194. - ("E" . "$(5!`(B") ; only for transcription of other scripts. - ("e" . "$(5!a(B") - ("ai" . "$(5!b(B") - ("ae" . "$(5!b(B") ; variation of transliteration. - ("EE" . "$(5!c(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!d(B") ; only for transcription of other scripts. - ("o" . "$(5!e(B") - ("au" . "$(5!f(B") - ("ao" . "$(5!f(B") ; variation of transliteration. - ("OO" . "$(5!g(B") ; only for transcription of other scripts. (Candra O) - )) - -;; -;; Independent vowels and other signs. -;; - -(defvar devanagari-other-letters-alist - '( - ("a" . "$(5!$(B") - ("A" . "$(5!%(B") - ("i" . "$(5!&(B") - ("I" . "$(5!'(B") - ("u" . "$(5!((B") - ("U" . "$(5!)(B") - ("R" . "$(5!*(B") - ;; ("RR" . "x") ; not specified in IS 13194. (but in Unicode??) - ("q" . "$(5#*(B") ; "$(5#*(B" = "$(5!*!i(B" in IS 13194. - ("L" . "$(5#&(B") ; "$(5#&(B" = "$(5!&!i(B" in IS 13194. - ("E" . "$(5#'(B") ; "$(5#'(B" = "$(5!'!i(B" in IS 13194. - ("Ex" . "$(5!+(B") ; only for transcription of other scripts. - ("e" . "$(5!,(B") - ("ai" . "$(5!-(B") - ("EE" . "$(5!.(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!/(B") ; only for transcription of other scripts. - ("o" . "$(5!0(B") - ("au" . "$(5!1(B") - ("ao" . "$(5!1(B") ; variation of transliteration. - ("OO" . "$(5!2(B") ; only for transcription of other scripts. (Candra O) - ("'" . "$(5#J(B") ; avagraha - ("@" . "$(5#!(B") ; OM - ("/" . "$(5!j(B") - ("M" . "$(5!"(B") - ("&" . "$(5!!(B") - ("H" . "$(5!#(B") - ("." . "$(5!i(B") ; Nukta - ("0" . "$(5!q(B") - ("1" . "$(5!r(B") - ("2" . "$(5!s(B") - ("3" . "$(5!t(B") - ("4" . "$(5!u(B") - ("5" . "$(5!v(B") - ("6" . "$(5!w(B") - ("7" . "$(5!x(B") - ("8" . "$(5!y(B") - ("9" . "$(5!z(B") - )) -) - -(defmacro devanagari-transliteration-quail-define-rules () - (cons 'quail-define-rules - (let ((cl devanagari-consonant-transliteration-alist) - (ml devanagari-other-letters-alist) rules) - (while cl - (let ((vl devanagari-vowel-transliteration-alist)) - (while vl - (setq rules - (cons (list (concat (car (car cl)) (car (car vl))) - (make-vector 1 - (concat (cdr (car cl)) (cdr (car vl))))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (list (car (car ml)) - (make-vector 1 (cdr (car ml)))) - rules)) - (setq ml (cdr ml))) - rules))) - -(quail-define-package - "devanagari-transliteration" "Devanagari" "DEVt" t - "Devanagari input method by transliteration -VOWELS : a $(5!$(B A $(5!%(B i $(5!&(B I $(5!'(B u $(5!((B U $(5!)(B - R $(5!*(B q $(5#*(B L $(5#&(B E $(5#'(B Ex $(5!+(B e $(5!,(B - ai $(5!-(B EE $(5!.(B O $(5!/(B o $(5!0(B au $(5!1(B OO $(5!2(B -GRUTTALS : k $(5!3(B kh $(5!4(B g $(5!5(B gh $(5!6(B G $(5!7(B -PALATALS : c $(5!8(B ch $(5!9(B j $(5!:(B jh $(5!;(B J $(5!<(B (Z $(5!:!i(B) -CEREBRALS : T $(5!=(B Th $(5!>(B D $(5!?(B Dh $(5!@(B N $(5!A(B -DENTALS : t $(5!B(B th $(5!C(B d $(5!D(B dh $(5!E(B n $(5!F(B (Nq $(5!G(B) -LABIALS : p $(5!H(B ph $(5!I(B b $(5!J(B bh $(5!K(B m $(5!L(B (f $(5!I(B) -SEMIVOWELS : y $(5!M(B Y $(5!N(B r $(5!O(B Rq $(5!P(B - l $(5!Q(B W $(5!R(B W. $(5!S(B v $(5!T(B w $(5!T(B -SIBILANTS : z $(5!U(B S $(5!V(B s $(5!W(B h $(5!X(B - -Specials : Anuswar M $(5!"(B Visarg H $(5!#(B - Chandrabindu & $(5!!(B Nukta . $(5!i(B - Danda / $(5!j(B Avagrah ' $(5#J(B - OM @ $(5#!(B -" - nil t t nil nil nil nil nil - ;; 'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-compose-characters) - ("-" . quail-devanagari-compose-characters) - ("," . quail-devanagari-compose-characters) - ("\C-m" . quail-devanagari-compose-characters) - ([return] . quail-devanagari-compose-characters)) - ) - -(devanagari-transliteration-quail-define-rules) - -;; -;; ITRANS - Indian Script Translation -;; - -(eval-and-compile - -(defun rule-indian-to-devanagari (alist) - (if (null alist) nil - (cons (cons (car (car alist)) - (indian-to-devanagari-string (cdr (car alist)))) - (rule-indian-to-devanagari (cdr alist))))) -) - -(eval-when-compile - -(defvar devanagari-consonant-itrans-alist - (rule-indian-to-devanagari indian-itrans-consonant-alist)) - -(defvar devanagari-vowel-itrans-alist - (rule-indian-to-devanagari indian-itrans-vowel-sign-alist)) - -(defvar devanagari-other-letters-itrans-alist - (rule-indian-to-devanagari indian-itrans-other-letters-alist)) - -) - -(defmacro devanagari-itrans-quail-define-rules () - (cons 'quail-define-rules - (let ((cl devanagari-consonant-itrans-alist) - (ml devanagari-other-letters-itrans-alist) rules) - (while cl - (let ((vl devanagari-vowel-itrans-alist)) - (while vl - (setq rules - (cons (list (concat (car (car cl)) (car (car vl))) - (make-vector 1 - (concat (cdr (car cl)) (cdr (car vl))))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (list (car (car ml)) - (make-vector 1 (cdr (car ml)))) - rules)) - (setq ml (cdr ml))) - rules))) - -(quail-define-package - "devanagari-itrans" "Devanagari" "DEVi" t - "Devanagari input method by ITRANS -Special Keys : Anuswar n' - Chandrabindu nn' - Visarg nh - Nukta type capital letter for first character. - $(5!7(B(ng) $(5!<(B(ny) $(5!A(B(nn) $(5!F(B(n) $(5!G(B(nnn) -" - nil t t nil nil nil nil nil - ;; 'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-compose-characters) - ("-" . quail-devanagari-compose-characters) - ("," . quail-devanagari-compose-characters) - ("\C-m" . quail-devanagari-compose-characters) - ([return] . quail-devanagari-compose-characters)) - ) - -(devanagari-itrans-quail-define-rules) - - -;; -;; Quail Hindi Input By Transliteration -;; - -(defun quail-devanagari-hindi-compose-characters () - (interactive) - (if (quail-point-in-conversion-region) - (let* ((from (overlay-start quail-conv-overlay)) - (to (overlay-end quail-conv-overlay)) - (dstr (buffer-substring from to))) - (delete-overlay quail-overlay) - (delete-overlay quail-conv-overlay) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (delete-region (point-min) (point-max)) - (insert (devanagari-compose-string dstr)) - (goto-char (point-max))) - (setq overriding-terminal-local-map nil))) - (setq unread-command-events (list last-command-event))) - -(eval-when-compile - -(defvar devanagari-hindi-consonant-transliteration-alist - '( - ; GUTTURALS - ("k" . "$(5!3(B") - ("ks" . "$(5$.(B") - ("k." . "$(5!3!i(B") - ("kh" . "$(5!4(B") - ("kh." . "$(5!4!i(B") - ("g" . "$(5!5(B") - ("g." . "$(5!5!i(B") - ("gh" . "$(5!6(B") - ("G" . "$(5!7(B") - ; PALATALS - ("ch" . "$(5!8(B") - ("chh" . "$(5!9(B") - ("j" . "$(5!:(B") - ("j." . "$(5!:!i(B") - ("z" . "$(5!:!i(B") - ("jh" . "$(5!;(B") - ("J" . "$(5!<(B") - ; CEREBRALS - ("T" . "$(5!=(B") - ("Th" . "$(5!>(B") - ("D" . "$(5!?(B") - ("D." . "$(5!?!i(B") - ("Dh" . "$(5!@(B") - ("Dh." . "$(5!@!i(B") - ("N" . "$(5!A(B") - ; DENTALS - ("t" . "$(5!B(B") - ("th" . "$(5!C(B") - ("d" . "$(5!D(B") - ("dh" . "$(5!E(B") - ("n" . "$(5!F(B") - ("N." . "$(5!G(B") - ; LABIALS - ("p" . "$(5!H(B") - ("ph" . "$(5!I(B") - ("ph." . "$(5!I!i(B") - ("f" . "$(5!I(B") - ("f." . "$(5!I!i(B") - ("b" . "$(5!J(B") - ("bh" . "$(5!K(B") - ("m" . "$(5!L(B") - ; SEMIVOWELS - ("y" . "$(5!M(B") - ("y." . "$(5!N(B") - ("Y" . "$(5!N(B") - ("r" . "$(5!O(B") - ("r." . "$(5!P(B") - ("l" . "$(5!Q(B") - ("W" . "$(5!R(B") - ("W." . "$(5!S(B") - ("v" . "$(5!T(B") - ("w" . "$(5!T(B") - ; SIBILANTS - ("sh" . "$(5!U(B") - ("S" . "$(5!V(B") - ("s" . "$(5!W(B") - ("h" . "$(5!X(B") - ; Special for Hindi - ("ks" . "$(5$.(B") - ("tr" . "$(5"%(B") - ("xn" . "$(5$E(B") - )) - -(defvar devanagari-hindi-vowel-transliteration-alist - '( - ; In hindi, halant sign is rarely used so should explicity typed in. - ("" . "") - ("~" . "$(5!h(B") - ; Matra (Vowel Sign) - ("a" . "$(5!Z(B") - ("i" . "$(5![(B") - ("I" . "$(5!\(B") - ("u" . "$(5!](B") - ("U" . "$(5!^(B") - ("R" . "$(5!_(B") - ;; ("RR" . "x") ; not specified in ordinary IS 13194.(but in Unicode??) - ("q" . "$(5#K(B") ; "$(5#K(B" = "$(5!_!i(B" in IS 13194. - ("L" . "$(5#L(B") ; "$(5#L(B" = "$(5![!i(B" in IS 13194. - ("E" . "$(5#M(B") ; "$(5#M(B" = "$(5!\!i(B" in IS 13194. - ("E" . "$(5!`(B") ; only for transcription of other scripts. - ("e" . "$(5!a(B") - ("ai" . "$(5!b(B") - ("ae" . "$(5!b(B") ; variation of transliteration. - ("EE" . "$(5!c(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!d(B") ; only for transcription of other scripts. - ("o" . "$(5!e(B") - ("au" . "$(5!f(B") - ("ao" . "$(5!f(B") ; variation of transliteration. - ("OO" . "$(5!g(B") ; only for transcription of other scripts. (Candra O) - )) - -;; -;; Independent vowels and other signs. -;; - -(defvar devanagari-hindi-other-letters-alist - '( - ("a" . "$(5!$(B") - ("A" . "$(5!%(B") - ("i" . "$(5!&(B") - ("I" . "$(5!'(B") - ("u" . "$(5!((B") - ("U" . "$(5!)(B") - ("R" . "$(5!*(B") - ;; ("RR" . "x") ; not specified in IS 13194. (but in Unicode??) - ("q" . "$(5#*(B") ; "$(5#*(B" = "$(5!*!i(B" in IS 13194. - ("L" . "$(5#&(B") ; "$(5#&(B" = "$(5!&!i(B" in IS 13194. - ("E" . "$(5#'(B") ; "$(5#'(B" = "$(5!'!i(B" in IS 13194. - ("Ex" . "$(5!+(B") ; only for transcription of other scripts. - ("e" . "$(5!,(B") - ("ai" . "$(5!-(B") - ("EE" . "$(5!.(B") ; only for transcription of other scripts. (Candra E) - ("O" . "$(5!/(B") ; only for transcription of other scripts. - ("o" . "$(5!0(B") - ("au" . "$(5!1(B") - ("ao" . "$(5!1(B") ; variation of transliteration. - ("OO" . "$(5!2(B") ; only for transcription of other scripts. (Candra O) - ("'" . "$(5#J(B") ; avagraha - ("@" . "$(5#!(B") ; OM - ("/" . "$(5!j(B") - ("M" . "$(5!"(B") - ("&" . "$(5!!(B") - ("H" . "$(5!#(B") - ("." . "$(5!i(B") ; Nukta - ("0" . "$(5!q(B") - ("1" . "$(5!r(B") - ("2" . "$(5!s(B") - ("3" . "$(5!t(B") - ("4" . "$(5!u(B") - ("5" . "$(5!v(B") - ("6" . "$(5!w(B") - ("7" . "$(5!x(B") - ("8" . "$(5!y(B") - ("9" . "$(5!z(B") - )) -) - -(defmacro devanagari-hindi-transliteration-quail-define-rules () - (cons 'quail-define-rules - (let ((cl devanagari-hindi-consonant-transliteration-alist) - (ml devanagari-hindi-other-letters-alist) rules) - (while cl - (let ((vl devanagari-hindi-vowel-transliteration-alist)) - (while vl - (setq rules - (cons (list (concat (car (car cl)) (car (car vl))) - (make-vector 1 - (concat (cdr (car cl)) (cdr (car vl))))) - rules)) - (setq vl (cdr vl)))) - (setq cl (cdr cl))) - (while ml - (setq rules (cons (list (car (car ml)) - (make-vector 1 (cdr (car ml)))) - rules)) - (setq ml (cdr ml))) - rules))) - -(quail-define-package - "devanagari-hindi-transliteration" "Hindi" "HINt" t - "Devanagari-Hindi input method by transliteration -VOWELS : a $(5!$(B A $(5!%(B i $(5!&(B I $(5!'(B u $(5!((B U $(5!)(B - R $(5!*(B q $(5#*(B L $(5#&(B E $(5#'(B Ex $(5!+(B e $(5!,(B - ai $(5!-(B EE $(5!.(B O $(5!/(B o $(5!0(B au $(5!1(B OO $(5!2(B -GRUTTALS : k $(5!3(B kh $(5!4(B g $(5!5(B gh $(5!6(B G $(5!7(B -PALATALS : c $(5!8(B ch $(5!9(B j $(5!:(B jh $(5!;(B J $(5!<(B z $(5!:!i(B -CEREBRALS : T $(5!=(B Th $(5!>(B D $(5!?(B Dh $(5!@(B N $(5!A(B -DENTALS : t $(5!B(B th $(5!C(B d $(5!D(B dh $(5!E(B n $(5!F(B (Nq $(5!G(B) -LABIALS : p $(5!H(B ph $(5!I(B b $(5!J(B bh $(5!K(B m $(5!L(B (f $(5!I(B) -SEMIVOWELS : y $(5!M(B Y $(5!N(B r $(5!O(B Rq $(5!P(B - l $(5!Q(B W $(5!R(B W. $(5!S(B v $(5!T(B w $(5!T(B -SIBILANTS : sh $(5!U(B S $(5!V(B s $(5!W(B h $(5!X(B -OTHERS : ks $(5$.(B tr $(5"%(B xn $(5$E(B - -Specials : Anuswar M $(5!"(B Visarg H $(5!#(B - Chandrabindu & $(5!!(B Nukta . $(5!i(B - Danda / $(5!j(B Avagrah ' $(5#J(B - OM @ $(5#!(B Halant ~ $(5!h(B -" - nil t t nil nil nil nil nil - ;; 'quail-devanagari-update-translation - nil - '((" " . quail-devanagari-hindi-compose-characters) - ("-" . quail-devanagari-hindi-compose-characters) - ("," . quail-devanagari-hindi-compose-characters) - ("\C-m" . quail-devanagari-hindi-compose-characters) - ([return] . quail-devanagari-hindi-compose-characters)) - ) - -(devanagari-hindi-transliteration-quail-define-rules)
--- a/lisp/leim/quail/ethiopic.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1041 +0,0 @@ -;; quail/ethiopic.el --- Quail package for inputting Ethiopic characters - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, ethiopic - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Author: TAKAHASHI Naoto <ntakahas@etl.go.jp> - -;;; Code: - -(require 'quail) -(require 'ethio-util) - -;; -;; The package "ethiopic" -;; - -(quail-define-package - "ethiopic" "Ethiopic" - '("$(3$O#U!.(B " - (ethio-prefer-ascii-space "_" "$(3$h(B") - (ethio-prefer-ascii-punctuation "." "$(3$i(B")) - t " QUAIL PACKAGE FOR ETHIOPIC (TIGRIGNA AND AMHARIC) - -When you activate this package, Ethio minor mode is also turned on. - - KEYS AND FUNCTIONS - -F2 or `M-x ethio-toggle-space' - Toggles space characters for keyboard input. The current mode is - indicated in mode-line, whether by `_' (ASCII space) or `$(3$h(B' - (Ethiopic colon-like word separator). Even in the `$(3$h(B' mode, an - ASCII space is inserted if the point is preceded by `an Ethiopic - punctuation followed by zero or more ASCII spaces'. - -F3 or `M-x ethio-toggle-punctuation' - Toggles ASCII punctuations and Ethiopic punctuations for keyboard input. - The current mode is indicated by `.' (ASCII) or `$(3$i(B' (Ethiopic). - -S-SPC or `M-x ethio-insert-ethio-space' - Always insert an Ethiopic word separator `$(3$h(B'. With a prefix number, - insert that many word separators. - -C-' or `M-x ethio-gemination' - Compose the character before the point with the Ethiopic gemination mark. - If the characater is already composed, decompose it and remove the - gemination mark." - - ;; The following keys should work as defined in lisp/language/ethio-util, - ;; even during the translation. - '(([f2] . quail-execute-non-quail-command) - ([f3] . quail-execute-non-quail-command) - (" " . quail-execute-non-quail-command) - ([?\S- ] . quail-execute-non-quail-command) - ([?\C-'] . quail-execute-non-quail-command)) - t t) - -(quail-define-rules - ("he" ?$(3!!(B) - ("hu" ?$(3!"(B) - ("hi" ?$(3!#(B) - ("ha" ?$(3!$(B) - ("hE" ?$(3!%(B) - ("h" ?$(3!&(B) - ("ho" ?$(3!'(B) - ("hW" ?$(3"N(B) - ("hWa" ?$(3"N(B) - ("hWe" ?$(3"K(B) - ("hWu" ?$(3"P(B) - ("hWi" ?$(3"M(B) - ("hWE" ?$(3"O(B) - ("hW'" ?$(3"P(B) - - ("le" ?$(3!)(B) - ("lu" ?$(3!*(B) - ("li" ?$(3!+(B) - ("la" ?$(3!,(B) - ("lE" ?$(3!-(B) - ("l" ?$(3!.(B) - ("lo" ?$(3!/(B) - ("lW" ?$(3!0(B) - ("lWa" ?$(3!0(B) - ("lWe" ["$(3!.%n(B"]) - ("lWu" ["$(3!.%r(B"]) - ("lWi" ["$(3!.%o(B"]) - ("lWE" ["$(3!.%q(B"]) - ("lW'" ["$(3!.%r(B"]) - - ("Le" ?$(3!)(B) - ("Lu" ?$(3!*(B) - ("Li" ?$(3!+(B) - ("La" ?$(3!,(B) - ("LE" ?$(3!-(B) - ("L" ?$(3!.(B) - ("Lo" ?$(3!/(B) - ("LW" ?$(3!0(B) - ("LWa" ?$(3!0(B) - ("LWe" ["$(3!.%n(B"]) - ("LWu" ["$(3!.%r(B"]) - ("LWi" ["$(3!.%o(B"]) - ("LWE" ["$(3!.%q(B"]) - ("LW'" ["$(3!.%r(B"]) - - ("He" ?$(3!1(B) - ("Hu" ?$(3!2(B) - ("Hi" ?$(3!3(B) - ("Ha" ?$(3!4(B) - ("HE" ?$(3!5(B) - ("H" ?$(3!6(B) - ("Ho" ?$(3!7(B) - ("HW" ?$(3!8(B) - ("HWa" ?$(3!8(B) - ("HWe" ["$(3!6%n(B"]) - ("HWu" ["$(3!6%r(B"]) - ("HWi" ["$(3!6%o(B"]) - ("HWE" ["$(3!6%q(B"]) - ("HW'" ["$(3!6%r(B"]) - - ("me" ?$(3!9(B) - ("mu" ?$(3!:(B) - ("mi" ?$(3!;(B) - ("ma" ?$(3!<(B) - ("mE" ?$(3!=(B) - ("m" ?$(3!>(B) - ("mo" ?$(3!?(B) - ("mWe" ?$(3%1(B) - ("mWu" ?$(3%a(B) - ("mWi" ?$(3%A(B) - ("mW" ?$(3!@(B) - ("mWa" ?$(3!@(B) - ("mWE" ?$(3%Q(B) - ("mW'" ?$(3%a(B) - ("mY" ?$(3$_(B) - ("mYa" ?$(3$_(B) - - ("Me" ?$(3!9(B) - ("Mu" ?$(3!:(B) - ("Mi" ?$(3!;(B) - ("Ma" ?$(3!<(B) - ("ME" ?$(3!=(B) - ("M" ?$(3!>(B) - ("Mo" ?$(3!?(B) - ("MWe" ?$(3%1(B) - ("MWu" ?$(3%a(B) - ("MWi" ?$(3%A(B) - ("MW" ?$(3!@(B) - ("MWa" ?$(3!@(B) - ("MWE" ?$(3%Q(B) - ("MW'" ?$(3%a(B) - ("MY" ?$(3$_(B) - ("MYa" ?$(3$_(B) - - ("`se" ?$(3!A(B) - ("`su" ?$(3!B(B) - ("`si" ?$(3!C(B) - ("`sa" ?$(3!D(B) - ("`sE" ?$(3!E(B) - ("`s" ?$(3!F(B) - ("`so" ?$(3!G(B) - ("`sW" ?$(3!H(B) - ("`sWa" ?$(3!H(B) - ("`sWe" ["$(3!F%n(B"]) - ("`sWu" ["$(3!F%r(B"]) - ("`sWi" ["$(3!F%o(B"]) - ("`sWE" ["$(3!F%q(B"]) - ("`sW'" ["$(3!F%r(B"]) - - ("s2e" ?$(3!A(B) - ("s2u" ?$(3!B(B) - ("s2i" ?$(3!C(B) - ("s2a" ?$(3!D(B) - ("s2E" ?$(3!E(B) - ("s2" ?$(3!F(B) - ("s2o" ?$(3!G(B) - ("s2W" ?$(3!H(B) - ("s2Wa" ?$(3!H(B) - ("s2We" ["$(3!F%n(B"]) - ("s2Wu" ["$(3!F%r(B"]) - ("s2Wi" ["$(3!F%o(B"]) - ("s2WE" ["$(3!F%q(B"]) - ("s2W'" ["$(3!F%r(B"]) - - ("sse" ?$(3!A(B) - ("ssu" ?$(3!B(B) - ("ssi" ?$(3!C(B) - ("ssa" ?$(3!D(B) - ("ssE" ?$(3!E(B) - ("ss" ?$(3!F(B) - ("sso" ?$(3!G(B) - ("ssW" ?$(3!H(B) - ("ssWa" ?$(3!H(B) - ("ssWe" ["$(3!F%n(B"]) - ("ssWu" ["$(3!F%r(B"]) - ("ssWi" ["$(3!F%o(B"]) - ("ssWE" ["$(3!F%q(B"]) - ("ssW'" ["$(3!F%r(B"]) - - ("re" ?$(3!I(B) - ("ru" ?$(3!J(B) - ("ri" ?$(3!K(B) - ("ra" ?$(3!L(B) - ("rE" ?$(3!M(B) - ("r" ?$(3!N(B) - ("ro" ?$(3!O(B) - ("rW" ?$(3!P(B) - ("rWa" ?$(3!P(B) - ("rY" ?$(3$`(B) - ("rYa" ?$(3$`(B) - ("rWe" ["$(3!N%n(B"]) - ("rWu" ["$(3!N%r(B"]) - ("rWi" ["$(3!N%o(B"]) - ("rWE" ["$(3!N%q(B"]) - ("rW'" ["$(3!N%r(B"]) - - ("Re" ?$(3!I(B) - ("Ru" ?$(3!J(B) - ("Ri" ?$(3!K(B) - ("Ra" ?$(3!L(B) - ("RE" ?$(3!M(B) - ("R" ?$(3!N(B) - ("Ro" ?$(3!O(B) - ("RW" ?$(3!P(B) - ("RWa" ?$(3!P(B) - ("RYa" ?$(3$`(B) - ("RWe" ["$(3!N%n(B"]) - ("RWu" ["$(3!N%r(B"]) - ("RWi" ["$(3!N%o(B"]) - ("RWE" ["$(3!N%q(B"]) - ("RW'" ["$(3!N%r(B"]) - - ("se" ?$(3!Q(B) - ("su" ?$(3!R(B) - ("si" ?$(3!S(B) - ("sa" ?$(3!T(B) - ("sE" ?$(3!U(B) - ("s" ?$(3!V(B) - ("so" ?$(3!W(B) - ("sW" ?$(3!X(B) - ("sWa" ?$(3!X(B) - ("sWe" ["$(3!V%n(B"]) - ("sWu" ["$(3!V%r(B"]) - ("sWi" ["$(3!V%o(B"]) - ("sWE" ["$(3!V%q(B"]) - ("sW'" ["$(3!V%r(B"]) - - ("xe" ?$(3!Y(B) - ("xu" ?$(3!Z(B) - ("xi" ?$(3 - ("x" ?$(3!^(B) - ("xo" ?$(3!_(B) - ("xW" ?$(3!`(B) - ("xWa" ?$(3!`(B) - ("xWe" ["$(3!^%n(B"]) - ("xWu" ["$(3!^%r(B"]) - ("xWi" ["$(3!^%o(B"]) - ("xWE" ["$(3!^%q(B"]) - ("xW'" ["$(3!^%r(B"]) - - ("qe" ?$(3!a(B) - ("qu" ?$(3!b(B) - ("qi" ?$(3!c(B) - ("qa" ?$(3!d(B) - ("qE" ?$(3!e(B) - ("q" ?$(3!f(B) - ("qo" ?$(3!g(B) - ("qWe" ?$(3!i(B) - ("qWu" ?$(3!n(B) - ("qWi" ?$(3!k(B) - ("qW" ?$(3!l(B) - ("qWa" ?$(3!l(B) - ("qWE" ?$(3!m(B) - ("qW'" ?$(3!n(B) - - ("`qe" ?$(3%)(B) - ("`qu" ?$(3%*(B) - ("`qi" ?$(3%+(B) - ("`qa" ?$(3%,(B) - ("`qE" ?$(3%-(B) - ("`q" ?$(3%.(B) - ("`qo" ?$(3%/(B) - - ("q2e" ?$(3%)(B) - ("q2u" ?$(3%*(B) - ("q2i" ?$(3%+(B) - ("q2a" ?$(3%,(B) - ("q2E" ?$(3%-(B) - ("q2" ?$(3%.(B) - ("q2o" ?$(3%/(B) - - ("qqe" ?$(3%)(B) - ("qqu" ?$(3%*(B) - ("qqi" ?$(3%+(B) - ("qqa" ?$(3%,(B) - ("qqE" ?$(3%-(B) - ("qq" ?$(3%.(B) - ("qqo" ?$(3%/(B) - - ("Qe" ?$(3!q(B) - ("Qu" ?$(3!r(B) - ("Qi" ?$(3!s(B) - ("Qa" ?$(3!t(B) - ("QE" ?$(3!u(B) - ("Q" ?$(3!v(B) - ("Qo" ?$(3!w(B) - ("QWe" ?$(3!y(B) - ("QWu" ?$(3!~(B) - ("QWi" ?$(3!{(B) - ("QW" ?$(3!|(B) - ("QWa" ?$(3!|(B) - ("QWE" ?$(3!}(B) - ("QW'" ?$(3!~(B) - - ("be" ?$(3"#(B) - ("bu" ?$(3"$(B) - ("bi" ?$(3"%(B) - ("ba" ?$(3"&(B) - ("bE" ?$(3"'(B) - ("b" ?$(3"((B) - ("bo" ?$(3")(B) - ("bWe" ?$(3%2(B) - ("bWu" ?$(3%b(B) - ("bWi" ?$(3%B(B) - ("bW" ?$(3"*(B) - ("bWa" ?$(3"*(B) - ("bWE" ?$(3%R(B) - ("bW'" ?$(3%b(B) - - ("Be" ?$(3"#(B) - ("Bu" ?$(3"$(B) - ("Bi" ?$(3"%(B) - ("Ba" ?$(3"&(B) - ("BE" ?$(3"'(B) - ("B" ?$(3"((B) - ("Bo" ?$(3")(B) - ("BWe" ?$(3%2(B) - ("BWu" ?$(3%b(B) - ("BWi" ?$(3%B(B) - ("BW" ?$(3"*(B) - ("BWa" ?$(3"*(B) - ("BWE" ?$(3%R(B) - ("BW'" ?$(3%b(B) - - ("ve" ?$(3"+(B) - ("vu" ?$(3",(B) - ("vi" ?$(3"-(B) - ("va" ?$(3".(B) - ("vE" ?$(3"/(B) - ("v" ?$(3"0(B) - ("vo" ?$(3"1(B) - ("vW" ?$(3"2(B) - ("vWa" ?$(3"2(B) - ("vWe" ["$(3"0%n(B"]) - ("vWu" ["$(3"0%r(B"]) - ("vWi" ["$(3"0%o(B"]) - ("vWE" ["$(3"0%q(B"]) - ("vW'" ["$(3"0%r(B"]) - - ("Ve" ?$(3"+(B) - ("Vu" ?$(3",(B) - ("Vi" ?$(3"-(B) - ("Va" ?$(3".(B) - ("VE" ?$(3"/(B) - ("V" ?$(3"0(B) - ("Vo" ?$(3"1(B) - ("VW" ?$(3"2(B) - ("VWa" ?$(3"2(B) - ("VWe" ["$(3"0%n(B"]) - ("VWu" ["$(3"0%r(B"]) - ("VWi" ["$(3"0%o(B"]) - ("VWE" ["$(3"0%q(B"]) - ("VW'" ["$(3"0%r(B"]) - - ("te" ?$(3"3(B) - ("tu" ?$(3"4(B) - ("ti" ?$(3"5(B) - ("ta" ?$(3"6(B) - ("tE" ?$(3"7(B) - ("t" ?$(3"8(B) - ("to" ?$(3"9(B) - ("tW" ?$(3":(B) - ("tWa" ?$(3":(B) - ("tWe" ["$(3"8%n(B"]) - ("tWu" ["$(3"8%r(B"]) - ("tWi" ["$(3"8%o(B"]) - ("tWE" ["$(3"8%q(B"]) - ("tW'" ["$(3"8%r(B"]) - - ("ce" ?$(3";(B) - ("cu" ?$(3"<(B) - ("ci" ?$(3"=(B) - ("ca" ?$(3">(B) - ("cE" ?$(3"?(B) - ("c" ?$(3"@(B) - ("co" ?$(3"A(B) - ("cW" ?$(3"B(B) - ("cWa" ?$(3"B(B) - ("cWe" ["$(3"@%n(B"]) - ("cWu" ["$(3"@%r(B"]) - ("cWi" ["$(3"@%o(B"]) - ("cWE" ["$(3"@%q(B"]) - ("cW'" ["$(3"@%r(B"]) - - ("`he" ?$(3"C(B) - ("`hu" ?$(3"D(B) - ("`hi" ?$(3"E(B) - ("`ha" ?$(3"F(B) - ("`hE" ?$(3"G(B) - ("`h" ?$(3"H(B) - ("`ho" ?$(3"I(B) - ("`hWe" ?$(3"K(B) - ("`hWu" ?$(3"P(B) - ("`hWi" ?$(3"M(B) - ("`hW" ?$(3"N(B) - ("`hWa" ?$(3"N(B) - ("`hWE" ?$(3"O(B) - ("`hW'" ?$(3"P(B) - - ("h2e" ?$(3"C(B) - ("h2u" ?$(3"D(B) - ("h2i" ?$(3"E(B) - ("h2a" ?$(3"F(B) - ("h2E" ?$(3"G(B) - ("h2" ?$(3"H(B) - ("h2o" ?$(3"I(B) - ("h2We" ?$(3"K(B) - ("h2Wu" ?$(3"P(B) - ("h2Wi" ?$(3"M(B) - ("h2W" ?$(3"N(B) - ("h2Wa" ?$(3"N(B) - ("h2WE" ?$(3"O(B) - ("h2W'" ?$(3"P(B) - - ("hhe" ?$(3"C(B) - ("hhu" ?$(3"D(B) - ("hhi" ?$(3"E(B) - ("hha" ?$(3"F(B) - ("hhE" ?$(3"G(B) - ("hh" ?$(3"H(B) - ("hho" ?$(3"I(B) - ("hhWe" ?$(3"K(B) - ("hhWu" ?$(3"P(B) - ("hhWi" ?$(3"M(B) - ("hhW" ?$(3"N(B) - ("hhWa" ?$(3"N(B) - ("hhWE" ?$(3"O(B) - ("hhW'" ?$(3"P(B) - - ("ne" ?$(3"S(B) - ("nu" ?$(3"T(B) - ("ni" ?$(3"U(B) - ("na" ?$(3"V(B) - ("nE" ?$(3"W(B) - ("n" ?$(3"X(B) - ("no" ?$(3"Y(B) - ("nW" ?$(3"Z(B) - ("nWa" ?$(3"Z(B) - ("nWe" ["$(3"X%n(B"]) - ("nWu" ["$(3"X%r(B"]) - ("nWi" ["$(3"X%o(B"]) - ("nWE" ["$(3"X%q(B"]) - ("nW'" ["$(3"X%r(B"]) - - ("Ne" ?$(3"[(B) - ("Nu" ?$(3"\(B) - ("Ni" ?$(3"](B) - ("Na" ?$(3"^(B) - ("NE" ?$(3"_(B) - ("N" ?$(3"`(B) - ("No" ?$(3"a(B) - ("NW" ?$(3"b(B) - ("NWa" ?$(3"b(B) - ("NWe" ["$(3"`%n(B"]) - ("NWu" ["$(3"`%r(B"]) - ("NWi" ["$(3"`%o(B"]) - ("NWE" ["$(3"`%q(B"]) - ("NW'" ["$(3"`%r(B"]) - - ("e" ?$(3"c(B) - ("u" ?$(3"d(B) - ("U" ?$(3"d(B) - ("i" ?$(3"e(B) - ("a" ?$(3"f(B) - ("A" ?$(3"f(B) - ("E" ?$(3"g(B) - ("I" ?$(3"h(B) - ("o" ?$(3"i(B) - ("O" ?$(3"i(B) - ("ea" ?$(3"j(B) - ("eee" ?$(3"j(B) - - ("ke" ?$(3"k(B) - ("ku" ?$(3"l(B) - ("ki" ?$(3"m(B) - ("ka" ?$(3"n(B) - ("kE" ?$(3"o(B) - ("k" ?$(3"p(B) - ("ko" ?$(3"q(B) - ("kWe" ?$(3"s(B) - ("kWu" ?$(3"x(B) - ("kWi" ?$(3"u(B) - ("kW" ?$(3"v(B) - ("kWa" ?$(3"v(B) - ("kWE" ?$(3"w(B) - ("kW'" ?$(3"x(B) - - ("`ke" ?$(3%9(B) - ("`ku" ?$(3%:(B) - ("`ki" ?$(3%;(B) - ("`ka" ?$(3%<(B) - ("`kE" ?$(3%=(B) - ("`k" ?$(3%>(B) - ("`ko" ?$(3%?(B) - - ("k2e" ?$(3%9(B) - ("k2u" ?$(3%:(B) - ("k2i" ?$(3%;(B) - ("k2a" ?$(3%<(B) - ("k2E" ?$(3%=(B) - ("k2" ?$(3%>(B) - ("k2o" ?$(3%?(B) - - ("kke" ?$(3%9(B) - ("kku" ?$(3%:(B) - ("kki" ?$(3%;(B) - ("kka" ?$(3%<(B) - ("kkE" ?$(3%=(B) - ("kk" ?$(3%>(B) - ("kko" ?$(3%?(B) - - ("Ke" ?$(3"{(B) - ("Ku" ?$(3"|(B) - ("Ki" ?$(3"}(B) - ("Ka" ?$(3"~(B) - ("KE" ?$(3#!(B) - ("K" ?$(3#"(B) - ("Ko" ?$(3##(B) - ("KWe" ?$(3#%(B) - ("KWu" ?$(3#*(B) - ("KWi" ?$(3#'(B) - ("KW" ?$(3#((B) - ("KWa" ?$(3#((B) - ("KWE" ?$(3#)(B) - ("KW'" ?$(3#*(B) - - ("Xe" ?$(3%I(B) - ("Xu" ?$(3%J(B) - ("Xi" ?$(3%K(B) - ("Xa" ?$(3%L(B) - ("XE" ?$(3%M(B) - ("X" ?$(3%N(B) - ("Xo" ?$(3%O(B) - - ("we" ?$(3#-(B) - ("wu" ?$(3#.(B) - ("wi" ?$(3#/(B) - ("wa" ?$(3#0(B) - ("wE" ?$(3#1(B) - ("w" ?$(3#2(B) - ("wo" ?$(3#3(B) - - ("`e" ?$(3#5(B) - ("`u" ?$(3#6(B) - ("`U" ?$(3#6(B) - ("`i" ?$(3#7(B) - ("`a" ?$(3#8(B) - ("`A" ?$(3#8(B) - ("`E" ?$(3#9(B) - ("`I" ?$(3#:(B) - ("`o" ?$(3#;(B) - ("`O" ?$(3#;(B) - - ("e2" ?$(3#5(B) - ("u2" ?$(3#6(B) - ("U2" ?$(3#6(B) - ("i2" ?$(3#7(B) - ("a2" ?$(3#8(B) - ("A2" ?$(3#8(B) - ("E2" ?$(3#9(B) - ("I2" ?$(3#:(B) - ("o2" ?$(3#;(B) - ("O2" ?$(3#;(B) - - ("ee" ?$(3#5(B) - ("uu" ?$(3#6(B) - ("UU" ?$(3#6(B) - ("ii" ?$(3#7(B) - ("aa" ?$(3#8(B) - ("AA" ?$(3#8(B) - ("EE" ?$(3#9(B) - ("II" ?$(3#:(B) - ("oo" ?$(3#;(B) - ("OO" ?$(3#;(B) - - ("ze" ?$(3#=(B) - ("zu" ?$(3#>(B) - ("zi" ?$(3#?(B) - ("za" ?$(3#@(B) - ("zE" ?$(3#A(B) - ("z" ?$(3#B(B) - ("zo" ?$(3#C(B) - ("zW" ?$(3#D(B) - ("zWa" ?$(3#D(B) - ("zWe" ["$(3#B%n(B"]) - ("zWu" ["$(3#B%r(B"]) - ("zWi" ["$(3#B%o(B"]) - ("zWE" ["$(3#B%q(B"]) - ("zW'" ["$(3#B%r(B"]) - - ("Ze" ?$(3#E(B) - ("Zu" ?$(3#F(B) - ("Zi" ?$(3#G(B) - ("Za" ?$(3#H(B) - ("ZE" ?$(3#I(B) - ("Z" ?$(3#J(B) - ("Zo" ?$(3#K(B) - ("ZW" ?$(3#L(B) - ("ZWa" ?$(3#L(B) - ("ZWe" ["$(3#J%n(B"]) - ("ZWu" ["$(3#J%r(B"]) - ("ZWi" ["$(3#J%o(B"]) - ("ZWE" ["$(3#J%q(B"]) - ("ZW'" ["$(3#J%r(B"]) - - ("ye" ?$(3#M(B) - ("yu" ?$(3#N(B) - ("yi" ?$(3#O(B) - ("ya" ?$(3#P(B) - ("yE" ?$(3#Q(B) - ("y" ?$(3#R(B) - ("yo" ?$(3#S(B) - ("yW" ?$(3#T(B) - ("yWa" ?$(3#T(B) - ("yWe" ["$(3#R%n(B"]) - ("yWu" ["$(3#R%r(B"]) - ("yWi" ["$(3#R%o(B"]) - ("yWE" ["$(3#R%q(B"]) - ("yW'" ["$(3#R%r(B"]) - - ("Ye" ?$(3#M(B) - ("Yu" ?$(3#N(B) - ("Yi" ?$(3#O(B) - ("Ya" ?$(3#P(B) - ("YE" ?$(3#Q(B) - ("Y" ?$(3#R(B) - ("Yo" ?$(3#S(B) - ("YW" ?$(3#T(B) - ("YWa" ?$(3#T(B) - ("YWe" ["$(3#R%n(B"]) - ("YWu" ["$(3#R%r(B"]) - ("YWi" ["$(3#R%o(B"]) - ("YWE" ["$(3#R%q(B"]) - ("YW'" ["$(3#R%r(B"]) - - ("de" ?$(3#U(B) - ("du" ?$(3#V(B) - ("di" ?$(3#W(B) - ("da" ?$(3#X(B) - ("dE" ?$(3#Y(B) - ("d" ?$(3#Z(B) - ("do" ?$(3#[(B) - ("dW" ?$(3#\(B) - ("dWa" ?$(3#\(B) - ("dWe" ["$(3#Z%n(B"]) - ("dWu" ["$(3#Z%r(B"]) - ("dWi" ["$(3#Z%o(B"]) - ("dWE" ["$(3#Z%q(B"]) - ("dW'" ["$(3#Z%r(B"]) - - ("De" ?$(3#](B) - ("Du" ?$(3#^(B) - ("Di" ?$(3#_(B) - ("Da" ?$(3#`(B) - ("DE" ?$(3#a(B) - ("D" ?$(3#b(B) - ("Do" ?$(3#c(B) - ("DW" ?$(3#d(B) - ("DWa" ?$(3#d(B) - ("DWe" ["$(3#b%n(B"]) - ("DWu" ["$(3#b%r(B"]) - ("DWi" ["$(3#b%o(B"]) - ("DWE" ["$(3#b%q(B"]) - ("DW'" ["$(3#b%r(B"]) - - ("je" ?$(3#e(B) - ("ju" ?$(3#f(B) - ("ji" ?$(3#g(B) - ("ja" ?$(3#h(B) - ("jE" ?$(3#i(B) - ("j" ?$(3#j(B) - ("jo" ?$(3#k(B) - ("jW" ?$(3#l(B) - ("jWa" ?$(3#l(B) - ("jWe" ["$(3#j%n(B"]) - ("jWu" ["$(3#j%r(B"]) - ("jWi" ["$(3#j%o(B"]) - ("jWE" ["$(3#j%q(B"]) - ("jW'" ["$(3#j%r(B"]) - - ("Je" ?$(3#e(B) - ("Ju" ?$(3#f(B) - ("Ji" ?$(3#g(B) - ("Ja" ?$(3#h(B) - ("JE" ?$(3#i(B) - ("J" ?$(3#j(B) - ("Jo" ?$(3#k(B) - ("JW" ?$(3#l(B) - ("JWa" ?$(3#l(B) - ("JWe" ["$(3#j%n(B"]) - ("JWu" ["$(3#j%r(B"]) - ("JWi" ["$(3#j%o(B"]) - ("JWE" ["$(3#j%q(B"]) - ("JW'" ["$(3#j%r(B"]) - - ("ge" ?$(3#m(B) - ("gu" ?$(3#n(B) - ("gi" ?$(3#o(B) - ("ga" ?$(3#p(B) - ("gE" ?$(3#q(B) - ("g" ?$(3#r(B) - ("go" ?$(3#s(B) - ("gWe" ?$(3#u(B) - ("gWu" ?$(3#z(B) - ("gWi" ?$(3#w(B) - ("gW" ?$(3#x(B) - ("gWa" ?$(3#x(B) - ("gWE" ?$(3#y(B) - ("gW'" ?$(3#z(B) - - ("`ge" ?$(3%Y(B) - ("`gu" ?$(3%Z(B) - ("`gi" ?$(3%[(B) - ("`ga" ?$(3%\(B) - ("`gE" ?$(3%](B) - ("`g" ?$(3%^(B) - ("`go" ?$(3%_(B) - - ("g2e" ?$(3%Y(B) - ("g2u" ?$(3%Z(B) - ("g2i" ?$(3%[(B) - ("g2a" ?$(3%\(B) - ("g2E" ?$(3%](B) - ("g2" ?$(3%^(B) - ("g2o" ?$(3%_(B) - - ("gge" ?$(3%Y(B) - ("ggu" ?$(3%Z(B) - ("ggi" ?$(3%[(B) - ("gga" ?$(3%\(B) - ("ggE" ?$(3%](B) - ("gg" ?$(3%^(B) - ("ggo" ?$(3%_(B) - - ("Ge" ?$(3#}(B) - ("Gu" ?$(3#~(B) - ("Gi" ?$(3$!(B) - ("Ga" ?$(3$"(B) - ("GE" ?$(3$#(B) - ("G" ?$(3$$(B) - ("Go" ?$(3$%(B) - ("GWe" ?$(3%3(B) - ("GWu" ?$(3%c(B) - ("GWi" ?$(3%C(B) - ("GW" ?$(3$&(B) - ("GWa" ?$(3$&(B) - ("GWE" ?$(3%S(B) - ("GW'" ?$(3%c(B) - - ("te" ?$(3$'(B) - ("tu" ?$(3$((B) - ("ti" ?$(3$)(B) - ("ta" ?$(3$*(B) - ("tE" ?$(3$+(B) - ("t" ?$(3$,(B) - ("to" ?$(3$-(B) - ("tW" ?$(3$.(B) - ("tWa" ?$(3$.(B) - ("tWe" ["$(3$,%n(B"]) - ("tWu" ["$(3$,%r(B"]) - ("tWi" ["$(3$,%o(B"]) - ("tWE" ["$(3$,%q(B"]) - ("tW'" ["$(3$,%r(B"]) - - ("Ce" ?$(3$/(B) - ("Cu" ?$(3$0(B) - ("Ci" ?$(3$1(B) - ("Ca" ?$(3$2(B) - ("CE" ?$(3$3(B) - ("C" ?$(3$4(B) - ("Co" ?$(3$5(B) - ("CW" ?$(3$6(B) - ("CWa" ?$(3$6(B) - ("CWe" ["$(3$4%n(B"]) - ("CWu" ["$(3$4%r(B"]) - ("CWi" ["$(3$4%o(B"]) - ("CWE" ["$(3$4%q(B"]) - ("CW'" ["$(3$4%r(B"]) - - ("Pe" ?$(3$7(B) - ("Pu" ?$(3$8(B) - ("Pi" ?$(3$9(B) - ("Pa" ?$(3$:(B) - ("PE" ?$(3$;(B) - ("P" ?$(3$<(B) - ("Po" ?$(3$=(B) - ("PW" ?$(3$>(B) - ("PWa" ?$(3$>(B) - ("PWe" ["$(3$<%n(B"]) - ("PWu" ["$(3$<%r(B"]) - ("PWi" ["$(3$<%o(B"]) - ("PWE" ["$(3$<%q(B"]) - ("PW'" ["$(3$<%r(B"]) - - ("Se" ?$(3$?(B) - ("Su" ?$(3$@(B) - ("Si" ?$(3$A(B) - ("Sa" ?$(3$B(B) - ("SE" ?$(3$C(B) - ("S" ?$(3$D(B) - ("So" ?$(3$E(B) - ("SW" ?$(3$F(B) - ("SWa" ?$(3$F(B) - ("SWe" ["$(3$D%n(B"]) - ("SWu" ["$(3$D%r(B"]) - ("SWi" ["$(3$D%o(B"]) - ("SWE" ["$(3$D%q(B"]) - ("SW'" ["$(3$D%r(B"]) - - ("`Se" ?$(3$G(B) - ("`Su" ?$(3$H(B) - ("`Si" ?$(3$I(B) - ("`Sa" ?$(3$J(B) - ("`SE" ?$(3$K(B) - ("`S" ?$(3$L(B) - ("`So" ?$(3$M(B) - ("`SW" ?$(3$F(B) - ("`SWa" ?$(3$F(B) - ("`SWe" ["$(3$L%n(B"]) - ("`SWu" ["$(3$L%r(B"]) - ("`SWi" ["$(3$L%o(B"]) - ("`SWE" ["$(3$L%q(B"]) - ("`SW'" ["$(3$L%r(B"]) - - ("S2e" ?$(3$G(B) - ("S2u" ?$(3$H(B) - ("S2i" ?$(3$I(B) - ("S2a" ?$(3$J(B) - ("S2E" ?$(3$K(B) - ("S2" ?$(3$L(B) - ("S2o" ?$(3$M(B) - ("S2W" ?$(3$F(B) - ("S2Wa" ?$(3$F(B) - ("S2We" ["$(3$L%n(B"]) - ("S2Wu" ["$(3$L%r(B"]) - ("S2Wi" ["$(3$L%o(B"]) - ("S2WE" ["$(3$L%q(B"]) - ("S2W'" ["$(3$L%r(B"]) - - ("SSe" ?$(3$G(B) - ("SSu" ?$(3$H(B) - ("SSi" ?$(3$I(B) - ("SSa" ?$(3$J(B) - ("SSE" ?$(3$K(B) - ("SS" ?$(3$L(B) - ("SSo" ?$(3$M(B) - ("SSW" ?$(3$F(B) - ("SSWa" ?$(3$F(B) - ("SSWe" ["$(3$L%n(B"]) - ("SSWu" ["$(3$L%r(B"]) - ("SSWi" ["$(3$L%o(B"]) - ("SSWE" ["$(3$L%q(B"]) - ("SW'" ["$(3$L%r(B"]) - - ("fe" ?$(3$O(B) - ("fu" ?$(3$P(B) - ("fi" ?$(3$Q(B) - ("fa" ?$(3$R(B) - ("fE" ?$(3$S(B) - ("f" ?$(3$T(B) - ("fo" ?$(3$U(B) - ("fWe" ?$(3%4(B) - ("fWu" ?$(3%d(B) - ("fWi" ?$(3%D(B) - ("fW" ?$(3$V(B) - ("fWa" ?$(3$V(B) - ("fWE" ?$(3%T(B) - ("fW'" ?$(3%d(B) - ("fY" ?$(3$a(B) - ("fYa" ?$(3$a(B) - - ("Fe" ?$(3$O(B) - ("Fu" ?$(3$P(B) - ("Fi" ?$(3$Q(B) - ("Fa" ?$(3$R(B) - ("FE" ?$(3$S(B) - ("F" ?$(3$T(B) - ("Fo" ?$(3$U(B) - ("FWe" ?$(3%4(B) - ("FWu" ?$(3%d(B) - ("FWi" ?$(3%D(B) - ("FW" ?$(3$V(B) - ("FWa" ?$(3$V(B) - ("FWE" ?$(3%T(B) - ("FW'" ?$(3%d(B) - ("FY" ?$(3$a(B) - ("FYa" ?$(3$a(B) - - ("pe" ?$(3$W(B) - ("pu" ?$(3$X(B) - ("pi" ?$(3$Y(B) - ("pa" ?$(3$Z(B) - ("pE" ?$(3$[(B) - ("p" ?$(3$\(B) - ("po" ?$(3$](B) - ("pWe" ?$(3%5(B) - ("pWu" ?$(3%e(B) - ("pWi" ?$(3%E(B) - ("pW" ?$(3$^(B) - ("pWa" ?$(3$^(B) - ("pWE" ?$(3%U(B) - ("pW'" ?$(3%e(B) - - ("'" [""]) - ("''" ?') - (":" ?$(3$h(B) - ("::" ?$(3$i(B) - (":::" ?:) - ("." ?$(3$i(B) - (".." ?$(3%u(B) - ("..." ?.) - ("," ?$(3$j(B) - (",," ?,) - (";" ?$(3$k(B) - (";;" ?\;) - ("-:" ?$(3$l(B) - (":-" ?$(3$m(B) - ("*" ?*) - ("**" ?$(3$o(B) - (":|:" ?$(3$o(B) - ("?" ?$(3%x(B) - ("??" ?$(3$n(B) - ("`?" ?$(3$n(B) - ("???" ??) - ("<<" ?$(3%v(B) - (">>" ?$(3%w(B) - ("`!" ?$(3%t(B) - ("wWe" ?$(3%n(B) - ("wWu" ?$(3%r(B) - ("wWi" ?$(3%o(B) - ("wW" ?$(3%p(B) - ("wWa" ?$(3%p(B) - ("wWE" ?$(3%q(B) - ("wW'" ?$(3%r(B) - ("We" ?$(3%n(B) - ("Wu" ?$(3%r(B) - ("Wi" ?$(3%o(B) - ("W" ?$(3%p(B) - ("Wa" ?$(3%p(B) - ("WE" ?$(3%q(B) - ("W'" ?$(3%r(B) - ("`1" ?$(3$p(B) - ("`2" ?$(3$q(B) - ("`3" ?$(3$r(B) - ("`4" ?$(3$s(B) - ("`5" ?$(3$t(B) - ("`6" ?$(3$u(B) - ("`7" ?$(3$v(B) - ("`8" ?$(3$w(B) - ("`9" ?$(3$x(B) - ("`10" ?$(3$y(B) - ("`20" ?$(3$z(B) - ("`30" ?$(3${(B) - ("`40" ?$(3$|(B) - ("`50" ?$(3$}(B) - ("`60" ?$(3$~(B) - ("`70" ?$(3%!(B) - ("`80" ?$(3%"(B) - ("`90" ?$(3%#(B) - ("`100" ?$(3%$(B) - ("`1000" ["$(3$y%$(B"]) - ("`2000" ["$(3$z%$(B"]) - ("`3000" ["$(3${%$(B"]) - ("`4000" ["$(3$|%$(B"]) - ("`5000" ["$(3$}%$(B"]) - ("`6000" ["$(3$~%$(B"]) - ("`7000" ["$(3%!%$(B"]) - ("`8000" ["$(3%"%$(B"]) - ("`9000" ["$(3%#%$(B"]) - ("`10000" ?$(3%%(B) - ("`20000" ["$(3$q%%(B"]) - ("`30000" ["$(3$r%%(B"]) - ("`40000" ["$(3$s%%(B"]) - ("`50000" ["$(3$t%%(B"]) - ("`60000" ["$(3$u%%(B"]) - ("`70000" ["$(3$v%%(B"]) - ("`80000" ["$(3$w%%(B"]) - ("`90000" ["$(3$x%%(B"]) - ("`100000" ["$(3$y%%(B"]) - ("`200000" ["$(3$z%%(B"]) - ("`300000" ["$(3${%%(B"]) - ("`400000" ["$(3$|%%(B"]) - ("`500000" ["$(3$}%%(B"]) - ("`600000" ["$(3$~%%(B"]) - ("`700000" ["$(3%!%%(B"]) - ("`800000" ["$(3%"%%(B"]) - ("`900000" ["$(3%#%%(B"]) - ("`1000000" ["$(3%$%%(B"]) -) - -(add-hook 'quail-mode-hook - (lambda nil - (if (not (string= (quail-name) "ethiopic")) - nil - ;; Also turn on the Ethio minor mode. - (ethio-mode 1) - ;; The translation of `a' depends on the language - ;; (either Tigrigna or Amharic). - (quail-defrule "a" - (if (ethio-prefer-amharic-p) ?$(3"c(B ?$(3"f(B) - "ethiopic")))) - -;;; quail/ethiopic.el ends here
--- a/lisp/leim/quail/japanese.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,381 +0,0 @@ -;;; quail/japanese.el --- Quail package for inputting Japanese - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, Japanese - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'quail) -(require 'kkc) - -;; Update Quail translation region while considering Japanese bizarre -;; translation rules. -(defun quail-japanese-update-translation (control-flag) - (cond ((eq control-flag t) - (insert quail-current-str) - (quail-terminate-translation)) - ((null control-flag) - (if (/= (aref quail-current-key 0) ?q) - (insert (or quail-current-str quail-current-key)))) - (t ; i.e. (numberp control-flag) - (cond ((= (aref quail-current-key 0) ?n) - (insert ?$B$s(B)) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) - (insert ?$B$C(B)) - (t - (insert (aref quail-current-key 0)))) - (setq unread-command-events - (list (aref quail-current-key control-flag))) - (quail-terminate-translation)))) - -;; Flag to control the behavior of `quail-japanese-toggle-kana'. -(defvar quail-japanese-kana-state nil) -(make-variable-buffer-local 'quail-japanese-kana-state) - -;; Convert Hiragana <-> Katakana in the current translation region. -(defun quail-japanese-toggle-kana () - (interactive) - (let ((start (overlay-start quail-conv-overlay)) - (end (overlay-end quail-conv-overlay))) - (setq quail-japanese-kana-state - (if (eq last-command this-command) - (not quail-japanese-kana-state))) - (if quail-japanese-kana-state - (japanese-hiragana-region start end) - (japanese-katakana-region start end)) - (goto-char (overlay-end quail-conv-overlay)))) - -;; Convert Hiragana in the current translation region to Kanji by KKC -;; (Kana Kanji Converter) utility. -(defun quail-japanese-kanji-kkc () - (interactive) - (let ((from (overlay-start quail-conv-overlay)) - (to (overlay-end quail-conv-overlay)) - newfrom) - (quail-delete-overlays) - (setq overriding-terminal-local-map nil) - (kkc-region from to 'quail-japanese-kkc-mode-exit))) - -;; Function to call on exiting KKC mode. ARG is nil if KKC mode is -;; exited normally, else ARG is a cons (FROM . TO) where FROM and TO -;; specify a region not yet processed. -(defun quail-japanese-kkc-mode-exit (arg) - (if arg - (progn - (setq overriding-terminal-local-map (quail-conversion-keymap)) - (move-overlay quail-conv-overlay (car arg) (cdr arg))) - (run-hooks 'input-method-after-insert-chunk-hook))) - -(defun quail-japanese-self-insert-and-switch-to-alpha (key idx) - (quail-delete-region) - (setq unread-command-events (list (aref key (1- idx)))) - (quail-japanese-switch-package "q" 1)) - -(defvar quail-japanese-switch-table - '((?z . "japanese-zenkaku") - (?k . "japanese-hankaku-kana") - (?h . "japanese") - (?q . ("japanese-ascii")))) - -(defvar quail-japanese-package-saved nil) -(make-variable-buffer-local 'quail-japanese-package-saved) -(put 'quail-japanese-package-saved 'permanent-local t) - -(defun quail-japanese-switch-package (key idx) - (let ((pkg (cdr (assq (aref key (1- idx)) quail-japanese-switch-table)))) - (if (null pkg) - (error "No package to be switched") - (setq overriding-terminal-local-map nil) - (quail-delete-region) - (if (stringp pkg) - (activate-input-method pkg) - (if (string= (car pkg) current-input-method) - (if quail-japanese-package-saved - (activate-input-method quail-japanese-package-saved)) - (setq quail-japanese-package-saved current-input-method) - (activate-input-method (car pkg)))))) - (throw 'quail-tag nil)) - -(quail-define-package - "japanese" "Japanese" "A$B$"(B" - nil - "Romaji -> Hiragana -> Kanji&Kana ----- Special key bindings ---- -qq: toggle between input methods `japanese' and `japanese-ascii' -qz: use `japanese-zenkaku' package, \"qh\" puts you back to `japanese' -K: toggle converting region between Katakana and Hiragana -SPC: convert to Kanji&Kana -z: insert one Japanese symbol according to a key which follows -" - nil t t nil nil nil nil nil - 'quail-japanese-update-translation - '(("K" . quail-japanese-toggle-kana) - (" " . quail-japanese-kanji-kkc) - ("\C-m" . quail-no-conversion) - ([return] . quail-no-conversion)) - ) - -(quail-define-rules - -( "a" "$B$"(B") ( "i" "$B$$(B") ( "u" "$B$&(B") ( "e" "$B$((B") ( "o" "$B$*(B") -("ka" "$B$+(B") ("ki" "$B$-(B") ("ku" "$B$/(B") ("ke" "$B$1(B") ("ko" "$B$3(B") -("sa" "$B$5(B") ("si" "$B$7(B") ("su" "$B$9(B") ("se" "$B$;(B") ("so" "$B$=(B") -("ta" "$B$?(B") ("ti" "$B$A(B") ("tu" "$B$D(B") ("te" "$B$F(B") ("to" "$B$H(B") -("na" "$B$J(B") ("ni" "$B$K(B") ("nu" "$B$L(B") ("ne" "$B$M(B") ("no" "$B$N(B") -("ha" "$B$O(B") ("hi" "$B$R(B") ("hu" "$B$U(B") ("he" "$B$X(B") ("ho" "$B$[(B") -("ma" "$B$^(B") ("mi" "$B$_(B") ("mu" "$B$`(B") ("me" "$B$a(B") ("mo" "$B$b(B") -("ya" "$B$d(B") ("yu" "$B$f(B") ("yo" "$B$h(B") -("ra" "$B$i(B") ("ri" "$B$j(B") ("ru" "$B$k(B") ("re" "$B$l(B") ("ro" "$B$m(B") -("la" "$B$i(B") ("li" "$B$j(B") ("lu" "$B$k(B") ("le" "$B$l(B") ("lo" "$B$m(B") -("wa" "$B$o(B") ("wi" "$B$p(B") ("wu" "$B$&(B") ("we" "$B$q(B") ("wo" "$B$r(B") -("n'" "$B$s(B") -("ga" "$B$,(B") ("gi" "$B$.(B") ("gu" "$B$0(B") ("ge" "$B$2(B") ("go" "$B$4(B") -("za" "$B$6(B") ("zi" "$B$8(B") ("zu" "$B$:(B") ("ze" "$B$<(B") ("zo" "$B$>(B") -("da" "$B$@(B") ("di" "$B$B(B") ("du" "$B$E(B") ("de" "$B$G(B") ("do" "$B$I(B") -("ba" "$B$P(B") ("bi" "$B$S(B") ("bu" "$B$V(B") ("be" "$B$Y(B") ("bo" "$B$\(B") -("pa" "$B$Q(B") ("pi" "$B$T(B") ("pu" "$B$W(B") ("pe" "$B$Z(B") ("po" "$B$](B") - -("kya" ["$B$-$c(B"]) ("kyu" ["$B$-$e(B"]) ("kye" ["$B$-$'(B"]) ("kyo" ["$B$-$g(B"]) -("sya" ["$B$7$c(B"]) ("syu" ["$B$7$e(B"]) ("sye" ["$B$7$'(B"]) ("syo" ["$B$7$g(B"]) -("sha" ["$B$7$c(B"]) ("shu" ["$B$7$e(B"]) ("she" ["$B$7$'(B"]) ("sho" ["$B$7$g(B"]) -("cha" ["$B$A$c(B"]) ("chu" ["$B$A$e(B"]) ("che" ["$B$A$'(B"]) ("cho" ["$B$A$g(B"]) -("tya" ["$B$A$c(B"]) ("tyu" ["$B$A$e(B"]) ("tye" ["$B$A$'(B"]) ("tyo" ["$B$A$g(B"]) -("nya" ["$B$K$c(B"]) ("nyu" ["$B$K$e(B"]) ("nye" ["$B$K$'(B"]) ("nyo" ["$B$K$g(B"]) -("hya" ["$B$R$c(B"]) ("hyu" ["$B$R$e(B"]) ("hye" ["$B$R$'(B"]) ("hyo" ["$B$R$g(B"]) -("mya" ["$B$_$c(B"]) ("myu" ["$B$_$e(B"]) ("mye" ["$B$_$'(B"]) ("myo" ["$B$_$g(B"]) -("rya" ["$B$j$c(B"]) ("ryu" ["$B$j$e(B"]) ("rye" ["$B$j$'(B"]) ("ryo" ["$B$j$g(B"]) -("lya" ["$B$j$c(B"]) ("lyu" ["$B$j$e(B"]) ("lye" ["$B$j$'(B"]) ("lyo" ["$B$j$g(B"]) -("gya" ["$B$.$c(B"]) ("gyu" ["$B$.$e(B"]) ("gye" ["$B$.$'(B"]) ("gyo" ["$B$.$g(B"]) -("zya" ["$B$8$c(B"]) ("zyu" ["$B$8$e(B"]) ("zye" ["$B$8$'(B"]) ("zyo" ["$B$8$g(B"]) -("jya" ["$B$8$c(B"]) ("jyu" ["$B$8$e(B"]) ("jye" ["$B$8$'(B"]) ("jyo" ["$B$8$g(B"]) -( "ja" ["$B$8$c(B"]) ( "ju" ["$B$8$e(B"]) ( "je" ["$B$8$'(B"]) ( "jo" ["$B$8$g(B"]) -("bya" ["$B$S$c(B"]) ("byu" ["$B$S$e(B"]) ("bye" ["$B$S$'(B"]) ("byo" ["$B$S$g(B"]) -("pya" ["$B$T$c(B"]) ("pyu" ["$B$T$e(B"]) ("pye" ["$B$T$'(B"]) ("pyo" ["$B$T$g(B"]) - -("kwa" ["$B$/$n(B"]) ("kwi" ["$B$/$#(B"]) ("kwe" ["$B$/$'(B"]) ("kwo" ["$B$/$)(B"]) -("tsa" ["$B$D$!(B"]) ("tsi" ["$B$D$#(B"]) ("tse" ["$B$D$'(B"]) ("tso" ["$B$D$)(B"]) -( "fa" ["$B$U$!(B"]) ( "fi" ["$B$U$#(B"]) ( "fe" ["$B$U$'(B"]) ( "fo" ["$B$U$)(B"]) -("gwa" ["$B$0$n(B"]) ("gwi" ["$B$0$#(B"]) ("gwe" ["$B$0$'(B"]) ("gwo" ["$B$0$)(B"]) - -("dyi" ["$B$G$#(B"]) ("dyu" ["$B$I$%(B"]) ("dye" ["$B$G$'(B"]) ("dyo" ["$B$I$)(B"]) -("xwi" ["$B$&$#(B"]) ("xwe" ["$B$&$'(B"]) ("xwo" ["$B$&$)(B"]) - -("shi" "$B$7(B") ("tyi" ["$B$F$#(B"]) ("chi" "$B$A(B") ("tsu" "$B$D(B") ("ji" "$B$8(B") -("fu" "$B$U(B") -("ye" ["$B$$$'(B"]) - -("va" ["$B%t$!(B"]) ("vi" ["$B%t$#(B"]) ("vu" "$B%t(B") ("ve" ["$B%t$'(B"]) ("vo" ["$B%t$)(B"]) - -("xa" "$B$!(B") ("xi" "$B$#(B") ("xu" "$B$%(B") ("xe" "$B$'(B") ("xo" "$B$)(B") -("xtu" "$B$C(B") ("xya" "$B$c(B") ("xyu" "$B$e(B") ("xyo" "$B$g(B") ("xwa" "$B$n(B") -("xka" "$B%u(B") ("xke" "$B%v(B") - -("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") ("4" "$B#4(B") ("5" "$B#5(B") -("6" "$B#6(B") ("7" "$B#7(B") ("8" "$B#8(B") ("9" "$B#9(B") ("0" "$B#0(B") - -("!" "$B!*(B") ("@" "$B!w(B") ("#" "$B!t(B") ("$" "$B!p(B") ("%" "$B!s(B") -("^" "$B!0(B") ("&" "$B!u(B") ("*" "$B!v(B") ("(" "$B!J(B") (")" "$B!K(B") -("-" "$B!<(B") ("=" "$B!a(B") ("`" "$B!.(B") ("\\" "$B!o(B") ("|" "$B!C(B") -("_" "$B!2(B") ("+" "$B!\(B") ("~" "$B!1(B") ("[" "$B!V(B") ("]" "$B!W(B") -("{" "$B!P(B") ("}" "$B!Q(B") (":" "$B!'(B") (";" "$B!((B") ("\"" "$B!I(B") -("'" "$B!G(B") ("." "$B!#(B") ("," "$B!"(B") ("<" "$B!c(B") (">" "$B!d(B") -("?" "$B!)(B") ("/" "$B!?(B") - -("z1" "$B!{(B") ("z!" "$B!|(B") -("z2" "$B"&(B") ("z@" "$B"'(B") -("z3" "$B"$(B") ("z#" "$B"%(B") -("z4" "$B""(B") ("z$" "$B"#(B") -("z5" "$B!~(B") ("z%" "$B"!(B") -("z6" "$B!y(B") ("z^" "$B!z(B") -("z7" "$B!}(B") ("z&" "$B!r(B") -("z8" "$B!q(B") ("z*" "$B!_(B") -("z9" "$B!i(B") ("z(" "$B!Z(B") -("z0" "$B!j(B") ("z)" "$B![(B") -("z-" "$B!A(B") ("z_" "$B!h(B") -("z=" "$B!b(B") ("z+" "$B!^(B") -("z\\" "$B!@(B") ("z|" "$B!B(B") -("z`" "$B!-(B") ("z~" "$B!/(B") - -("zq" "$B!T(B") ("zQ" "$B!R(B") -("zw" "$B!U(B") ("zW" "$B!S(B") -("zr" "$B!9(B") ("zR" "$B!8(B") -("zt" "$B!:(B") ("zT" "$B!x(B") -("zp" "$B")(B") ("zP" "$B",(B") -("z[" "$B!X(B") ("z{" "$B!L(B") -("z]" "$B!Y(B") ("z}" "$B!M(B") - -("zs" "$B!3(B") ("zS" "$B!4(B") -("zd" "$B!5(B") ("zD" "$B!6(B") -("zf" "$B!7(B") ("zF" "$B"*(B") -("zg" "$B!>(B") ("zG" "$B!=(B") -("zh" "$B"+(B") -("zj" "$B"-(B") -("zk" "$B",(B") -("zl" "$B"*(B") -("z;" "$B!+(B") ("z:" "$B!,(B") -("z\'" "$B!F(B") ("z\"" "$B!H(B") - -("zx" ":-") ("zX" ":-)") -("zc" "$B!;(B") ("zC" "$B!n(B") -("zv" "$B"((B") ("zV" "$B!`(B") -("zb" "$B!k(B") ("zB" "$B"+(B") -("zn" "$B!l(B") ("zN" "$B"-(B") -("zm" "$B!m(B") ("zM" "$B".(B") -("z," "$B!E(B") ("z<" "$B!e(B") -("z." "$B!D(B") ("z>" "$B!f(B") -("z/" "$B!&(B") ("z?" "$B!g(B") - -("\\\\" quail-japanese-self-insert-and-switch-to-alpha) -("{{" quail-japanese-self-insert-and-switch-to-alpha) -("}}" quail-japanese-self-insert-and-switch-to-alpha) - -("qq" quail-japanese-switch-package) -("qz" quail-japanese-switch-package) - -) - -(quail-define-package - "japanese-ascii" "Japanese" "Aa" - nil - "Temporary ASCII input mode while using Quail package `japanese' -Type \"qq\" to go back to previous package." - nil t t) - -(quail-define-rules ("qq" quail-japanese-switch-package)) - -(quail-define-package - "japanese-zenkaku" "Japanese" "$B#A(B" - nil - "Japanese zenkaku alpha numeric character input method ----- Special key bindings ---- -qq: toggle between `japanese-zenkaku' and `japanese-ascii' -qh: use `japanese' package, \"qz\" puts you back to `japanese-zenkaku' -" - nil t t) - -(quail-define-rules - -(" " "$B!!(B") ("!" "$B!*(B") ("\"" "$B!m(B") ("#" "$B!t(B") -("$" "$B!p(B") ("%" "$B!s(B") ("&" "$B!u(B") ("'" "$B!l(B") -("(" "$B!J(B") (")" "$B!K(B") ("*" "$B!v(B") ("+" "$B!\(B") -("," "$B!$(B") ("-" "$B!](B") ("." "$B!%(B") ("/" "$B!?(B") -("0" "$B#0(B") ("1" "$B#1(B") ("2" "$B#2(B") ("3" "$B#3(B") -("4" "$B#4(B") ("5" "$B#5(B") ("6" "$B#6(B") ("7" "$B#7(B") -("8" "$B#8(B") ("9" "$B#9(B") (":" "$B!'(B") (";" "$B!((B") -("<" "$B!c(B") ("=" "$B!a(B") (">" "$B!d(B") ("?" "$B!)(B") -("@" "$B!w(B") ("A" "$B#A(B") ("B" "$B#B(B") ("C" "$B#C(B") -("D" "$B#D(B") ("E" "$B#E(B") ("F" "$B#F(B") ("G" "$B#G(B") -("H" "$B#H(B") ("I" "$B#I(B") ("J" "$B#J(B") ("K" "$B#K(B") -("L" "$B#L(B") ("M" "$B#M(B") ("N" "$B#N(B") ("O" "$B#O(B") -("P" "$B#P(B") ("Q" "$B#Q(B") ("R" "$B#R(B") ("S" "$B#S(B") -("T" "$B#T(B") ("U" "$B#U(B") ("V" "$B#V(B") ("W" "$B#W(B") -("X" "$B#X(B") ("Y" "$B#Y(B") ("Z" "$B#Z(B") ("[" "$B!N(B") -("\\" "$B!o(B") ("]" "$B!O(B") ("^" "$B!0(B") ("_" "$B!2(B") -("`" "$B!F(B") ("a" "$B#a(B") ("b" "$B#b(B") ("c" "$B#c(B") -("d" "$B#d(B") ("e" "$B#e(B") ("f" "$B#f(B") ("g" "$B#g(B") -("h" "$B#h(B") ("i" "$B#i(B") ("j" "$B#j(B") ("k" "$B#k(B") -("l" "$B#l(B") ("m" "$B#m(B") ("n" "$B#n(B") ("o" "$B#o(B") -("p" "$B#p(B") ("q" "$B#q(B") ("r" "$B#r(B") ("s" "$B#s(B") -("t" "$B#t(B") ("u" "$B#u(B") ("v" "$B#v(B") ("w" "$B#w(B") -("x" "$B#x(B") ("y" "$B#y(B") ("z" "$B#z(B") ("{" "$B!P(B") -("|" "$B!C(B") ("}" "$B!Q(B") ("~" "$B!A(B") - -("qq" quail-japanese-switch-package) -("qh" quail-japanese-switch-package) -) - -(defun quail-japanese-hankaku-update-translation (control-flag) - (cond ((eq control-flag t) - (insert (japanese-hankaku quail-current-str)) - (quail-terminate-translation)) - ((null control-flag) - (insert (if quail-current-str - (japanese-hankaku quail-current-str) - quail-current-key))) - (t ; i.e. (numberp control-flag) - (cond ((= (aref quail-current-key 0) ?n) - (insert ?(I](B)) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) - (insert ?(I/(B)) - (t - (insert (aref quail-current-key 0)))) - (setq unread-command-events - (list (aref quail-current-key control-flag))) - (quail-terminate-translation)))) - - -(quail-define-package - "japanese-hankaku-kana" - "Japanese" "(I1(B" - nil - "Japanese hankaku katakana input method by Roman transliteration ----- Special key bindings ---- -qq: toggle between `japanese-hankaku-kana' and `japanese-ascii' -" - nil t t nil nil nil nil nil - 'quail-japanese-hankaku-update-translation) - -;; Use the same map as that of `japanese'. -(setcar (cdr (cdr quail-current-package)) - (nth 2 (assoc "japanese" quail-package-alist))) - -(quail-define-package - "japanese-hiragana" "Japanese" "$B$"(B" - nil - "Japanese hiragana input method by Roman transliteration" - nil t t nil nil nil nil nil - 'quail-japanese-update-translation) - -;; Use the same map as that of `japanese'. -(setcar (cdr (cdr quail-current-package)) - (nth 2 (assoc "japanese" quail-package-alist))) - -;; Update Quail translation region while converting Hiragana to Katakana. -(defun quail-japanese-katakana-update-translation (control-flag) - (cond ((eq control-flag t) - (insert (japanese-katakana quail-current-str)) - (quail-terminate-translation)) - ((null control-flag) - (insert (if quail-current-str - (japanese-katakana quail-current-str) - quail-current-key))) - (t ; i.e. (numberp control-flag) - (cond ((= (aref quail-current-key 0) ?n) - (insert ?$B%s(B)) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) - (insert ?$B%C(B)) - (t - (insert (aref quail-current-key 0)))) - (setq unread-command-events - (list (aref quail-current-key control-flag))) - (quail-terminate-translation)))) - -(quail-define-package - "japanese-katakana" "Japanese" "$B%"(B" - nil - "Japanese katakana input method by Roman transliteration" - nil t t nil nil nil nil nil - 'quail-japanese-katakana-update-translation) - -;; Use the same map as that of `japanese'. -(setcar (cdr (cdr quail-current-package)) - (nth 2 (assoc "japanese" quail-package-alist)))
--- a/lisp/leim/quail/lao.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,266 +0,0 @@ -;;; quail/lao.el --- Quail package for inputting Lao characters - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, Lao - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'quail) -(require 'lao-util) - -(eval-and-compile - -(defconst lao-keyboard-mapping - [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ; control codes - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ; control codes - 0 "1" "=" "3" "4" "(1l(B" "5" "(1'(B" ; SPC .. ' - "7" "8" "6" "(1mh(B" "(1A(B" "(1*(B" "(1c(B" "(1=(B" ; ( .. / - "(1"(B" "(1B(B" "(1?(B" "(1b(B" "(16(B" "(1X(B" "(1Y(B" "(1$(B" ; 0 .. 7 - "(15(B" "(1((B" "%" "(1G(B" "(1}(B" "(1m(B" "$" "\)" ; 8 .. ? - "2" "(1Qi(B" "(1Vi(B" "(1O(B" "." "(1Si(B" "," ":" ; @ .. G - "(1j(B" "(1N(B" "(1k(B" "!" "?" "(1f(B" "(1Wi(B" "(1|(B" ; H .. O - "(1](B" "(1[i(B" "_" ";" "+" "(1Ui(B" "x" "0" ; P .. W - "\(" "(1Ti(B" "\"" "(1:(B" 0 "(1E(B" "(1\(B" "9" ; X .. _ - "(1'(B" "(1Q(B" "(1V(B" "(1a(B" "(1!(B" "(1S(B" "(14(B" "(1`(B" ; ` .. g - "(1i(B" "(1C(B" "(1h(B" "(1R(B" "(1J(B" "(17(B" "(1W(B" "(19(B" ; h .. o - "(1-(B" "(1[(B" "(1>(B" "(1K(B" "(1P(B" "(1U(B" "(1M(B" "(1d(B" ; p .. w - "(1;(B" "(1T(B" "(1<(B" "-" "(1K\(B" "/" "~" 0] ; x .. DEL - "A table which maps ASCII key codes to corresponding Lao characters." - ) - -) - -;; Template of a cdr part of a Quail map when a consonant is entered. -(defvar lao-consonant-alist nil) -;; Template of a cdr part of a Quail map when a vowel upper is entered. -(defvar lao-vowel-upper-alist nil) -;; Template of a cdr part of a Quail map when a vowel lower is entered. -(defvar lao-vowel-lower-alist nil) -;; Template of a cdr part of a Quail map when a semivowel lower is entered. -(defvar lao-semivowel-lower-alist nil) - -;; Return a Quail map corresponding to KEY of length LEN. -;; The car part of the map is a translation generated automatically. -;; The cdr part of the map is a copy of ALIST. -(defun lao-generate-quail-map (key len alist) - (let ((str "") - (idx 0)) - (while (< idx len) - (setq str (concat str (aref lao-keyboard-mapping (aref key idx))) - idx (1+ idx))) - (cons (string-to-char (compose-string str)) (copy-alist alist)))) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; tone mark is entered. -(defun lao-tone-input (key len) - (lao-generate-quail-map key len nil)) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; vowel upper is entered. -(defun lao-vowel-upper-input (key len) - (lao-generate-quail-map key len lao-vowel-upper-alist)) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; vowel lower is entered. -(defun lao-vowel-lower-input (key len) - (lao-generate-quail-map key len lao-vowel-lower-alist)) - -;; Return a Quail map corresponding to KEY of length LEN when Lao -;; semivowel lower is entered. -(defun lao-semivowel-lower-input (key len) - (lao-generate-quail-map key len lao-semivowel-lower-alist)) - -;; Return an alist which can be a cdr part of a Quail map -;; corresponding to the current key when Lao consonant is entered. -(defun lao-consonant-input (key len) - (copy-alist lao-consonant-alist)) - -(quail-define-package - "lao" "Lao" "(1E(B" t - "Lao input method simulating Lao keyboard layout based on Thai TIS620" - nil t t t t nil nil nil nil nil t) - -(defmacro lao-quail-define-rules (&rest rules) - (let ((l rules) - consonant-alist - vowel-upper-alist - vowel-lower-alist - semivowel-lower-alist - rule trans ch c-set) - (while l - (setq rule (car l)) - (setq trans (nth 1 rule)) - (if (consp trans) - (setq trans (car trans))) - (setq c-set (char-category-set (string-to-char trans))) - (cond ((aref c-set ?2) ; vowel upper - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-vowel-upper-input) - consonant-alist))) - ((aref c-set ?3) ; vowel lower - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-vowel-lower-input) - consonant-alist) - semivowel-lower-alist - (cons (cons (string-to-char (car rule)) - 'lao-vowel-lower-input) - semivowel-lower-alist))) - ((aref c-set ?4) ; tone - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-tone-input) - consonant-alist) - vowel-upper-alist - (cons (cons (string-to-char (car rule)) - 'lao-tone-input) - vowel-upper-alist) - vowel-lower-alist - (cons (cons (string-to-char (car rule)) - 'lao-tone-input) - vowel-lower-alist))) - ((aref c-set ?9) ; semivowel lower - (setq consonant-alist - (cons (cons (string-to-char (car rule)) - 'lao-semivowel-lower-input) - consonant-alist) - vowel-upper-alist - (cons (cons (string-to-char (car rule)) - 'lao-semivowel-lower-input) - vowel-upper-alist)))) - (setq l (cdr l))) - (list 'progn - (cons 'quail-define-rules rules) - `(setq lao-consonant-alist ',consonant-alist - lao-vowel-upper-alist ',vowel-upper-alist - lao-vowel-lower-alist ',vowel-lower-alist - lao-semivowel-lower-alist ',semivowel-lower-alist)))) - -(lao-quail-define-rules - ("!" "1") - ("\"" "=") - ("#" "3") - ("$" "4") - ("&" "5") - ("%" "(1l(B") - ("'" ("(1'(B" . lao-consonant-input)) - ("(" "7") - (")" "8") - ("*" "6") - ("+" "0(1mh1(B") - ("," ("(1A(B" . lao-consonant-input)) - ("-" ("(1*(B" . lao-consonant-input)) - ("." "(1c(B") - ("/" ("(1=(B" . lao-consonant-input)) - ("0" ("(1"(B" . lao-consonant-input)) - ("1" ("(1B(B" . lao-consonant-input)) - ("2" ("(1?(B" . lao-consonant-input)) - ("3" "(1b(B") - ("4" ("(16(B" . lao-consonant-input)) - ("5" "(1X(B") - ("6" "(1Y(B") - ("7" ("(1$(B" . lao-consonant-input)) - ("8" ("(15(B" . lao-consonant-input)) - ("9" ("(1((B" . lao-consonant-input)) - (":" "%") - (";" ("(1G(B" . lao-consonant-input)) - ("<" ("(1}(B" . lao-consonant-input)) - ("=" "(1m(B") - (">" "$") - ("?" ")") - ("@" "2") - ("A" "0(1Qi1(B") - ("B" "0(1Vi1(B") - ("C" "(1O(B") - ("D" ".") - ("E" "0(1Si1(B") - ("F" ",") - ("G" ":") - ("H" "(1j(B") - ("I" ("(1N(B" . lao-consonant-input)) - ("J" "(1k(B") - ("K" "!") - ("L" "?") - ("M" "(1f(B") - ("N" "0(1Wi1(B") - ("O" ("(1|(B" . lao-consonant-input)) - ("P" "(1](B") - ("Q" "0(1[i1(B") - ("R" "_") - ("S" ";") - ("T" "+") - ("U" "0(1Ui1(B") - ("V" "x") - ("W" "0") - ("X" "(") - ("Y" "0(1Ti1(B") - ("Z" "\"") - ("[" ("(1:(B" . lao-consonant-input)) - ("]" ("(1E(B" . lao-consonant-input)) - ("^" "(1\(B") - ("_" "9") - ("`" ("(1'(B" . lao-consonant-input)) - ("a" "(1Q(B") - ("b" "(1V(B") - ("c" "(1a(B") - ("d" ("(1!(B" . lao-consonant-input)) - ("e" "(1S(B") - ("f" ("(14(B" . lao-consonant-input)) - ("g" "(1`(B") - ("h" "(1i(B") - ("i" ("(1C(B" . lao-consonant-input)) - ("j" "(1h(B") - ("k" "(1R(B") - ("l" ("(1J(B" . lao-consonant-input)) - ("m" ("(17(B" . lao-consonant-input)) - ("n" "(1W(B") - ("o" ("(19(B" . lao-consonant-input)) - ("p" ("(1-(B" . lao-consonant-input)) - ("q" "(1[(B") - ("r" ("(1>(B" . lao-consonant-input)) - ("s" ("(1K(B" . lao-consonant-input)) - ("t" "(1P(B") - ("u" "(1U(B") - ("v" ("(1M(B" . lao-consonant-input)) - ("w" "(1d(B") - ("x" ("(1;(B" . lao-consonant-input)) - ("y" "(1T(B") - ("z" ("(1<(B" . lao-consonant-input)) - ("{" "-") - ("|" ("0(1K\1(B" . lao-consonant-input)) - ("}" "/") - ("~" "(1l(B") - ("\\0" "(1p(B") - ("\\1" "(1q(B") - ("\\2" "(1r(B") - ("\\3" "(1s(B") - ("\\4" "(1t(B") - ("\\5" "(1u(B") - ("\\6" "(1v(B") - ("\\7" "(1w(B") - ("\\8" "(1x(B") - ("\\9" "(1y(B") - ) - - -;;; quail/lao.el ends here
--- a/lisp/leim/quail/lrt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,423 +0,0 @@ -;;; quail/lrt.el --- Quail package for inputting Lao characters by LRT method - -;; Copyright (C) 1997 Electrotechnical Laboratory, JAPAN. -;; Licensed to the Free Software Foundation. - -;; Keywords: multilingual, input method, Lao, LRT. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'quail) -(require 'lao-util) - -;; LRT (Lao Roman Transcription) input method accepts the following -;; key sequence: -;; consonant [+ semi-vowel-sign-lo ] + vowel [+ maa-sakod ] [+ tone-mark ] - -(eval-and-compile - -;; Upper vowels and tone-marks are put on the letter. -;; Semi-vowel-sign-lo and lower vowels are put under the letter. -(defconst lrt-single-consonant-table - `(("k" . ?(1!(B) - ("kh" . ?(1"(B) - ("qh" . ?(1$(B) - ("ng" . ?(1'(B) - ("j" . ?(1((B) - ("s" . ?(1J(B) - ("x" . ?(1*(B) - ("y" . ?(1-(B) - ("d" . ?(14(B) - ("t" . ?(15(B) - ("th" . ?(16(B) - ("dh" . ?(17(B) - ("n" . ?(19(B) - ("b" . ?(1:(B) - ("p" . ?(1;(B) - ("hp" . ?(1<(B) - ("fh" . ?(1=(B) - ("ph" . ?(1>(B) - ("f" . ?(1?(B) - ("m" . ?(1A(B) - ("gn" . ?(1B(B) - ("l" . ?(1E(B) - ("r" . ?(1C(B) - ("v" . ?(1G(B) - ("w" . ?(1G(B) - ("hh" . ?(1K(B) - ("O" . ?(1M(B) - ("h" . ?(1N(B) - ("nh" . ?(1|(B) - ("mh" . ?(1}(B) - ("lh" . "0(1K\1(B") - )) - -;; Semi-vowel-sign-lo is put under the first letter. -;; Lower vowels are put under the last letter. -;; Upper vowels and tone-marks are put on the last letter. -(defconst lrt-double-consonant-table - '(("ngh" . "(1K'(B") - ("yh" . "(1K](B") - ("wh" . "(1KG(B") - ("hl" . "(1KE(B") - ("hy" . "(1K-(B") - ("hn" . "(1K9(B") - ("hm" . "(1KA(B") - )) - -(defconst lrt-semi-vowel-sign-lo - '("r" . ?(1\(B)) - -(defconst lrt-vowel-table - '(("a" "(1P(B" (0 ?(1P(B) (0 ?(1Q(B)) - ("ar" "(1R(B" (0 ?(1R(B)) - ("i" "(1T(B" (0 ?(1T(B)) - ("ii" "(1U(B" (0 ?(1U(B)) - ("eu" "(1V(B" (0 ?(1V(B)) - ("ur" "(1W(B" (0 ?(1W(B)) - ("u" "(1X(B" (0 ?(1X(B)) - ("uu" "(1Y(B" (0 ?(1Y(B)) - ("e" "(1`(B (1P(B" (?(1`(B 0 ?(1P(B) (?(1`(B 0 ?(1Q(B)) - ("ee" "(1`(B" (?(1`(B 0)) - ("ae" "(1a(B (1P(B" (?(1a(B 0 ?(1P(B) (?(1a(B 0 ?(1Q(B)) - ("aa" "(1a(B" (?(1a(B 0)) - ("o" "(1b(B (1P(B" (?(1b(B 0 ?(1P(B) (0 ?(1[(B) (?(1-(B ?(1b(B 0 ?(1Q(B) (?(1G(B ?(1b(B 0 ?(1Q(B)) - ("oo" "(1b(B" (?(1b(B 0)) - ("oe" "(1`(B (1RP(B" (?(1`(B 0 ?(1R(B ?(1P(B) (0 ?(1Q(B ?(1M(B)) - ("or" "(1m(B" (0 ?(1m(B) (0 ?(1M(B)) - ("er" "(1`(B (1T(B" (?(1`(B 0 ?(1T(B)) - ("ir" "(1`(B (1U(B" (?(1`(B 0 ?(1U(B)) - ("ua" "(1[GP(B" (0 ?(1[(B ?(1G(B ?(1P(B) (0 ?(1Q(B ?(1G(B)) - ("uaa" "(1[G(B" (0 ?(1[(B ?(1G(B) (0 ?(1G(B)) - ("ie" "(1`Q]P(B" (?(1`(B 0 ?(1Q(B ?(1](B ?(1P(B) (0 ?(1Q(B ?(1](B)) - ("ia" "(1`Q](B" (?(1`(B 0 ?(1Q(B ?(1](B) (0 ?(1](B)) - ("ea" "(1`VM(B" (?(1`(B 0 ?(1V(B ?(1M(B)) - ("eaa" "(1`WM(B" (?(1`(B 0 ?(1W(B ?(1M(B)) - ("ai" "(1d(B" (?(1d(B 0)) - ("ei" "(1c(B" (?(1c(B 0)) - ("ao" "(1`[R(B" (?(1`(B 0 ?(1[(B ?(1R(B)) - ("aM" "(1S(B" (0 ?(1S(B)))) - -;; Maa-sakod is put at the tail. -(defconst lrt-maa-sakod-table - '((?k . ?(1!(B) - (?g . ?(1'(B) - (?y . ?(1-(B) - (?d . ?(14(B) - (?n . ?(19(B) - (?b . ?(1:(B) - (?m . ?(1A(B) - (?v . ?(1G(B) - (?w . ?(1G(B) - )) - -(defconst lrt-tone-mark-table - '(("'" . ?(1h(B) - ("\"" . ?(1i(B) - ("^" . ?(1j(B) - ("+" . ?(1k(B) - ("~" . ?(1l(B))) - -;; Return list of composing patterns for normal (without maa-sakod) -;; key sequence and with-maa-sakod key sequence starting with single -;; consonant C and optional SEMI-VOWEL. -(defun lrt-composing-pattern-single-c (c semi-vowel vowel-pattern) - (let* ((patterns (copy-sequence vowel-pattern)) - (tail patterns) - place) - ;; Embed C and SEMI-VOWEL (if any) at the place of 0. - (while tail - ;; At first, make a copy. - (setcar tail (copy-sequence (car tail))) - ;; Then, do embedding. - (setq place (memq 0 (car tail))) - (setcar place c) - (if semi-vowel - (setcdr place (cons semi-vowel (cdr place)))) - (setq tail (cdr tail))) - patterns)) - -;; Return list of composing patterns for normal (without maa-sakod) -;; key sequence and with-maa-sakod key sequence starting with double -;; consonant STR and optional SEMI-VOWEL. -(defun lrt-composing-pattern-double-c (str semi-vowel vowel-pattern) - (let* ((patterns (copy-sequence vowel-pattern)) - (tail patterns) - (chars (string-to-list - (if (= (chars-in-string str) 1) - (decompose-string str) - str))) - place) - ;; Embed C and SEMI-VOWEL (if any) at the place of 0. - (while tail - ;; At first, make a copy. - (setcar tail (copy-sequence (car tail))) - ;; Then, do embedding. - (setq place (memq 0 (car tail))) - (setcar place (car chars)) - (setcdr place (cons (nth 1 chars) (cdr place))) - (if semi-vowel - ;; Embed SEMI-VOWEL in between CHARS. - (setcdr place (cons semi-vowel (cdr place)))) - (setq tail (cdr tail))) - patterns)) - -;; Return a string made of characters in CHAR-LIST while composing -;; such characters as vowel-upper, vowel-lower, semi-vowel(lower), -;; and tone-mark with the preceding base character. -(defun lrt-compose-string (char-list) - ;; Make a copy because the following work alters it. - (setq char-list (copy-sequence char-list)) - (let ((i -1) - (l char-list)) - (while l - (if (memq (get-char-code-property (car l) 'phonetic-type) - '(vowel-upper vowel-lower semivowel-lower tone)) - (let (composed-char) - (if (< i 0) - ;; No preceding base character. - (error "Invalid CHAR-LIST: %s" char-list)) - (setq composed-char - (string-to-char (compose-chars (nth i char-list) (car l)))) - (setcar (nthcdr i char-list) composed-char) - (setq l (cdr l)) - (setcdr (nthcdr i char-list) l)) - (setq l (cdr l)) - (setq i (1+ i)))) - (concat (apply 'vector char-list)))) - -(defun lrt-compose-c-s-v (consonant semi-vowel vowel-pattern) - (let ((pattern-list - (if (integerp consonant) - (lrt-composing-pattern-single-c - consonant semi-vowel vowel-pattern) - (lrt-composing-pattern-double-c - consonant semi-vowel vowel-pattern)))) - (cons (vector (lrt-compose-string (car pattern-list))) - (cons t pattern-list)))) - -) - -(defun lrt-handle-maa-sakod () - (interactive) - (if (or (= (length quail-current-key) 0) - (not quail-current-data)) - (quail-self-insert-command) - (if (not (car quail-current-data)) - (progn - (setq quail-current-data nil) - (setq unread-command-events - (cons last-command-event unread-command-events)) - (quail-terminate-translation)) - (if (not (integerp last-command-event)) - (error "Bogus calling sequence")) - (let* ((maa-sakod (cdr (assq last-command-event lrt-maa-sakod-table))) - (maa-sakod-pattern (append - (or (cdr (assq maa-sakod - (nthcdr 3 quail-current-data))) - (nth 2 quail-current-data) - (nth 1 quail-current-data)) - (list maa-sakod)))) - (quail-delete-region) - (setq quail-current-str (lrt-compose-string maa-sakod-pattern)) - (insert quail-current-str) - (quail-show-translations) - (setq quail-current-data (list nil maa-sakod-pattern)))))) - -(defun lrt-handle-tone-mark () - (interactive) - (if (= (length quail-current-key) 0) - (quail-self-insert-command) - (if (not quail-current-data) - (progn - (setq unread-command-events - (cons last-command-event unread-command-events)) - (quail-terminate-translation)) - (if (not (integerp last-command-event)) - (error "Bogus calling sequence")) - (let* ((tone-mark (cdr (assoc (char-to-string last-command-event) - lrt-tone-mark-table))) - (tone-mark-pattern - (if (car quail-current-data) - (copy-sequence (nth 1 quail-current-data)) - ;; No need of copy because lrt-handle-maa-sakod should - ;; have already done it. - (nth 1 quail-current-data))) - (tail tone-mark-pattern) - (double-consonant-keys lrt-double-consonant-table) - (double-consonant-flag nil) - place) - - ;; Set DOUBLE-CONSONANT-FLAG to t if a user entered a double - ;; consonant. - (while (and double-consonant-keys (not double-consonant-flag)) - (setq double-consonant-flag - (eq (string-match (car (car double-consonant-keys)) - quail-current-key) - 0) - double-consonant-keys (cdr double-consonant-keys))) - - ;; Find a place to embed TONE-MARK. It should be after a - ;; single or double consonant and following upper or lower vowels. - (while (and tail (not place)) - (if (and - (eq (get-char-code-property (car tail) 'phonetic-type) - 'consonant) - ;; Skip `(1K(B' if it is the first letter of double consonant. - (or (not double-consonant-flag) - (/= (car tail) ?(1K(B))) - (progn - (setq place tail) - (setq tail (cdr tail)) - (while (and tail - (memq (get-char-code-property (car tail) - 'phonetic-type) - '(vowel-upper vowel-lower semivowel-lower))) - (setq place tail tail (cdr tail)))) - (setq tail (cdr tail)))) - ;; Embed TONE-MARK. - (setcdr place (cons tone-mark (cdr place))) - (quail-delete-region) - (insert (lrt-compose-string tone-mark-pattern)) - (setq quail-current-data nil) - (quail-terminate-translation))))) - -(defmacro lrt-generate-quail-map () - `(quail-install-map - ',(let ((map (list nil)) - (semi-vowel-key (car lrt-semi-vowel-sign-lo)) - (semi-vowel-char (cdr lrt-semi-vowel-sign-lo)) - l1 e1 l2 e2 pattern key) - ;; Single consonants. - (setq l1 lrt-single-consonant-table) - (while l1 - (setq e1 (car l1)) - (quail-defrule-internal (car e1) (vector (cdr e1)) map) - (quail-defrule-internal - (concat (car e1) semi-vowel-key) - (if (stringp (cdr e1)) - (compose-string (format "%s%c" (cdr e1) semi-vowel-char)) - (compose-string (format "%c%c" (cdr e1) semi-vowel-char))) - map) - (setq l2 lrt-vowel-table) - (while l2 - (setq e2 (car l2)) - (setq key (concat (car e1) (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) nil (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq key (concat (car e1) semi-vowel-key (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) semi-vowel-char - (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq l2 (cdr l2))) - (setq l1 (cdr l1))) - - ;; Double consonants. - (setq l1 lrt-double-consonant-table) - (while l1 - (setq e1 (car l1)) - (quail-defrule-internal (car e1) (vector (cdr e1)) map) - (quail-defrule-internal - (concat (car e1) semi-vowel-key) - (vector (concat (compose-string - (format "%c%c" (sref (cdr e1) 0) semi-vowel-char)) - (substring (cdr e1) (charset-bytes 'lao)))) - map) - (setq l2 lrt-vowel-table) - (while l2 - (setq e2 (car l2)) - (setq key (concat (car e1) (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) nil (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq key (concat (car e1) semi-vowel-key (car e2)) - pattern (lrt-compose-c-s-v (cdr e1) semi-vowel-char - (nthcdr 2 e2))) - (quail-defrule-internal key pattern map) - (quail-defrule-internal - (concat key " ") - (vector (concat (aref (car pattern) 0) " ")) map) - (setq l2 (cdr l2))) - (setq l1 (cdr l1))) - - ;; Vowels. - (setq l1 lrt-vowel-table) - (while l1 - (setq e1 (car l1) l1 (cdr l1)) - (quail-defrule-internal (car e1) (vector (nth 1 e1)) map)) - - ;; Tone-marks. - (setq l1 lrt-tone-mark-table) - (while l1 - (setq e1 (car l1) l1 (cdr l1)) - (quail-defrule-internal (car e1) (cdr e1) map)) - - map))) - -(quail-define-package - "lao-lrt" "Lao" "(1E(BR" t - "Lao input method using LRT (Lao Roman Transcription). -`\\' (backslash) + number-key => (1p(B,(1q(B,(1r(B,... LAO DIGIT ZERO, ONE, TWO, ... -`\\' (backslash) + `\\' => (1f(B LAO KO LA (REPETITION) -`\\' (backslash) + `$' => (1O(B LAO ELLIPSIS -" - '(("k" . lrt-handle-maa-sakod) - ("g" . lrt-handle-maa-sakod) - ("y" . lrt-handle-maa-sakod) - ("d" . lrt-handle-maa-sakod) - ("n" . lrt-handle-maa-sakod) - ("b" . lrt-handle-maa-sakod) - ("m" . lrt-handle-maa-sakod) - ("v" . lrt-handle-maa-sakod) - ("w" . lrt-handle-maa-sakod) - ("'" . lrt-handle-tone-mark) - ("\"" . lrt-handle-tone-mark) - ("^" . lrt-handle-tone-mark) - ("+" . lrt-handle-tone-mark) - ("~" . lrt-handle-tone-mark)) - 'forget-last-selection 'deterministic 'kbd-translate 'show-layout - nil nil nil nil nil t) - -(lrt-generate-quail-map) - -;; Additional key definitions for Lao digits. - -(quail-defrule "\\0" ?(1p(B) -(quail-defrule "\\1" ?(1q(B) -(quail-defrule "\\2" ?(1r(B) -(quail-defrule "\\3" ?(1s(B) -(quail-defrule "\\4" ?(1t(B) -(quail-defrule "\\5" ?(1u(B) -(quail-defrule "\\6" ?(1v(B) -(quail-defrule "\\7" ?(1w(B) -(quail-defrule "\\8" ?(1x(B) -(quail-defrule "\\9" ?(1y(B) -(quail-defrule "\\\\" ?(1f(B) -(quail-defrule "\\$" ?(1O(B) - -;;; quail/lrt.el ends here
--- a/lisp/leim/quail/tibetan.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,519 +0,0 @@ -;;; quail/tibetan.el -- Quail package for inputting Tibetan characters - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. - -;; Keywords: multilingual, input method, Tibetan - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;; Author: Toru TOMABECHI, <Toru.Tomabechi@orient.unil.ch> - -;; Created: Feb. 17. 1997 - -;; History: -;; 1997.03.13 Support for inputting special signs and punctuations added. -;; (Only Ext. Wylie input) - -;;; Code: - -(require 'quail) - -;;; -;;; Functions for making some composite punctuations. -;;; - -(defun tibetan-quail-bzhi-shad (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7!>(B '(mr . ml) ?\x20 '(mr . ml) ?$(7!>(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla-phur-shad (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B '(bc . tl) ?$(7!I(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla-double (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B '(mr . ml) ?$(7#S(B)) - (throw 'quail-tag nil)) - -(defun tibetan-quail-nyi-zla-triple (&rest ignore) - (quail-delete-region) - (quail-delete-overlays) - (insert (compose-chars ?$(7#R(B '(mr . ml) ?$(7#S(B '(mr . ml) ?$(7#S(B '(mr . ml) ?$(7#S(B)) - (throw 'quail-tag nil)) - -;;; -;;; Setting-ups for Extended Wylie input. -;;; - -(defun quail-tibetan-input-wylie (key &rest ignore) - (let (pc) - (quail-delete-region) - (quail-delete-overlays) - (setq pc (preceding-char)) - (if (not (eq (point) (point-min))) - (delete-backward-char 1 nil)) - (insert (tibetan-composition pc key)) - (throw 'quail-tag nil))) - - -(quail-define-package "tibetan-wylie" "Tibetan" "TIBw" t -"Tibetan character input by Extended Wylie key assignment. - - +-------------------------------------+ - |2$(7"!`#T1$(8!;(B k |2$(7""`#T1$(8!;(B kh |2$(7"#`#T1$(8!;(B g |2$(7"$`#T1$(8!;(B gh |2$(7"%`#T1$(8!;(B ng| $(7"S(B i $(8!=(B / - |2$(7"&`#T1$(8!;(B c |2$(7"'`#T1$(8!;(B ch |2$(7"(`#T1$(8!;(B j | |$(7"*$(8!;(B ny| $(7"U(B u $(7!>(B // - |$(7"+$(8!;(B T |$(7",$(8!;(B TH |$(7"-$(8!;(B D |$(7".$(8!;(B DH |$(7"/$(8!;(B N | $(7"[(B e 2$(7!>P(B P$(7!>1(B //// - |$(7"0$(8!;(B t |$(7"1$(8!;(B th |$(7"2$(8!;(B d |$(7"3$(8!;(B dh |$(7"4$(8!;(B n | $(7"](B o $(7!A(B ; - |$(7"5$(8!;(B p |$(7"6$(8!;(B ph |$(7"7$(8!;(B b |$(7"8$(8!;(B bh |$(7"9$(8!;(B m | $(7"\(B ai (ee, E) $(8!?(B $ - |$(7":$(8!;(B ts|$(7";$(8!;(B tsh|$(7"<$(8!;(B dz |$(7"=$(8!;(B dzh|$(7">$(8!;(B w | $(7"^(B au (oo, O) $(8!@(B & - |$(7"?$(8!;(B zh|$(7"@$(8!;(B z |$(7"A$(8!;(B ' | |$(7"B$(8!;(B y | $(7"a(B I 2$(7#RP#SP#S1(B * - |$(7"C$(8!;(B r |$(7"D$(8!;(B l |$(7"E$(8!;(B sh |$(7"F$(8!;(B SH |$(7"G$(8!;(B s | $(7"`(B : 2$(7#RP#SP#SP#S1(B # - |$(7"H$(8!;(B h |$(7"I$(8!;(B A |$(7"J$(8!;(B kSH| | | $(7"_(B M $(7!l(B $(7!m(B < > - +-------------------------------------+ $(8!D(B % - (The consonant $(7"I$(8!;(B must be typed explicitly.) - - NOT SPECIFIED IN EXT. WYLIE: - +--------------------------------------------------------+ - |$(7"c(B = ~ |$(7"d(B = ` |$(7"e(B = , |$(7"f(B = @ |$(7!g(B = _o|$(7!e(B = _O|2$(7#RP#S_!I1(B = ^| - +--------------------------------------------------------+ - |$(7"i(B = x |$(7"j(B = X |$(7"g(B = v |$(7"h(B = V |$(7"k(B = q |$(7"l(B = Q | - +-----------------------------------------------+ - - SPECIAL KEYS - + : Consonant Stacking - \(Consonant stacking for ordinary Tibetan is done automatically) - - : No Consonant Stacking - \(To suppress automatic stacking for \"g-y\", - and to get da-drag in -r-d, -l-d .) - | : Special signs. - - Tsheg is assigned to SPC. Space is assigned to period '.'. -" - nil nil nil) - -(quail-define-rules - ("." ?\x20) - ("k" quail-tibetan-input-wylie) - ("g" quail-tibetan-input-wylie) - ("c" quail-tibetan-input-wylie) - ("j" quail-tibetan-input-wylie) - ("T" quail-tibetan-input-wylie) - ("D" quail-tibetan-input-wylie) - ("N" quail-tibetan-input-wylie) - ("t" quail-tibetan-input-wylie) - ("d" quail-tibetan-input-wylie) - ("n" quail-tibetan-input-wylie) - ("p" quail-tibetan-input-wylie) - ("b" quail-tibetan-input-wylie) - ("m" quail-tibetan-input-wylie) - ("w" quail-tibetan-input-wylie) - ("z" quail-tibetan-input-wylie) - ("'" quail-tibetan-input-wylie) - ("y" quail-tibetan-input-wylie) - ("r" quail-tibetan-input-wylie) - ("l" quail-tibetan-input-wylie) - ("SH" quail-tibetan-input-wylie) - ("s" quail-tibetan-input-wylie) - ("h" quail-tibetan-input-wylie) - ("H" quail-tibetan-input-wylie) - ("A" quail-tibetan-input-wylie) - ("+k" quail-tibetan-input-wylie) - ("+g" quail-tibetan-input-wylie) - ("+c" quail-tibetan-input-wylie) - ("+j" quail-tibetan-input-wylie) - ("+T" quail-tibetan-input-wylie) - ("+D" quail-tibetan-input-wylie) - ("+N" quail-tibetan-input-wylie) - ("+t" quail-tibetan-input-wylie) - ("+d" quail-tibetan-input-wylie) - ("+n" quail-tibetan-input-wylie) - ("+p" quail-tibetan-input-wylie) - ("+b" quail-tibetan-input-wylie) - ("+m" quail-tibetan-input-wylie) - ("+w" quail-tibetan-input-wylie) - ("+z" quail-tibetan-input-wylie) - ("+'" quail-tibetan-input-wylie) - ("+y" quail-tibetan-input-wylie) - ("+r" quail-tibetan-input-wylie) - ("+l" quail-tibetan-input-wylie) - ("+SH" quail-tibetan-input-wylie) - ("+s" quail-tibetan-input-wylie) - ("+h" quail-tibetan-input-wylie) - ("+H" quail-tibetan-input-wylie) - ("+A" quail-tibetan-input-wylie) - ("-d" ?$(7"2(B) ; To avoid default stacking - ("-y" ?$(7"B(B) ; Idem. - ("a" quail-tibetan-input-wylie) ; invisible vowel sign - ("i" quail-tibetan-input-wylie) - ("u" quail-tibetan-input-wylie) - ("e" quail-tibetan-input-wylie) - ("o" quail-tibetan-input-wylie) - ("I" quail-tibetan-input-wylie) - ("E" quail-tibetan-input-wylie) - ("O" quail-tibetan-input-wylie) - ("M" quail-tibetan-input-wylie) - ("~" quail-tibetan-input-wylie) - ("`" quail-tibetan-input-wylie) - ("," quail-tibetan-input-wylie) - ("x" quail-tibetan-input-wylie) - ("X" quail-tibetan-input-wylie) - ("v" quail-tibetan-input-wylie) - ("V" quail-tibetan-input-wylie) - ("q" quail-tibetan-input-wylie) - ("Q" quail-tibetan-input-wylie) - ("_o" quail-tibetan-input-wylie) - ("_O" quail-tibetan-input-wylie) -;;; ("_/" quail-tibetan-input-wylie) - (":" ?$(8"`(B) - (" " ?$(8!;(B) - ("/" ?$(8!=(B) - ("//" ?$(7!>(B) - ("////" tibetan-quail-bzhi-shad) - ("$" ?$(8!?(B) - ("/\"" ?$(8!@(B) ; Not defined in Ext. Wylie. - ("&" ?$(8!@(B) - (";" ?$(8!A(B) - ("%" ?$(8!D(B) - ("!" ?$(7!8(B) - ("<" ?$(7!l(B) - (">" ?$(7!m(B) - ("@" ?$(7"f(B) - ("*" tibetan-quail-nyi-zla-double) - ("#" tibetan-quail-nyi-zla-triple) - ("^" tibetan-quail-nyi-zla-phur-shad) - ("0" ?$(7!P(B) - ("1" ?$(7!Q(B) - ("2" ?$(7!R(B) - ("3" ?$(7!S(B) - ("4" ?$(7!T(B) - ("5" ?$(7!U(B) - ("6" ?$(7!V(B) - ("7" ?$(7!W(B) - ("8" ?$(7!X(B) - ("9" ?$(7!Y(B) - ("-0" ?$(7!c(B) - ("-1" ?$(7!Z(B) - ("-2" ?$(7 - ("-5" ?$(7!^(B) - ("-6" ?$(7!_(B) - ("-7" ?$(7!`(B) - ("-8" ?$(7!a(B) - ("-9" ?$(7!b(B) - ("|" "$(7!1!2!3!9!:!B!C!E!F!G!H!I!J!K!L!M!N!O!d!f!h!j!k!n!o(B") - ) - -;;; -;;; Setting-ups for TibKey input -;;; - -(defconst tibetan-tibkey-to-transcription-alist - '( - ("`" . "`") ; sna ldan - ("~" . "~") ; sna ldan + nada - ("q" . "k") ; ka - ("Q" ."kSH") ; kSHa - ("w" . "kh") ; kha - ("e" . "g") ; ga - ("r" . "ng") ; nga - ("t" . "c") ; ca - ("T" . "I") ; gi gu log - ("y" . "ch") ; cha - ("u" . "j") ; ja - ("i" . "ny") ; nya - ("o" . "t") ; ta - ("O" . "T") ; Ta - ("p" . "th") ; tha - ("P" . "TH") ; THa - ("[" . "d") ; da - ("{" . "D") ; Da - ("]" . "n") ; na - ("}" . "N") ; Na - ("a" . "p") ; pa - ("A" . "a") ; Vowel a (not used in original TibKey) - ("s" . "ph") ; pha - ("d" . "b") ; ba - ("f" . "m") ; ma - ("F" . "M") ; anusvara - ("g" . "u") ; zhabs kyu - ("G" . "i") ; gi gu - ("H" . ",") ; viraama - ("j" . "o") ; naro - ("J" . "e") ; 'greng bu - ("k" . "ts") ; tsa - ("l" . "tsh") ; tsha - (";" . "dz") ; dza - ("'" . "w") ; wa - ("\"" . "+w") ; wa zur - ("z" . "zh") ; zha - ("x" . "z") ; za - ("c" . "'") ; 'a - ("C" . "+'") ; 'a chung - ("v" . "y") ; ya - ("V" . "+y") ; ya btags - ("b" . "r") ; ra - ("B" . "+r") ; ra btags - ("n" . "l") ; la - ("N" . "+l") ; la btags - ("m" . "sh") ; sha - ("M" . "SH") ; SHa - ("," . "s") ; sa - ("." . "h") ; ha - ("/" . "A") ; Aa - ;;subjoined - ("hq" . "+k") ; ka - ("hQ" ."+kSH") ; kSHa - ("hw" . "+kh") ; kha - ("he" . "+g") ; ga - ("hr" . "+ng") ; nga - ("ht" . "+c") ; ca - ("hy" . "+ch") ; cha - ("hu" . "+j") ; ja - ("hi" . "+ny") ; nya - ("ho" . "+t") ; ta - ("hO" . "+T") ; Ta - ("hp" . "+th") ; tha - ("hP" . "+TH") ; THa - ("h[" . "+d") ; da - ("h{" . "+D") ; Da - ("h]" . "+n") ; na - ("h}" . "+N") ; Na - ("ha" . "+p") ; pa - ("hs" . "+ph") ; pha - ("hd" . "+b") ; ba - ("hf" . "+m") ; ma - ("hk" . "+ts") ; tsa - ("hl" . "+tsh") ; tsha - ("h;" . "+dz") ; dza - ("h'" . "+w") ; wa - ("hz" . "+zh") ; zha - ("hx" . "+z") ; za - ("hc" . "+'") ; 'a - ("hv" . "+y") ; ya - ("hb" . "+r") ; ra - ("hn" . "+l") ; la - ("hm" . "+sh") ; sha - ("hM" . "+SH") ; SHa - ("h," . "+s") ; sa - ("h." . "+h") ; ha - ("h/" . "+A") ; Aa - )) - -(defun quail-tibetan-input-tibkey (key &rest ignore) - (let (trans pc) - (setq trans (cdr (assoc key tibetan-tibkey-to-transcription-alist))) - (quail-delete-region) - (quail-delete-overlays) - (setq pc (preceding-char)) - (if (not (eq (point) (point-min))) - (delete-backward-char 1 nil)) - (insert (tibetan-composition pc trans)) - (throw 'quail-tag nil))) - - - -(quail-define-package "tibetan-tibkey" "Tibetan" "TIBt" t -"Tibetan character input by TibKey key assignment. - -(This implementation is still incomplete. - Therefore, the following key assignment is a provisional one.) - - [NOT SHIFTED] - - +-------------------------------------------------------+ - |`$(7"d(B|1$(7!Q(B|2$(7!R(B|3$(7!S(B|4$(7!T(B|5$(7!U(B|6$(7!V(B|7$(7!W(B|8$(7!X(B|9$(7!Y(B|0$(7!P(B|- |= |\\$(7!8(B| - +-------------------------------------------------------+ - |q$(7"!(B|w$(7""(B|e$(7"#(B|r$(7"%(B|t$(7"&(B|y$(7"'(B|u$(7"((B|i$(7"*(B|o$(7"0(B|p$(7"1(B|[$(7"2(B|]$(7"4(B| - +-----------------------------------------------+ - |a$(7"5(B| s$(7"6(B| d$(7"7(B|f$(7"9(B|g$(7"U(B|h |j$(7"](B|k$(7":(B|l$(7";(B|;$(7"<(B|'$(7">(B| - +---------------------------------------------+ - |z$(7"?(B|x$(7"@(B|c$(7"A(B|v$(7"B(B|b$(7"C(B|n$(7"D(B|m$(7"E(B|,$(7"G(B|.$(7"H(B|/$(7"I(B| - +---------------------------------------+ - The key 'h' is used for consonant stacking. - - [SHIFTED] - - +----------------------------------------------------------+ - |~$(7"c(B|!2$(7#RP#S1(B|@$(7#S(B|# |$ |%$(8!D(B |^$(7!1(B|& |* |($(7!l(B|)$(7!m(B|_ |+$(7!A(B| |$(7!8(B| - +----------------------------------------------------------+ - |Q$(7"J(B|W$(7#T(B|E |R |T$(7"a(B|Y |U |I$(7"f(B|O$(7"+(B|P$(7",(B|{$(7"-(B|}$(7"/(B| - +-----------------------------------------------+ - |A |S |D |F$(7"_(B|G$(7"S(B|H$(7"e(B|J$(7"[(B|K |L |:$(7"`(B|\"$(7#>(B| - +-------------------------------------------+ - |Z |X |C$(7#A(B|V$(7#B(B|B$(7#C(B|N$(7#D(B|M$(7"F(B|< |> |?$(8!=(B | - +---------------------------------------+ - - DIFFERENCE FROM THE ORIGINAL TIBKEY: - - 1. Vowel 'a' should be typed explicitly by the key 'A'. - This is really inconvenient. But to make the coding - scheme clear, it is desirable to have an explicite - vowel sign for 'a'. - 2. Tsheg is assigned to SPC key. You can input a space - by typing '>'. - 4. To avoid the default stacking $(7$B(B and to obtain $(7"#"B(B, - type 'E' instead of 'v' (=$(7"B(B). - 3. There are many characters that are not supported in the - current implementation (especially special signs). I hope - I'll complete in a future revision. -" - nil t) - -(quail-define-rules - ("`" quail-tibetan-input-tibkey) ; sna ldan, not supported yet - ("~" quail-tibetan-input-tibkey) ; sna ldan + nada - ("1" ?$(7!Q(B) - ("!" tibetan-quail-nyi-zla) ; nyi zla long - ("2" ?$(7!R(B) - ("@" ?$(7#S(B) ; nyi zla simple - ("3" ?$(7!S(B) -;;; ("#" ) - ("4" ?$(7!T(B) -;;; ("$" ) - ("5" ?$(7!U(B) - ("%" ?$(8!D(B) - ("6" ?$(7!V(B) - ("^" ?$(7!1(B) - ("7" ?$(7!W(B) - ("8" ?$(7!X(B) -;;; ("*" ) ; avagraha, not supported yet - ("9" ?$(7!Y(B) - ("(" ?$(7!l(B) - ("0" ?$(7!P(B) - (")" ?$(7!m(B) -;;; ("-" ) ; enphatic, not yet supported -;;; ("_" ) ; id. -;;; ("=" ) ; special sign, not yet supported - ("+" ?$(8!A(B) - ("\\" ?$(8!?(B) - ("|" ?$(7!8(B) - ("q" quail-tibetan-input-tibkey) ; ka - ("Q" quail-tibetan-input-tibkey) ; kSHa - ("w" quail-tibetan-input-tibkey) ; kha - ("e" quail-tibetan-input-tibkey) ; ga - ("E" ?$(7"B(B) - ("r" quail-tibetan-input-tibkey) ; nga - ("t" quail-tibetan-input-tibkey) ; ca - ("T" quail-tibetan-input-tibkey) ; gi gu log - ("y" quail-tibetan-input-tibkey) ; cha - ("u" quail-tibetan-input-tibkey) ; ja - ("i" quail-tibetan-input-tibkey) ; nya - ("I" ?$(7"f(B) ; avagraha - ("o" quail-tibetan-input-tibkey) ; ta - ("O" quail-tibetan-input-tibkey) ; Ta - ("p" quail-tibetan-input-tibkey) ; tha - ("P" quail-tibetan-input-tibkey) ; THa - ("[" quail-tibetan-input-tibkey) ; da - ("{" quail-tibetan-input-tibkey) ; Da - ("]" quail-tibetan-input-tibkey) ; na - ("}" quail-tibetan-input-tibkey) ; Na - ("a" quail-tibetan-input-tibkey) ; pa - ("A" quail-tibetan-input-tibkey) ; Vowel sign a - ("s" quail-tibetan-input-tibkey) ; pha - ("d" quail-tibetan-input-tibkey) ; ba -;;; ("D" ) ; special sign, not supported yet - ("f" quail-tibetan-input-tibkey) ; ma - ("F" quail-tibetan-input-tibkey) ; anusvara - ("g" quail-tibetan-input-tibkey) ; zhabs kyu - ("G" quail-tibetan-input-tibkey) ; gi gu - ("H" quail-tibetan-input-tibkey) ; viraama - ("j" quail-tibetan-input-tibkey) ; naro - ("J" quail-tibetan-input-tibkey) ; 'greng bu - ("k" quail-tibetan-input-tibkey);;tsa -;;; ("K" ) ; tsadru, not supported yet - ("l" quail-tibetan-input-tibkey) ; tsha - (";" quail-tibetan-input-tibkey) ; dza - (":" ?$(8"`(B) - ("'" quail-tibetan-input-tibkey) ; wa - ("\"" quail-tibetan-input-tibkey) ; wa zur - ("z" quail-tibetan-input-tibkey) ; zha - ("x" quail-tibetan-input-tibkey) ; za - ("c" quail-tibetan-input-tibkey) ; 'a - ("C" quail-tibetan-input-tibkey) ; 'a chung - ("v" quail-tibetan-input-tibkey) ; ya - ("V" quail-tibetan-input-tibkey) ; ya btags - ("b" quail-tibetan-input-tibkey) ; ra - ("B" quail-tibetan-input-tibkey) ; ra btags - ("n" quail-tibetan-input-tibkey) ; la - ("N" quail-tibetan-input-tibkey) ; la btags - ("m" quail-tibetan-input-tibkey) ; sha - ("M" quail-tibetan-input-tibkey) ; SHa - ("," quail-tibetan-input-tibkey) ; sa - ("." quail-tibetan-input-tibkey) ; ha -;;; (">" ?$(8!;(B) ; to be assigned to SPC - (">" ?\x20) - ("/" quail-tibetan-input-tibkey) ; Aa - ("?" ?$(8!=(B) - ("??" ?$(7!>(B) - ("????" tibetan-quail-bzhi-shad) - (" " ?$(8!;(B) - ;;subjoined - ("hq" quail-tibetan-input-tibkey) ; ka - ("hQ" quail-tibetan-input-tibkey) ; kSHa - ("hw" quail-tibetan-input-tibkey) ; kha - ("he" quail-tibetan-input-tibkey) ; ga - ("hr" quail-tibetan-input-tibkey) ; nga - ("ht" quail-tibetan-input-tibkey) ; ca - ("hy" quail-tibetan-input-tibkey) ; cha - ("hu" quail-tibetan-input-tibkey) ; ja - ("hi" quail-tibetan-input-tibkey) ; nya - ("ho" quail-tibetan-input-tibkey) ; ta - ("hO" quail-tibetan-input-tibkey) ; Ta - ("hp" quail-tibetan-input-tibkey) ; tha - ("hP" quail-tibetan-input-tibkey) ; THa - ("h[" quail-tibetan-input-tibkey) ; da - ("h{" quail-tibetan-input-tibkey) ; Da - ("h]" quail-tibetan-input-tibkey) ; na - ("h}" quail-tibetan-input-tibkey) ; Na - ("ha" quail-tibetan-input-tibkey) ; pa - ("hs" quail-tibetan-input-tibkey) ; pha - ("hd" quail-tibetan-input-tibkey) ; ba - ("hf" quail-tibetan-input-tibkey) ; ma - ("hk" quail-tibetan-input-tibkey) ; tsa - ("hl" quail-tibetan-input-tibkey) ; tsha - ("h;" quail-tibetan-input-tibkey) ; dza - ("h'" quail-tibetan-input-tibkey) ; wa - ("hz" quail-tibetan-input-tibkey) ; zha - ("hx" quail-tibetan-input-tibkey) ; za - ("hc" quail-tibetan-input-tibkey) ; 'a - ("hv" quail-tibetan-input-tibkey) ; ya - ("hb" quail-tibetan-input-tibkey) ; ra - ("hn" quail-tibetan-input-tibkey) ; la - ("hm" quail-tibetan-input-tibkey) ; sha - ("hM" quail-tibetan-input-tibkey) ; SHa - ("h," quail-tibetan-input-tibkey) ; sa - ("h." quail-tibetan-input-tibkey) ; ha - ("h/" quail-tibetan-input-tibkey) ; Aa - ) - -;;; quail/tibetan.el ends here. - - -
--- a/lisp/mailcrypt/ANNOUNCE Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -Mailcrypt version 3.4 is now available. - -Mailcrypt is an Emacs Lisp package which provides a simple interface -to message encryption with PGP. (You do use Emacs to handle your mail -and news, right?) - -Features: Encryption, decryption, signing, adding keys, extracting -keys, passphrase caching with timeout, multiple secret key (identity) -support, a simple but flexible interface to Cypherpunk remailers -(including chaining, response blocks, pseudonyms, and Mixmaster -support), and an automatic keyserver interface via HTTP. - -*We* think it's the best interface to these functions anywhere, but -then again, we're biased. - -The NEWS file is appended to this message. - -Obtain it from the Mailcrypt home page at - - http://cag-www.lcs.mit.edu/mailcrypt/ - -or via FTP to - - ftp://cag.lcs.mit.edu/pub/patl/ - -Enjoy! - - - Patrick J. LoPresti (patl@lcs.mit.edu) - - Jin S. Choi (jin@atype.com)
--- a/lisp/mailcrypt/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,394 +0,0 @@ -Wed Apr 24 17:59:45 1996 Steven L Baur <steve@miranova.com> - - * mailcrypt.el (mc-modes-alist): September Gnus has message-mode - for editing mail and news messages. - -Tue Oct 10 15:53:01 1995 Patrick J. LoPresti <patl@eiffel.lcs.mit.edu> - - * Version 3.4 released. - -Wed Oct 4 18:25:02 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * INSTALL: Document setting mc-pgp-comment to nil if using - obsolete version of PGP. - - * mc-remail.el (mc-parse-levien-buffer): Allow remailers with - "mix" property, even if "pgp" and "cpunk" properties are lacking. - (mc-generic-pre-encrypt-function): Don't try to - expand-mail-aliases if 'mail-abbrevs is provided. - - * mc-pgp.el (mc-pgp-always-fetch): New variable. Use to regulate - key fetching. - -Fri Sep 29 14:39:17 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-deactivate-passwd): Don't give feedback unless - called interactively. - (mc-get-fields): Use `buffer-substring-no-properties' to get the - body of the field as well as the name. Egad. - -Fri Sep 22 15:34:47 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-gnus-verify-signature): Renamed from - `mc-gnus-summary-verify-signature'. - (mc-gnus-snarf-keys): Renamed from `mc-gnus-summary-snarf-keys'. - (mc-gnus-decrypt-message): Renamed from - `mc-gnus-summary-decrypt-message'. - - * mailcrypt.el (mc-modes-alist): Add `gnus-article-mode'. - Reflect name changes to Gnus support functions. - -Wed Sep 20 09:30:53 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Bind - `case-fold-search' to nil when matching "Gnus". - - * mailcrypt.el (mc-xemacs-p): "XEmacs", not "Xemacs". - -Sat Sep 16 09:51:03 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-encrypt-region): If no recipients, just armor - file. - (mc-pgp-msg-end-line): Match optional newline at end. - (mc-pgp-encrypt-region): Don't honor mc-encrypt-for-me if only - armoring. - Output "Armoring..." if only armoring. - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Don't - bother trapping error on decrypt. - Require Gnus version 5.0.4 or higher. - Use new `gnus-group-read-only-p' predicate. - Pass t to `gnus-summary-edit-article'. - (mc-encrypt-message): Punt check for no recipients. - -Sun Sep 10 16:36:37 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-decrypt-parser): Deal with armor-only files. - - * mc-remail.el (mc-eliminate-continuation-lines): New function. - (mc-generic-pre-encrypt-function): Eliminate continuation lines in - preserved headers. - (mc-rewrite-for-mixmaster): Ditto. - -Mon Sep 4 17:57:47 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-process-region): Make sure we are in the source - buffer when starting process, in case `process-environment' is - buffer-local. - - * mc-remail.el (mc-rewrite-for-mixmaster): Signal error if - attempting to post through a Mixmaster. - -Sun Sep 3 18:09:58 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-decrypt-region): Add strategic - `save-excursion' calls to avoid changing buffers inside `let'. - -Fri Sep 1 15:05:56 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-remail.el (mc-remailer-remove-property): New function. - (mc-remailer-canonicalize-chain): Make second arg CHAINS-ALIST - optional; default to `(mc-remailer-make-chains-alist)'. - (mc-demix): New function. - - * mailcrypt.el (mc-process-region): Fix regexp to match "Process - *PGP* killed" et al. - -Thu Aug 31 12:52:44 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-encrypt-message): Clean up. Use - `mc-get-fields' and `mc-strip-addresses'. - - * mailcrypt.el (mc-strip-addresses): New function. Use everywhere. - - * mc-remail.el (mc-remailer-choose-first): New function. - (mc-remailer-choose-chain): New function. - (mc-parse-levien-buffer): Add support for returning a "ranking" of - remailers. - (mc-remailer-canonicalize-elmt): Add support for using an integer - N in a remailer-list to represent the top N remailers, shuffled - randomly. - (mc-strip-address): New function. Use everywhere. - - * mc-toplev.el (mc-vm-decrypt-message): Bind `this-command' to - `vm-edit-message-end' to trick VM into doing the right thing when - redisplaying. - -Sun Aug 27 13:12:22 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-sign-generic): Only run hooks if signing was - successful. - -Sat Aug 26 09:18:51 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-vm-decrypt-message): Bind `vm-frame-per-edit' - to nil. - -Fri Aug 25 17:41:28 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-sign-generic): Return result of signing - message, instead of always returning nil. - -Mon Aug 21 11:58:07 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-modes-alist): Add support for - `vm-virutal-mode'. - -Sun Aug 20 15:19:52 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * Makefile.in (install): Use a loop for installing .elc files, - since install-sh can't copy multiple files at once. - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Back out 8/4 - change; call `gnus-summary-edit-article-postpone' instead. - Call `gnus-version' function instead of reading variable. - -Fri Aug 4 11:51:37 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Run - `gnus-article-display-hook' after decrypting. - -Wed Aug 2 10:05:06 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-split): Use \\' instead of $ to match end of - string. - -Tue Aug 1 15:55:47 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * Version 3.3 released. - -Mon Jul 31 11:22:23 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-rmail-decrypt-message): Use abstractions for - keymaps to work with XEmacs. - (mc-gnus-summary-decrypt-message): Clean up. - (mc-gnus-summary-verify-signature): Don't display all headers. - (mc-gnus-summary-snarf-keys): Ditto. - -Sat Jul 29 11:47:51 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-decrypt-region): Call `undo-boundary'. - -Thu Jul 27 20:56:41 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * load-path.hack: Give a friendly warning if a version of Emacs - other than 19 is used to byte-compile. - -Thu Jul 27 16:05:13 1995 Patrick J. LoPresti <patl@eiffel.lcs.mit.edu> - - * configure.in: Use `EMACS19' instead of `EMACS' for autoconf - substitution variable, lest "configure" get confused when run - under an Emacs shell. - - * Makefile.in: Ditto. - -Thu Jul 27 10:24:47 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-keyserver-address): Use "pgp.ai.mit.edu" - instead of "www-swiss.ai.mit.edu". - - * ANNOUNCE: Update version and date in preparation for 3.3 - release. - - * INSTALL: Updated to reflect new installation directory and - absolute requirement of `easymenu'. - - * mailcrypt.el (mc-process-region): Fix parenthesization error. - Again. - -Wed Jul 26 12:48:50 1995 Patrick J. LoPresti <patl@eiffel.lcs.mit.edu> - - * mc-remail.el (mc-rewrite-for-remailer): Use `mc-encrypt-for-me' - instead of `mc-encrypt-to-me', since there the latter does not - exist. - -Sun Jul 23 13:01:47 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-decrypt-region): Clean up case where key is - missing and we offer to fetch it. - -Thu Jul 20 11:51:06 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-newkey-re): Incorporate fix from Mike Long to - only recognize key additions. - -Wed Jul 19 10:50:55 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el: Deal with unbound buffer-substring-no-properties - to work with Emacs 19.28 after all. - - * mc-pgp.el (mc-pgp-verify-region): Return nil if signature fails - to verify. - - * mc-toplev.el (mc-sign-generic): Make sure start and end are - markers before calling mc-pre-signature-hook. - (mc-encrypt-generic): Ditto, mc-pre-encryption-hook. - - * mc-remail.el (mc-remailer-insert-response-block): Fix - parenthesization error. - - * mc-toplev.el (mc-gnus-summary-decrypt-message): Incorporate Fran - Litterio's changes for (ding) GNUS. - Clean up MH-E stuff a bit. Should really redo it entirely at some - point. - - * texi2html.ext: New file. - -Tue Jul 18 14:26:00 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * Fix stuff all over to silence byte compilation warnings under - XEmacs. - - * mailcrypt.el: (require 'easymenu) outright. Starting now we - demand at least FSF Emacs 19.28 or XEmacs 19.13. - -Mon Jul 17 16:30:43 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * Makefile.in: Minor tweaks. Use `.../share/emacs/site-lisp'. - -Sun Jul 16 13:48:06 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el: Use "buffer-substring-no-properties" everywhere. Feh. - mc-remail.el: Ditto. - -Sat Jul 15 01:41:18 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el: Add "+language=en" to PGP command lines so that we - are sure to parse the output correctly. - -Wed Jul 12 16:37:37 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-vm-verify-signature): Call vm-widen-page in - case vm-honor-page-delimiters is set. - (mc-vm-snarf-keys): Ditto. - ('mail-utils): Required for mail-fetch-field on some Emacsen. - -Fri Jun 30 10:20:52 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-remail.el (mc-rewrite-news-to-mail): Nuke "Newsgroups" field. - -Fri Jun 23 11:04:54 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * Version 3.2 released. - - * mc-pgp.el (mc-pgp-fetch-key): Add "+batchmode" to PGP arglist. - (mc-pgp-key-begin-line): Allow match only when delimiter string - is the entire line. - (mc-pgp-key-end-line): Likewise. - - * configure.in: New file. - configure: New file. - Makefile.in: New file. Brought into conformance with GNU - standards. - INSTALL: Revised to reflect `autoconf'-generated configuration - scheme. - - * mailcrypt.el (mc-deactivate-passwd, mc-activate-passwd): Do the - right thing if both `timer' and `itimer' are present. - -Thu Jun 22 16:57:49 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-generic-parser): Include '\n' from final - delimiter line. - -Wed Jun 21 18:13:10 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-fetch-key): Give a diagnostic if the key was - not found. - -Tue Jun 20 00:53:51 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-toplev.el (mc-rmail-view-quit): Mark buffer unmodified when - quitting. - - * mailcrypt.el (mc-process-region): Don't rely on - accept-process-output returning immediately if process is dead - (for XEmacs' sake). - - * README: Revised (i.e., truncated) to reflect INSTALL file, - Texinfo docs, and Web pages. - - * INSTALL: New file. - - * Makefile: New file. - -Mon Jun 19 16:55:39 1995 Patrick J. LoPresti <patl@catfish.lcs.mit.edu> - - * NEWS: New file. - - * mailcrypt.texi: New file. Spent last few days getting this - written and the Web pages up. - -Fri Jun 16 17:55:14 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el (mc-pgp-comment): New variable. - -Thu Jun 15 00:33:44 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mc-pgp.el: New file. - - * mc-toplev.el: New file. - -Wed Jun 14 16:51:00 1995 Patrick J. LoPresti <patl@catfish.lcs.mit.edu> - - * mailcrypt.el (mc-pgp-fetch-from-keyrings): New function. - (mc-pgp-fetch-keyring-list): New variable. - Forgot to document most of the changes in the past week, oh well. - (mc-scheme-pgp): New function to replace variable of same name in - preparation for putting PGP support into its own file. - -Thu Jun 8 13:16:50 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-pgp-fetch-finger): New function. - (mc-pgp-fetch-http): New function. - (mc-pgp-fetch-key): New function. - -Thu Jun 1 20:09:21 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-encrypt-generic): Only use Email addresses in - default-recipients. - (mc-pgp-generic-parser): Fix parenthesis error causing non-nil - return on bad passphrase. Fix regular expression for bad - passphrase. - -Thu May 11 19:32:19 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-pgp-display-snarf-output): New variable, - defaults to nil. If t, pop up a window to display the output of - key snarfing. - - * mc-remail.el (mc-nuke-field): Do not clobber markers. (This is - the wrong place to do it anyway.) - (mc-rewrite-for-remailer): Eliminate "Comment" and "From" headers - after encryption. - -Tue May 9 15:58:53 1995 Patrick J. LoPresti <patl@eiffel.lcs.mit.edu> - - * mailcrypt.el (mc-modes-alist): Fix typos for mh-folder-mode and - gnus-summary-mode. - (mc-sign-message): Fix parenthesization error in let. - -Mon May 8 22:27:20 1995 Patrick J. LoPresti <patl@skyclad.lcs.mit.edu> - - * mailcrypt.el (mc-encrypt-region): New interactive function. - Encrypts the current region by calling the appropriate function as - determined by mc-modes-alist. - (mc-encrypt-generic): New function; bottom level of - scheme-independent encryption routines. - (mc-encrypt-message): Rewritten to call mc-encrypt-generic. - (mc-encrypt): Rewritten to just call mc-encrypt-region. - Upshot of all this is to allow encryption in arbitrary buffers, - not just message buffers. - (mc-sign-region): New interactive function. - (mc-sign-generic): New function; bottom level of - scheme-independent signing routines. - (mc-sign-message): Rewritten to call mc-sign-generic. - (mc-sign): Rewritten to just call mc-sign-region. - Upshot of all this is to allow signing in arbitrary buffers, not - just message buffers. - -Mon May 8 16:02:45 1995 Patrick J. LoPresti <patl@eiffel.lcs.mit.edu> - - * mailcrypt.el (mc-always-replace): Add 'never option. - (mc-message): Remove "is-err" argument. - Only deactivate passphrase on "Bad passphrase" error.
--- a/lisp/mailcrypt/NEWS Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -Noteworthy changes in Mailcrypt version 3.4: - -Several bug fixes, mostly in the remailer functions. - -`C-c / d' can now decode armor-only messages. - -`C-c / e' with an empty recipient list now generates an armor-only -message. - -Better support for Gnus 5 (formerly "(ding) Gnus"), including -decryption of messages in read-only groups. Requires Gnus 5.0.4 or -higher. - -Better support for recent versions (5.95+) of VM. - -New option for remailer list entries: Positive integer N represents a -random permutation of the N "best" remailers as ordered in -`~/.remailers'. - -New configuration variable `mc-pgp-always-fetch' to control attempts -to fetch PGP keys. Legal values are t, 'never, and nil (the default). - - -Noteworthy changes in Mailcrypt version 3.3: - -Numerous minor bugs have been fixed. - -Mailcrypt now requires at least FSF Emacs version 19.28 or XEmacs -version 19.12. Sorry, but anything else is too annoying. - -Support has been added for reading mail under (ding) Gnus. - - -Noteworthy changes in Mailcrypt version 3.2: - -Mailcrypt now uses "start-process" instead of "call-process-region" to -run PGP; this uses a pipe instead of a temp file for various inputs, -including your passphrase. Ahem. - -All Mailcrypt commands now start with the prefix `C-c /' to bring -Mailcrypt into line with documented GNU standards. - -`mc-insert-public-key' is now bound to `C-c / x' (an in "extract") -instead of `C-c a'. - -`mc-deactivate-passwd' is bound to `C-c / f' (as in "forget"). - -`mc-read-mode' and `mc-write-mode' are now full-blown minor modes. So -you can do, for example, `M-x mc-install-write-mode' from a Text mode -buffer and have the normal encryption and signing commands available. -The keymaps for the modes are configurable variables. - -Interactive commands `mc-encrypt-region', `mc-sign-region', etc. are -now defined. - -If you use RMAIL and you say no to "Replace encrypted message with -decrypted?", you will be dropped into RMAIL mode for viewing. - -RMAIL summary mode is now supported. - -Documentation in the form of a Texinfo file is now part of the -distribution. - -Mailcrypt can now fetch a needed key from finger, HTTP, or any of a -list of locally stored keyrings. `C-c / k' initiates a fetch -manually; Mailcrypt will offer to initiate one automatically as -appropriate during encryption or signature verification. - -The remailer functions now support Mixmaster. - -`C-c / d' can handle conventionally encrypted messages.
--- a/lisp/mailcrypt/ONEWS Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -;;{{{ Change Log -;;{{{ Changes from 3.0: -;; * Generate a warning if some public keys are found while others -;; are not during encryption. -;; * Rewrite calls like (message msg) to (message "%s" msg), in case -;; msg includes a "%". -;; * Handle case in mc-pgp-decrypt-region when signature verifies, but -;; key has not been certified. -;; * Put save-excursion around each top-level function. -;; * Handle case in mc-pgp-decrypt-region when signature fails to verify -;; because you don't have the necessary public key. -;; * Locally bind mc-encrypt-for-me to nil before encrypting in -;; mc-remail. -;; * Include "+encrypttoself=off" in PGP command line flags. -;; * Include "+verbose=1" in PGP command line flags (finally). -;; * Hacked mc-rmail-verify-signature to make sure rmailkwd is loaded -;; before message is verified. -;; * (require 'gnus) when compiling. Thanks to Peter Arius -;; <arius@immd2.informatik.uni-erlangen.de> -;;}}} -;;{{{ Changes from 2.0: -;; * C-u to mc-encrypt-message now prompts for an ID to use -;; for signing. C-u C-u also prompts for scheme to use. -;; * Signing now uses the From line (pseudonym) to choose key. -;; * Support for multiple secret keys added. Many internal interfaces -;; changed. -;; * autoload remailer support for mc-remail.el and set default keybindings. -;; * mc-pgp-always-sign now has a 'never option. -;; * mc-pgp-encrypt-region returns t on success. -;; * Added mc-vm-snarf-keys, from Joe Reinhardt -;; <jmr@everest.radiology.uiowa.edu>. -;; * Changed mc-snarf-keys to actually snarf all keys in the buffer instead -;; of just the first one. -;; * In VM, not replacing a message puts the message into its own VM buffer -;; so you can reply to it, forward it, etc. Thanks to Pat Lopresti -;; <patl@lcs.mit.edu> for the suggestion. -;; * Abort edit mode in VM and RMAIL decrypt functions if no encrypted -;; message was found. -;; * Added version string. -;; * Applied some new patches from stig adding autoloads and minor additions. -;; * Made check for window-system generic, and only for emacs versions > 19. -;; * Added option to mc-sign-message to disable clearsig when signing messages. -;; From Stig <stig@hackvan.com>. -;; * Fixed extra comma bug when offering default recipients to encrypt for. -;;}}} -;;{{{ Changes from 1.6: -;; * Decrypting a signed message in RMAIL adds a verified tag to the message. -;; * mc-sign-message takes an optional argument specifying which key to use, -;; for people who have multiple private keys. -;; * Added mc-{pre,post}-{de,en}cryption-hooks. -;; * Additions to docstrings of the major functions and `mailcrypt-*' aliases -;; for the same. -;; * Added cleanup for possible temp files left over if a process was -;; interrupted. -;; * Easier installation instructions. -;; * Lots of little bug fixes from all over. Too many to list -;; individual credits, but I've tried to include all of them. Thanks -;; to all who sent them in, especially to John T Kohl who fixed an -;; especially trying problem. -;; * Another optional argument to mc-insert-public-key that allows the -;; user to specify which public key to insert when called with a -;; prefix argument. -;; * Tons of changes from Paul Furnanz <paul_furnanz@rainbow.mentorg.com>: -;; 1) Use the itimer package instead of the timer package if it exists. -;; This makes the password deactivation code work for Lemacs as well -;; as emacs 19. -;; 2) Fractured the code, so that there is a single function to use -;; when calling the encryption program. The new function is -;; mc-process-region. The function copies all data to a temporary -;; buffer, and does the work there. This way if you do an undo after -;; an encryption or signing, your password is not visible on the -;; screen. -;; 3) All process output goes to the *MailCrypt* buffer. No longer use -;; a separate buffer for decryption, encryption, verification, ... -;; This allows the user to always look at the *MailCrypt* buffer to -;; see what pgp or ripem said. -;; 4) No longer call mc-temp-display. Use display-buffer if there is a -;; reason to show the buffer (like an error occured). -;; 5) Try to print more useful messages. -;; 6) If an error occurs on encryption, the message is left unchanged. -;; No reason to undo. -;;}}} -;;{{{ Changes from 1.5: -;; * Changed mc-temp-display to just dump into a temp buffer, without -;; any fancy display stuff. Pick up show-temp.el if you liked the -;; display stuff (or uncomment the old mc-temp-buffer and remove the -;; new version). -;; * Provided a generic read mode function to call in hooks, like the -;; generic write mode function that was already there. -;; * Fixed bug in regexp that prevented compilation under recent -;; versions of FSF emacs. -;; * Narrow to headers when extracting default recipients for encryption -;; to avoid pulling in recipients of included messages. -;; * Use `fillarray' to overwrite passwords with nulls before deactivation -;; for increased security. -;; * Load mail-extr.el to get mail-extract-address-components defined. -;; Thanks to Kevin Rodgers <kevin@traffic.den.mmc.com> for the following -;; improvements. -;; * Quoted an unquoted lambda expression that prevented optimized -;; compilation under emacs 18. -;; * Used `nconc' instead of `append' in various places to save on -;; garbage collection. -;; * Modified mc-split to run more efficiently. -;;}}} -;;{{{ Changes from 1.4: -;; * Call mail-extract-address-components on the recipients if we guessed -;; them from the header fields. -;; * If you don't replace a message with its decrypted version, it will now -;; pop you into a view buffer with the contents of the message. -;; * Added support for mh-e, contributed by Fritz Knabe <Fritz.Knabe@ecrc.de> -;; * Fixed bug in snarfing keys from menubar under GNUS. -;; * Fixed RIPEM verification problem, thanks to Sergey Gleizer -;; <sgleizer@cs.nmsu.edu>. -;;}}} -;;{{{ Changes from 1.3: -;; * Temp display function does not barf on F-keys or mouse events. -;; Thanks to Jonathan Stigelman <stig@key.amdahl.com> -;; * Lucid emacs menu support provided by William Perry <wmperry@indiana.edu> -;; * Cited signed messages would interfere with signature -;; verification; fixed. -;;}}} -;;{{{ Changes from 1.2: -;; * Added menu bar support for emacs 19. -;; * Added GNUS support thanks to Samuel Druker <samuel@telmar.com>. -;;}}} -;;{{{ Changes from 1.1: -;; * Added recipients field to mc-encrypt-message. -;;}}} -;;{{{ Changes from 1.0: -;; * Fixed batchmode bug in decryption, where unsigned messages would return -;; with exit code of 1. -;;}}} -;;{{{ Changes from 0.3b: -;; * Only set PGPPASSFD when needed, so PGP won't break when used -;; in shell mode. -;; * Use call-process-region instead of shell-command-on-region in order -;; to detect exit codes. -;; * Changed mc-temp-display to not use the kill ring. -;; * Bug fixes. -;;}}} -;;{{{ Changes from 0.2b: -;; * Prompts for replacement in mc-rmail-decrypt-message. -;; * Bug fixes. -;;}}} -;;{{{ Changes from 0.1b: -;; * Several bug fixes. -;; Contributed by Jason Merrill <jason@cygnus.com>: -;; * VM mailreader support -;; * Support for addresses with spaces and <>'s in them -;; * Support for using an explicit path for the pgp executable -;; * Key management functions -;; * The ability to avoid some of the prompts when encrypting -;; * Assumes mc-default-scheme unless prefixed -;;}}} - -;;}}}
--- a/lisp/mailcrypt/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -Mailcrypt is an Emacs lisp package which provides a simple interface -to cryptographic functions with PGP. It was written by Patrick -LoPresti (patl@lcs.mit.edu) and Jin Choi (jin@atype.com). - -The latest version of Mailcrypt is always (?) available through the -Mailcrypt home page at `http://cag-www.lcs.mit.edu/mailcrypt/'. An -FTP mirror is at `ftp://cag.lcs.mit.edu/pub/patl/'. - -To install the Mailcrypt package on your system, follow the directions -in the file `INSTALL'. - -To hook Mailcrypt into your mail and news browsers, follow the -directions in the "Installation" section of the Mailcrypt manual. If -you don't know how to use the Emacs Info browser, you should learn; -type `C-h i' and poke around. You can read the Info version of the -Mailcrypt manual by doing `C-u C-h i' on the file `mailcrypt.info'. - -Or read the HTML version of the manual which is directly accessible -from the Mailcrypt home page. - -To automatically be informed of improvements to Mailcrypt, add -yourself to the (very low volume) Mailcrypt announcement list. Send -Email to mc-announce-request@cag.lcs.mit.edu with a request to be -added. - -Send all bug reports and comments to the authors. And most of all, -enjoy! - - - Patrick LoPresti (patl@lcs.mit.edu) and Jin Choi (jin@atype.com) - Thu Jun 22 19:58:35 1995
--- a/lisp/mailcrypt/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'mailcrypt-autoloads) (error "Already loaded")) - -;;;### (autoloads (mc-deactivate-passwd mc-install-write-mode mc-install-read-mode) "mailcrypt" "mailcrypt/mailcrypt.el") - -(autoload 'mc-install-read-mode "mailcrypt" nil t nil) - -(autoload 'mc-install-write-mode "mailcrypt" nil t nil) - -(autoload 'mc-deactivate-passwd "mailcrypt" "\ -*Deactivate the passphrase cache." t nil) - -;;;*** - -;;;### (autoloads (mc-pgp-fetch-key mc-scheme-pgp) "mc-pgp" "mailcrypt/mc-pgp.el") - -(autoload 'mc-scheme-pgp "mc-pgp" nil nil nil) - -(autoload 'mc-pgp-fetch-key "mc-pgp" "\ -Attempt to fetch a key for addition to PGP keyring. Interactively, -prompt for string matching key to fetch. - -Non-interactively, ID must be a pair. The CAR must be a bare Email -address and the CDR a keyID (with \"0x\" prefix). Either, but not -both, may be nil. - -Return t if we think we were successful; nil otherwise. Note that nil -is not necessarily an error, since we may have merely fired off an Email -request for the key." t nil) - -;;;*** - -;;;### (autoloads (mc-remailer-insert-response-block mc-remailer-encrypt-for-chain mc-remailer-insert-pseudonym) "mc-remail" "mailcrypt/mc-remail.el") - -(autoload 'mc-remailer-insert-pseudonym "mc-remail" "\ -Insert pseudonym as a From field in the hash-mark header. - -See the documentation for the variable `mc-remailer-pseudonyms' for -more information." t nil) - -(autoload 'mc-remailer-encrypt-for-chain "mc-remail" "\ -Encrypt message for a remailer chain, prompting for chain to use. - -With \\[universal-argument], pause before each encryption." t nil) - -(autoload 'mc-remailer-insert-response-block "mc-remail" "\ -Insert response block at point, prompting for chain to use. - -With \\[universal-argument], enter a recursive edit of the innermost -layer of the block before encrypting it." t nil) - -;;;*** - -;;;### (autoloads (mc-mh-snarf-keys mc-mh-verify-signature mc-mh-decrypt-message mc-gnus-decrypt-message mc-gnus-snarf-keys mc-gnus-verify-signature mc-vm-snarf-keys mc-vm-decrypt-message mc-vm-verify-signature mc-rmail-decrypt-message mc-rmail-verify-signature mc-rmail-summary-snarf-keys mc-rmail-summary-decrypt-message mc-rmail-summary-verify-signature mc-snarf-keys mc-snarf mc-insert-public-key mc-verify-signature mc-verify mc-sign-message mc-sign mc-decrypt-message mc-decrypt mc-encrypt-message mc-encrypt mc-cleanup-recipient-headers) "mc-toplev" "mailcrypt/mc-toplev.el") - -(autoload 'mc-cleanup-recipient-headers "mc-toplev" nil nil nil) - -(autoload 'mc-encrypt "mc-toplev" "\ -*Encrypt the current buffer. - -Exact behavior depends on current major mode. - -With \\[universal-argument], prompt for User ID to sign as. - -With \\[universal-argument] \\[universal-argument], prompt for encryption scheme to use." t nil) - -(autoload 'mc-encrypt-message "mc-toplev" "\ -*Encrypt a message for RECIPIENTS using the given encryption SCHEME. -RECIPIENTS is a comma separated string. If SCHEME is nil, use the value -of `mc-default-scheme'. Returns t on success, nil otherwise." nil nil) - -(autoload 'mc-decrypt "mc-toplev" "\ -*Decrypt a message in the current buffer. - -Exact behavior depends on current major mode." t nil) - -(autoload 'mc-decrypt-message "mc-toplev" "\ -Decrypt whatever message is in the current buffer. -Returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if the encryption -succeeded and VERIFIED is t if it had a valid signature." nil nil) - -(autoload 'mc-sign "mc-toplev" "\ -*Sign a message in the current buffer. - -Exact behavior depends on current major mode. - -With one prefix arg, prompts for private key to use, with two prefix args, -also prompts for encryption scheme to use. With negative prefix arg, -inhibits clearsigning (pgp)." t nil) - -(autoload 'mc-sign-message "mc-toplev" "\ -Clear sign the message." nil nil) - -(autoload 'mc-verify "mc-toplev" "\ -*Verify a message in the current buffer. - -Exact behavior depends on current major mode." t nil) - -(autoload 'mc-verify-signature "mc-toplev" "\ -*Verify the signature of the signed message in the current buffer. -Show the result as a message in the minibuffer. Returns t if the signature -is verified." nil nil) - -(autoload 'mc-insert-public-key "mc-toplev" "\ -*Insert your public key at point. -With one prefix arg, prompts for user id to use. With two prefix -args, prompts for encryption scheme." t nil) - -(autoload 'mc-snarf "mc-toplev" "\ -*Add all public keys in the buffer to your keyring. - -Exact behavior depends on current major mode." t nil) - -(autoload 'mc-snarf-keys "mc-toplev" "\ -*Add all public keys in the buffer to your keyring." t nil) - -(autoload 'mc-rmail-summary-verify-signature "mc-toplev" "\ -*Verify the signature in the current message." t nil) - -(autoload 'mc-rmail-summary-decrypt-message "mc-toplev" "\ -*Decrypt the contents of this message" t nil) - -(autoload 'mc-rmail-summary-snarf-keys "mc-toplev" "\ -*Adds keys from current message to public key ring" t nil) - -(autoload 'mc-rmail-verify-signature "mc-toplev" "\ -*Verify the signature in the current message." t nil) - -(autoload 'mc-rmail-decrypt-message "mc-toplev" "\ -*Decrypt the contents of this message" t nil) - -(autoload 'mc-vm-verify-signature "mc-toplev" "\ -*Verify the signature in the current VM message" t nil) - -(autoload 'mc-vm-decrypt-message "mc-toplev" "\ -*Decrypt the contents of the current VM message" t nil) - -(autoload 'mc-vm-snarf-keys "mc-toplev" "\ -*Snarf public key from the contents of the current VM message" t nil) - -(autoload 'mc-gnus-verify-signature "mc-toplev" nil t nil) - -(autoload 'mc-gnus-snarf-keys "mc-toplev" nil t nil) - -(autoload 'mc-gnus-decrypt-message "mc-toplev" nil t nil) - -(autoload 'mc-mh-decrypt-message "mc-toplev" "\ -Decrypt the contents of the current MH message in the show buffer." t nil) - -(autoload 'mc-mh-verify-signature "mc-toplev" "\ -*Verify the signature in the current MH message." t nil) - -(autoload 'mc-mh-snarf-keys "mc-toplev" nil t nil) - -;;;*** - -(provide 'mailcrypt-autoloads)
--- a/lisp/mailcrypt/mailcrypt.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,537 +0,0 @@ -;; mailcrypt.el v3.4, mail encryption with PGP -;; Copyright (C) 1995 Jin Choi <jin@atype.com> -;; Patrick LoPresti <patl@lcs.mit.edu> -;; Any comments or suggestions welcome. -;; Inspired by pgp.el, by Gray Watson <gray@antaire.com>. - -;;{{{ Licensing -;; This file is intended to be used with GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;}}} - -;;{{{ Load some required packages - -(eval-when-compile - ;; Quiet warnings - (autoload 'start-itimer "itimer") - (autoload 'cancel-itimer "itimer") - (autoload 'delete-itimer "itimer")) - -(require 'easymenu) -(require 'comint) - -(eval-and-compile - (condition-case nil (require 'itimer) (error nil)) - (if (not (featurep 'itimer)) - (condition-case nil (require 'timer) (error nil))) - - (if (not (fboundp 'buffer-substring-no-properties)) - (fset 'buffer-substring-no-properties 'buffer-substring))) - -(defconst mc-xemacs-p (string-match "XEmacs" emacs-version)) - -(if (not mc-xemacs-p) - (progn - (autoload 'mc-decrypt "mc-toplev" nil t) - (autoload 'mc-verify "mc-toplev" nil t) - (autoload 'mc-snarf "mc-toplev" nil t) - (autoload 'mc-pgp-fetch-key "mc-pgp" nil t) - (autoload 'mc-encrypt "mc-toplev" nil t) - (autoload 'mc-sign "mc-toplev" nil t) - (autoload 'mc-insert-public-key "mc-toplev" nil t) - (autoload 'mc-remailer-encrypt-for-chain "mc-remail" nil t) - (autoload 'mc-remailer-insert-response-block "mc-remail" nil t) - (autoload 'mc-remailer-insert-pseudonym "mc-remail" nil t))) - -;;}}} - -;;{{{ Minor mode variables and functions - -(defvar mc-read-mode nil - "Non-nil means Mailcrypt read mode key bindings are available.") - -(defvar mc-write-mode nil - "Non-nil means Mailcrypt write mode key bindings are available.") - -(make-variable-buffer-local 'mc-read-mode) -(make-variable-buffer-local 'mc-write-mode) - -(defvar mc-read-mode-string " MC-r" - "*String to put in mode line when Mailcrypt read mode is active.") - -(defvar mc-write-mode-string " MC-w" - "*String to put in mode line when Mailcrypt write mode is active.") - -(defvar mc-read-mode-map nil - "Keymap for Mailcrypt read mode bindings.") - -(defvar mc-write-mode-map nil - "Keymap for Mailcrypt write mode bindings.") - -(or mc-read-mode-map - (progn - (setq mc-read-mode-map (make-sparse-keymap)) - (define-key mc-read-mode-map "\C-c/f" 'mc-deactivate-passwd) - (define-key mc-read-mode-map "\C-c/d" 'mc-decrypt) - (define-key mc-read-mode-map "\C-c/v" 'mc-verify) - (define-key mc-read-mode-map "\C-c/a" 'mc-snarf) - (define-key mc-read-mode-map "\C-c/k" 'mc-pgp-fetch-key))) - -(or mc-write-mode-map - (progn - (setq mc-write-mode-map (make-sparse-keymap)) - (define-key mc-write-mode-map "\C-c/f" 'mc-deactivate-passwd) - (define-key mc-write-mode-map "\C-c/e" 'mc-encrypt) - (define-key mc-write-mode-map "\C-c/s" 'mc-sign) - (define-key mc-write-mode-map "\C-c/x" 'mc-insert-public-key) - (define-key mc-write-mode-map "\C-c/k" 'mc-pgp-fetch-key) - (define-key mc-write-mode-map "\C-c/r" - 'mc-remailer-encrypt-for-chain) - (define-key mc-write-mode-map "\C-c/b" - 'mc-remailer-insert-response-block) - (define-key mc-write-mode-map "\C-c/p" - 'mc-remailer-insert-pseudonym))) - -(easy-menu-define - mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map)) - "Mailcrypt read mode menu." - '("Mailcrypt" - ["Decrypt Message" mc-decrypt t] - ["Verify Signature" mc-verify t] - ["Snarf Keys" mc-snarf t] - ["Fetch Key" mc-pgp-fetch-key t] - ["Forget Passphrase(s)" mc-deactivate-passwd t])) - -(easy-menu-define - mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map)) - "Mailcrypt write mode menu." - '("Mailcrypt" - ["Encrypt Message" mc-encrypt t] - ["Sign Message" mc-sign t] - ["Insert Public Key" mc-insert-public-key t] - ["Fetch Key" mc-pgp-fetch-key t] - ["Encrypt for Remailer(s)" mc-remailer-encrypt-for-chain t] - ["Insert Pseudonym" mc-remailer-insert-pseudonym t] - ["Insert Response Block" mc-remailer-insert-response-block t] - ["Forget Passphrase(s)" mc-deactivate-passwd t])) - -(or (assq 'mc-read-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'mc-read-mode mc-read-mode-map) - minor-mode-map-alist))) - -(or (assq 'mc-write-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'mc-write-mode mc-write-mode-map) - minor-mode-map-alist))) - -(or (assq 'mc-read-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(mc-read-mode mc-read-mode-string) minor-mode-alist))) - -(or (assq 'mc-write-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(mc-write-mode mc-write-mode-string) minor-mode-alist))) - -(defun mc-read-mode (&optional arg) - "\nMinor mode for interfacing with cryptographic functions. -\\<mc-read-mode-map> -\\[mc-decrypt]\t\tDecrypt an encrypted message -\\[mc-verify]\t\tVerify signature on a clearsigned message -\\[mc-snarf]\t\tAdd public key(s) to keyring -\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP -\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n" - (interactive) - (setq mc-read-mode - (if (null arg) (not mc-read-mode) - (> (prefix-numeric-value arg) 0))) - (and mc-read-mode mc-write-mode (mc-write-mode nil)) - (if mc-read-mode - (easy-menu-add mc-read-mode-menu) - (easy-menu-remove mc-read-mode-menu))) - -(defun mc-write-mode (&optional arg) - "\nMinor mode for interfacing with cryptographic functions. -\\<mc-write-mode-map> -\\[mc-encrypt]\t\tEncrypt (and optionally sign) message -\\[mc-sign]\t\tClearsign message -\\[mc-insert-public-key]\t\tExtract public key from keyring and insert into message -\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP -\\[mc-remailer-encrypt-for-chain]\t\tEncrypt message for remailing -\\[mc-remailer-insert-pseudonym]\t\tInsert a pseudonym (for remailing) -\\[mc-remailer-insert-response-block]\t\tInsert a response block (for remailing) -\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n" - (interactive) - (setq mc-write-mode - (if (null arg) (not mc-write-mode) - (> (prefix-numeric-value arg) 0))) - (and mc-write-mode mc-read-mode (mc-read-mode nil)) - (if mc-write-mode - (easy-menu-add mc-write-mode-menu) - (easy-menu-remove mc-write-mode-menu))) - -;;;###autoload -(defun mc-install-read-mode () - (interactive) - (mc-read-mode 1)) - -;;;###autoload -(defun mc-install-write-mode () - (interactive) - (mc-write-mode 1)) - -;;}}} - -;;{{{ Note: -;; The funny triple braces you see are used by `folding-mode', a minor -;; mode by Jamie Lokier, available from the elisp archive. -;;}}} - -;;{{{ User variables. -(defconst mc-version "3.4") -(defvar mc-default-scheme 'mc-scheme-pgp "*Default encryption scheme to use.") -(defvar mc-passwd-timeout 60 - "*Time to deactivate password in seconds after a use. -nil or 0 means deactivate immediately. If the only timer package available -is the 'timer' package, then this can be a string in timer format.") - -(defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME") - (user-full-name) "*Your RIPEM user ID.")) - -(defvar mc-always-replace nil - "*If t, decrypt mail messages in place without prompting. - -If 'never, always use a viewer instead of replacing.") - -(defvar mc-use-default-recipients nil "*Assume that the message should - be encoded for everyone listed in the To, Cc, and Bcc fields.") - -(defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with - user's public key.") - -(defvar mc-pre-signature-hook nil - "*List of hook functions to run immediately before signing.") -(defvar mc-post-signature-hook nil - "*List of hook functions to run immediately after signing.") -(defvar mc-pre-encryption-hook nil - "*List of hook functions to run immediately before encrypting.") -(defvar mc-post-encryption-hook nil - "*List of hook functions to run after encrypting.") -(defvar mc-pre-decryption-hook nil - "*List of hook functions to run immediately before decrypting.") -(defvar mc-post-decryption-hook nil - "*List of hook functions to run after decrypting.") - -(defconst mc-buffer-name "*MailCrypt*" - "Name of temporary buffer for mailcrypt") - -(defvar mc-modes-alist - '((rmail-mode (decrypt . mc-rmail-decrypt-message) - (verify . mc-rmail-verify-signature)) - (rmail-summary-mode (decrypt . mc-rmail-summary-decrypt-message) - (verify . mc-rmail-summary-verify-signature) - (snarf . mc-rmail-summary-snarf-keys)) - (vm-mode (decrypt . mc-vm-decrypt-message) - (verify . mc-vm-verify-signature) - (snarf . mc-vm-snarf-keys)) - (vm-virtual-mode (decrypt . mc-vm-decrypt-message) - (verify . mc-vm-verify-signature) - (snarf . mc-vm-snarf-keys)) - (vm-summary-mode (decrypt . mc-vm-decrypt-message) - (verify . mc-vm-verify-signature) - (snarf . mc-vm-snarf-keys)) - (mh-folder-mode (decrypt . mc-mh-decrypt-message) - (verify . mc-mh-verify-signature) - (snarf . mc-mh-snarf-keys)) - ;; September Gnus (5.2) has a new message editing mode - (message-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (gnus-summary-mode (decrypt . mc-gnus-decrypt-message) - (verify . mc-gnus-verify-signature) - (snarf . mc-gnus-snarf-keys)) - (gnus-article-mode (decrypt . mc-gnus-decrypt-message) - (verify . mc-gnus-verify-signature) - (snarf . mc-gnus-snarf-keys)) - (mail-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (vm-mail-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (mh-letter-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - (news-reply-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message))) - - "Association list (indexed by major mode) of association lists -(indexed by operation) of functions to call for each major mode.") - -;;}}} -;;{{{ Program variables and constants. - -(defvar mc-timer nil "Timer object for password deactivation.") - -(defvar mc-passwd-cache nil "Cache for passphrases.") - -(defvar mc-schemes '(("pgp" . mc-scheme-pgp))) - -;;}}} - -;;{{{ Utility functions. - -(defun mc-message-delimiter-positions (start-re end-re &optional begin) - ;; Returns pair of integers (START . END) that delimit message marked off - ;; by the regular expressions start-re and end-re. Optional argument BEGIN - ;; determines where we should start looking from. - (setq begin (or begin (point-min))) - (let (start) - (save-excursion - (goto-char begin) - (and (re-search-forward start-re nil t) - (setq start (match-beginning 0)) - (re-search-forward end-re nil t) - (cons start (point)))))) - - -(defun mc-split (regexp str) - "Splits STR into a list of elements which were separated by REGEXP, -stripping initial and trailing whitespace." - (let ((data (match-data)) - (retval '()) - beg end) - (unwind-protect - (progn - (string-match "[ \t\n]*" str) ; Will always match at 0 - (setq beg (match-end 0)) - (setq end (string-match "[ \t\n]*\\'" str)) - (while (string-match regexp str beg) - (setq retval - (cons (substring str beg (match-beginning 0)) - retval)) - (setq beg (match-end 0))) - (if (not (= (length str) beg)) ; Not end - (setq retval (cons (substring str beg end) retval))) - (nreverse retval)) - (store-match-data data)))) - -;;; FIXME - Function never called? -;(defun mc-temp-display (beg end &optional name) -; (let (tmp) -; (if (not name) -; (setq name mc-buffer-name)) -; (if (string-match name "*ERROR*") -; (progn -; (message "mailcrypt: An error occured! See *ERROR* buffer.") -; (beep))) -; (setq tmp (buffer-substring beg end)) -; (delete-region beg end) -; (save-excursion -; (save-window-excursion -; (with-output-to-temp-buffer name -; (princ tmp)))))) - -;; In case I ever decide to do this right. -(defconst mc-field-name-regexp "^\\(.+\\)") -(defconst mc-field-body-regexp "\\(.*\\(\n[ \t].*\\)*\n\\)") - -(defun mc-get-fields (&optional matching bounds nuke) - "Get all header fields within BOUNDS. Return as an -alist ((FIELD-NAME . FIELD-BODY) (FIELD-NAME . FIELD-BODY) ...). - -Argument MATCHING, if present, is a regexp which each FIELD-NAME -must match exactly. Matching is case-insensitive. - -Optional arg NUKE, if non-nil, means eliminate all fields returned." - (save-excursion - (save-restriction - (let ((case-fold-search t) - (header-field-regexp - (concat mc-field-name-regexp ":" mc-field-body-regexp)) - ret name body field-start field-end) - ;; Ensure exact match - (if matching - (setq matching (concat "^\\(" matching "\\)$"))) - - (if bounds - (narrow-to-region (car bounds) (cdr bounds))) - - (goto-char (point-max)) - - (while (re-search-backward header-field-regexp nil 'move) - (setq field-start (match-beginning 0)) - (setq field-end (match-end 0)) - (setq name (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (setq body (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (if (or (null matching) (string-match matching name)) - (progn - (setq ret (cons (cons name body) ret)) - (if nuke - (delete-region field-start field-end))))) - ret)))) - -(defsubst mc-strip-address (addr) - "Strip everything from ADDR except the basic Email address." - (car (cdr (mail-extract-address-components addr)))) - -(defun mc-strip-addresses (addr-list) - "Strip everything from the addresses in ADDR-LIST except the basic -Email address. ADDR-LIST may be a single string or a list of strings." - (if (not (listp addr-list)) (setq addr-list (list addr-list))) - (setq addr-list - (mapcar - (function (lambda (s) (mc-split "\\([ \t\n]*,[ \t\n]*\\)" s))) - addr-list)) - (setq addr-list (apply 'append addr-list)) - (mapconcat 'mc-strip-address addr-list ", ")) - -(defun mc-display-buffer (buffer) - "Like display-buffer, but always display top of the buffer." - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (display-buffer buffer))) - -(defun mc-message (msg &optional buffer default) - ;; returns t if we used msg, nil if we used default - (let ((retval t)) - (if buffer - (setq msg - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward msg nil t) - (buffer-substring-no-properties - (match-beginning 0) (match-end 0)) - (setq retval nil) - default)))) - (if msg (message "%s" msg)) - retval)) - -(defun mc-process-region (beg end passwd program args parser &optional buffer) - (let ((obuf (current-buffer)) - (process-connection-type nil) - mybuf result rgn proc) - (unwind-protect - (progn - (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp"))) - (set-buffer mybuf) - (erase-buffer) - (set-buffer obuf) - (buffer-disable-undo mybuf) - (setq proc - (apply 'start-process "*PGP*" mybuf program args)) - (if passwd - (progn - (process-send-string proc (concat passwd "\n")) - (or mc-passwd-timeout (mc-deactivate-passwd t)))) - (process-send-region proc beg end) - (process-send-eof proc) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - (setq result (process-exit-status proc)) - ;; Hack to force a status_notify() in Emacs 19.29 - (delete-process proc) - (set-buffer mybuf) - (goto-char (point-max)) - (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - ;; CRNL -> NL - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - ;; Hurm. FIXME; must get better result codes. - (if (stringp result) - (error "%s exited abnormally: '%s'" program result) - (setq rgn (funcall parser result)) - ;; If the parser found something, migrate it - (if (consp rgn) - (progn - (set-buffer obuf) - (delete-region beg end) - (goto-char beg) - (insert-buffer-substring mybuf (car rgn) (cdr rgn)) - (set-buffer mybuf) - (delete-region (car rgn) (cdr rgn))))) - ;; Return nil on failure and exit code on success - (if rgn result)) - ;; Cleanup even on nonlocal exit - (if (and proc (eq 'run (process-status proc))) - (interrupt-process proc)) - (set-buffer obuf) - (or buffer (null mybuf) (kill-buffer mybuf))))) - -;;}}} - -;;{{{ Passphrase management -(defun mc-activate-passwd (id &optional prompt) - "Activate the passphrase matching ID, using PROMPT for a prompt. -Return the passphrase. If PROMPT is nil, only return value if cached." - (cond ((featurep 'itimer) - (if mc-timer (delete-itimer mc-timer)) - (setq mc-timer (if mc-passwd-timeout - (start-itimer "mc-itimer" - 'mc-deactivate-passwd - mc-passwd-timeout) - nil))) - ((featurep 'timer) - (let ((string-time (if (integerp mc-passwd-timeout) - (format "%d sec" mc-passwd-timeout) - mc-passwd-timeout))) - (if mc-timer (cancel-timer mc-timer)) - (setq mc-timer (if string-time - (run-at-time string-time - nil 'mc-deactivate-passwd) - nil))))) - (let ((cell (assoc id mc-passwd-cache)) - passwd) - (setq passwd (cdr-safe cell)) - (if (and (not passwd) prompt) - (setq passwd (comint-read-noecho prompt))) - (if cell - (setcdr cell passwd) - (setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache))) - passwd)) - -;;;###autoload -(defun mc-deactivate-passwd (&optional inhibit-message) - "*Deactivate the passphrase cache." - (interactive) - (if mc-timer - (cond ((featurep 'itimer) (delete-itimer mc-timer)) - ((featurep 'timer) (cancel-timer mc-timer)))) - (mapcar - (function - (lambda (cell) - (if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0)) - (setcdr cell nil))) - mc-passwd-cache) - (or inhibit-message - (not (interactive-p)) - (message "Passphrase%s deactivated" - (if (> (length mc-passwd-cache) 1) "s" "")))) - -;;}}} - -;;{{{ Define several aliases so that an apropos on `mailcrypt' will -;; return something. -(defalias 'mailcrypt-encrypt 'mc-encrypt) -(defalias 'mailcrypt-decrypt 'mc-decrypt) -(defalias 'mailcrypt-sign 'mc-sign) -(defalias 'mailcrypt-verify 'mc-verify) -(defalias 'mailcrypt-insert-public-key 'mc-insert-public-key) -(defalias 'mailcrypt-snarf 'mc-snarf) -;;}}} -(provide 'mailcrypt)
--- a/lisp/mailcrypt/mc-pgp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,620 +0,0 @@ -;; mc-pgp.el, PGP support for Mailcrypt -;; Copyright (C) 1995 Jin Choi <jin@atype.com> -;; Patrick LoPresti <patl@lcs.mit.edu> - -;;{{{ Licensing -;; This file is intended to be used with GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;}}} -(require 'mailcrypt) - -(defvar mc-pgp-user-id (user-login-name) - "*PGP ID of your default identity.") -(defvar mc-pgp-always-sign nil - "*If t, always sign encrypted PGP messages, or never sign if 'never.") -(defvar mc-pgp-path "pgp" "*The PGP executable.") -(defvar mc-pgp-display-snarf-output nil - "*If t, pop up the PGP output window when snarfing keys.") -(defvar mc-pgp-alternate-keyring nil - "*Public keyring to use instead of default.") -(defvar mc-pgp-comment - (format "Processed by Mailcrypt %s, an Emacs/PGP interface" mc-version) - "*Comment field to appear in ASCII armor output. If nil, let PGP -use its default.") - -(defconst mc-pgp-msg-begin-line "-----BEGIN PGP MESSAGE-----" - "Text for start of PGP message delimiter.") -(defconst mc-pgp-msg-end-line "-----END PGP MESSAGE-----\n?" - "Text for end of PGP message delimiter.") -(defconst mc-pgp-signed-begin-line "-----BEGIN PGP SIGNED MESSAGE-----" - "Text for start of PGP signed messages.") -(defconst mc-pgp-signed-end-line "-----END PGP SIGNATURE-----" - "Text for end of PGP signed messages.") -(defconst mc-pgp-key-begin-line "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" - "Text for start of PGP public key.") -(defconst mc-pgp-key-end-line "^-----END PGP PUBLIC KEY BLOCK-----\r?$" - "Text for end of PGP public key.") -(defconst mc-pgp-error-re "^\\(ERROR:\\|WARNING:\\).*" - "Regular expression matching an error from PGP") -(defconst mc-pgp-sigok-re "^.*Good signature.*" - "Regular expression matching a PGP signature validation message") -(defconst mc-pgp-newkey-re "^[ \t]*\\(No\\|[0-9]+\\) +new [ku].*" - "Regular expression matching a PGP key snarf message") -(defconst mc-pgp-nokey-re - "Cannot find the public key matching userid '\\(.+\\)'$" - "Regular expression matching a PGP missing-key message") -(defconst mc-pgp-key-expected-re - "Key matching expected Key ID \\(\\S +\\) not found") - -(defvar mc-pgp-keydir nil - "Directory in which keyrings are stored.") - -(defun mc-get-pgp-keydir () - (if (null mc-pgp-keydir) - (let ((buffer (generate-new-buffer " *mailcrypt temp*")) - (obuf (current-buffer))) - (unwind-protect - (progn - (call-process mc-pgp-path nil buffer nil "+verbose=1" - "+language=en" "-kv" "XXXXXXXXXX") - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward "^Key ring:\\s *'\\(.*\\)'") - (setq mc-pgp-keydir - (file-name-directory - (buffer-substring-no-properties - (match-beginning 1) (match-end 1))))) - (set-buffer obuf) - (kill-buffer buffer)))) - mc-pgp-keydir) - -(defvar mc-pgp-key-cache nil - "Association list mapping PGP IDs to canonical \"keys\". A \"key\" -is a pair (USER-ID . KEY-ID) which identifies the canonical IDs of the -PGP ID.") - -(defun mc-pgp-lookup-key (str) - ;; Look up the string STR in the user's secret key ring. Return a - ;; pair of strings (USER-ID . KEY-ID) which uniquely identifies the - ;; matching key, or nil if no key matches. - (if (equal str "***** CONVENTIONAL *****") nil - (let ((keyring (concat (mc-get-pgp-keydir) "secring")) - (result (cdr-safe (assoc str mc-pgp-key-cache))) - (key-regexp - "^\\(pub\\|sec\\)\\s +[^/]+/\\(\\S *\\)\\s +\\S +\\s +\\(.*\\)$") - (obuf (current-buffer)) - buffer) - (if (null result) - (unwind-protect - (progn - (setq buffer (generate-new-buffer " *mailcrypt temp")) - (call-process mc-pgp-path nil buffer nil - "+language=en" "-kv" str keyring) - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward key-regexp nil t) - (progn - (setq result - (cons (buffer-substring-no-properties - (match-beginning 3) (match-end 3)) - (concat - "0x" - (buffer-substring-no-properties - (match-beginning 2) (match-end 2))))) - (setq mc-pgp-key-cache (cons (cons str result) - mc-pgp-key-cache))))) - (if buffer (kill-buffer buffer)) - (set-buffer obuf))) - (if (null result) - (error "No PGP secret key for %s" str)) - result))) - -(defun mc-pgp-generic-parser (result) - (let (start) - (goto-char (point-min)) - (cond ((not (eq result 0)) - (prog1 - nil - (if (mc-message "^\aError: +Bad pass phrase\\.$" (current-buffer)) - (mc-deactivate-passwd t) - (mc-message mc-pgp-error-re (current-buffer) - (format "PGP exited with status %d" result))))) - ((re-search-forward mc-pgp-nokey-re nil t) - nil) - (t - (and - (goto-char (point-min)) - (re-search-forward "-----BEGIN PGP.*-----$" nil t) - (setq start (match-beginning 0)) - (goto-char (point-max)) - (re-search-backward "^-----END PGP.*-----\n" nil t) - (cons start (match-end 0))))))) - -(defun mc-pgp-encrypt-region (recipients start end &optional id sign) - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - ;; Crock. Rewrite someday. - (mc-pgp-always-sign mc-pgp-always-sign) - (obuf (current-buffer)) - action msg args key passwd result pgp-id) - (setq args (list "+encrypttoself=off +verbose=1" "+batchmode" - "+language=en" "-fat")) - (setq action (if recipients "Encrypting" "Armoring")) - (setq msg (format "%s..." action)) ; May get overridden below - (if recipients (setq args (cons "-e" args))) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args))) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (if (and (not (eq mc-pgp-always-sign 'never)) - (or mc-pgp-always-sign sign (y-or-n-p "Sign the message? "))) - (progn - (setq mc-pgp-always-sign t) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq passwd - (mc-activate-passwd - (cdr key) - (format "PGP passphrase for %s (%s): " (car key) (cdr key)))) - (setq args - (nconc args (list "-s" "-u" (cdr key)))) - (setenv "PGPPASSFD" "0") - (setq msg (format "%s+signing as %s ..." action (car key)))) - (setq mc-pgp-always-sign 'never)) - - (or key - (setq key (mc-pgp-lookup-key mc-pgp-user-id))) - - (if (and recipients mc-encrypt-for-me) - (setq recipients (cons (cdr key) recipients))) - - (setq args (append args recipients)) - - (message "%s" msg) - (setq result (mc-process-region start end passwd mc-pgp-path args - 'mc-pgp-generic-parser buffer)) - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward mc-pgp-nokey-re nil t) - (progn - (if result (error "This should never happen.")) - (setq pgp-id (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (if (and (not (eq mc-pgp-always-fetch 'never)) - (or mc-pgp-always-fetch - (y-or-n-p - (format "Key for '%s' not found; try to fetch? " - pgp-id)))) - (progn - (mc-pgp-fetch-key (cons pgp-id nil)) - (set-buffer obuf) - (mc-pgp-encrypt-region recipients start end id)) - (mc-message mc-pgp-nokey-re buffer) - nil)) - (if (not result) - nil - (message "%s Done." msg) - t))))) - -(defun mc-pgp-decrypt-parser (result) - (goto-char (point-min)) - (cond ((eq result 0) - ;; Valid signature - (re-search-forward "^Signature made.*\n") - (if (looking-at - "\a\nWARNING: Because this public key.*\n.*\n.*\n") - (goto-char (match-end 0))) - (cons (point) (point-max))) - ((eq result 1) - (re-search-forward - "\\(\\(^File is conven.*\\)?Just a moment\\.+\\)\\|\\(^\\.\\)") - (if (eq (match-beginning 2) (match-end 2)) - (if (looking-at - "\nFile has signature.*\\(\n\a.*\n\\)*\nWARNING:.*\n") - (goto-char (match-end 0))) - (if (looking-at "Pass phrase appears good\\. \\.") - (goto-char (match-end 0)))) - (cons (point) (point-max))) - (t nil))) - -(defun mc-pgp-decrypt-region (start end &optional id) - ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if - ;; the decryption succeeded and verified is t if there was a valid signature - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - args key new-key passwd result pgp-id) - (undo-boundary) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq - passwd - (if key - (mc-activate-passwd (cdr key) - (and id - (format "PGP passphrase for %s (%s): " - (car key) (cdr key)))) - (mc-activate-passwd id "PGP passphrase for conventional decryption: "))) - (if passwd - (setenv "PGPPASSFD" "0")) - (setq args '("+verbose=1" "+batchmode" "+language=en" "-f")) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (message "Decrypting...") - (setq result - (mc-process-region - start end passwd mc-pgp-path args 'mc-pgp-decrypt-parser buffer)) - (cond - (result - (message "Decrypting... Done.") - ;; If verification failed due to missing key, offer to fetch it. - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward mc-pgp-key-expected-re nil t) - (setq pgp-id (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))))) - (if (and pgp-id - (not (eq mc-pgp-always-fetch 'never)) - (or mc-pgp-always-fetch - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id))) - (mc-pgp-fetch-key (cons nil pgp-id))) - (progn - (undo-start) - (undo-more 1) - (mc-pgp-decrypt-region start end id)) - (mc-message mc-pgp-key-expected-re buffer) - (cons t (eq result 0)))) - ;; Decryption failed; maybe we need to use a different user-id - ((save-excursion - (and - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward - "^Key for user ID:.*\n.*Key ID \\([0-9A-F]+\\)" nil t) - (setq new-key - (mc-pgp-lookup-key - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) - (not (and id (equal key new-key))))) - (mc-pgp-decrypt-region start end (cdr new-key))) - ;; Or maybe it is conventionally encrypted - ((save-excursion - (and - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward "^File is conventionally encrypted" nil t))) - (if (null key) (mc-deactivate-passwd t)) - (mc-pgp-decrypt-region start end "***** CONVENTIONAL *****")) - (t - (mc-display-buffer buffer) - (if (mc-message "^\aError: +Bad pass phrase\\.$" buffer) - (mc-deactivate-passwd t) - (mc-message mc-pgp-error-re buffer "Error decrypting buffer")) - (cons nil nil))))) - -(defun mc-pgp-sign-region (start end &optional id unclear) - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - passwd args key) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq passwd - (mc-activate-passwd - (cdr key) - (format "PGP passphrase for %s (%s): " (car key) (cdr key)))) - (setenv "PGPPASSFD" "0") - (setq args - (list - "-fast" "+verbose=1" "+language=en" - (format "+clearsig=%s" (if unclear "off" "on")) - "+batchmode" "-u" (cdr key))) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args))) - (message "Signing as %s ..." (car key)) - (if (mc-process-region start end passwd mc-pgp-path args - 'mc-pgp-generic-parser buffer) - (progn - (message "Signing as %s ... Done." (car key)) - t) - nil))) - -(defun mc-pgp-verify-parser (result) - (cond ((eq result 0) - (mc-message mc-pgp-sigok-re (current-buffer) "Good signature") - t) - ((eq result 1) - (mc-message mc-pgp-error-re (current-buffer) "Bad signature") - nil) - (t - (mc-message mc-pgp-error-re (current-buffer) - (format "PGP exited with status %d" result)) - nil))) - -(defun mc-pgp-verify-region (start end &optional no-fetch) - (let ((buffer (get-buffer-create mc-buffer-name)) - (obuf (current-buffer)) - args pgp-id) - (setq args '("+verbose=1" "+batchmode" "+language=en" "-f")) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (message "Verifying...") - (if (mc-process-region - start end nil mc-pgp-path args 'mc-pgp-verify-parser buffer) - t - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (and - (not no-fetch) - (re-search-forward mc-pgp-key-expected-re nil t) - (setq pgp-id - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))) - (not (eq mc-pgp-always-fetch 'never)) - (or mc-pgp-always-fetch - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id))) - (mc-pgp-fetch-key (cons nil pgp-id)) - (set-buffer obuf)) - (mc-pgp-verify-region start end t) - (mc-message mc-pgp-error-re buffer) - nil))))) - -(defun mc-pgp-insert-public-key (&optional id) - (let ((buffer (get-buffer-create mc-buffer-name)) - args) - (setq id (or id mc-pgp-user-id)) - (setq args (list "+verbose=1" "+batchmode" "+language=en" "-kxaf" id)) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args))) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - - (if (mc-process-region (point) (point) nil mc-pgp-path - args 'mc-pgp-generic-parser buffer) - (progn - (mc-message "Key for user ID: .*" buffer) - t)))) - -(defun mc-pgp-snarf-parser (result) - (eq result 0)) - -(defun mc-pgp-snarf-keys (start end) - ;; Returns number of keys found. - (let ((buffer (get-buffer-create mc-buffer-name)) tmpstr args) - (setq args '("+verbose=1" "+batchmode" "+language=en" "-kaf")) - (if mc-pgp-alternate-keyring - (setq args (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - (message "Snarfing...") - (if (mc-process-region start end nil mc-pgp-path args - 'mc-pgp-snarf-parser buffer) - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (if (re-search-forward mc-pgp-newkey-re nil t) - (progn - (if mc-pgp-display-snarf-output (mc-display-buffer buffer)) - (setq tmpstr (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))) - (if (equal tmpstr "No") - 0 - (car (read-from-string tmpstr)))))) - (mc-display-buffer buffer) - (mc-message mc-pgp-error-re buffer "Error snarfing PGP keys") - 0))) - -;;;###autoload -(defun mc-scheme-pgp () - (list - (cons 'encryption-func 'mc-pgp-encrypt-region) - (cons 'decryption-func 'mc-pgp-decrypt-region) - (cons 'signing-func 'mc-pgp-sign-region) - (cons 'verification-func 'mc-pgp-verify-region) - (cons 'key-insertion-func 'mc-pgp-insert-public-key) - (cons 'snarf-func 'mc-pgp-snarf-keys) - (cons 'msg-begin-line mc-pgp-msg-begin-line) - (cons 'msg-end-line mc-pgp-msg-end-line) - (cons 'signed-begin-line mc-pgp-signed-begin-line) - (cons 'signed-end-line mc-pgp-signed-end-line) - (cons 'key-begin-line mc-pgp-key-begin-line) - (cons 'key-end-line mc-pgp-key-end-line) - (cons 'user-id mc-pgp-user-id))) - -;;{{{ Key fetching - -(defvar mc-pgp-always-fetch nil - "*If t, always attempt to fetch missing keys, or never fetch if -'never.") - -(defvar mc-pgp-keyserver-url-template - "/htbin/pks-extract-key.pl?op=get&search=%s" - "The URL to pass to the keyserver.") - -(defvar mc-pgp-keyserver-address "pgp.ai.mit.edu" - "Host name of keyserver.") - -(defvar mc-pgp-keyserver-port 80 - "Port on which the keyserver's HTTP daemon lives.") - -(defvar mc-pgp-fetch-timeout 20 - "*Timeout, in seconds, for any particular key fetch operation.") - -(defvar mc-pgp-fetch-keyring-list nil - "*List of strings which are filenames of public keyrings to search -when fetching keys.") - -(defsubst mc-pgp-buffer-get-key (buf) - "Return the first key block in BUF as a string, or nil if none found." - (save-excursion - (let (start) - (set-buffer buf) - (goto-char (point-min)) - (and (re-search-forward mc-pgp-key-begin-line nil t) - (setq start (match-beginning 0)) - (re-search-forward mc-pgp-key-end-line nil t) - (buffer-substring-no-properties start (match-end 0)))))) - -(defun mc-pgp-fetch-from-keyrings (id) - (let ((keyring-list mc-pgp-fetch-keyring-list) - buf proc key) - (unwind-protect - (progn - (message "Fetching %s from keyrings..." (or (cdr id) (car id))) - (while (and (not key) keyring-list) - (setq buf (generate-new-buffer " *mailcrypt temp*")) - (setq proc - (start-process "*PGP*" buf mc-pgp-path "-kxaf" - "+verbose=0" "+batchmode" - (format "+pubring=%s" (car keyring-list)) - (or (cdr id) (car id)))) - ;; Because PGPPASSFD might be set - (process-send-string proc "\r\n") - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - (setq key (mc-pgp-buffer-get-key buf)) - (setq keyring-list (cdr keyring-list))) - key) - (if buf (kill-buffer buf)) - (if (and proc (eq 'run (process-status proc))) - (interrupt-process proc))))) - -(defun mc-pgp-fetch-from-http (id) - (let (buf connection) - (unwind-protect - (progn - (message "Fetching %s via HTTP to %s..." - (or (cdr id) (car id)) mc-pgp-keyserver-address) - (setq buf (generate-new-buffer " *mailcrypt temp*")) - (setq connection - (open-network-stream "*key fetch*" buf mc-pgp-keyserver-address - mc-pgp-keyserver-port)) - (process-send-string - connection - (concat "GET " (format mc-pgp-keyserver-url-template - (or (cdr id) (car id))) "\r\n")) - (while (and (eq 'open (process-status connection)) - (accept-process-output connection mc-pgp-fetch-timeout))) - (mc-pgp-buffer-get-key buf)) - (if buf (kill-buffer buf)) - (if connection (delete-process connection))))) - -(defun mc-pgp-fetch-from-finger (id) - (let (buf connection user host) - (unwind-protect - (and (car id) - (string-match "^\\(.+\\)@\\([^@]+\\)$" (car id)) - (progn - (message "Trying finger %s..." (car id)) - (setq user (substring (car id) - (match-beginning 1) (match-end 1))) - (setq host (substring (car id) - (match-beginning 2) (match-end 2))) - (setq buf (generate-new-buffer " *mailcrypt temp*")) - (condition-case nil - (progn - (setq connection - (open-network-stream "*key fetch*" buf host 79)) - (process-send-string connection - (concat "/W " user "\r\n")) - (while - (and (eq 'open (process-status connection)) - (accept-process-output connection - mc-pgp-fetch-timeout))) - (mc-pgp-buffer-get-key buf)) - (error nil)))) - (if buf (kill-buffer buf)) - (if connection (delete-process connection))))) - -(defvar mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings - mc-pgp-fetch-from-finger - mc-pgp-fetch-from-http) - "List of methods to try when attempting to fetch a key. Each -element is a function to call with an ID as argument. See the -documentation for the function mc-pgp-fetch-key for a description of -the ID.") - -;;;###autoload -(defun mc-pgp-fetch-key (&optional id) - "Attempt to fetch a key for addition to PGP keyring. Interactively, -prompt for string matching key to fetch. - -Non-interactively, ID must be a pair. The CAR must be a bare Email -address and the CDR a keyID (with \"0x\" prefix). Either, but not -both, may be nil. - -Return t if we think we were successful; nil otherwise. Note that nil -is not necessarily an error, since we may have merely fired off an Email -request for the key." - (interactive) - (let ((methods mc-pgp-fetch-methods) - (process-connection-type nil) key proc buf args) - (if (null id) - (setq id (cons (read-string "Fetch key for: ") nil))) - (while (and (not key) methods) - (setq key (funcall (car methods) id)) - (setq methods (cdr methods))) - (if (not (stringp key)) - (progn - (message "Key not found.") - nil) - ;; Maybe I'll do this right someday. - (unwind-protect - (save-window-excursion - (setq buf (generate-new-buffer " *PGP Key Info*")) - (pop-to-buffer buf) - (if (< (window-height) (/ (frame-height) 2)) - (enlarge-window (- (/ (frame-height) 2) - (window-height)))) - (setq args '("-f" "+verbose=0" "+batchmode")) - (if mc-pgp-alternate-keyring - (setq args - (append args (list (format "+pubring=%s" - mc-pgp-alternate-keyring))))) - - (setq proc (apply 'start-process "*PGP*" buf mc-pgp-path args)) - ;; Because PGPPASSFD might be set - (process-send-string proc "\r\n") - (process-send-string proc key) - (process-send-string proc "\r\n") - (process-send-eof proc) - (set-buffer buf) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5) - (goto-char (point-min))) - (if (y-or-n-p "Add this key to keyring? ") - (progn - (setq args (append args '("-ka"))) - (setq proc - (apply 'start-process "*PGP*" buf mc-pgp-path args)) - ;; Because PGPPASSFD might be set - (process-send-string proc "\r\n") - (process-send-string proc key) - (process-send-string proc "\r\n") - (process-send-eof proc) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - t))) - (if buf (kill-buffer buf)))))) - -;;}}}
--- a/lisp/mailcrypt/mc-remail.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,862 +0,0 @@ -;; mc-remail.el --- Remailer support for Mailcrypt - -;; Copyright (C) 1995 Patrick LoPresti <patl@lcs.mit.edu> - -;;{{{ Licensing - -;; This file is intended to be used with GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;}}} -;;{{{ Load required packages - -(require 'mail-utils) -(require 'sendmail) -(require 'mailcrypt) - -(eval-and-compile - (if (not mc-xemacs-p) - (progn - (autoload 'mc-cleanup-recipient-headers "mc-toplev") - (autoload 'mc-encrypt-message "mc-toplev")))) - -(eval-and-compile - (condition-case nil (require 'mailalias) (error nil))) - -;;}}} -;;{{{ Functions dealing with remailer structures - -(defsubst mc-remailer-create (addr id props pre-encr post-encr) - "Create a remailer structure. - -ADDR is the remailer's Email address, a string. - -ID is the remailer's public key ID (a string) or nil if the same as -ADDR. - -PROPS is a list of properties, as strings. - -PRE-ENCR is a list of pre-encryption functions. Its elements will be -called with the remailer structure itself as argument. - -POST-ENCR is similar, but for post-encryption functions." -(list 'remailer addr id props pre-encr post-encr)) - -(defsubst mc-remailerp (remailer) - "Test whether REMAILER is a valid remailer struct." - (and (listp remailer) (eq 'remailer (car-safe remailer)))) - -(defsubst mc-remailer-address (remailer) - "Return the Email address of REMAILER." - (nth 1 remailer)) - -(defsubst mc-remailer-userid (remailer) - "Return the userid with which to look up the public key for REMAILER." - (or (nth 2 remailer) - (mc-strip-address (mc-remailer-address remailer)))) - -(defsubst mc-remailer-properties (remailer) - "Return the property list for REMAILER" - (nth 3 remailer)) - -(defsubst mc-remailer-pre-encrypt-hooks (remailer) - "Return the list of pre-encryption hooks for REMAILER." - (nth 4 remailer)) - -(defsubst mc-remailer-post-encrypt-hooks (remailer) - "Return the list of post-encryption hooks for REMAILER." - (nth 5 remailer)) - -(defun mc-remailer-remove-property (remailer prop) - (let ((props (append (mc-remailer-properties remailer) nil))) - (setq props (delete prop props)) - (mc-remailer-create - (mc-remailer-address remailer) - (mc-remailer-userid remailer) - props - (mc-remailer-pre-encrypt-hooks remailer) - (mc-remailer-post-encrypt-hooks remailer)))) - -;;}}} -;;{{{ User variables - -(defvar mc-response-block-included-headers - '("From" "To" "Newsgroups") - "List of header fields to include in response blocks. - -These will be copied into the deepest layer of the response block to -help you identify it when it is used to Email you.") - - -(defvar mc-remailer-tag "(*REMAILER*)" - "A string which marks an Email address as belonging to a remailer.") - -(defvar mc-levien-file-name "~/.remailers" - "The file containing a Levien format list of remailers. - -The file is read by `mc-read-levien-file' and `mc-reread-levien-file'. - -The file should include lines of the following form (other lines -are ignored): - -$remailer{\"NAME\"} = \"<EMAIL ADDRESS> PROPERTIES\"; - -PROPERTIES is a space-separated set of strings. - -This format is named after Raphael Levien, who maintains a list of -active remailers. Do \"finger remailer-list@kiwi.cs.berkeley.edu\" -for the latest copy of his list.") - -(defvar mc-remailer-user-chains nil - "An alist of remailer chains defined by the user. - -Format is - -((NAME . REMAILER-LIST) - (NAME . REMAILER-LIST) - ...) - -NAME must be a string. - -REMAILER-LIST may be an arbitrary sequence, not just a list. Its -elements may be any of the following: - -1) A remailer structure created by `mc-remailer-create'. This is - the base case. - -2) A string naming another remailer chain to be spliced in - at this point. - -3) A positive integer N representing a chain to be spliced in at this - point and consisting of a random permutation of the top N remailers - as ordered in the file `mc-levien-file-name'. - -4) An arbitrary Lisp form to be evaluated, which should - return another REMAILER-LIST to be recursively processed and - spliced in at this point. - -The complete alist of chains is given by the union of the two lists -`mc-remailer-internal-chains' and `mc-remailer-user-chains'.") - -(defvar mc-remailer-internal-chains nil - "List of \"internal\" remailer chains. - -This variable is normally generated automatically from a human-readable -list of remailers; see, for example, the function `mc-reread-levien-file'. - -To define your own chains, you probably want to use the variable -`mc-remailer-user-chains'. See that variable's documentation for -format information.") - -(defvar mc-remailer-internal-ranking nil - "Ordered list of remailers, most reliable first. - -This variable is normally generated automatically from a human-readable -list of remailers; see, for example, the function `mc-reread-levien-file'.") - -(defvar mc-remailer-user-response-block - (function - (lambda (addr lines block) - (concat - ";;;\n" - (format - "To reply to this message, take the following %d-line block, remove\n" - lines) - "leading \"- \" constructs (if any), and place it at the top of a\n" - (format "message to %s :\n" addr) - block))) - "A function called to generate response block text. - -Value should be a function taking three arguments (ADDR LINES BLOCK). -ADDR is the address to which the response should be sent. -LINES is the number of lines in the encrypted response block. -BLOCK is the response block itself. -Function should return a string to be inserted into the buffer -by mc-remailer-insert-response-block.") - -(defvar mc-remailer-pseudonyms nil - "*A list of your pseudonyms. - -This is a list of strings. Completion against it will be available -when you are prompted for your pseudonym.") - -(defvar mc-remailer-preserved-headers - '("References" "Followup-to" "In-reply-to") - "*Header fields which are preserved as hashmark headers when rewriting. - -This is a list of strings naming the preserved headers. Note that -\"Subject\", \"Newsgroups\", and \"To\" are handled specially and -should not be included in this list.") - -;;}}} -;;{{{ Handling Levien format remailer lists - -(defun mc-parse-levien-buffer () - ;; Parse a buffer in Levien format. - (goto-char (point-min)) - (let (chains remailer remailer-name ranking) - (while - (re-search-forward - "^\\$remailer{\"\\(.+\\)\"}[ \t]*=[ \t]*\"\\(.*\\)\";" - nil t) - (let ((name (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - property-list address - (value-start (match-beginning 2)) - (value-end (match-end 2))) - (goto-char value-start) - (while (re-search-forward "[^ \t]+" value-end 'no-error) - (setq property-list - (append - property-list - (list (buffer-substring-no-properties - (match-beginning 0) (match-end 0)))))) - (setq address (car property-list) - property-list (cdr property-list) - remailer-name name) - (if (not - (or (member "mix" property-list) - (and (or (member "pgp" property-list) - (member "pgp." property-list)) - (or (member "cpunk" property-list) - (member "eric" property-list))))) - (setq remailer nil) - (setq remailer - (mc-remailer-create - address ; Address - (if (member "pgp." property-list) - name) ; User ID - property-list - '(mc-generic-pre-encrypt-function) ; Pre-encrypt hooks - '(mc-generic-post-encrypt-function) ; Post-encrypt hooks - )))) - (if (not (null remailer)) - (setq chains (cons (list remailer-name remailer) chains)))) - (goto-char (point-min)) - (if (re-search-forward "----------" nil t) - (while (re-search-forward "^\\([a-zA-Z0-9\\-]+\\) " nil t) - (setq remailer-name (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (if (assoc remailer-name chains) - (setq ranking (append ranking (list remailer-name)))))) - (cons chains ranking))) - -(defun mc-read-levien-file () - "Read the Levien format file specified in `mc-levien-file-name'. -Return an alist of length-1 chains, one for each remailer, named -after the remailer. Only include remailers supporting PGP -encryption." - (save-excursion - (if (file-readable-p mc-levien-file-name) - (prog2 - (find-file-read-only mc-levien-file-name) - (mc-parse-levien-buffer) - (bury-buffer))))) - -(defun mc-reread-levien-file () - "Read the Levien format file specified in `mc-levien-file-name'. - -Place result in `mc-remailer-internal-chains' and `mc-remailer-internal-ranking'. - -See the documentation for the variable `mc-levien-file-name' for -a description of Levien file format." - (interactive) - (let ((parsed-levien-file (mc-read-levien-file))) - (setq mc-remailer-internal-chains (car parsed-levien-file) - mc-remailer-internal-ranking (cdr parsed-levien-file)))) - -;;}}} -;;{{{ Arbitrary chain choice - -(defun mc-remailer-choose-first (n &optional l) - (cond - ((= n 0) nil) - ((null l) (mc-remailer-choose-first n mc-remailer-internal-ranking)) - (t (cons (car l) (mc-remailer-choose-first (1- n) (cdr l)))))) - -(defun mc-remailer-choose-chain (n) - (if (null mc-remailer-internal-ranking) - (error "No ranking information, cannot choose the %d best remailer%s" - n (if (> n 1) "s" ""))) - (append (shuffle-vector (vconcat (mc-remailer-choose-first n))) - nil)) - -;;}}} -;;{{{ Canonicalization function - -(defun mc-remailer-canonicalize-elmt (elmt chains-alist) - (cond - ((mc-remailerp elmt) (list elmt)) - ((stringp elmt) - (mc-remailer-canonicalize-chain (cdr (assoc elmt chains-alist)) - chains-alist)) - ((integerp elmt) - (mc-remailer-canonicalize-chain (mc-remailer-choose-chain elmt) - chains-alist)) - (t (mc-remailer-canonicalize-chain (eval elmt) chains-alist)))) - -(defun mc-remailer-canonicalize-chain (chain &optional chains-alist) - ;; Canonicalize a remailer chain with respect to CHAINS-ALIST. - ;; That is, use CHAINS-ALIST to resolve strings. - ;; Here is where we implement the functionality described in - ;; the documentation for the variable `mc-remailer-user-chains'. - (if (null chains-alist) - (setq chains-alist (mc-remailer-make-chains-alist))) - (cond - ((null chain) nil) - ;; Handle case where chain is actually a string or a single - ;; remailer. - ((or (stringp chain) (mc-remailerp chain) (integerp chain)) - (mc-remailer-canonicalize-elmt chain chains-alist)) - (t - (let ((first (elt chain 0)) - (rest (cdr (append chain nil)))) - (append - (mc-remailer-canonicalize-elmt first chains-alist) - (mc-remailer-canonicalize-chain rest chains-alist)))))) - -;;}}} -;;{{{ Auxiliaries for mail header munging - -(defsubst mc-nuke-field (field &optional bounds) - ;; Delete all fields exactly matching regexp FIELD from header, - ;; bounded by BOUNDS. Default is entire visible region of buffer. - (mc-get-fields field bounds t)) - -(defun mc-replace-field (field-name replacement header) - (save-excursion - (save-restriction - (if (not (string-match "^[ \t]" replacement)) - (setq replacement (concat " " replacement))) - (if (not (string-match "\n$" replacement)) - (setq replacement (concat replacement "\n"))) - (let ((case-fold-search t) - (field-regexp (regexp-quote field-name))) - (narrow-to-region (car header) (cdr header)) - (goto-char (point-min)) - (re-search-forward - (concat "^" field-regexp ":" mc-field-body-regexp) - nil t) - (mc-nuke-field field-regexp header) - (insert field-name ":" replacement))))) - -(defun mc-find-main-header (&optional ignored) - ;; Find the main header of the mail message; return as a pair of - ;; markers (START . END). - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (forward-line -1) - (cons (copy-marker (point-min)) (copy-marker (point))))) - -(defun mc-find-colon-header (&optional insert) - ;; Find the header with a "::" immediately after the - ;; mail-header-separator. Return region enclosing header. Optional - ;; arg INSERT means insert the header if it does not exist already. - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (if (or (and (looking-at "::\n") (forward-line 1)) - (and insert - (progn - (insert-before-markers "::\n\n") - (forward-line -1)))) - (let ((start (point))) - (re-search-forward "^$" nil 'move) - (cons (copy-marker start) (copy-marker (point))))))) - -(defun mc-find-hash-header (&optional insert) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (if (or (and (looking-at "##\n") (forward-line 1)) - (and (looking-at "::\n") - (re-search-forward "^\n" nil 'move) - (looking-at "##\n") - (forward-line 1)) - (and insert - (progn - (insert-before-markers "##\n\n") - (forward-line -1)))) - (let ((start (point))) - (re-search-forward "^$" nil 'move) - (cons (copy-marker start) (copy-marker (point))))))) - - -(defsubst mc-replace-main-field (field replacement) - (mc-replace-field field replacement (mc-find-main-header t))) - -(defsubst mc-replace-hash-field (field replacement) - (mc-replace-field field replacement (mc-find-hash-header t))) - -(defsubst mc-replace-colon-field (field replacement) - (mc-replace-field field replacement (mc-find-colon-header t))) - -(defun mc-recipient-is-remailerp () - (let ((to (mc-get-fields "To" (mc-find-main-header)))) - (and to - (string-match (regexp-quote mc-remailer-tag) (cdr (car to)))))) - -;;}}} -;;{{{ Pre-encryption and post-encryption hook defaults - -(defun mc-generic-post-encrypt-function (remailer) - (let ((main-header (mc-find-main-header)) - (colon-header (mc-find-colon-header t))) - (mc-replace-field "Encrypted" "PGP" colon-header) - (mc-replace-field - "To" - (concat (mc-remailer-address remailer) " " mc-remailer-tag) - main-header))) - -(defun mc-generic-pre-encrypt-function (remailer) - (let ((addr (mc-remailer-address remailer)) - (props (mc-remailer-properties remailer)) - (main-header (mc-find-main-header)) - (colon-header (mc-find-colon-header t)) - to to-field preserved-regexp preserved) - - (setq preserved-regexp - (mc-disjunction-regexp mc-remailer-preserved-headers)) - (setq preserved (mc-get-fields preserved-regexp main-header t)) - (if preserved (goto-char (cdr (mc-find-hash-header t)))) - (mapcar (function - (lambda (c) - (insert (car c) ":" - (mc-eliminate-continuation-lines (cdr c))))) - preserved) - - (if (and (mc-find-hash-header) (not (member "hash" props))) - (error "Remailer %s does not support hashmarks" addr)) - - (if (mc-get-fields "Newsgroups" main-header) - (cond ((not (member "post" props)) - (error "Remailer %s does not support posting" addr)) - ((not (member "hash" props)) - (error "Remailer %s does not support hashmarks" addr)) - (t (mc-rewrite-news-to-mail remailer))) - (and (featurep 'mailalias) - (not (featurep 'mail-abbrevs)) - mail-aliases - (expand-mail-aliases (car main-header) (cdr main-header))) - (setq to (mc-strip-addresses - (mapcar 'cdr (mc-get-fields "To" main-header)))) - (if (string-match "," to) - (error "Remailer %s does not support multiple recipients." addr)) - (setq to-field - (if (mc-get-fields "From" colon-header) - "Send-To" - (cond - ((member "eric" props) "Anon-Send-To") - ((member "cpunk" props) "Request-Remailing-To") - (t (error "Remailer %s is not type-1" addr))))) - (mc-replace-field to-field to colon-header) - (mc-nuke-field "Reply-to" main-header)))) - -;;}}} -;;{{{ Misc. random - -(defun mc-disjunction-regexp (regexps) - ;; Take a list of regular expressions and return a single - ;; regular expression which matches anything that any of the - ;; original regexps match. - (concat "\\(" - (mapconcat 'identity regexps "\\)\\|\\(") - "\\)")) - -(defun mc-user-mail-address () - "Figure out the user's Email address as best we can." - (mc-strip-address - (cond ((and (boundp 'gnus-user-from-line) - (stringp gnus-user-from-line)) - gnus-user-from-line) - ((stringp mail-default-reply-to) mail-default-reply-to) - ((boundp 'user-mail-address) user-mail-address) - (t (concat (user-login-name) "@" (system-name)))))) - -(defun mc-eliminate-continuation-lines (string) - (while (string-match "\n[\t ]+" string) - (setq string (replace-match " " t nil string))) - string) - -(defun mc-remailer-make-chains-alist () - (if (null mc-remailer-internal-chains) - (mc-reread-levien-file)) - (append mc-remailer-internal-chains mc-remailer-user-chains)) - -;;;###autoload -(defun mc-remailer-insert-pseudonym () - "Insert pseudonym as a From field in the hash-mark header. - -See the documentation for the variable `mc-remailer-pseudonyms' for -more information." - (interactive) - (let ((completion-ignore-case t) - pseudonym) - (setq pseudonym - (cond ((null mc-remailer-pseudonyms) - (read-from-minibuffer "Pseudonym: ")) - (t - (completing-read "Pseudonym: " - (mapcar 'list mc-remailer-pseudonyms))))) - (if (not (string-match "\\S +@\\S +" pseudonym)) - (setq pseudonym (concat pseudonym " <x@x.x>"))) - (mc-replace-colon-field "From" pseudonym))) - -;;}}} -;;{{{ Mixmaster support -(defvar mc-mixmaster-path nil - "*Path to the Mixmaster binary. If defined, Mixmaster chains will -be passed to this program for rewriting.") - -(defvar mc-mixmaster-list-path nil - "*Path to the Mixmaster type2.list file.") - -(defun mc-demix (&rest chain) - "Use arguments as a remailer-list and return a new list with the -\"mix\" property removed from all the elements." - (mapcar (function (lambda (r) (mc-remailer-remove-property r "mix"))) - (mc-remailer-canonicalize-chain chain))) - -(defun mc-mixmaster-process (beg end recipients preserved mix-chain) - ;; Run a region through Mixmaster. - (let (ret) - (if (not (markerp end)) - (setq end (copy-marker end))) - (goto-char beg) - (mapcar (function (lambda (x) (insert x ?\n))) recipients) - (insert ?\n) - (mapcar (function (lambda (x) (insert x))) preserved) - (insert ?\n) - (setq mix-chain (mapcar (function (lambda (x) (format "%d" x))) mix-chain)) - ;; Handle case of empty message - (if (< end (point)) (setq end (point))) - (setq ret - (apply 'call-process-region beg end mc-mixmaster-path t t nil - "-f" "-o" "stdout" "-l" mix-chain)) - (if (not (eq ret 0)) (error "Mixmaster barfed.")) - (goto-char beg) - (re-search-forward "^::$") - (delete-region beg (match-beginning 0)))) - -(defun mc-mixmaster-build-alist (&optional n) - ;; Construct an alist mapping Mixmaster Email addresses to integers. - ;; FIXME; this is terrible - (let (buf) - (save-excursion - (unwind-protect - (progn - (setq n (or n 1)) - (setq buf (find-file-noselect mc-mixmaster-list-path)) - (set-buffer buf) - (if (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)" nil t) - (cons (cons (buffer-substring-no-properties - (match-beginning 1) (match-end 1)) - n) - (mc-mixmaster-build-alist (+ n 1))))) - (if buf (kill-buffer buf)))))) - -(defvar mc-mixmaster-alist nil) - -(defsubst mc-mixmaster-alist () - (or mc-mixmaster-alist - (setq mc-mixmaster-alist (mc-mixmaster-build-alist)))) - -(defun mc-mixmaster-translate-chain (chain) - ;; Take a chain of Mixmaster remailers and convert it to the list - ;; of integers which represents them. - (if (or (null chain) - (not (member "mix" (mc-remailer-properties (car chain))))) - nil - (cons (cdr (assoc (mc-strip-address (mc-remailer-address (car chain))) - (mc-mixmaster-alist))) - (mc-mixmaster-translate-chain (cdr chain))))) - -(defun mc-mixmaster-skip (chain) - ;; Return the largest possible suffix of CHAIN whose first element - ;; is not a Mixmaster. - (cond ((null chain) nil) - ((not (member "mix" (mc-remailer-properties (car chain)))) - chain) - (t (mc-mixmaster-skip (cdr chain))))) - -(defun mc-rewrite-for-mixmaster (chain &optional pause) - ;; Rewrite the current mail buffer for a chain of Mixmasters. - (let ((mix-chain (mc-mixmaster-translate-chain chain)) - (main-header (mc-find-main-header)) - (colon-header (mc-find-colon-header)) - (hash-header (mc-find-hash-header)) - recipients preserved newsgroups first last rest preserved-regexp) - - ;; Figure out FIRST and LAST. FIRST is the first Mixmaster in the - ;; chain. LAST is the last. - (setq first (car chain) - rest chain) - (while (and rest (member "mix" (mc-remailer-properties (car rest)))) - (setq last (car rest) - rest (cdr rest))) - - ;; If recipient is not a remailer, deal with hashmark and colon - ;; headers and get rid of them. - (if (mc-recipient-is-remailerp) - nil - (if hash-header - (progn - (setq preserved (mc-get-fields nil hash-header)) - (goto-char (car hash-header)) - (forward-line -1) - (delete-region (point) (+ (cdr hash-header) 1)))) - ;; Preserve pseduonym line... - (if colon-header - (progn - (setq preserved - (append (mc-get-fields "From" colon-header) preserved)) - (goto-char (car colon-header)) - (forward-line -1) - (delete-region (point) (+ (cdr colon-header) 1))))) - - ;; Expand aliases and get recipients. - (and (featurep 'mailalias) - (not (featurep 'mail-abbrevs)) - mail-aliases - (expand-mail-aliases (car main-header) (cdr main-header))) - (setq recipients - (mc-cleanup-recipient-headers - (mapconcat 'cdr (mc-get-fields "To" main-header t) ", "))) - (setq newsgroups (mc-get-fields "Newsgroups" nil t)) - ;; Mixmaster does not support posting... -;;; (if (and newsgroups -;;; (not (member "post" (mc-remailer-properties last)))) - (if newsgroups - (error "Remailer %s does not support posting" - (mc-remailer-address last))) - (setq - recipients - (append (mapcar - (function (lambda (c) (concat "Post:" (cdr c)))) newsgroups) - recipients)) - - (setq - preserved-regexp - (mc-disjunction-regexp (cons "Subject" mc-remailer-preserved-headers))) - - (setq preserved - (append (mc-get-fields preserved-regexp main-header t) preserved)) - - ;; Convert preserved header alist to simple list of strings - (setq preserved - (mapcar - (function - (lambda (c) - (concat (car c) ":" - (mc-eliminate-continuation-lines (cdr c))))) - preserved)) - - ;; Do the conversion - (goto-char (cdr main-header)) - (forward-line 1) - (mc-mixmaster-process (point) (point-max) recipients preserved - mix-chain) - - (mc-replace-field "To" - (concat - (mc-remailer-address first) " " mc-remailer-tag) - main-header))) - -;;}}} -;;{{{ High level message rewriting - -(defun mc-rewrite-news-to-mail (remailer) - (let ((main-header (mc-find-main-header)) - newsgroups) - (setq newsgroups (mc-get-fields "Newsgroups" main-header t)) - (mc-replace-colon-field "Post-To" (cdr (car newsgroups))) - (mail-mode))) - -(defun mc-rewrite-for-remailer (remailer &optional pause) - ;; Rewrite the current mail buffer for a single remailer. This - ;; includes running the pre-encryption hooks, modifying the To: - ;; field, encrypting with the remailer's public key, and running the - ;; post-encryption hooks. - (let ((addr (mc-remailer-address remailer)) - (main-header (mc-find-main-header))) - ;; If recipient is already a remailer, make sure the "::" and "##" - ;; headers get to it - (if (mc-recipient-is-remailerp) - (progn - (goto-char (cdr main-header)) - (forward-line 1) - (insert "::\n\n"))) - - (mapcar - (function (lambda (hook) (funcall hook remailer))) - (mc-remailer-pre-encrypt-hooks remailer)) - - ;; Move "Subject" lines down. - (goto-char (car (mc-find-colon-header t))) - (mapcar - (function (lambda (f) (insert (car f) ":" (cdr f)))) - (mc-get-fields "Subject" main-header t)) - - (if pause - (let ((cursor-in-echo-area t)) - (message "SPC to encrypt for %s : " addr) - (read-char-exclusive))) - (setq main-header (mc-find-main-header)) - (goto-char (cdr main-header)) - (forward-line 1) - (if (let ((mc-pgp-always-sign 'never) - (mc-encrypt-for-me nil)) - (mc-encrypt-message (mc-remailer-userid remailer) nil (point))) - (progn - (mapcar - (function (lambda (hook) (funcall hook remailer))) - (mc-remailer-post-encrypt-hooks remailer)) - (mc-nuke-field "Comment") - (mc-nuke-field "From")) - (error "Unable to encrypt message to %s" - (mc-remailer-userid remailer))))) - -(defun mc-rewrite-for-chain (chain &optional pause) - ;; Rewrite the current buffer for a chain of remailers. - ;; CHAIN must be in canonical form. - (let (rest) - (if mc-mixmaster-path - (setq rest (mc-mixmaster-skip chain)) - (setq rest chain)) - (if (null chain) nil - (mc-rewrite-for-chain - (if (eq rest chain) (cdr rest) rest) pause) - (if (eq rest chain) - (mc-rewrite-for-remailer (car chain) pause) - (mc-rewrite-for-mixmaster chain pause))))) - -(defun mc-unparse-chain (chain) - ;; Unparse CHAIN into a string suitable for printing. - (if (null chain) - nil - (concat (mc-remailer-address (car chain)) "\n" - (mc-unparse-chain (cdr chain))))) - -(defun mc-disallow-field (field &optional header) - (let ((case-fold-search t)) - (if (null header) - (setq header (mc-find-main-header))) - (goto-char (car header)) - (if (re-search-forward (concat "^" (regexp-quote field) ":") - (cdr header) t) - - (progn - (goto-char (match-beginning 0)) - (error "Cannot use a %s field." field))))) - -;;;###autoload -(defun mc-remailer-encrypt-for-chain (&optional pause) - "Encrypt message for a remailer chain, prompting for chain to use. - -With \\[universal-argument], pause before each encryption." - (interactive "P") - (let ((chains (mc-remailer-make-chains-alist)) - (buffer (get-buffer-create mc-buffer-name)) - chain-name chain) - (mc-disallow-field "CC") - (mc-disallow-field "FCC") - (mc-disallow-field "BCC") - (setq chain-name - (completing-read - "Choose a remailer or chain: " chains nil 'strict-match)) - (setq chain - (mc-remailer-canonicalize-chain - (cdr (assoc chain-name chains)) - chains)) - (mc-rewrite-for-chain chain pause) - (if chain - (save-excursion - (set-buffer buffer) - (erase-buffer) - (insert "Rewritten for chain `" chain-name "':\n\n" - (mc-unparse-chain chain)) - (message "Done. See %s buffer for details." mc-buffer-name))))) - -;;}}} -;;{{{ Response block generation - -;;;###autoload -(defun mc-remailer-insert-response-block (&optional arg) - "Insert response block at point, prompting for chain to use. - -With \\[universal-argument], enter a recursive edit of the innermost -layer of the block before encrypting it." - (interactive "p") - (let (buf main-header to addr block lines) - (save-excursion - (setq buf - (mc-remailer-make-response-block (if (> arg 1) t))) - (set-buffer buf) - (setq main-header (mc-find-main-header)) - (setq to (cdr (car (mc-get-fields "To" main-header)))) - (setq addr (concat "<" (mc-strip-address to) ">")) - (goto-char (cdr main-header)) - (forward-line 1) - (setq block (buffer-substring-no-properties - (point) (point-max)) - lines (count-lines (point) (point-max))) - (kill-buffer buf)) - (let ((opoint (point))) - (insert (funcall mc-remailer-user-response-block - addr lines block)) - (goto-char opoint)) - (mc-nuke-field "Reply-to" (mc-find-main-header)) - (mc-replace-hash-field "Reply-to" addr))) - -(defun mc-remailer-make-response-block (&optional recurse) - ;; Return a buffer which contains a response block - ;; for the user, and a To: header for the remailer to use. - (let ((buf (generate-new-buffer " *Remailer Response Block*")) - (original-buf (current-buffer)) - (mc-mixmaster-path nil) - all-headers included-regexp included) - (setq all-headers (mc-find-main-header)) - (setcdr all-headers - (max - (cdr all-headers) - (or (cdr-safe (mc-find-colon-header)) 0) - (or (cdr-safe (mc-find-hash-header)) 0))) - (save-excursion - (setq - included-regexp - (mc-disjunction-regexp mc-response-block-included-headers)) - (setq included (mc-get-fields included-regexp all-headers)) - (set-buffer buf) - (insert "To: " (mc-user-mail-address) "\n" mail-header-separator "\n") - (insert ";; Response block created " (current-time-string) "\n") - (mapcar (function (lambda (c) (insert "; " (car c) ":" (cdr c)))) - included) - (if recurse - (progn - (switch-to-buffer buf) - (message "Editing response block ; %s when done." - (substitute-command-keys "\\[exit-recursive-edit]")) - (recursive-edit))) - (set-buffer buf) - (mc-remailer-encrypt-for-chain) - (switch-to-buffer original-buf)) - buf)) - -;;}}}
--- a/lisp/mailcrypt/mc-toplev.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,655 +0,0 @@ -;; mc-toplev.el, entry point functions for Mailcrypt -;; Copyright (C) 1995 Jin Choi <jsc@mit.edu> -;; Patrick LoPresti <patl@lcs.mit.edu> - -;;{{{ Licensing -;; This file is intended to be used with GNU Emacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;}}} -;;{{{ Load some required packages -(require 'mailcrypt) -(require 'mail-utils) - -(eval-when-compile - ;; RMAIL - (condition-case nil (require 'rmail) (error nil)) - (autoload 'rmail-abort-edit "rmailedit") - (autoload 'rmail-cease-edit "rmailedit") - ;; Is this a good idea? - (defvar rmail-buffer nil) - - ;; VM - (condition-case nil (require 'vm) (error nil)) - - ;; GNUS - (condition-case nil (require 'gnus) (error nil)) - - ;; MH-E - (condition-case nil (require 'mh-e) (error nil))) - -(eval-and-compile - (condition-case nil (require 'mailalias) (error nil))) - -(if (not mc-xemacs-p) - (autoload 'mc-scheme-pgp "mc-pgp" nil t)) - -;;}}} - -;;{{{ Encryption - -;;;###autoload -(defun mc-cleanup-recipient-headers (str) - ;; Takes a comma separated string of recipients to encrypt for and, - ;; assuming they were possibly extracted from the headers of a reply, - ;; returns a list of the address components. - (mapcar 'mc-strip-address - (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" str))) - -(defun mc-find-headers-end () - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (if (looking-at "^::\n") - (re-search-forward "^\n" nil t)) - (if (looking-at "^##\n") - (re-search-forward "^\n" nil t)) - (point-marker))) - -;;;###autoload -(defun mc-encrypt (arg) - "*Encrypt the current buffer. - -Exact behavior depends on current major mode. - -With \\[universal-argument], prompt for User ID to sign as. - -With \\[universal-argument] \\[universal-argument], prompt for encryption scheme to use." - (interactive "p") - (mc-encrypt-region arg nil nil)) - -(defun mc-encrypt-region (arg start end) - "*Encrypt the current region." - (interactive "p\nr") - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'encrypt mode-alist)) - 'mc-encrypt-generic)) - sign scheme from) - (if (>= arg 4) - (setq from (read-string "User ID: ") - sign t)) - (if (>= arg 16) - (setq scheme - (cdr (assoc - (completing-read "Encryption Scheme: " mc-schemes) - mc-schemes)))) - (funcall func nil scheme start end from sign))) - -(defun mc-encrypt-generic (&optional recipients scheme start end from sign) - "*Generic function to encrypt a region of data." - (save-excursion - (or start (setq start (point-min-marker))) - (or (markerp start) (setq start (copy-marker start))) - (or end (setq end (point-max-marker))) - (or (markerp end) (setq end (copy-marker end))) - (run-hooks 'mc-pre-encryption-hook) - (cond ((stringp recipients) - (setq recipients - (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients))) - ((null recipients) - (setq recipients - (mc-cleanup-recipient-headers (read-string "Recipients: ")))) - (t (error "mc-encrypt-generic: recipients not string or nil"))) - (or scheme (setq scheme mc-default-scheme)) - (if (funcall (cdr (assoc 'encryption-func (funcall scheme))) - recipients start end from sign) - (progn - (run-hooks 'mc-post-encryption-hook) - t)))) - -;;;###autoload -(defun mc-encrypt-message (&optional recipients scheme start end from sign) - "*Encrypt a message for RECIPIENTS using the given encryption SCHEME. -RECIPIENTS is a comma separated string. If SCHEME is nil, use the value -of `mc-default-scheme'. Returns t on success, nil otherwise." - (save-excursion - (let ((headers-end (mc-find-headers-end)) - default-recipients) - - (setq default-recipients - (save-restriction - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (narrow-to-region (point-min) (point)) - (and (featurep 'mailalias) - (not (featurep 'mail-abbrevs)) - mail-aliases - (expand-mail-aliases (point-min) (point-max))) - (mc-strip-addresses - (mapcar 'cdr - (mc-get-fields "to\\|cc\\|bcc"))))) - - (if (not from) - (save-restriction - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (narrow-to-region (point) headers-end) - (setq from (mail-fetch-field "From")))) - - (if (not recipients) - (setq recipients - (if mc-use-default-recipients - default-recipients - (read-from-minibuffer "Recipients: " default-recipients)))) - - (or start (setq start headers-end)) - (or end (setq end (point-max-marker))) - - (mc-encrypt-generic recipients scheme start end from sign)))) - - -;;}}} -;;{{{ Decryption - -;;;###autoload -(defun mc-decrypt () - "*Decrypt a message in the current buffer. - -Exact behavior depends on current major mode." - (interactive) - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'decrypt mode-alist)) - 'mc-decrypt-message))) - (funcall func))) - -;;;###autoload -(defun mc-decrypt-message () - "Decrypt whatever message is in the current buffer. -Returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if the encryption -succeeded and VERIFIED is t if it had a valid signature." - (save-excursion - (let ((schemes mc-schemes) - limits scheme) - (while (and schemes - (setq scheme (cdr (car schemes))) - (not (setq - limits - (mc-message-delimiter-positions - (cdr (assoc 'msg-begin-line (funcall scheme))) - (cdr (assoc 'msg-end-line (funcall scheme))))))) - (setq schemes (cdr schemes))) - - (if (null limits) - (error "Found no encrypted message in this buffer.") - (run-hooks 'mc-pre-decryption-hook) - (let ((resultval (funcall (cdr (assoc 'decryption-func - (funcall scheme))) - (car limits) (cdr limits)))) - (goto-char (point-min)) - (if (car resultval) ; decryption succeeded - (run-hooks 'mc-post-decryption-hook)) - resultval))))) -;;}}} -;;{{{ Signing -;;;###autoload -(defun mc-sign (arg) - "*Sign a message in the current buffer. - -Exact behavior depends on current major mode. - -With one prefix arg, prompts for private key to use, with two prefix args, -also prompts for encryption scheme to use. With negative prefix arg, -inhibits clearsigning (pgp)." - (interactive "p") - (mc-sign-region arg nil nil)) - -(defun mc-sign-region (arg start end) - "*Sign the current region." - (interactive "p\nr") - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'sign mode-alist)) - 'mc-sign-generic)) - from scheme) - (if (>= arg 16) - (setq scheme - (cdr (assoc - (completing-read "Encryption Scheme: " mc-schemes) - mc-schemes)))) - (if (>= arg 4) - (setq from (read-string "User ID: "))) - - (funcall func from scheme start end (< arg 0)))) - -(defun mc-sign-generic (withkey scheme start end unclearsig) - (or scheme (setq scheme mc-default-scheme)) - (or start (setq start (point-min-marker))) - (or (markerp start) (setq start (copy-marker start))) - (or end (setq end (point-max-marker))) - (or (markerp end) (setq end (copy-marker end))) - (run-hooks 'mc-pre-signature-hook) - (if (funcall (cdr (assoc 'signing-func (funcall scheme))) - start end withkey unclearsig) - (progn - (run-hooks 'mc-post-signature-hook) - t))) - -;;;###autoload -(defun mc-sign-message (&optional withkey scheme start end unclearsig) - "Clear sign the message." - (save-excursion - (let ((headers-end (mc-find-headers-end))) - (or withkey - (progn - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (save-restriction - (narrow-to-region (point) headers-end) - (setq withkey (mail-fetch-field "From"))))) - (or start (setq start headers-end)) - (or end (setq end (point-max-marker))) - (mc-sign-generic withkey scheme start end unclearsig)))) - -;;}}} -;;{{{ Signature verification - -;;;###autoload -(defun mc-verify () - "*Verify a message in the current buffer. - -Exact behavior depends on current major mode." - (interactive) - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'verify mode-alist)) - 'mc-verify-signature))) - (funcall func))) - -;;;###autoload -(defun mc-verify-signature () - "*Verify the signature of the signed message in the current buffer. -Show the result as a message in the minibuffer. Returns t if the signature -is verified." - (save-excursion - (let ((schemes mc-schemes) - limits scheme) - (while (and schemes - (setq scheme (cdr (car schemes))) - (not - (setq - limits - (mc-message-delimiter-positions - (cdr (assoc 'signed-begin-line (funcall scheme))) - (cdr (assoc 'signed-end-line (funcall scheme))))))) - (setq schemes (cdr schemes))) - - (if (null limits) - (error "Found no signed message in this buffer.") - (funcall (cdr (assoc 'verification-func (funcall scheme))) - (car limits) (cdr limits)))))) - - -;;}}} -;;{{{ Key management - -;;{{{ mc-insert-public-key - -;;;###autoload -(defun mc-insert-public-key (&optional userid scheme) - "*Insert your public key at point. -With one prefix arg, prompts for user id to use. With two prefix -args, prompts for encryption scheme." - (interactive - (let (arglist) - (if (not (and (listp current-prefix-arg) - (numberp (car current-prefix-arg)))) - nil - (if (>= (car current-prefix-arg) 16) - (setq arglist - (cons (cdr (assoc (completing-read "Encryption Scheme: " - mc-schemes) - mc-schemes)) - arglist))) - (if (>= (car current-prefix-arg) 4) - (setq arglist (cons (read-string "User ID: ") arglist)))) - arglist)) - -; (if (< (point) (mc-find-headers-end)) -; (error "Can't insert key inside message header")) - (or scheme (setq scheme mc-default-scheme)) - (or userid (setq userid (cdr (assoc 'user-id (funcall scheme))))) - - ;; (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - (funcall (cdr (assoc 'key-insertion-func (funcall scheme))) userid)) - -;;}}} -;;{{{ mc-snarf-keys - -;;;###autoload -(defun mc-snarf () - "*Add all public keys in the buffer to your keyring. - -Exact behavior depends on current major mode." - (interactive) - (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist))) - (func (or (cdr-safe (assq 'snarf mode-alist)) - 'mc-snarf-keys))) - (funcall func))) - -;;;###autoload -(defun mc-snarf-keys () - "*Add all public keys in the buffer to your keyring." - (interactive) - (let ((schemes mc-schemes) - (start (point-min)) - (found 0) - limits scheme) - (save-excursion - (catch 'done - (while t - (while (and schemes - (setq scheme (cdr (car schemes))) - (not - (setq - limits - (mc-message-delimiter-positions - (cdr (assoc 'key-begin-line (funcall scheme))) - (cdr (assoc 'key-end-line (funcall scheme))) - start)))) - (setq schemes (cdr schemes))) - (if (null limits) - (throw 'done found) - (setq start (cdr limits)) - (setq found (+ found (funcall (cdr (assoc 'snarf-func - (funcall scheme))) - (car limits) (cdr limits))))))) - (message (format "%d new key%s found" found - (if (eq 1 found) "" "s")))))) -;;}}} -;;}}} -;;{{{ Mode specific functions - -;;{{{ RMAIL -;;;###autoload -(defun mc-rmail-summary-verify-signature () - "*Verify the signature in the current message." - (interactive) - (if (not (eq major-mode 'rmail-summary-mode)) - (error - "mc-rmail-summary-verify-signature called in inappropriate buffer")) - (save-excursion - (set-buffer rmail-buffer) - (mc-verify))) - -;;;###autoload -(defun mc-rmail-summary-decrypt-message () - "*Decrypt the contents of this message" - (interactive) - (if (not (eq major-mode 'rmail-summary-mode)) - (error - "mc-rmail-summary-decrypt-message called in inappropriate buffer")) - (save-excursion - (set-buffer rmail-buffer) - (mc-decrypt))) - -;;;###autoload -(defun mc-rmail-summary-snarf-keys () - "*Adds keys from current message to public key ring" - (interactive) - (if (not (eq major-mode 'rmail-summary-mode)) - (error - "mc-rmail-summary-snarf-keys called in inappropriate buffer")) - (save-excursion - (set-buffer rmail-buffer) - (mc-snarf))) - -;;;###autoload -(defun mc-rmail-verify-signature () - "*Verify the signature in the current message." - (interactive) - (if (not (equal mode-name "RMAIL")) - (error "mc-rmail-verify-signature called in a non-RMAIL buffer")) - ;; Hack to load rmailkwd before verifying sig - (rmail-add-label "verified") - (rmail-kill-label "verified") - (if (mc-verify-signature) - (rmail-add-label "verified"))) - -;;;###autoload -(defun mc-rmail-decrypt-message () - "*Decrypt the contents of this message" - (interactive) - (let (decryption-result) - (if (not (equal mode-name "RMAIL")) - (error "mc-rmail-decrypt-message called in a non-RMAIL buffer")) - (unwind-protect - (progn - (rmail-edit-current-message) - (setq decryption-result (mc-decrypt-message)) - (cond ((not (car decryption-result)) - (rmail-abort-edit)) - ((and (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p - "Replace encrypted message with decrypted? "))) - (rmail-cease-edit) - (rmail-kill-label "edited") - (rmail-add-label "decrypted") - (if (cdr decryption-result) - (rmail-add-label "verified"))) - (t - (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*"))) - (copy-to-buffer tmp (point-min) (point-max)) - (rmail-abort-edit) - (switch-to-buffer tmp t) - (goto-char (point-min)) - (insert "From Mailcrypt-" mc-version " " - (current-time-string) "\n") - (rmail-convert-file) - (rmail-mode) - (use-local-map (copy-keymap (current-local-map))) - (local-set-key "q" 'mc-rmail-view-quit) - (set-buffer-modified-p nil))))) - (if (eq major-mode 'rmail-edit-mode) - (rmail-abort-edit))))) - -(defun mc-rmail-view-quit () - (interactive) - (let ((buf (current-buffer))) - (set-buffer-modified-p nil) - (rmail-quit) - (kill-buffer buf))) - -;;}}} -;;{{{ VM -;;;###autoload -(defun mc-vm-verify-signature () - "*Verify the signature in the current VM message" - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (save-restriction - (vm-widen-page) - (mc-verify-signature))) - -;;;###autoload -(defun mc-vm-decrypt-message () - "*Decrypt the contents of the current VM message" - (interactive) - (let ((vm-frame-per-edit nil) - from-line) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - - ;; store away a valid "From " line for possible later use. - (setq from-line (vm-leading-message-separator)) - (vm-edit-message) - (cond ((not (condition-case condition-data - (car (mc-decrypt-message)) - (error - (vm-edit-message-abort) - (error (message "Decryption failed: %s" - (car (cdr condition-data))))))) - (vm-edit-message-abort) - (error "Decryption failed.")) - ((and (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p "Replace encrypted message with decrypted? "))) - (let ((this-command 'vm-edit-message-end)) - (vm-edit-message-end))) - (t - (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*"))) - (copy-to-buffer tmp (point-min) (point-max)) - (vm-edit-message-abort) - (switch-to-buffer tmp t) - (goto-char (point-min)) - (insert from-line) - (set-buffer-modified-p nil) - (vm-mode t)))))) - -;;;###autoload -(defun mc-vm-snarf-keys () - "*Snarf public key from the contents of the current VM message" - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (save-restriction - (vm-widen-page) - (mc-snarf-keys))) - -;;}}} -;;{{{ GNUS - -;;;###autoload -(defun mc-gnus-verify-signature () - (interactive) - (gnus-summary-select-article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (save-restriction (widen) (mc-verify-signature)))) - -;;;###autoload -(defun mc-gnus-snarf-keys () - (interactive) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction (widen) (mc-snarf-keys)))) - -;;;###autoload -(defun mc-gnus-decrypt-message () - (interactive) - (gnus-summary-select-article) - ;; Gnus 5 has the string "Gnus" instead of "GNUS" in gnus-version. - (if (not (let ((case-fold-search nil)) - (string-match "Gnus" gnus-version))) - (gnus-eval-in-buffer-window - gnus-article-buffer - (save-restriction (widen) (mc-decrypt-message))) - ;; Gnus 5 allows editing of articles. (Actually, it makes a great - ;; mail reader.) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-summary-edit-article t) - (save-restriction - (widen) - (cond ((not (car (mc-decrypt-message))) - (gnus-summary-edit-article-postpone)) - ((and (not (gnus-group-read-only-p)) - (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p - "Replace encrypted message on disk? "))) - (gnus-summary-edit-article-done)) - (t - (gnus-summary-edit-article-postpone))))))) - -;;}}} -;;{{{ MH - -;;;###autoload -(defun mc-mh-decrypt-message () - "Decrypt the contents of the current MH message in the show buffer." - (interactive "P") - (let* ((msg (mh-get-msg-num t)) - (msg-filename (mh-msg-filename msg)) - (show-buffer (get-buffer mh-show-buffer)) - decrypt-okay decrypt-on-disk) - (setq - decrypt-on-disk - (and (not (eq mc-always-replace 'never)) - (or mc-always-replace - (y-or-n-p "Replace encrypted message on disk? ")))) - (if decrypt-on-disk - (progn - (save-excursion - (set-buffer (create-file-buffer msg-filename)) - (insert-file-contents msg-filename t) - (if (setq decrypt-okay (car (mc-decrypt-message))) - (save-buffer) - (message "Decryption failed.") - (set-buffer-modified-p nil)) - (kill-buffer nil)) - (if decrypt-okay - (if (and show-buffer - (equal msg-filename (buffer-file-name show-buffer))) - (save-excursion - (save-window-excursion - (mh-invalidate-show-buffer))))) - (mh-show msg)) - (mh-show msg) - (save-excursion - (set-buffer mh-show-buffer) - (if (setq decrypt-okay (car (mc-decrypt-message))) - (progn - (goto-char (point-min)) - (set-buffer-modified-p nil)) - (message "Decryption failed."))) - (if (not decrypt-okay) - (progn - (mh-invalidate-show-buffer) - (mh-show msg)))))) - -;;;###autoload -(defun mc-mh-verify-signature () - "*Verify the signature in the current MH message." - (interactive) - (mh-show) - (mh-in-show-buffer (mh-show-buffer) - (mc-verify-signature))) - - -;;;###autoload -(defun mc-mh-snarf-keys () - (interactive) - (mh-show) - (mh-in-show-buffer (mh-show-buffer) - (mc-snarf-keys))) - -;;}}} - -;;}}}
--- a/lisp/mel/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,530 +0,0 @@ -1997-07-25 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.10.1 was released. - -1997-07-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el (uuencode-external-decode-region): Use - `inhibit-read-only' instead of `(setq buffer-read-only nil)'. - -1997-07-09 Steven L Baur <steve@altair.xemacs.org> - - * mel-u.el (uuencode-external-decode-region): Force - buffer-read-only nil because it gets changed magically to t during - the call to `insert-file-contents'. - - -1997-07-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.10 was released. - -1997-07-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el: Add autoload comments for command `mime-encode-region', - `mime-decode-region' and `mime-insert-encoded-file'. - -1997-07-13 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-internal-encoding-limit): Change - initial value; 0 for XEmacs/mule; 1000 if mmencode is found; - otherwise nil; Don't use `quoted-printable-internal-encode-region' - for XEmacs/mule. - - * mel-q.el: Use `start' instead of `beg' for argument. - - * mel-q.el (quoted-printable-internal-encode-region): New - implementation. - - * mel-q.el (quoted-printable-quote-char): Change to `defsubst'; - use `aref'. - - * mel-q.el: Abolish unused function `byte-to-hex-string'. - -1997-07-01 Steven L Baur <steve@altair.xemacs.org> - - * mel/mel-q.el (q-encoding-encode-string): Fix Ebola-ified - comparison. (cf. [xemacs-beta:10342][tm-en:1367]) - - -1997-05-15 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.9.1 was released. - -Thu May 15 05:43:48 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * README.en (make install): Add LISPDIR. - -Tue May 13 14:59:52 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * Makefile (LISPDIR): New variable. - - * MEL-MK (config-mel): set LISPDIR. - - * MEL-CFG: Setting for load-path is modified. - - -1997-04-30 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.9 was released. - -Wed Apr 30 17:29:02 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * README.en (q-encoding-encode-string, q-encoding-decode-string): - Modify documentation. - -Wed Apr 30 17:24:32 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el, mel-q.el (q-encoding-encode-string, - q-encoding-decode-string): Add DOC-string. - -Wed Apr 30 17:14:46 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el (base64-insert-encoded-file, - quoted-printable-insert-encoded-file): Modify DOC-string. - - * mel-q.el (quoted-printable-insert-encoded-file): Add DOC-string. - -Wed Apr 30 17:09:57 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-encode-region, - quoted-printable-decode-region): Add DOC-string. - - * mel.el: Add autoload for `quoted-printable-encode-string' and - `quoted-printable-decode-string'. - - * mel-q.el (quoted-printable-encode-string, - quoted-printable-decode-string): Add DOC-string. - -Wed Apr 30 13:23:00 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el (base64-insert-encoded-file): DOC-string was modified. - - * mel-b.el (base64-insert-encoded-file): Add DOC-string. - -Wed Apr 30 13:15:12 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el (base64-encode-region, base64-decode-region): Add - DOC-string. - -Wed Apr 30 13:01:16 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el (base64-encode-string, base64-decode-string): Add - DOC-string. - - * mel-b.el (base64-encode-string, base64-decode-string): Add - DOC-string. - - * mel.el: autoload for `q-encoding-encode-string-for-text', - `q-encoding-encode-string-for-comment' and - `q-encoding-encode-string-for-phrase' were abolished. - -Tue Apr 29 11:47:35 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * README.en: New file. - - -1997-03-14 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.3 was released. - -Fri Mar 14 07:40:13 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL-MK (config-mel): New function; load "MEL-CFG". - - * MEL-CFG: New file. - -Wed Mar 12 06:31:16 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL-MK: mk-mel was renamed to MEL-MK. - -Mon Mar 10 15:15:09 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el: Variable `mime/tmp-dir' was abolished. - - Require mel. - - (uuencode-external-decoder): Use variable `mime-temp-directory' - instead of `mime/tmp-dir'. - - (uuencode-external-decode-region): Use variable - `mime-temp-directory' instead of `mime/tmp-dir'. - - * mel.el (mime-temp-directory): New variable. - - * mel-u.el (uuencode-external-decode-region): Use - `as-binary-input-file'. - - -1997-03-10 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.2.3 was released. - - * mel-g.el (gzip64-external-encoder, gzip64-external-decoder): Use - `exec-installed-p' instead of `file-installed-p' to search - mmencode. - - -1997-03-03 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.2.2 was released. - - * mel-g.el (gzip64-external-encoder, gzip64-external-decoder): - Search mmencode from `exec-path'. (cf. [xemacs-beta:3730]) - - -Wed Jan 1 11:01:44 1997 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.2.1 was released. - -Wed Dec 28 13:57:22 1996 Martin Buchholz <mrb@Eng.Sun.COM> - - * mk-mel: Use variable `default-directory' instead of `(getenv - "PWD")'. (cf. [tm-en:1084]) - - * Makefile: A makefile command like `cd some-dir; do-something' is - generally better written as: `cd some-dir && do-something' since - if the cd fails (usually because of a coding or file-system error) - the do-something is not executed in the wrong - directory. (cf. [tm-en:1084]) - - -Wed Dec 25 06:30:59 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.2 was released. - - * mel.el (mime-encoding-method-alist, mime-decoding-method-alist, - mime-file-encoding-method-alist): Add DOC-string. - -Wed Dec 25 01:08:47 1996 Steven L Baur <steve@miranova.com> - - * mel.el: to decode `x-uuencode'. (cf. [tm-en:1062]) - - -Thu Oct 31 16:05:41 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.0.1 was released. - -Mon Oct 28 12:53:09 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-insert-encoded-file): New constant. - (q-encoding-encode-string): New implementation; Function - `q-encoding-encode-string-for-text', - `q-encoding-encode-string-for-comment' and - `q-encoding-encode-string-for-phrase' were abolished. - - -Mon Sep 23 16:53:19 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 6.0 was released. - - * mel.el (mime-file-encoding-method-alist): Use function - `insert-binary-file-contents-literally'. - - -Fri Aug 23 07:31:32 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 5.6.1 was released. - -Thu Aug 22 14:49:14 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL-ELS: Variable `mel-el-files' and `mel-elc-files' were - abolished. - -Thu Aug 22 14:47:45 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mk-mel: Variable `el-file-mode' was abolished. - Function `install-el', `install-el-files', `install-elc' and - `install-elc-files' were abolished. - (install-mel): Use function `install-elisp-modules'. - -Mon Aug 19 16:55:27 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mk-mel (compile-mel): Use function `compile-elisp-modules'. - -Mon Aug 19 16:53:14 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL-ELS (mel-modules): changed to list of symbols. - - * mk-mel: mel-els was renamed to MEL-ELS. - - -Thu Jun 27 22:28:57 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 5.6 was released. - -Wed Jun 26 16:25:13 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-g.el (gzip64-external-encode-region): regularize line break - code (for OS/2). - -Wed Jun 26 16:23:39 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-g.el (gzip64-external-encode-region): Use macro - `as-binary-process'. - (gzip64-external-decode-region): Use macro `as-binary-process'. - -Wed Jun 26 16:21:11 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el (uuencode-external-encode-region): regularize line - break code (for OS/2). - -Wed Jun 26 16:18:39 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el (uuencode-external-encode-region): Use macro - `as-binary-process'. - (uuencode-external-decode-region): Use macro `as-binary-process'. - -Wed Jun 26 16:13:39 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-external-encode-region): Use macro - `as-binary-process'. - (quoted-printable-external-decode-region): Use macro - `as-binary-process'. - - * mel-b.el (base64-external-encode-region): Use macro - `as-binary-process'. - (base64-external-decode-region): Use macro `as-binary-process'. - -Wed Jun 12 05:30:23 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 5.5 was released. - -Mon Jun 10 05:06:27 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (q-encoding-printable-char-p): New function. - - (q-encoding-encoded-length): Use function - `q-encoding-printable-char-p'. - - -Sun Jun 9 04:10:08 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 5.4 was released. - -Fri Jun 7 14:06:59 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-g.el (gzip64-external-encode-region): fixed. - (gzip64-external-decode-region): fixed. - -Fri Jun 7 14:04:09 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-external-encode-region): fixed. - (quoted-printable-external-decode-region): fixed. - -Fri Jun 7 12:12:47 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el (uuencode-external-encode-region): fixed. - (uuencode-external-decode-region): fixed. - -Thu Jun 6 08:46:55 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el (mime-file-encoding-method-alist): New variable. - (mime-insert-encoded-file): New function. - - * mel-g.el (gzip64-external-encode-region): fixed - `default-process-coding-system'. - - (gzip64-external-decode-region): fixed - `default-process-coding-system'. - -Thu Jun 6 07:51:30 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el (uuencode-external-encode-region): fixed - `default-process-coding-system'. - - (uuencode-external-decode-region): fixed - `default-process-coding-system'. - -Thu Jun 6 07:48:44 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-external-encode-region): fixed - `default-process-coding-system'. - - (quoted-printable-external-decode-region): fixed - `default-process-coding-system'. - -Thu Jun 6 07:09:23 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el (base64-external-encode-region): fixed - `default-process-coding-system'. - - (base64-external-decode-region): fixed - `default-process-coding-system'. - - -Mon Jun 3 14:43:47 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 5.2 was released. - -Wed May 29 12:54:45 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-g.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (gzip64-external-encode-region): set for process code. - (gzip64-external-decode-region): set for process code. - -Wed May 29 12:49:41 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (uuencode-external-encode-region): set for process code. - (uuencode-external-decode-region): set for process code. - -Wed May 29 12:40:12 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (quoted-printable-external-encode-region): set for process code. - (quoted-printable-external-decode-region): set for process code. - -Wed May 29 10:54:01 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el: Don't use function `define-program-coding-system' and - `define-program-kanji-code'. - (base64-external-encode-region): set for process code. - (base64-external-decode-region): set for process code. - -Wed May 29 08:10:15 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-g.el (gzip64-insert-encoded-file): New function. - -Wed May 29 08:00:01 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-g.el: Shuhei KOBAYASHI's address was changed. - - * mel-u.el (uuencode-insert-encoded-file): New function. - -Wed May 29 07:30:48 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (quoted-printable-insert-encoded-file): New function. - - * mel-b.el (base64-insert-encoded-file): New function. - - -Tue May 28 03:31:13 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 5.0 was released. - - * mel.el: Function `mime/encode-region' and `mime/decode-region' - were abolished. - - -Thu May 23 01:32:04 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 4.7.1 was released. - -Wed May 22 02:20:35 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel.el (mime-encode-region): New function; Order of arguments - was changed. - (mime-decode-region): New function; Order of arguments was - changed. - (mime/encode-region): New implementation. - (mime/decode-region): New implementation. - - -Wed May 15 21:19:12 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 4.7 was released. - - * mel-b.el (base64-internal-decode-region): fixed about last line - which does not have line break. - - -Tue May 14 02:43:41 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 4.6 was released. - -Sun May 12 17:43:04 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el (base64-decode-1): New spec; Argument was changed; - Return string instead of list of characters. - (base64-decode-string): modified for new spec of function - `base64-decode-1'. - (base64-internal-decode-region): fixed. - -Sun May 12 17:05:17 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el (base64-encode-1): New spec; Argument was changed; - Return string instead of list of characters. - (base64-encode-string): modified for new spec of function - `base64-encode-1'. - (base64-internal-decode-region): fixed. - -Sun May 12 16:17:11 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el: Function `base64-encode-chars' was abolished. - (base64-encode-1): New spec; use function `base64-num-to-char. - (base64-encode-string): Use function `base64-encode-1' instead of - `base64-encode-chars'. - -Sun May 12 15:50:26 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el: Function `base64-decode-chars' was abolished. - (base64-decode-1): New spec; use function `base64-char-to-num'. - (base64-decode-string): Use function `base64-decode-1' instead of - `base64-decode-chars'. - - -Sat May 11 08:12:23 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 4.2 was released. - - * mel-b.el (base64-encode-1): don't use function `base64-mask'. - Function `base64-mask' was abolished. - -Sat May 11 07:52:05 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el (base64-decode-1): don't use function `base64-mask'. - -Sat May 11 06:35:20 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-b.el (base64-internal-decode-region): New implementation. - - -Wed Mar 13 16:40:46 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 3.5 was released. - -Mon Mar 11 14:29:31 1996 MORIOKA Tomohiko <morioka@jaist.ac.jp> - - * mel-q.el (byte-to-hex-string): New function. - -Tue Mar 12 11:19:02 1996 Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp> - - * mel-els (mel-modules): "mel-g" was added. (cf.[tm-ja:1661]) - - * mel.el: gzip64 support was added. (cf.[tm-ja:1661]) - - * mel-g.el: New file. - gzip64 encoder/decoder. `gzip64' is an experimental encoding. - (cf.[tm-ja:1661]) - - -Mon Mar 4 09:13:20 1996 Morioka Tomohiko <morioka@jaist.ac.jp> - - * MEL: Version 3.3.1 was released. - - * mel-els: New module - - * mk-mel: use mel-els file. - -Thu Jan 18 10:26:38 1996 Morioka Tomohiko <morioka@jaist.ac.jp> - - * Makefile: Yoshiyuki Yamagami <yamagami@hb.nmcc.co.jp>'s patch - was applied to specify `-no-site-file' option. (cf. [tm-ja:1474]) - -Thu Jan 18 01:55:25 1996 Yoshiyuki Yamagami <yamagami@hb.nmcc.co.jp> - - * Makefile: specify `-no-site-file' option (cf. [tm-ja:1474]) - - -Wed Jan 9 19:09:44 1996 Morioka Tomohiko <morioka@jaist.ac.jp> - - * MEL: version 3.3 was released. - -Tue Jan 9 18:25:22 1996 Morioka Tomohiko <morioka@jaist.ac.jp> - - * mel-u.el (uuencode-external-decode-region): - don't display uuencode output. - (cf. [tm-en:253])
--- a/lisp/mel/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'mel-autoloads) (error "Already loaded")) - -;;;### (autoloads (mime-insert-encoded-file mime-decode-region mime-encode-region) "mel" "mel/mel.el") - -(autoload 'mime-encode-region "mel" "\ -Encode region START to END of current buffer using ENCODING." t nil) - -(autoload 'mime-decode-region "mel" "\ -Decode region START to END of current buffer using ENCODING." t nil) - -(autoload 'mime-insert-encoded-file "mel" "\ -Insert file FILENAME encoded by ENCODING format." t nil) - -;;;*** - -(provide 'mel-autoloads)
--- a/lisp/mel/mel-b.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,309 +0,0 @@ -;;; mel-b.el: Base64 encoder/decoder for GNU Emacs - -;; Copyright (C) 1992,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/6/24 -;; Version: $Id: mel-b.el,v 1.3 1997/06/06 00:57:14 steve Exp $ -;; Keywords: MIME, Base64 - -;; This file is part of MEL (MIME Encoding Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) - - -;;; @ variables -;;; - -(defvar base64-external-encoder '("mmencode") - "*list of base64 encoder program name and its arguments.") - -(defvar base64-external-decoder '("mmencode" "-u") - "*list of base64 decoder program name and its arguments.") - -(defvar base64-internal-encoding-limit 1000 - "*limit size to use internal base64 encoder. -If size of input to encode is larger than this limit, -external encoder is called.") - -(defvar base64-internal-decoding-limit 1000 - "*limit size to use internal base64 decoder. -If size of input to decode is larger than this limit, -external decoder is called.") - - -;;; @ internal base64 decoder/encoder -;;; based on base64 decoder by Enami Tsugutomo - -;;; @@ convert from/to base64 char -;;; - -(defun base64-num-to-char (n) - (cond ((eq n nil) ?=) - ((< n 26) (+ ?A n)) - ((< n 52) (+ ?a (- n 26))) - ((< n 62) (+ ?0 (- n 52))) - ((= n 62) ?+) - ((= n 63) ?/) - (t (error "not a base64 integer %d" n)))) - -(defun base64-char-to-num (c) - (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A)) - ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26)) - ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52)) - ((= c ?+) 62) - ((= c ?/) 63) - ((= c ?=) nil) - (t (error "not a base64 character %c" c)))) - - -;;; @@ encode/decode one base64 unit -;;; - -(defun base64-encode-1 (pack) - (let ((a (car pack)) - (b (nth 1 pack)) - (c (nth 2 pack))) - (concat - (char-to-string (base64-num-to-char (ash a -2))) - (if b - (concat - (char-to-string - (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4)))) - (if c - (concat - (char-to-string - (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6)))) - (char-to-string (base64-num-to-char (logand c 63))) - ) - (concat (char-to-string - (base64-num-to-char (ash (logand b 15) 2))) "=") - )) - (concat (char-to-string - (base64-num-to-char (ash (logand a 3) 4))) "==") - )))) - -(defun base64-decode-1 (pack) - (let ((a (base64-char-to-num (car pack))) - (b (base64-char-to-num (nth 1 pack))) - (c (nth 2 pack)) - (d (nth 3 pack))) - (concat (char-to-string (logior (ash a 2) (ash b -4))) - (if (and c (setq c (base64-char-to-num c))) - (concat (char-to-string - (logior (ash (logand b 15) 4) (ash c -2))) - (if (and d (setq d (base64-char-to-num d))) - (char-to-string (logior (ash (logand c 3) 6) d)) - )))))) - - -;;; @@ base64 encoder/decoder for string -;;; - -(defun base64-encode-string (string) - "Encode STRING to base64, and return the result." - (let ((len (length string)) - (b 0)(e 57) - dest) - (while (< e len) - (setq dest - (concat dest - (mapconcat - (function base64-encode-1) - (pack-sequence (substring string b e) 3) - "") - "\n")) - (setq b e - e (+ e 57) - ) - ) - (let* ((es (mapconcat - (function base64-encode-1) - (pack-sequence (substring string b) 3) - "")) - (m (mod (length es) 4)) - ) - (concat dest es (cond ((= m 3) "=") - ((= m 2) "==") - )) - ))) - -(defun base64-decode-string (string) - "Decode STRING which is encoded in base64, and return the result." - (mapconcat (function base64-decode-1) - (pack-sequence string 4) - "")) - - -;;; @ base64 encoder/decoder for region -;;; - -(defun base64-internal-encode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let ((str (buffer-substring beg end))) - (delete-region beg end) - (insert (base64-encode-string str)) - ) - (or (bolp) - (insert "\n") - ) - ))) - -(defun base64-internal-decode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (looking-at ".*\n") - (condition-case err - (replace-match - (base64-decode-string - (buffer-substring (match-beginning 0) (1- (match-end 0)))) - t t) - (error - (prog1 - (message (nth 1 err)) - (replace-match ""))))) - (if (looking-at ".*$") - (condition-case err - (replace-match - (base64-decode-string - (buffer-substring (match-beginning 0) (match-end 0))) - t t) - (error - (prog1 - (message (nth 1 err)) - (replace-match ""))) - )) - ))) - -(defun base64-external-encode-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (as-binary-process (apply (function call-process-region) - beg end (car base64-external-encoder) - t t nil (cdr base64-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - ))) - -(defun base64-external-decode-region (beg end) - (save-excursion - (as-binary-process (apply (function call-process-region) - beg end (car base64-external-decoder) - t t nil (cdr base64-external-decoder)) - ))) - -(defun base64-encode-region (start end) - "Encode current region by base64. -START and END are buffer positions. -This function calls internal base64 encoder if size of region is -smaller than `base64-internal-encoding-limit', otherwise it calls -external base64 encoder specified by `base64-external-encoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-encoding-limit - (> (- end start) base64-internal-encoding-limit)) - (base64-external-encode-region start end) - (base64-internal-encode-region start end) - )) - -(defun base64-decode-region (start end) - "Decode current region by base64. -START and END are buffer positions. -This function calls internal base64 decoder if size of region is -smaller than `base64-internal-decoding-limit', otherwise it calls -external base64 decoder specified by `base64-external-decoder'. In -this case, you must install the program (maybe mmencode included in -metamail or XEmacs package)." - (interactive "r") - (if (and base64-internal-decoding-limit - (> (- end start) base64-internal-decoding-limit)) - (base64-external-decode-region start end) - (base64-internal-decode-region start end) - )) - - -;;; @ base64 encoder/decoder for file -;;; - -(defun base64-insert-encoded-file (filename) - "Encode contents of file FILENAME to base64, and insert the result. -It calls external base64 encoder specified by -`base64-external-encoder'. So you must install the program (maybe -mmencode included in metamail or XEmacs package)." - (interactive (list (read-file-name "Insert encoded file: "))) - (apply (function call-process) (car base64-external-encoder) - filename t nil (cdr base64-external-encoder)) - ) - - -;;; @ etc -;;; - -(defun base64-encoded-length (string) - (let ((len (length string))) - (* (+ (/ len 3) - (if (= (mod len 3) 0) 0 1) - ) 4) - )) - -(defun pack-sequence (seq size) - "Split sequence SEQ into SIZE elements packs, -and return list of packs. [mel-b; tl-seq function]" - (let ((len (length seq)) (p 0) obj - unit (i 0) - dest) - (while (< p len) - (setq obj (elt seq p)) - (setq unit (cons obj unit)) - (setq i (1+ i)) - (if (= i size) - (progn - (setq dest (cons (reverse unit) dest)) - (setq unit nil) - (setq i 0) - )) - (setq p (1+ p)) - ) - (if unit - (setq dest (cons (reverse unit) dest)) - ) - (reverse dest) - )) - - -;;; @ end -;;; - -(provide 'mel-b) - -;;; mel-b.el ends here.
--- a/lisp/mel/mel-g.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -;;; mel-g.el: Gzip64 encoder/decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko -;; Copyright (C) 1996 Shuhei KOBAYASHI - -;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Created: 1995/10/25 -;; Version: $Id: mel-g.el,v 1.5 1997/03/16 03:05:14 steve Exp $ -;; Keywords: Gzip64, base64, gzip, MIME - -;; This file is not part of MEL (MIME Encoding Library) yet. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'file-detect) - - -;;; @ variables -;;; - -(defvar gzip64-external-encoder - (let ((file (exec-installed-p "mmencode"))) - (and file - (` ("sh" "-c" (, (concat "gzip -c | " file)))) - )) - "*list of gzip64 encoder program name and its arguments.") - -(defvar gzip64-external-decoder - (let ((file (exec-installed-p "mmencode"))) - (and file - (` ("sh" "-c" (, (concat file " -u | gzip -dc")))) - )) - "*list of gzip64 decoder program name and its arguments.") - - -;;; @ encoder/decoder for region -;;; - -(defun gzip64-external-encode-region (beg end) - (interactive "*r") - (save-excursion - (as-binary-process (apply (function call-process-region) - beg end (car gzip64-external-encoder) - t t nil (cdr gzip64-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - )) - -(defun gzip64-external-decode-region (beg end) - (interactive "*r") - (save-excursion - (as-binary-process (apply (function call-process-region) - beg end (car gzip64-external-decoder) - t t nil (cdr gzip64-external-decoder)) - ) - )) - -(defalias 'gzip64-encode-region 'gzip64-external-encode-region) -(defalias 'gzip64-decode-region 'gzip64-external-decode-region) - - -;;; @ encoder/decoder for file -;;; - -(defun gzip64-insert-encoded-file (filename) - (interactive (list (read-file-name "Insert encoded file: "))) - (apply (function call-process) (car gzip64-external-encoder) - filename t nil - (cdr gzip64-external-encoder)) - ) - - -;;; @ end -;;; - -(provide 'mel-g) - -;;; mel-g.el ends here.
--- a/lisp/mel/mel-q.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,335 +0,0 @@ -;;; mel-q.el: Quoted-Printable and Q-encoding encoder/decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/6/25 -;; Version: $Id: mel-q.el,v 1.5 1997/07/26 22:09:47 steve Exp $ -;; Keywords: MIME, Quoted-Printable, Q-encoding - -;; This file is part of MEL (MIME Encoding Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) - - -;;; @ Quoted-Printable encoder -;;; - -(defconst quoted-printable-hex-chars "0123456789ABCDEF") - -(defsubst quoted-printable-quote-char (character) - (concat - "=" - (char-to-string (aref quoted-printable-hex-chars (ash character -4))) - (char-to-string (aref quoted-printable-hex-chars (logand character 15))) - )) - -(defun quoted-printable-internal-encode-region (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (let ((col 0) - enable-multibyte-characters) - (while (< (point)(point-max)) - (cond ((>= col 75) - (insert "=\n") - (setq col 0) - ) - ((looking-at "^From ") - (replace-match "=46rom ") - (backward-char 1) - (setq col (+ col 6)) - ) - ((looking-at "[ \t]\n") - (forward-char 1) - (insert "=\n") - (forward-char 1) - (setq col 0) - ) - (t - (let ((chr (char-after (point)))) - (cond ((= chr ?\n) - (forward-char 1) - (setq col 0) - ) - ((or (= chr ?\t) - (and (<= 32 chr)(/= chr ?=)(< chr 127)) - ) - (forward-char 1) - (setq col (1+ col)) - ) - ((>= col 73) - (insert "=\n") - (setq col 0) - ) - (t - (delete-char 1) - (insert (quoted-printable-quote-char chr)) - (setq col (+ col 3)) - )) - ))) - ))))) - -(defvar quoted-printable-external-encoder '("mmencode" "-q") - "*list of quoted-printable encoder program name and its arguments.") - -(defun quoted-printable-external-encode-region (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (as-binary-process - (apply (function call-process-region) - start end (car quoted-printable-external-encoder) - t t nil (cdr quoted-printable-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - ))) - -(defvar quoted-printable-internal-encoding-limit - (if (and (featurep 'xemacs)(featurep 'mule)) - 0 - (require 'file-detect) - (if (exec-installed-p "mmencode") - 1000 - (message "Don't found external encoder for Quoted-Printable!") - nil)) - "*limit size to use internal quoted-printable encoder. -If size of input to encode is larger than this limit, -external encoder is called.") - -(defun quoted-printable-encode-region (start end) - "Encode current region by quoted-printable. -START and END are buffer positions. -This function calls internal quoted-printable encoder if size of -region is smaller than `quoted-printable-internal-encoding-limit', -otherwise it calls external quoted-printable encoder specified by -`quoted-printable-external-encoder'. In this case, you must install -the program (maybe mmencode included in metamail or XEmacs package)." - (interactive "r") - (if (and quoted-printable-internal-encoding-limit - (> (- end start) quoted-printable-internal-encoding-limit)) - (quoted-printable-external-encode-region start end) - (quoted-printable-internal-encode-region start end) - )) - -(defun quoted-printable-encode-string (string) - "Encode STRING to quoted-printable, and return the result." - (with-temp-buffer - (insert string) - (quoted-printable-encode-region (point-min)(point-max)) - (buffer-string) - )) - -(defun quoted-printable-insert-encoded-file (filename) - "Encode contents of file FILENAME to quoted-printable, and insert the result. -It calls external quoted-printable encoder specified by -`quoted-printable-external-encoder'. So you must install the program -\(maybe mmencode included in metamail or XEmacs package)." - (interactive (list (read-file-name "Insert encoded file: "))) - (apply (function call-process) (car quoted-printable-external-encoder) - filename t nil (cdr quoted-printable-external-encoder)) - ) - - -;;; @ Quoted-Printable decoder -;;; - -(defun quoted-printable-decode-string (string) - "Decode STRING which is encoded in quoted-printable, and return the result." - (let (q h l) - (mapconcat (function - (lambda (chr) - (cond ((eq chr ?=) - (setq q t) - "") - (q (setq h - (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (setq q nil) - "") - (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (prog1 - (char-to-string (logior (ash h 4) l)) - (setq h nil) - ) - ) - (t (char-to-string chr)) - ))) - string ""))) - -(defconst quoted-printable-octet-regexp - (concat "=[" quoted-printable-hex-chars - "][" quoted-printable-hex-chars "]")) - -(defun quoted-printable-internal-decode-region (start end) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (re-search-forward "=\n" nil t) - (replace-match "") - ) - (goto-char (point-min)) - (let (b e str) - (while (re-search-forward quoted-printable-octet-regexp nil t) - (setq b (match-beginning 0)) - (setq e (match-end 0)) - (setq str (buffer-substring b e)) - (delete-region b e) - (insert (quoted-printable-decode-string str)) - )) - ))) - -(defvar quoted-printable-external-decoder '("mmencode" "-q" "-u") - "*list of quoted-printable decoder program name and its arguments.") - -(defun quoted-printable-external-decode-region (start end) - (save-excursion - (as-binary-process - (apply (function call-process-region) - start end (car quoted-printable-external-decoder) - t t nil (cdr quoted-printable-external-decoder)) - ))) - -(defvar quoted-printable-internal-decoding-limit nil - "*limit size to use internal quoted-printable decoder. -If size of input to decode is larger than this limit, -external decoder is called.") - -(defun quoted-printable-decode-region (start end) - "Decode current region by quoted-printable. -START and END are buffer positions. -This function calls internal quoted-printable decoder if size of -region is smaller than `quoted-printable-internal-decoding-limit', -otherwise it calls external quoted-printable decoder specified by -`quoted-printable-external-decoder'. In this case, you must install -the program (maybe mmencode included in metamail or XEmacs package)." - (interactive "r") - (if (and quoted-printable-internal-decoding-limit - (> (- end start) quoted-printable-internal-decoding-limit)) - (quoted-printable-external-decode-region start end) - (quoted-printable-internal-decode-region start end) - )) - - -;;; @ Q-encoding encode/decode string -;;; - -(defconst q-encoding-special-chars-alist - '((text ?= ?? ?_) - (comment ?= ?? ?_ ?\( ?\) ?\\) - (phrase ?= ?? ?_ ?\( ?\) ?\\ ?\" ?# ?$ ?% ?& ?' ?, ?. ?/ - ?: ?\; ?< ?> ?@ ?\[ ?\] ?^ ?` ?{ ?| ?} ?~) - )) - -(defun q-encoding-encode-string (string &optional mode) - "Encode STRING to Q-encoding of encoded-word, and return the result. -MODE allows `text', `comment', `phrase' or nil. Default value is -`phrase'." - (let ((specials (cdr (or (assq mode q-encoding-special-chars-alist) - (assq 'phrase q-encoding-special-chars-alist) - )))) - (mapconcat (function - (lambda (chr) - (cond ((eq chr ? ) "_") - ((or (< chr 32) (< 126 chr) - (memq chr specials) - ) - (quoted-printable-quote-char chr) - ) - (t - (char-to-string chr) - )) - )) - string "") - )) - -(defun q-encoding-decode-string (string) - "Decode STRING which is encoded in Q-encoding and return the result." - (let (q h l) - (mapconcat (function - (lambda (chr) - (cond ((eq chr ?_) " ") - ((eq chr ?=) - (setq q t) - "") - (q (setq h (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (setq q nil) - "") - (h (setq l (cond ((<= ?a chr) (+ (- chr ?a) 10)) - ((<= ?A chr) (+ (- chr ?A) 10)) - ((<= ?0 chr) (- chr ?0)) - )) - (prog1 - (char-to-string (logior (ash h 4) l)) - (setq h nil) - ) - ) - (t (char-to-string chr)) - ))) - string ""))) - - -;;; @@ etc -;;; - -(defun q-encoding-printable-char-p (chr mode) - (and (not (memq chr '(?= ?? ?_))) - (<= ?\ chr)(<= chr ?~) - (cond ((eq mode 'text) t) - ((eq mode 'comment) - (not (memq chr '(?\( ?\) ?\\))) - ) - (t - (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr)) - )))) - -(defun q-encoding-encoded-length (string &optional mode) - (let ((l 0)(i 0)(len (length string)) chr) - (while (< i len) - (setq chr (elt string i)) - (if (q-encoding-printable-char-p chr mode) - (setq l (+ l 1)) - (setq l (+ l 3)) - ) - (setq i (+ i 1)) ) - l)) - - -;;; @ end -;;; - -(provide 'mel-q) - -;;; mel-q.el ends here
--- a/lisp/mel/mel-u.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -;;; mel-u.el: uuencode encoder/decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/10/25 -;; Version: $Id: mel-u.el,v 1.5 1997/07/26 22:09:47 steve Exp $ -;; Keywords: uuencode - -;; This file is part of MEL (MIME Encoding Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'mel) - - -;;; @ variables -;;; - -(defvar uuencode-external-encoder '("uuencode" "-") - "*list of uuencode encoder program name and its arguments.") - -(defvar uuencode-external-decoder - (list "sh" "-c" (format "(cd %s; uudecode)" mime-temp-directory)) - "*list of uuencode decoder program name and its arguments.") - - -;;; @ uuencode encoder/decoder for region -;;; - -(defun uuencode-external-encode-region (start end) - "Encode current region by unofficial uuencode format. -This function uses external uuencode encoder which is specified by -variable `uuencode-external-encoder'." - (interactive "*r") - (save-excursion - (as-binary-process (apply (function call-process-region) - start end (car uuencode-external-encoder) - t t nil (cdr uuencode-external-encoder)) - ) - ;; for OS/2 - ;; regularize line break code - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - )) - -(defun uuencode-external-decode-region (start end) - "Decode current region by unofficial uuencode format. -This function uses external uuencode decoder which is specified by -variable `uuencode-external-decoder'." - (interactive "*r") - (save-excursion - (let ((filename (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0) - (match-end 0)) - )))))) - (if filename - (as-binary-process - (apply (function call-process-region) - start end (car uuencode-external-decoder) - t nil nil (cdr uuencode-external-decoder)) - (setq filename (expand-file-name filename mime-temp-directory)) - (as-binary-input-file (insert-file-contents filename)) - ;; The previous line causes the buffer to be made read-only, I - ;; do not pretend to understand the control flow leading to this - ;; but suspect it has something to do with image-mode. -slb - ;; Use `inhibit-read-only' to avoid to force - ;; buffer-read-only nil. - tomo. - (let ((inhibit-read-only t)) - (delete-file filename) - ) - )) - ))) - -(defalias 'uuencode-encode-region 'uuencode-external-encode-region) -(defalias 'uuencode-decode-region 'uuencode-external-decode-region) - - -;;; @ uuencode encoder/decoder for file -;;; - -(defun uuencode-insert-encoded-file (filename) - "Insert file encoded by unofficial uuencode format. -This function uses external uuencode encoder which is specified by -variable `uuencode-external-encoder'." - (interactive (list (read-file-name "Insert encoded file: "))) - (call-process (car uuencode-external-encoder) filename t nil - (file-name-nondirectory filename)) - ) - - -;;; @ end -;;; - -(provide 'mel-u) - -;;; mel-u.el ends here
--- a/lisp/mel/mel.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -;;; mel.el : a MIME encoding/decoding library - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; modified by Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Created: 1995/6/25 -;; Version: $Id: mel.el,v 1.5 1997/07/26 22:09:47 steve Exp $ -;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64 - -;; This file is part of MEL (MIME Encoding Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;;; @ variable -;;; - -(defvar mime-temp-directory (or (getenv "MIME_TMP_DIR") - (getenv "TM_TMP_DIR") - "/tmp/") - "*Directory for temporary files.") - - -;;; @ region -;;; - -(autoload 'base64-encode-region - "mel-b" "Encode current region by base64." t) -(autoload 'quoted-printable-encode-region - "mel-q" "Encode current region by Quoted-Printable." t) -(autoload 'uuencode-encode-region - "mel-u" "Encode current region by unofficial uuencode format." t) -(autoload 'gzip64-encode-region - "mel-g" "Encode current region by unofficial x-gzip64 format." t) - -(defvar mime-encoding-method-alist - '(("base64" . base64-encode-region) - ("quoted-printable" . quoted-printable-encode-region) - ("x-uue" . uuencode-encode-region) - ("x-gzip64" . gzip64-encode-region) - ("7bit") - ("8bit") - ("binary") - ) - "Alist of encoding vs. corresponding method to encode region. -Each element looks like (STRING . FUNCTION) or (STRING . nil). -STRING is content-transfer-encoding. -FUNCTION is region encoder and nil means not to encode.") - - -(autoload 'base64-decode-region - "mel-b" "Decode current region by base64." t) -(autoload 'quoted-printable-decode-region - "mel-q" "Decode current region by Quoted-Printable." t) -(autoload 'uuencode-decode-region - "mel-u" "Decode current region by unofficial uuencode format." t) -(autoload 'gzip64-decode-region - "mel-g" "Decode current region by unofficial x-gzip64 format." t) - -(defvar mime-decoding-method-alist - '(("base64" . base64-decode-region) - ("quoted-printable" . quoted-printable-decode-region) - ("x-uue" . uuencode-decode-region) - ("x-uuencode" . uuencode-decode-region) - ("x-gzip64" . gzip64-decode-region) - ) - "Alist of encoding vs. corresponding method to decode region. -Each element looks like (STRING . FUNCTION). -STRING is content-transfer-encoding. -FUNCTION is region decoder.") - - -;;;###autoload -(defun mime-encode-region (start end encoding) - "Encode region START to END of current buffer using ENCODING." - (interactive - (list (region-beginning) (region-end) - (completing-read "encoding: " - mime-encoding-method-alist - nil t "base64")) - ) - (let ((f (cdr (assoc encoding mime-encoding-method-alist)))) - (if f - (funcall f start end) - ))) - -;;;###autoload -(defun mime-decode-region (start end encoding) - "Decode region START to END of current buffer using ENCODING." - (interactive - (list (region-beginning) (region-end) - (completing-read "encoding: " - mime-decoding-method-alist - nil t "base64")) - ) - (let ((f (cdr (assoc encoding mime-decoding-method-alist)))) - (if f - (funcall f start end) - ))) - - -;;; @ file -;;; - -(autoload 'base64-insert-encoded-file "mel-b" - "Encode contents of file to base64, and insert the result." t) -(autoload 'quoted-printable-insert-encoded-file "mel-q" - "Encode contents of file to quoted-printable, and insert the result." t) -(autoload 'uuencode-insert-encoded-file - "mel-u" "Insert file encoded by unofficial uuencode format." t) -(autoload 'gzip64-insert-encoded-file - "mel-g" "Insert file encoded by unofficial gzip64 format." t) - -(defvar mime-file-encoding-method-alist - '(("base64" . base64-insert-encoded-file) - ("quoted-printable" . quoted-printable-insert-encoded-file) - ("x-uue" . uuencode-insert-encoded-file) - ("x-gzip64" . gzip64-insert-encoded-file) - ("7bit" . insert-binary-file-contents-literally) - ("8bit" . insert-binary-file-contents-literally) - ("binary" . insert-binary-file-contents-literally) - ) - "Alist of encoding vs. corresponding method to insert encoded file. -Each element looks like (STRING . FUNCTION). -STRING is content-transfer-encoding. -FUNCTION is function to insert encoded file.") - -;;;###autoload -(defun mime-insert-encoded-file (filename encoding) - "Insert file FILENAME encoded by ENCODING format." - (interactive - (list (read-file-name "Insert encoded file: ") - (completing-read "encoding: " - mime-encoding-method-alist - nil t "base64")) - ) - (let ((f (cdr (assoc encoding mime-file-encoding-method-alist)))) - (if f - (funcall f filename) - ))) - - -;;; @ string -;;; - -(autoload 'base64-encode-string "mel-b" - "Encode STRING to base64, and return the result.") -(autoload 'base64-decode-string "mel-b" - "Decode STRING which is encoded in base64, and return the result.") -(autoload 'quoted-printable-encode-string "mel-q" - "Encode STRING to quoted-printable, and return the result.") -(autoload 'quoted-printable-decode-string "mel-q" - "Decode STRING which is encoded in quoted-printable, and return the result.") - -(autoload 'q-encoding-encode-string "mel-q" - "Encode STRING to Q-encoding of encoded-word, and return the result.") -(autoload 'q-encoding-decode-string "mel-q" - "Decode STRING which is encoded in Q-encoding and return the result.") - -(autoload 'base64-encoded-length "mel-b") -(autoload 'q-encoding-encoded-length "mel-q") - - -;;; @ end -;;; - -(provide 'mel) - -;;; mel.el ends here.
--- a/lisp/modes/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -228,6 +228,42 @@ ;;;*** +;;;### (autoloads (c-comment-edit) "c-comment" "modes/c-comment.el") + +(autoload 'c-comment-edit "c-comment" "\ +Edit multi-line C comments. +This command allows the easy editing of a multi-line C comment like this: + /* + * ... + * ... + */ +The comment may be indented or flush with the left margin. + +If point is within a comment, that comment is used. Otherwise the +comment to be edited is found by searching forward from point. + +With one \\[universal-argument] searching starts after moving back one + paragraph. +With two \\[universal-argument]'s searching starts at the beginning of the + current or proceeding C function. +With three \\[universal-argument]'s searching starts at the beginning of the + current page. +With four \\[universal-argument]'s searching starts at the beginning of the + current buffer (clipping restrictions apply). + +Once located, the comment is copied into a temporary buffer, the comment +leaders and delimiters are stripped away and the resulting buffer is +selected for editing. The major mode of this buffer is controlled by +the variable `c-comment-edit-mode'.\\<c-comment-edit-map> + +Use \\[c-comment-edit-end] when you have finished editing the comment. The +comment will be inserted into the original buffer with the appropriate +delimiters and indention, replacing the old version of the comment. If +you don't want your edited version of the comment to replace the +original, use \\[c-comment-edit-abort]." t nil) + +;;;*** + ;;;### (autoloads (common-lisp-indent-function) "cl-indent" "modes/cl-indent.el") (autoload 'common-lisp-indent-function "cl-indent" nil nil nil) @@ -707,7 +743,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.12 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.13 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -1286,7 +1322,7 @@ ;;;*** -;;;### (autoloads (reftex-add-to-label-alist reftex-mode turn-on-reftex) "reftex" "modes/reftex.el") +;;;### (autoloads (reftex-mode turn-on-reftex) "reftex" "modes/reftex.el") (autoload 'turn-on-reftex "reftex" "\ Turn on RefTeX minor mode." nil nil) @@ -1299,7 +1335,7 @@ context of the label definition. The selected label is inserted as a \\ref macro. -Citations can be made with `\\[reftex-citation]' which will use a regular expression +Citations can be made with `\\[reftex-citation]' which will use a regular expression to pull out a *formatted* list of articles from your BibTeX database. The selected citation is inserted as a \\cite macro. @@ -1309,24 +1345,15 @@ Most command have help available on the fly. This help is accessed by pressing `?' to any prompt mentioning this feature. -Extensive documentation about reftex is in the file header of `reftex.el'. +Extensive documentation about RefTeX is in the file header of `reftex.el'. +You can view this information with `\\[reftex-show-commentary]'. \\{reftex-mode-map} -Under X, these functions will also be available in a menu on the menu bar. +Under X, these and other functions will also be available as `Ref' menu +on the menu bar. ------------------------------------------------------------------------------" t nil) -(autoload 'reftex-add-to-label-alist "reftex" "\ -Add label environment descriptions to `reftex-label-alist-external-add-ons'. -The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there -for details. -This function makes it possible to support RefTeX from AUCTeX style files. -The entries in ENTRY-LIST will be processed after the user settings in -`reftex-label-alist', and before the defaults (specified in -`reftex-default-label-alist-entries'). Any changes made to -`reftex-label-alist-external-add-ons' will raise a flag to the effect that a -mode reset is done on the next occasion." nil nil) - ;;;*** ;;;### (autoloads (rexx-mode) "rexx-mode" "modes/rexx-mode.el") @@ -2019,7 +2046,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.12 $ +vhdl-mode $Revision: 1.13 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the
--- a/lisp/modes/c-comment.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/c-comment.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,20 +1,47 @@ ;;; c-comment.el --- edit C comments -;; Keywords: c +;; Copyright (C) 1987, 1988, 1989 Kyle E. Jones +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Kyle Jones <kyle_jones@wonderworks.com> +;; Maintainer: XEmacs Development Team +;; Keywords: languages + +;; This file is part of XEmacs. -;;; Copyright (C) 1987, 1988, 1989 Kyle E. Jones -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. +;; XEmacs 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. + +;; XEmacs 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: + +;; +;; Verbatim copies of this file may be freely redistributed. +;; +;; Modified versions of this file may be redistributed provided that this +;; notice remains unchanged, the file contains prominent notice of +;; author and time of modifications, and redistribution of the file +;; is not further restricted in any way. +;; +;; This file is distributed `as is', without warranties of any kind. + +;; sb [23-Oct-1997] Put into standard format, fixed an autoload cookie. + +;;; Code: + (provide 'c-comment-edit) (defvar c-comment-leader " *" @@ -56,8 +83,15 @@ (defmacro marker (pos &optional buffer) (list 'set-marker '(make-marker) pos buffer)) +(defvar c-comment-edit-map nil "Key map for c-comment-edit buffers") +(if c-comment-edit-map + nil + (setq c-comment-edit-map (make-sparse-keymap)) + (define-key c-comment-edit-map [(meta control c)] 'c-comment-edit-end) + (define-key c-comment-edit-map [(control c) (control c)] 'c-comment-edit-end) + (define-key c-comment-edit-map [(control c) (control ?\])] 'c-comment-edit-abort)) -;;;### autoload +;;;###autoload (defun c-comment-edit (search-prefix) "Edit multi-line C comments. This command allows the easy editing of a multi-line C comment like this: @@ -82,7 +116,7 @@ Once located, the comment is copied into a temporary buffer, the comment leaders and delimiters are stripped away and the resulting buffer is selected for editing. The major mode of this buffer is controlled by -the variable `c-comment-edit-mode'. +the variable `c-comment-edit-mode'.\\<c-comment-edit-map> Use \\[c-comment-edit-end] when you have finished editing the comment. The comment will be inserted into the original buffer with the appropriate @@ -157,7 +191,8 @@ (delete-char 1)) ;; restore cursor if possible (goto-char (or marker (point-min))) - (set-buffer-modified-p nil)) + (set-buffer-modified-p nil) + (use-local-map c-comment-edit-map c-comment-buffer)) ;; run user hook, if present. (if c-comment-edit-hook (funcall c-comment-edit-hook)) @@ -293,9 +328,5 @@ (if (eq (car (car list)) buffer) (throw 'return-value (car list)) (setq list (cdr list))))))) - -;; keys; -(define-key mode-specific-map "\e" 'c-comment-edit-end) -(define-key mode-specific-map "\C-]" 'c-comment-edit-abort) - +;;; c-comment.el ends here
--- a/lisp/modes/cperl-mode.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/cperl-mode.el Mon Aug 13 10:03:52 2007 +0200 @@ -37,7 +37,7 @@ ;;; Karl M. Hegbloom <karlheg@inetarena.com> ;; Original Vendor Version Number: (mostly based on...) -;; $Id: cperl-mode.el,v 1.14 1997/10/12 01:39:40 steve Exp $ +;; $Id: cperl-mode.el,v 1.15 1997/10/31 14:52:54 steve Exp $ ;; Increment the final digit once per XEmacs-only revision, the other ;; for merges. (sound ok?) @@ -632,7 +632,9 @@ :group 'cperl-faces) (defface cperl-here-face - '(( ((class color)) (:foreground "green") )) + '((((type x) (class color) (background light)) + (:foreground "green4" :background "grey85")) + (t (:foreground "green"))) "*The result of evaluation of this expression is used for here-docs highlighting." :group 'cperl-faces)
--- a/lisp/modes/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,73 +1,72 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:16 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("auto-show" "strokes")) -(custom-put 'message 'custom-loads '("sendmail")) -(custom-put 'prolog 'custom-loads '("prolog")) -(custom-put 'auto-show 'custom-loads '("auto-show")) -(custom-put 'mouse 'custom-loads '("outl-mouse" "strokes")) -(custom-put 'mail-abbrevs 'custom-loads '("mail-abbrevs")) -(custom-put 'pascal 'custom-loads '("pascal")) -(custom-put 'tex 'custom-loads '("reftex" "texinfo")) -(custom-put 'tcl 'custom-loads '("tcl")) -(custom-put 'icon 'custom-loads '("icon")) -(custom-put 'texinfo 'custom-loads '("texinfo")) -(custom-put 'xrdb 'custom-loads '("xrdb-mode")) -(custom-put 'mail 'custom-loads '("mail-abbrevs")) -(custom-put 'fortran-indent 'custom-loads '("fortran")) -(custom-put 'docs 'custom-loads '("texinfo")) -(custom-put 'lisp-indent 'custom-loads '("cl-indent")) -(custom-put 'tools 'custom-loads '("hideshow" "lazy-shot" "make-mode")) -(custom-put 'lisp 'custom-loads '("lisp-mode" "cl-indent" "strokes")) -(custom-put 'reftex 'custom-loads '("reftex")) -(custom-put 'outlines 'custom-loads '("hideshow" "outl-mouse" "whitespace-mode")) -(custom-put 'f90 'custom-loads '("f90")) -(custom-put 'perl 'custom-loads '("cperl-mode")) -(custom-put 'asm 'custom-loads '("asm-mode")) -(custom-put 'ada 'custom-loads '("ada-mode")) -(custom-put 'reftex-label-support 'custom-loads '("reftex")) -(custom-put 'data 'custom-loads '("arc-mode" "xrdb-mode")) -(custom-put 'fortran-comment 'custom-loads '("fortran")) -(custom-put 'outl-mouse 'custom-loads '("outl-mouse")) -(custom-put 'frames 'custom-loads '("rsz-minibuf")) -(custom-put 'cperl-electric 'custom-loads '("cperl-mode")) -(custom-put 'verilog 'custom-loads '("verilog-mode")) -(custom-put 'abbrev 'custom-loads '("abbrev")) -(custom-put 'f90-indent 'custom-loads '("f90")) -(custom-put 'strokes 'custom-loads '("strokes")) -(custom-put 'lazy-shot 'custom-loads '("lazy-shot")) -(custom-put 'archive-lzh 'custom-loads '("arc-mode")) -(custom-put 'scribe 'custom-loads '("scribe")) -(custom-put 'archive 'custom-loads '("arc-mode")) -(custom-put 'c-macro 'custom-loads '("cmacexp")) -(custom-put 'vrml 'custom-loads '("vrml-mode")) -(custom-put 'simula 'custom-loads '("simula")) -(custom-put 'archive-arc 'custom-loads '("arc-mode")) -(custom-put 'fortran 'custom-loads '("f90" "fortran")) -(custom-put 'cperl-faces 'custom-loads '("cperl-mode")) -(custom-put 'resize-minibuffer 'custom-loads '("rsz-minibuf")) -(custom-put 'languages 'custom-loads '("ada-mode" "asm-mode" "cperl-mode" "fortran" "icon" "pascal" "prolog" "rexx-mode" "sh-script" "simula" "tcl" "verilog-mode" "vhdl-mode" "vrml-mode" "winmgr-mode" "xrdb-mode")) -(custom-put 'cperl-indent 'custom-loads '("cperl-mode")) -(custom-put 'archive-zoo 'custom-loads '("arc-mode")) -(custom-put 'archive-zip 'custom-loads '("arc-mode")) -(custom-put 'display 'custom-loads '("auto-show")) -(custom-put 'faces 'custom-loads '("cperl-mode")) -(custom-put 'hideshow 'custom-loads '("hideshow")) -(custom-put 'vhdl 'custom-loads '("vhdl-mode")) -(custom-put 'enriched 'custom-loads '("enriched")) -(custom-put 'processes 'custom-loads '("executable")) -(custom-put 'rexx 'custom-loads '("rexx-mode")) -(custom-put 'executable 'custom-loads '("executable")) -(custom-put 'wp 'custom-loads '("enriched" "scribe" "texinfo")) -(custom-put 'sh 'custom-loads '("sh-script")) -(custom-put 'makefile-mode 'custom-loads '("make-mode")) -(custom-put 'whitespace 'custom-loads '("whitespace-mode")) -(custom-put 'matching 'custom-loads '("whitespace-mode")) -(custom-put 'winmgr 'custom-loads '("winmgr-mode")) -(custom-put 'unix 'custom-loads '("sh-script")) -(custom-put 'c 'custom-loads '("cmacexp")) +(custom-add-loads 'extensions '("auto-show" "strokes")) +(custom-add-loads 'message '("sendmail")) +(custom-add-loads 'prolog '("prolog")) +(custom-add-loads 'auto-show '("auto-show")) +(custom-add-loads 'mouse '("outl-mouse" "strokes")) +(custom-add-loads 'mail-abbrevs '("mail-abbrevs")) +(custom-add-loads 'pascal '("pascal")) +(custom-add-loads 'tex '("reftex" "texinfo")) +(custom-add-loads 'tcl '("tcl")) +(custom-add-loads 'icon '("icon")) +(custom-add-loads 'texinfo '("texinfo")) +(custom-add-loads 'xrdb '("xrdb-mode")) +(custom-add-loads 'mail '("mail-abbrevs")) +(custom-add-loads 'fortran-indent '("fortran")) +(custom-add-loads 'docs '("texinfo")) +(custom-add-loads 'lisp-indent '("cl-indent")) +(custom-add-loads 'tools '("hideshow" "lazy-shot" "make-mode")) +(custom-add-loads 'lisp '("lisp-mode" "cl-indent" "strokes")) +(custom-add-loads 'reftex '("reftex")) +(custom-add-loads 'outlines '("hideshow" "outl-mouse" "whitespace-mode")) +(custom-add-loads 'f90 '("f90")) +(custom-add-loads 'perl '("cperl-mode")) +(custom-add-loads 'asm '("asm-mode")) +(custom-add-loads 'ada '("ada-mode")) +(custom-add-loads 'reftex-label-support '("reftex")) +(custom-add-loads 'data '("arc-mode" "xrdb-mode")) +(custom-add-loads 'fortran-comment '("fortran")) +(custom-add-loads 'outl-mouse '("outl-mouse")) +(custom-add-loads 'frames '("rsz-minibuf")) +(custom-add-loads 'cperl-electric '("cperl-mode")) +(custom-add-loads 'verilog '("verilog-mode")) +(custom-add-loads 'abbrev '("abbrev")) +(custom-add-loads 'f90-indent '("f90")) +(custom-add-loads 'strokes '("strokes")) +(custom-add-loads 'lazy-shot '("lazy-shot")) +(custom-add-loads 'archive-lzh '("arc-mode")) +(custom-add-loads 'scribe '("scribe")) +(custom-add-loads 'archive '("arc-mode")) +(custom-add-loads 'c-macro '("cmacexp")) +(custom-add-loads 'vrml '("vrml-mode")) +(custom-add-loads 'simula '("simula")) +(custom-add-loads 'archive-arc '("arc-mode")) +(custom-add-loads 'fortran '("f90" "fortran")) +(custom-add-loads 'cperl-faces '("cperl-mode")) +(custom-add-loads 'resize-minibuffer '("rsz-minibuf")) +(custom-add-loads 'languages '("ada-mode" "asm-mode" "cperl-mode" "fortran" "icon" "pascal" "prolog" "rexx-mode" "sh-script" "simula" "tcl" "verilog-mode" "vhdl-mode" "vrml-mode" "winmgr-mode" "xrdb-mode")) +(custom-add-loads 'cperl-indent '("cperl-mode")) +(custom-add-loads 'archive-zoo '("arc-mode")) +(custom-add-loads 'archive-zip '("arc-mode")) +(custom-add-loads 'display '("auto-show")) +(custom-add-loads 'faces '("cperl-mode" "lazy-shot")) +(custom-add-loads 'hideshow '("hideshow")) +(custom-add-loads 'vhdl '("vhdl-mode")) +(custom-add-loads 'enriched '("enriched")) +(custom-add-loads 'processes '("executable")) +(custom-add-loads 'rexx '("rexx-mode")) +(custom-add-loads 'executable '("executable")) +(custom-add-loads 'wp '("enriched" "scribe" "texinfo")) +(custom-add-loads 'sh '("sh-script")) +(custom-add-loads 'makefile-mode '("make-mode")) +(custom-add-loads 'whitespace '("whitespace-mode")) +(custom-add-loads 'matching '("whitespace-mode")) +(custom-add-loads 'winmgr '("winmgr-mode")) +(custom-add-loads 'unix '("sh-script")) +(custom-add-loads 'c '("cmacexp")) ;;; custom-load.el ends here
--- a/lisp/modes/enriched.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/enriched.el Mon Aug 13 10:03:52 2007 +0200 @@ -417,10 +417,10 @@ (t (let* ((fg (and (not (eq (face-foreground face) (face-foreground 'default))) - (color-instance-name (face-foreground face)))) + (color-name (face-foreground face)))) (bg (and (not (eq (face-background face) (face-background 'default))) - (color-instance-name (face-background face)))) + (color-name (face-background face)))) (ans '())) (if fg (setq ans (cons (list "x-color" fg) ans))) (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
--- a/lisp/modes/lazy-shot.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/lazy-shot.el Mon Aug 13 10:03:52 2007 +0200 @@ -22,27 +22,32 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Synched up with: Not synched. +;;; Synched up with: Not in FSF (mostly equivalent to lazy-lock 2.06 +;;; in FSF 19.34). ;;; Commentary: -;; This versions has basic demand lock functionality. Somebody please -;; sync further with lazy-lock v2 from FSF, customize etc. -;; -;; -;; Idea for the stealth lock function: -;; -;; -;; On an Idle itimer -;; Loop over all buffers with lazy-lock set -;; mapcar-extent in the region (point) point-max for -;; one-shot-function property -;; If not found do the same for [point-min,point] -;; font-lock the found region and delete the extent +;;; This is an experimental demand based font-lock implemenation. It +;;; is almost equal in functionality and interface to lazy-lock 2.06 +;;; Does somebody really need defer-locking? +;;; +;;; To use: put +;;; (add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) +;;; in .emacs (.xemacs/init.el). Do not use in combination with +;;; lazy-lock. + +;;; It is exprimental in the sense that it relies on C support from +;;; the redisplay engine, that is experimental. The code in this file +;;; is more or less finished. The C code support experimental because +;;; the current design is rumoured to be ugly. Secondly because +;;; XEmacs does actually display the "un-font-locked" parts of the +;;; buffer first, the user notices flashing as the buffer is repainted +;;; with color/fonts. ;;; Code: (require 'font-lock) +(require 'itimer) (defvar lazy-shot-mode nil) @@ -50,13 +55,62 @@ (defgroup lazy-shot nil "Lazy-shot customizations" :group 'tools + :group 'faces :prefix "lazy-shot-") +(defcustom lazy-shot-minimum-size 0 + "*Minimum size of a buffer for demand-driven fontification. +On-demand fontification occurs if the buffer size is greater than this value. +If nil, means demand-driven fontification is never performed." + :type '(choice (const :tag "Off" nil) + (integer :tag "Size")) + :group 'lazy-shot) + + (defcustom lazy-shot-step-size 1024 ; Please test diffent sizes "Minimum size of each fontification shot." :type 'integer :group 'lazy-shot) +(defcustom lazy-shot-stealth-time 30 + "*Time in seconds to delay before beginning stealth fontification. +Stealth fontification occurs if there is no input within this time. +If nil, means stealth fontification is never performed. + +The value of this variable is used when Lazy Shot mode is turned on." + :type '(choice (const :tag "Off" nil) + (number :tag "Time")) + :group 'lazy-shot) + +(defcustom lazy-shot-stealth-lines (if font-lock-maximum-decoration 100 250) + "*Maximum size of a chunk of stealth fontification. +Each iteration of stealth fontification can fontify this number of lines. +To speed up input response during stealth fontification, at the cost of stealth +taking longer to fontify, you could reduce the value of this variable." + :type 'integer + :group 'lazy-shot) + +(defcustom lazy-shot-stealth-nice + (/ (float 1) (float 8)) + "*Time in seconds to pause between chunks of stealth fontification. +Each iteration of stealth fontification is separated by this amount of time. +To reduce machine load during stealth fontification, at the cost of stealth +taking longer to fontify, you could increase the value of this variable." + :type 'number + :group 'lazy-shot) + +(defcustom lazy-shot-verbose (not (null font-lock-verbose)) + "*If non-nil, means demand fontification should show status messages." + :type 'boolean + :group 'lazy-shot) + +(defcustom lazy-shot-stealth-verbose (not (null lazy-shot-verbose)) + "*If non-nil, means stealth fontification should show status messages." + :type 'boolean + :group 'lazy-shot) + + + ;;;###autoload (defun lazy-shot-mode (&optional arg) "Toggle Lazy Lock mode. @@ -75,72 +129,123 @@ ;; Turn ourselves off. (lazy-shot-unstall)))) +(custom-add-option 'font-lock-mode-hook 'turn-on-lazy-lock) + ;;;###autoload (defun turn-on-lazy-shot () "Unconditionally turn on Lazy Lock mode." (lazy-shot-mode t)) + ;; Can we do something intelligent here? + ;; I would want to set-extent-end-position start on extents that + ;; only partially overlap! +(defun lazy-shot-clean-up-extents (start end) + "Make sure there are no lazy-shot-extens betweeen START and END. +This improves efficiency and C-g behavior." + ;; Be carefull this function is typically called with inhibit-quit! + (map-extents (lambda (e b) (delete-extent e)) + nil start end nil 'start-and-end-in-region 'initial-redisplay-function + 'lazy-shot-redisplay-function)) + +(defun lazy-shot-redisplay-function (extent) + "Lazy lock the EXTENT when it has become visisble." + (lazy-shot-lock-extent extent nil)) -(defun lazy-shot-shot-function (extent) - "Lazy lock the extent when it has become visisble" - (let ((start (extent-start-position extent)) - (end (extent-end-position extent)) - (buffer (extent-object extent))) - (delete-extent extent) - (with-current-buffer buffer - (save-excursion - ;; This magic should really go into font-lock-fonity-region - (goto-char start) - (unless (bolp) - (beginning-of-line) - (setq start (point))) - (goto-char end) - (unless (bolp) - (forward-line) - (setq end (point))) - (display-message 'progress - (format "Lazy-shot fontifying from %s to %s in %s" - start end buffer)) - (save-match-data - (font-lock-fontify-region start end)))))) +(defun lazy-shot-lock-extent (extent stealth) + "Font-lock the EXTENT. Called from redisplay-trigger functions and +stealth locking functions" + (when (extent-live-p extent) + (let ((start (extent-start-position extent)) + (end (extent-end-position extent)) + (buffer (extent-object extent))) + (delete-extent extent) + (save-excursion + ;; Should inhibit quit here + (set-buffer buffer) ;; with-current-buffer is silly here + ;; This magic should really go into font-lock-fonity-region + (goto-char start) + (setq start (point-at-bol)) + (goto-char end) + (setq end (point-at-bol 2)) + (lazy-shot-clean-up-extents start end) + (if (or lazy-shot-verbose (and stealth lazy-shot-stealth-verbose)) + (display-message 'progress + (format "Lazy-shot fontifying %sfrom %s to %s in %s" + (if stealth "stealthy " "") start end buffer))) + ;; and a allow quit here + (save-match-data + (font-lock-fontify-region start end)))))) +(defun lazy-shot-stealth-lock (buffer) + "Find an extent to lazy lock in buffer." + (if (buffer-live-p buffer) + (with-current-buffer buffer + (let ((extent t)) + (while (and extent (sit-for lazy-shot-stealth-nice)) + (setq extent + (or ;; First after point + (map-extents (lambda (e n) e) nil (point) nil nil nil + 'initial-redisplay-function + 'lazy-shot-redisplay-function) + ;; Then before it + (map-extents (lambda (e n) e) nil nil (point) nil nil + 'initial-redisplay-function + 'lazy-shot-redisplay-function))) + (if extent + (lazy-shot-lock-extent extent t) + (delete-itimer current-itimer) + (setq lazy-shot-stealth-timer nil))))) + (delete-itimer current-itimer))) + (defun lazy-shot-install-extent (spos epos &optional buffer) - "Make an extent that will lazy-shot if it is displayed" + "Make an extent that will lazy-shot if it is displayed." (let ((extent (make-extent spos epos buffer))) (when extent - (set-extent-one-shot-function extent - 'lazy-shot-shot-function)) + (set-extent-initial-redisplay-function extent + 'lazy-shot-redisplay-function)) extent)) -(defun lazy-shot-next-line (pos &optional buffer) - "Return the next end-of-line from POS in BUFFER." - (save-excursion - (goto-char pos buffer) - (forward-line 1 buffer) - (point buffer))) (defun lazy-shot-install-extents (fontifying) ;; ;; Add hook if lazy-shot.el is deferring or is fontifying on scrolling. (when fontifying - (let ((max (point-max))) - (do* ((start (point-min) end) - (end (min max (lazy-shot-next-line (+ start lazy-shot-step-size))) - (min max (lazy-shot-next-line (+ start lazy-shot-step-size))))) - ((>= start max)) - (lazy-shot-install-extent start end))))) + (let ((max (point-max)) + start) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq start (point)) + (goto-char (min max (+ start lazy-shot-step-size))) + (forward-line 1) + (lazy-shot-install-extent start (point))))))) + +(defun lazy-shot-install-timer (fontifying) + (when (and lazy-shot-stealth-time fontifying) + (make-variable-buffer-local 'lazy-shot-stealth-timer) + (setq lazy-shot-stealth-timer + (start-itimer (format "lazy shot for %s" (current-buffer)) + 'lazy-shot-stealth-lock lazy-shot-stealth-time + lazy-shot-stealth-time + t t (current-buffer))))) + (defun lazy-shot-install () (make-local-variable 'font-lock-fontified) - (setq font-lock-fontified t) - (lazy-shot-install-extents font-lock-fontified)) + (setq font-lock-fontified (and lazy-shot-minimum-size + (>= (buffer-size) lazy-shot-minimum-size))) + (lazy-shot-install-extents font-lock-fontified) + (lazy-shot-install-timer font-lock-fontified)) (defun lazy-shot-unstall () - ;; + ;; Stop the timer + (when lazy-shot-stealth-timer + (delete-itimer lazy-shot-stealth-timer) + (setq lazy-shot-stealth-timer nil)) ;; Remove the extents. (map-extents (lambda (e arg) (delete-extent e) nil) - nil nil nil nil nil 'one-shot-function 'lazy-shot-shot-function) + nil nil nil nil nil 'initial-redisplay-function 'lazy-shot-redisplay-function) ;; ;; Remove the fontification hooks. (remove-hook 'after-change-functions 'lazy-shot-defer-after-change t)
--- a/lisp/modes/reftex.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/modes/reftex.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,7 +1,7 @@ ;; reftex.el --- Minor mode for doing \label, \ref and \cite in LaTeX - ;; Copyright (c) 1997 Free Software Foundation, Inc. +;; Version: 3.7 ;; Author: Carsten Dominik <dominik@strw.LeidenUniv.nl> ;; Keywords: tex @@ -30,7 +30,8 @@ ;; \cite commands in (multi-file) LaTeX documents. ;; Labels are created semi-automatically. Definition context of labels is ;; provided when creating a reference. Citations are simplified with -;; efficient database lookup. +;; efficient database lookup. A table of contents buffer provides easy +;; access to any part of a document. ;; ;; To turn RefTeX Minor Mode on and off in a particular buffer, use ;; `M-x reftex-mode'. @@ -41,239 +42,312 @@ ;; (add-hook 'LaTeX-mode-hook 'turn-on-reftex) ; with AUCTeX LaTeX mode ;; (add-hook 'latex-mode-hook 'turn-on-reftex) ; with Emacs latex mode ;; -;; For key bindings, see further down in this documentation. +;; For default key bindings, see further down in this documentation. +;; +;;--------------------------------------------------------------------------- +;; +;; CONTENTS +;; -------- +;; +;; Overview............................ All you need to know to get started. ;; +;; Configuration....................... How to configure RefTeX. +;; Configuration Examples........... Tutorial examples. +;; Hooks............................ Available hooks. +;; Configuration Variables.......... Complete listing. +;; Key Bindings........................ A list of default bindings. +;; Multifile Documents................. Documents spread over many files. +;; References to Other Documents....... RefTeX and the LaTeX package `xr'. +;; Optimizations for Large Documents... How to improve speed and memory use. +;; Related Packages.................... Other Emacs packages. +;; Known Bugs and Work-Arounds......... First aid. +;; Author.............................. Who wrote RefTeX and who helped. +;; History............................. What was new in which version. ;;--------------------------------------------------------------------------- ;; ;; OVERVIEW -;; -;; 1. USING \label AND \ref. Labels and references are one of the -;; strong points of LaTeX. But, in documents with hundreds of -;; equations, figures, tables etc. it becomes quickly impossible to -;; find good label names and to actually remember them. Then, also -;; completion of labels in not enough. One actually needs to see the -;; context of the label definition to find the right one. -;; -;; - RefTeX distinguishes labels for different environments. It -;; always knows if a certain label references a figure, table -;; etc.. You can configure RefTeX to recognize any additional -;; labeled environments you might have defined yourself. +;; ======== +;; +;; 1. USING \label AND \ref. Labels and references are one of the strong +;; points of LaTeX. But, in documents with hundreds of equations, +;; figures, tables etc. it becomes quickly impossible to find good label +;; names and to actually remember them. Then, also completion of labels +;; is not enough. One actually needs to see the context of the label +;; definition to find the right one. +;; +;; - RefTeX distinguishes labels for different environments. It always +;; knows if a certain label references a figure, table etc.. You can +;; configure RefTeX to recognize any additional labeled environments +;; you have defined yourself. ;; ;; - RefTeX defines automatically unique labels. Type `C-c (' -;; (reftex-label) to insert a label at point. RefTeX will either +;; (`reftex-label') to insert a label at point. RefTeX will either ;; - derive a label from context (default for section labels) ;; - insert a simple label consisting of a prefix and a number -;; (default for equations and enumerate items) or +;; (default for equations,enumerate items, and footnotes) or ;; - prompt for a label string (figures and tables). ;; Which labels are created how can be controlled with the variable ;; `reftex-insert-label-flags'. ;; -;; - Referencing labels is a snap and I promise you'll love it. -;; In order to make a reference, type `C-c )' (`reftex-reference'). -;; This shows an outline of the documents with all labels of a -;; certain type (figure, equation,...) and context of the label -;; definition. Selecting one of the labels inserts a \ref macro -;; into the original buffer. Online help during the selection is -;; available with `?'. -;; -;; 2. CITATIONS. After typing `C-c [' (`reftex-citation'), RefTeX will -;; let you specify a regexp to search in current BibTeX database files -;; (as specified in the \bibliography command) and pull out a formatted -;; list of matches for you to choose from. The list is *formatted* and -;; thus much easier to read than the raw database entries. It can also -;; be sorted. The text inserted into the buffer is by default just -;; `\cite{KEY}', but can also contain author names and the year in a -;; configurable way. See documentation of the variable -;; `reftex-cite-format'. -;; -;; 3. TABLE OF CONTENTS. Typing `C-c =' (`reftex-toc') will show -;; a table of contents of the document. From that buffer, you can -;; jump quickly to every part of your document. This is similar to -;; imenu, only it works for entire multifile documents and uses the -;; keyboard rather than the mouse. The initial version of this -;; function was contributed by Stephen Eglen. +;; - Referencing labels is a snap and I promise you'll love it. In +;; order to make a reference, type `C-c )' (`reftex-reference'). This +;; shows an outline of the document with all labels of a certain type +;; (figure, equation,...) and context of the label definition. +;; Selecting one of the labels inserts a \ref macro into the original +;; buffer. Online help during the selection is available with `?'. +;; +;; 2. CITATIONS. After typing `C-c [' (`reftex-citation'), RefTeX will let +;; you specify a regexp to search in current BibTeX database files (as +;; specified in the \bibliography command) and pull out a formatted list +;; of matches for you to choose from. The list is *formatted* and +;; sorted, thus much easier to read than the raw database entries. The +;; text inserted into the buffer is by default just `\cite{KEY}', but +;; can also contain author names and the year in a configurable way. +;; See documentation of the variable `reftex-cite-format'. ;; -;; 4. MULTIFILE DOCUMENTS are supported in the same way as by AUCTeX. -;; I.e. if a source file is not a full LaTeX document by itself, -;; but included by another file, you may specify the name of -;; the (top level) master file in a local variable section at the -;; end of the source file, like so: -;; -;; %%% Local Variables: -;; %%% TeX-master: my_master.tex -;; %%% End: -;; -;; This will only take effect when you load the file next time or when -;; you reset RefTeX with M-x reftex-reset-mode. +;; 3. TABLE OF CONTENTS. Typing `C-c =' (`reftex-toc') will show a table +;; of contents of the document. From that buffer, you can jump quickly +;; to every part of your document. This is similar to imenu, only it +;; works for entire multifile documents and uses the keyboard rather +;; than the mouse. The initial version of this function was contributed +;; by Stephen Eglen. ;; -;; RefTeX will also recognize the file variable tex-main-file. This -;; variable is used by the Emacs TeX modes and works just like -;; AUCTeX's TeX-master variable. See the documentation of your TeX/LaTeX -;; modes. -;; -;; RefTeX knows about all files related to a document via input and -;; include. It provides functions to run regular expression searches and -;; replaces over the entire document and to create a TAGS file. +;; 4. MULTIFILE DOCUMENTS are fully supported by RefTeX. Such documents +;; consist of a master file and many other files being included via +;; \input or \include. RefTeX will provide cross referencing +;; information from all files which are part of the document. See +;; `RefTeX and Multifile Documents' further down in the documentation +;; for more information on this topic. ;; -;; 5. DOCUMENT PARSING. RefTeX needs to parse the document in order to find -;; labels and other information. It will do it automatically once, when -;; you start working with a document. If you need to enforce reparsing -;; later, call any of the functions `reftex-citation', `reftex-label', -;; `reftex-reference', `reftex-toc' with a raw C-u prefix. -;; -;;------------------------------------------------------------------------- -;; -;; CONFIGURATION -;; -;; RefTeX contains many configurable options which change the way it works. +;; 5. DOCUMENT PARSING. RefTeX needs to parse the document in order to +;; find labels and other information. It will do it automatically once, +;; when you start working with a document. Re-parsing should not be +;; necessary too often since RefTeX updates its lists internally when +;; you make a new label with `reftex-label'. To enforce reparsing, +;; call any of the functions `reftex-citation', `reftex-label', +;; `reftex-reference', `reftex-toc' with a raw C-u prefix, or press the +;; `r' key in the label menu and table of contents buffer. +;;--------------------------------------------------------------------------- ;; -;; Most importantly, RefTeX needs to be configured if you use labels to -;; mark non-standard environments. RefTeX always understands LaTeX section -;; commands and the following environments: figure, figure*, -;; sidewaysfigure, table, table*, sidewaystable, equation, eqnarray, -;; enumerate. For everythings else, it needs to be configured. +;; CONFIGURATION +;; ============= ;; -;; A good way to configure RefTeX is with the custom.el package by Per -;; Abrahamsen, shipped with Emacs 20 and XEmacs 19.15. To do this, just -;; say `M-x reftex-customize'. This will not work with older versions -;; of custom.el. -;; -;; Here is a complete list of the RefTeX configuration variables with -;; their default settings. You could copy this list to your .emacs file -;; and change whatever is necessary. Each variable has an extensive -;; documentation string. Look it up for more information! +;; RefTeX needs to be configured if you use labels to mark environments +;; defined by yourself (e.g. with `\newenvironment') or in packages not +;; included in the standard LaTeX distribution. RefTeX's default settings +;; make it recognize practically all labeled environments and macros +;; discussed in `The LaTeX Companion' by Goossens, Mittelbach & Samarin, +;; Addison-Wesley 1994. These are: ;; -;; ;; Configuration Variables and User Options for RefTeX ------------------ -;; ;; Support for \label and \ref -------------------------------------- -;; (setq reftex-label-alist nil) -;; (setq reftex-default-label-alist-entries '(Sideways LaTeX)) -;; (setq reftex-use-text-after-label-as-context nil) -;; ;; Label insertion -;; (setq reftex-insert-label-flags '("s" "sft")) -;; (setq reftex-derive-label-parameters '(3 20 t 1 "-" -;; ("the" "on" "in" "off" "a" "for" "by" "of" "and" "is"))) -;; (setq reftex-label-illegal-re "[\000-\040\177-\377\\\\#$%&~^_{}]") -;; (setq reftex-abbrev-parameters '(4 2 "^saeiou" "aeiou")) -;; ;; Label referencing -;; (setq reftex-label-menu-flags '(t t nil nil nil nil)) -;; (setq reftex-guess-label-type t) -;; ;; BibteX citation configuration ---------------------------------------- -;; (setq reftex-bibpath-environment-variables '("BIBINPUTS" "TEXBIB")) -;; (setq reftex-bibfile-ignore-list nil) -;; (setq reftex-sort-bibtex-matches 'reverse-year) -;; (setq reftex-cite-format 'reftex-cite-format-default) -;; ;; Table of contents configuration -------------------------------------- -;; (setq reftex-toc-follow-mode nil) -;; ;; Miscellaneous configurations ----------------------------------------- -;; (setq reftex-extra-bindings nil) -;; (setq reftex-plug-into-AUCTeX nil) -;; (setq reftex-use-fonts t) -;; (setq reftex-keep-temporary-buffers t) -;; (setq reftex-auto-show-entry t) +;; - figure, figure*, table, table*, equation, eqnarray, enumerate, +;; the \footnote macro (this is the LaTeX core stuff) +;; - align, gather, multline, flalign, alignat, xalignat, xxalignat, +;; subequations (from AMS-LaTeX's amsmath.sty package) +;; - the \endnote macro (from endnotes.sty) +;; - Beqnarray (fancybox.sty) +;; - floatingfig (floatfig.sty) +;; - longtable (longtable.sty) +;; - figwindow, tabwindow (picinpar.sty) +;; - sidewaysfigure, sidewaystable (rotating.sty) +;; - subfigure, subfigure*, the \subfigure macro (subfigure.sty) +;; - supertabular (supertab.sty) +;; - wrapfigure (wrapfig.sty) ;; -;; CONFIGURATION EXAMPLES: -;; ======================= +;; If you want to use any other labeled environments or macros, you need +;; to configure RefTeX. ;; -;; Suppose you are working with AMS-LaTeX amsmath package (with its math -;; environments like `align', `multiline' etc.). Here is how you would -;; configure RefTeX to recognize these environments: +;; Per Abrahamsens custom.el package provides a simple way to do +;; configuration. To try it out, use `M-x reftex-customize'. ;; -;; (setq reftex-label-alist '(AMSTeX)) +;; CONFIGURATION EXAMPLES +;; ---------------------- ;; -;; This is very easy since RefTeX has builtin support for AMS-LaTeX. -;; Suppose, however, you are also +;; Suppose you are working with AMS-LaTeX amsmath package (with its math +;; environments like `align', `multline' etc.). RefTeX is preconfigured to +;; recognize these - so there is nothing you have to do. ;; -;; - using "\newtheorem" in LaTeX in order to define two new environments -;; "Theorem" and "Axiom" like this: +;; Suppose you are also using `\newtheorem' in LaTeX in order to define two +;; new environments `theorem' and `axiom' ;; ;; \newtheorem{axiom}{Axiom} ;; \newtheorem{theorem}{Theorem} ;; -;; - making your figures not directly with the figure environment, but with -;; a macro like +;; to be used like this: ;; -;; \newcommand{\myfig}[4][tbp]{ -;; \begin{figure}[#1] -;; \epsimp[#4]{#2} -;; \caption{#3} -;; \end{figure}} -;; -;; which would be called like -;; -;; \myfig{filename}{\label{fig:13} caption text}{1} +;; \begin{axiom} +;; \label{ax:first} +;; .... +;; \end{axiom} ;; -;; Here is how to tell RefTeX to also recognize Theorem and Axiom as -;; labeled environments, and that any labels defined inside the \myfig -;; macro are figure labels: +;; So we need to tell RefTeX that `theorem' and `axiom' are new labeled +;; environments which define their own label categories. Here is how: ;; -;; (setq reftex-label-alist -;; '(AMSTeX -;; ("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) -;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")) -;; ("\\myfig" ?f "fig:" nil t))) +;; (setq reftex-label-alist +;; '(("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) +;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")))) ;; -;; The type indicator characters ?a and ?h are used for prompts when -;; RefTeX queries for a label type. Note that "h" was chosen for "theorem" -;; since "t" is already taken by "table". Note that also "s", "f", "e", "n" -;; are taken by the standard environments. +;; The type indicator characters ?a and ?h are used for prompts when RefTeX +;; queries for a label type. Note that `h' was chosen for `theorem' since +;; `t' is already taken by `table'. Note that also `s', `f', `e', `i', `n' +;; are already used for standard environments. ;; The automatic labels for Axioms and Theorems will look like "ax:23" or ;; "thr:24". ;; The "\ref{%s}" is a format string indicating how to insert references to -;; these labels. The nil format in the \myfig entry means to use the same -;; format as other figure labels. -;; The next item indicates how to grab context of the label definition. -;; - t means to get it from a default location (from the beginning of a \macro -;; or after the \begin statement). t is *not* a good choice for eqnarray -;; and similar environments. +;; these labels. +;; The next item indicates how to grab context of the label definition. +;; - t means to get it from a default location (from the beginning of a +;; \macro or after the \begin statement). t is *not* a good choice for +;; eqnarray and similar environments. ;; - nil means to use the text right after the label definition. ;; - For more complex ways of getting context, see the docstring of ;; `reftex-label-alist'. ;; The strings at the end of each entry are used to guess the correct label ;; type from the word before point when creating a reference. E.g. if you -;; write: "as we have shown in Theorem" and then press `C-)', RefTeX will -;; know that you are looking for a Theorem label and restrict the labels in -;; the menu to only these labels without even asking. -;; See also the documentation string of the variable `reftex-label-alist'. +;; write: "As we have shown in Theorem" and then press `C-c )', RefTeX will +;; know that you are looking for a theorem label and restrict the menu to +;; only these labels without even asking. +;; +;; Depending on how you would like the label insertion and selection for +;; the new environments to work, you might want to add the letters "a" and +;; "h" to some of the flags in the following variables: +;; +;; reftex-insert-label-flags reftex-label-menu-flags +;; +;; Suppose you want to make figures not directly with the figure +;; environment, but with a macro like +;; +;; \newcommand{\myfig}[5][tbp]{% +;; \begin{figure}[#1] +;; \epsimp[#5]{#2} +;; \caption{#3} +;; \label{#4} +;; \end{figure}} ;; -;; Depending on how you would like the label insertion and selection for the -;; new environments to work, you might want to add the letters "a" and "h" -;; to some of the flags in the following variables: +;; which would be called like +;; +;; \myfig[htp]{filename}{caption text}{label}{1} +;; +;; Now we also need to tell RefTeX that the 4th argument of the \myfig +;; macro is a figure label, and where to find the context. ;; -;; reftex-insert-label-flags -;; reftex-label-menu-flags +;; (setq reftex-label-alist +;; '(("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) +;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")) +;; ("\\myfig[]{}{}{*}{}" ?f nil nil 3))) ;; -;; The individual flags in these variables can be set to t or nil to enable or -;; disable the feature for all label types. They may also contain a string of -;; label type letters in order to turn on the feature for those types only. +;; The empty pairs of brackets indicate the different arguments of the +;; \myfig macro. The `*' marks the label argument. `?f' indicates that +;; this is a figure label which will be listed together with labels from +;; normal figure environments. The nil entries for prefix and reference +;; format mean to use the defaults for figure labels. The `3' for the +;; context method means to grab the 3rd macro argument - the caption. +;; +;; As a side effect of this configuration, `reftex-label' will now insert +;; the required naked label (without the \label macro) when point is +;; directly after the opening parenthesis of a \myfig macro argument. ;; ;; ----- -;; If you are writing in a language different from english you might want to -;; add magic words for that language. Here is a German example: ;; -;; (setq reftex-label-alist +;; If you are writing in a language different from English you might want +;; to add magic words for that language. Here is a German example: +;; +;; (setq reftex-label-alist ;; '((nil ?s nil nil nil ("Kapitel" "Kap." "Abschnitt" "Teil")) ;; (nil ?e nil nil nil ("Gleichung" "Gl.")) ;; (nil ?t nil nil nil ("Tabelle")) ;; (nil ?f nil nil nil ("Figur" "Abbildung" "Abb.")) -;; (nil ?n nil nil nil ("Punkt")))) +;; (nil ?n nil nil nil ("Anmerkung" "Anm.")) +;; (nil ?i nil nil nil ("Punkt")))) ;; ;; Using nil as first item in each entry makes sure that this entry does -;; not replace the original entry for that label type. +;; not replace the original entry for that label type, but just adds magic +;; words. +;; +;; ----- +;; +;; Normally, RefTeX inserts equation references with parenthesis like +;; "~(\ref{KEY})". If you want to change this to square brackets, use +;; +;; (setq reftex-label-alist '((nil ?e nil "~[\\ref{%s}]" nil nil))) +;; +;; In order to use the AMS-LaTeX \eqref macro instead, either of the +;; following lines does the job. +;; +;; (setq reftex-label-alist '((nil ?e nil "~\\eqref{%s}" nil nil))) +;; (setq reftex-label-alist '(AMSTeX)) +;; +;; ---- +;; +;; By default, citations are inserted simply as \cite{KEY}. You can have +;; more complex citation commands with many available packages, most +;; notably the harvard and natbib packages. RefTeX can be configured to +;; support these and other styles by setting the variable +;; `reftex-cite-format'. E.g., for the natbib package you would use +;; +;; (setq reftex-cite-format 'natbib) +;; +;; This can also be done as a file variable. For the full list of builtin +;; options, try `M-x customize-variable RET reftex-cite-format RET'. ;; ;; HOOKS ;; ----- -;; Loading reftex.el runs the hook `reftex-load-hook'. -;; Turning on reftex-mode runs `reftex-mode-hook'. +;; - Loading reftex.el runs the hook `reftex-load-hook'. +;; - Turning on reftex-mode runs `reftex-mode-hook'. +;; - Files visited literally are processed with +;; `reftex-initialize-temporary-buffers' if that is a list of functions. +;; +;; CONFIGURATION VARIABLES +;; ----------------------- +;; +;; The best way to learn about all configuration variables is via the +;; browser interface of the custom library. For reference, I am giving +;; here a complete list. ;; +;; ;; Defining label environments +;; reftex-default-label-alist-entries +;; reftex-label-alist +;; reftex-section-levels +;; reftex-default-context-regexps +;; reftex-use-text-after-label-as-context +;; ;; Label insertion +;; reftex-insert-label-flags +;; reftex-derive-label-parameters +;; reftex-label-illegal-re +;; reftex-abbrev-parameters +;; ;; Label referencing +;; reftex-label-menu-flags +;; reftex-level-indent +;; reftex-refontify-context +;; reftex-guess-label-type +;; ;; BibteX citation configuration +;; reftex-bibpath-environment-variables +;; reftex-bibfile-ignore-list +;; reftex-sort-bibtex-matches +;; reftex-cite-format +;; reftex-comment-citations +;; reftex-cite-comment-format +;; reftex-cite-punctuation +;; ;; Table of contents configuration +;; reftex-toc-follow-mode +;; ;; Fine-tuning the parser +;; reftex-keep-temporary-buffers +;; reftex-initialize-temporary-buffers +;; reftex-enable-partial-scans +;; reftex-save-parse-info +;; ;; Miscellaneous configurations +;; reftex-extra-bindings +;; reftex-plug-into-AUCTeX +;; reftex-use-fonts +;; reftex-auto-show-entry +;; reftex-load-hook +;; reftex-mode-hook ;;------------------------------------------------------------------------- ;; ;; KEY BINDINGS +;; ============ ;; -;; All important functions of RefTeX can be reached from its menu which -;; is installed in the menu bar as "Ref" menu. Only the more frequently used -;; functions have key bindings. -;; -;; Here is the default set of keybindings from RefTeX. +;; All RefTeX commands can be reached from its menu, the `Ref' menu on the +;; menu bar. More frequently used commands have key bindings: ;; ;; C-c = reftex-toc ;; C-c ( reftex-label @@ -281,9 +355,9 @@ ;; C-c [ reftex-citation ;; C-c & reftex-view-crossref ;; -;; I've used these bindings in order to avoid interfering with AUCTeX's -;; settings. Personally, I also bind some functions in the C-c LETTER -;; map for easier access: +;; These keys are chosen to avoid interfering with AUCTeX's settings. +;; Personally, I also bind some functions in the C-c LETTER map for +;; easier access: ;; ;; C-c t reftex-toc ;; C-c l reftex-label @@ -294,59 +368,137 @@ ;; C-c g reftex-grep-document ;; ;; If you want to copy those as well, set in your .emacs file: -;; +;; ;; (setq reftex-extra-bindings t) ;; ;; It is possible to bind the function for viewing cross references to a -;; mouse event. Something like the following in .emacs will do the trick: +;; mouse event. Something like the following will do the trick: ;; -;; (add-hook 'reftex-load-hook +;; (add-hook 'reftex-load-hook ;; '(lambda () -;; (define-key reftex-mode-map [(alt mouse-1)] +;; (define-key reftex-mode-map [(shift mouse-2)] ;; 'reftex-mouse-view-crossref))) -;; +;;------------------------------------------------------------------------- +;; +;; REFTEX AND MULTIFILE DOCUMENTS +;; ============================== +;; +;; The following is relevant when using RefTeX for multi-file documents: +;; +;; o RefTeX has full support for multifile documents. You can edit parts +;; of several (multifile) documents at the same time without conflicts. +;; RefTeX provides functions to run `grep', `search' and `query-replace' +;; on all files which are part of a multifile document. +;; +;; o All files belonging to a multifile document should have a File +;; Variable (`TeX-master' for AUCTeX or `tex-main-file' for the standard +;; Emacs LaTeX mode) set to the name of the master file. See the +;; documentation of your (La)TeX mode and the Emacs documentation on +;; file variables: [Emacs/Customization/Variables/File Variables]. +;; +;; o The context of a label definition must be found in the same file as +;; the label itself in order to be processed correctly by RefTeX. The +;; only exception is that section labels referring to a section statement +;; outside the current file can still use that section title as context. ;;------------------------------------------------------------------------- ;; +;; REFERENCES TO OTHER DOCUMENTS +;; ============================= +;; +;; RefTeX supports the LaTeX package `xr', which makes it possible to +;; reference labels defined in another document. See the documentation on +;; `xr' for details. +;; When the document is set up to work with `xr', you can use the `x' key +;; in the reference label menu to switch to the label menu of an external +;; document and select any labels from there. In the *toc* buffer, the +;; `x' key can be used to switch to the table of contents of an external +;; document. +;; +;; For this kind of inter-document cross references, saving of parsing +;; information can mean a large speed-up. +;; +;; (setq reftex-save-parse-info t) +;; +;;------------------------------------------------------------------------- +;; +;; OPTIMIZATIONS FOR LARGE DOCUMENTS +;; ================================= +;; +;; The default settings of RefTeX ensure a safe ride for beginners and +;; casual users. However, when using RefTeX for a large project and/or on +;; a small computer, there are ways to improve speed or memory usage. +;; +;; o RefTeX will load other parts of a multifile document as well as BibTeX +;; database files for lookup purposes. These buffers are kept, so that +;; subsequent use of the same files is fast. If you can't afford keeping +;; these buffers around, and if you can live with a speed penalty, try +;; +;; (setq reftex-keep-temporary-buffers nil) +;; +;; o The `C-u' prefix on the major RefTeX commands `reftex-label', +;; `reftex-reference', `reftex-citation' and `reftex-toc' initiates +;; re-parsing of the entire document in order to update the parsing +;; information. For a large document this can be unnecessary, in +;; particular if only one file has changed. RefTeX can be configured to +;; do partial scans instead of full ones. `C-u' re-parsing then does +;; apply only to the current buffer and files included from it. +;; Likewise, the `r' key in both the label menu and the table-of-contents +;; buffer will only prompt scanning of the file in which the label or +;; section macro near the cursor was defined. Re-parsing of the entire +;; document is still available by using `C-u C-u' as a prefix, or the +;; capital `R' key in the menus. To use this feature, try +;; +;; (setq reftex-enable-partial-scans t) +;; +;; o Even with partial scans enabled, RefTeX still has to make one full +;; scan, when you start working with a document. To avoid this, parsing +;; information can stored in a file. The file `MASTER.rel' is used for +;; storing information about a document with master file `MASTER.tex'. +;; It is written each time RefTeX parses (part of) the document, and +;; restored when you begin working with a document in a new editing +;; session. To use this feature, put into .emacs: +;; +;; (setq reftex-save-parse-info t) +;;---------------------------------------------------------------------------- +;; ;; RELATED PACKAGES +;; ================ ;; ;; AUCTeX ;; ------ -;; If you are writing any TeX or LaTeX documents with Emacs, you should -;; have a look at AUCTeX, the definitive package to work with TeX and LaTeX. +;; If you are writing TeX or LaTeX documents with Emacs, you should have +;; a look at AUCTeX, the definitive package to work with TeX and LaTeX. ;; Information on AUCTeX can be found here: ;; ;; http://www.sunsite.auc.dk/auctex/ ;; -;; Instead of using the RefTeX functions described above directly, you -;; can also use them indirectly through AUCTeX (>9.7p). RefTeX provides -;; several interface functions which can be used as replacement for -;; corresponding AUCTeX functions dealing with labels and citations. -;; In this way you can work normally with AUCTeX and use RefTeX +;; Instead of using the RefTeX functions described above directly, you can +;; also use them indirectly, through AUCTeX (version 9.8a or later). +;; RefTeX provides several interface functions which can be used as +;; replacement for corresponding AUCTeX functions dealing with labels and +;; citations. In this way you can work normally with AUCTeX and use RefTeX ;; internals to create and complete labels and citation keys. ;; ;; `reftex-label' can be used as the `LaTeX-label-function' which does -;; label insertion when new environments are created with C-c C-e. +;; label insertion when new environments are created with `C-c C-e'. ;; ;; `reftex-arg-label', `reftex-arg-ref' and `reftex-arg-cite' can replace -;; the corresponding `TeX-arg-...' functions. E.g. when you insert a -;; label macro with `C-c RET label RET', RefTeX will be transparently used -;; to create the label. +;; the corresponding `TeX-arg-...' functions. E.g. when you insert a label +;; macro with `C-c RET label RET', RefTeX will be transparently used to +;; create the label. ;; -;; In order to plug all 4 functions into AUCTeX, use in .emacs: +;; In order to plug all 4 functions into AUCTeX, use: ;; ;; (setq reftex-plug-into-AUCTeX t) ;; -;; You may also choose to plug in only some of these functions. The -;; following setting will leave TeX-arg-cite as it was while replacing -;; the other 3 AUCTeX functions: -;; -;; (setq reftex-plug-into-AUCTeX '(t t t nil)) +;; You may also choose to plug in only some of these functions. See the +;; docstring of `reftex-plug-into-AUCTeX'. ;; ;; AUCTeX can support RefTeX via style files. A style file may contain ;; calls to `reftex-add-to-label-alist' which defines additions to -;; `reftex-label-alist'. The argument taken by this function must have -;; the same format as `reftex-label-alist'. The `amsmath.el' style file -;; of AUCTeX (>9.7p) for example contains the following: +;; `reftex-label-alist'. The argument taken by this function must have the +;; same format as `reftex-label-alist'. The `amsmath.el' style file of +;; AUCTeX (>9.7p) for example contains the following: ;; ;; (TeX-add-style-hook "amsmath" ;; (function @@ -362,111 +514,93 @@ ;; (lambda () ;; (if (featurep 'reftex) ;; (reftex-add-to-label-alist -;; '(("proposition" ?p "prop:" "~\\ref{%s}" t +;; '(("proposition" ?p "prop:" "~\\ref{%s}" t ;; ("Proposition" "Prop.")))))))) ;; ;; Bib-cite.el ;; ----------- -;; Once you have written a document with labels, refs and citations, -;; it can be nice to read such a file like a hypertext document. -;; RefTeX has some support for that (`reftex-view-crossref', -;; `reftex-search-document'). A more elegant interface with mouse -;; support and links into Hyperbole is provided (among other things) -;; by Peter S. Galbraith's `bib-cite.el'. There is some overlap in the -;; functionalities of Bib-cite and RefTeX. Bib-cite.el comes bundled -;; with AUCTeX. You can also get the latest version from +;; Once you have written a document with labels, refs and citations, it can +;; be nice to read such a file like a hypertext document. RefTeX has some +;; support for that (`reftex-view-crossref', `reftex-search-document'). A +;; more elegant interface with mouse support and links into Hyperbole is +;; provided (among other things) by Peter S. Galbraith's `bib-cite.el'. +;; There is some overlap in the functionalities of Bib-cite and RefTeX. +;; Bib-cite.el comes bundled with AUCTeX. You can also get the latest +;; version from ;; ;; ftp://ftp.phys.ocean.dal.ca/users/rhogee/elisp/bib-cite.el -;; -;;------------------------------------------------------------------------- -;; -;; PERFORMANCE ISSUES -;; -;; 1. RefTeX will load other parts of a multifile document as well as BibTeX -;; database files for lookup purposes. These buffers are kept, so that -;; subsequent lookup in the same files is fast. For large documents and -;; large BibTeX databases, this can use up a lot of memory. If you have -;; more time than memory, try the following option, which will remove -;; buffers created for lookup after use. -;; -;; (setq reftex-keep-temporary-buffers nil) +;;--------------------------------------------------------------------------- ;; -;; 2. Parsing the document for labels and their context can be slow. -;; Therefore, RefTeX does it just once automatically. Further parsing -;; happens only on user request -;; - with a raw C-u prefix arg to any of the functions `reftex-label', -;; `reftex-reference', `reftex-citation', `reftex-toc'. -;; - with the `r' key from the label selection menu or the *toc* buffer. +;; KNOWN BUGS AND WORK-AROUNDS +;; =========================== ;; -;; *** If you use `reftex-label' to create labels, the list will be -;; *** updated internally, so that no extra parsing is required. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; KNOWN BUGS +;; o \input, \include, \bibliography and \section (etc.) statements have +;; to be first on a line (except for white space). ;; -;; o If you change `reftex-label-alist' in an editing session, you need to -;; reset reftex with `M-x reftex-reset-mode' in order to make these -;; changes effective. Changes introduced with the function -;; `reftex-add-to-label-alist' as well as changes applied from the -;; customization buffer automatically trigger a reset. +;; o RefTeX sees also labels in regions commented out and will refuse to +;; make duplicates of such a label. This is considered to be a feature. ;; -;; o At times the short context shown by RefTeX may not be what you want. -;; In particular, eqnarray environments can be difficult to -;; parse. RefTeX's default behavior for eqnarrays is to scan backwards to -;; either a double backslash or the beginning of the environment. If this -;; gives unsatisfactory results, make it a habit to place the label -;; *before* each equation -;; -;; \begin{eqnarray} -;; \label{eq:1} -;; E = \gamma m c^2 \\ -;; \label{eq:2} -;; \gamma = \sqrt{1-v^2/c^2} -;; \end{eqnarray} -;; -;; and turn off parsing for context in equation and eqnarray environments -;; with -;; -;; (setq reftex-use-text-after-label-as-context "e"). -;; -;; o RefTeX keeps only one global copy of the configuration variables. -;; Also any additions from style files go into a global variable. +;; o When using partial scans (`reftex-enable-partial-scans'), the section +;; numbers in the table of contents may eventually become wrong. A full +;; scan will fix this. +;; +;; o RefTeX keeps only a global copy of the configuration variables. +;; Also, any additions from style files go into a global variable. ;; Practically, this should not be a problem. Theoretically, it could ;; give conflicts if two documents used environments with identical ;; names, but different associated label types. -;; -;; o Input, include, bibliography and section statements have to be first -;; on a line (except for white space) in order to be seen by reftex. -;; -;; o When the document is scanned, RefTeX creates a large buffer containing -;; the entire document instead of scanning the individual files one by -;; one. This is necessary since a file might not contain the context -;; needed by RefTeX. +;; +;; o When using packages which make the buffer representation of a file +;; different from its disk representation (e.g. x-symbol, isotex, +;; iso-cvt) you may find that RefTeX's parsing information sometimes +;; reflects the disk state of a file. This happens only in *unvisited* +;; parts of a multifile document, because RefTeX visits these files +;; literally for speed reasons. Then both short context and section +;; headings may look different from what you usually see on your screen. +;; In rare cases `reftex-toc' may have problems to jump to an affected +;; section heading. There are three possible ways to deal with this: +;; +;; - (setq reftex-keep-temporary-buffers t) +;; This implies that RefTeX will load all parts of a multifile +;; document into Emacs (i.e. there will be no temporary buffers). +;; - (setq reftex-initialize-temporary-buffers t) +;; This means full initialization of temporary buffers. It involves +;; a penalty when the same file is used for lookup often. +;; - Set `reftex-initialize-temporary-buffers' to a list of hook +;; functions doing a minimal initialization. +;; +;; You might also want to check the variable `reftex-refontify-context'. ;; -;; o If you have two identical section headings in the same file, -;; `reftex-toc' will only let you jump to the first one because it searches -;; for the section heading from the beginning of the file. You can work -;; around this by changing one of the section titles in a way LaTeX does -;; not see, e.g. with extra white space. RefTeX will distinguish -;; \section{Introduction} from \section{ Introduction}. +;; o Some nasty :-# packages use an additional argument to a \begin macro +;; to specify a label. E.g. Lamport's "pf.sty" uses both +;; +;; \step{LABEL}{CLAIM} and \begin{step+}{LABEL} +;; CLAIM +;; \end{step+} +;; +;; We need to trick RefTeX into swallowing this: ;; -;; o RefTeX sees also labels in regions commented out and will refuse to -;; make duplicates of such a label. This is considered to be a feature. -;; -;; o When RefTeX tries to show a window full of context from inside a -;; section hidden with `outline-minor-mode', it will unhide that section. -;; This change will not be reversed automatically. +;; ;; Configuration for Lamport's pf.sty +;; (setq reftex-label-alist +;; '(("\\step{*}{}" ?p "st:" "~\\stepref{%s}" 2 ("Step" "St.")) +;; ("\\begin{step+}{*}" ?p "st:" "~\\stepref{%s}" 1000))) ;; -;;--------------------------------------------------------------------------- +;; The first line is just a normal configuration for a macro. For the +;; `step+' environment we actually tell RefTeX to look for the *macro* +;; "\begin{step+}" and interprete the *first* argument (which in reality +;; is a second argument to the macro \begin) as a label of type ?p. +;; Argument count for this macro starts only after the {step+}, also +;; when specifying how to get context. ;; -;; TO DO -;; -;; I think I am pretty much done with this one... -;; +;; o In XEmacs 19.15, the overlay library has a bug. RefTeX does not +;; suffer from it, but since it loads the library, other packages like +;; GNUS will switch from extents to overlays and hit the bug. Upgrade +;; to XEmacs 20, or fix the overlay library (in line 180 of overlay.el, +;; change `(list before after)' to `(cons before after)'). ;;--------------------------------------------------------------------------- ;; ;; AUTHOR +;; ====== ;; ;; Carsten Dominik <dominik@strw.LeidenUniv.nl> ;; @@ -480,29 +614,113 @@ ;; THANKS TO: ;; --------- ;; At least the following people have invested time to test and bug-fix -;; reftex.el. Some have send patches for fixes or new features. +;; reftex.el. Some have send patches for fixes or new features, or came +;; up with useful ideas. ;; ;; Stephen Eglen <stephene@cogs.susx.ac.uk> -;; F.E.Burstall <F.E.Burstall@maths.bath.ac.uk> +;; F.E. Burstall <F.E.Burstall@maths.bath.ac.uk> ;; Karl Eichwalder <ke@ke.Central.DE> ;; Laurent Mugnier <mugnier@onera.fr> ;; Rory Molinari <molinari@yunt.math.lsa.umich.edu> ;; Soren Dayton <csdayton@cs.uchicago.edu> ;; Daniel Polani <polani@Informatik.Uni-Mainz.DE> ;; Allan Strand <astrand@trillium.NMSU.Edu> +;; Adrian Lanz <lanz@waho.ethz.ch> +;; Jan Vroonhof <vroonhof@math.ethz.ch> +;; Alastair Burt <alastair.burt@dfki.de> +;; Dieter Kraft <dkraft@acm.org> +;; Robin S. Socha <r.socha@franck.pc.uni-koeln.de> ;; -;; The view crossref feature was inspired by the similar function in +;; The view crossref feature was inspired by the similar function in ;; Peter S. Galbraith's bib-cite.el. -;; +;; ;; Finally thanks to Uwe Bolick <bolick@physik.tu-berlin.de> who first ;; got me (some years ago) into supporting LaTeX labels and references ;; with an Editor (which was MicroEmacs at the time). ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; +;; HISTORY +;; ======= +;; +;; Here are the more important changes made to RefTeX since initial release. +;; Minor bug fixes are not mentioned. +;; +;; Version 1.00 +;; - released on 7 Jan 1997. +;; Version 1.04 +;; - Macros as wrappers, AMSTeX support, delayed context parsing for +;; new labels. +;; Version 1.05 +;; - XEmacs port. +;; Version 1.07 +;; - RefTeX gets its own menu. +;; Version 1.09 +;; - Support for tex-main-file, an analogue for TeX-master. +;; - MS-DOS support. +;; Version 2.00 +;; - Labels can be derived from context (default for sections). +;; - Configuration of label insertion and label referencing revised. +;; - Crossref fields in BibTeX database entries. +;; - `reftex-toc' introduced (thanks to Stephen Eglen). +;; Version 2.03 +;; - Figure*, table*, Sidewaysfigure/table added to default environments. +;; - `reftex-bibfile-ignore-list' introduced (thanks to Rory Molinari). +;; - New functions `reftex-arg-label', `reftex-arg-ref', `reftex-arg-cite'. +;; - Emacs/XEmacs compatibility reworked. XEmacs 19.15 now is required. +;; - `reftex-add-to-label-alist' (to be called from AUCTeX style files). +;; - Finding context with a hook function. +;; - Sorting BibTeX entries (new variable: `reftex-sort-bibtex-matches'). +;; Version 2.05 +;; - Support for `custom.el'. +;; - New function `reftex-grep-document' (thanks to Stephen Eglen). +;; Version 2.07 +;; - New functions `reftex-search-document', `reftex-query-replace-document' +;; Version 2.11 +;; - Submitted for inclusion to Emacs and XEmacs. +;; Version 2.14 +;; - Variable `reftex-plug-into-AUCTeX' simplifies cooperation with AUCTeX. +;; Version 2.17 +;; - Label prefix expands % escapes with current file name and other stuff. +;; - Citation format now with % escapes. This is not backward compatible! +;; - TEXINPUTS variable recognized when looking for input files. +;; - Context can be the nth argument of a macro. +;; - Searching in the select buffer is now possible (C-s and C-r). +;; - Display and derive-label can use two different context methods. +;; - AMSmath xalignat and xxalignat added. +;; - THIS IS THE VERSION DISTRIBUTED WITH EMACS 20.1 and 20.2 +;; Version 3.00 +;; - RefTeX should work better for very large projects: +;; - The new parser works without creating a master buffer. +;; - Rescanning can be limited to a part of a multifile document. +;; - Information from the parser can be stored in a file. +;; - RefTeX can deal with macros having a naked label as an argument. +;; - Macros may have white space and newlines between arguments. +;; - Multiple identical section headings no longer confuse `reftex-toc'. +;; - RefTeX should work correctly in combination with buffer-altering +;; packages like outline, folding, x-symbol, iso-cvt, isotex, etc. +;; - All labeled environments discussed in `The LaTeX Companion' by +;; Goossens, Mittelbach & Samarin, Addison-Wesley 1994) are part of +;; RefTeX's defaults. +;; Version 3.03 +;; - Support for the LaTeX package `xr', for inter-document references. +;; - A few (minor) Mule-related changes. +;; - Fixed bug which could cause HUGE .rel files. +;; - Search for input and .bib files with recursive path definitions. +;; Version 3.04 +;; - Fixed BUG in the `xr' support. +;; Version 3.05 +;; - Compatibility code now first checks for XEmacs feature. +;; Version 3.07 +;; - `Ref' menu improved. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;;;;; ;;; Code: +(eval-when-compile (require 'cl)) + ;; Stuff that needs to be there when we use defcustom ;; -------------------------------------------------- @@ -516,103 +734,322 @@ (setq reftex-tables-dirty t) (set symbol value))) +(eval-and-compile + (defmacro reftex-fp (n) + (if (fboundp 'forward-point) + (list 'forward-point n) + (list '+ '(point) n)))) + ;;; Begin of Configuration Section ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Define the two constants which are needed during compilation + +(eval-and-compile +(defconst reftex-label-alist-builtin + '( + ;; Some aliases, mostly for backward compatibility + (Sideways "Alias for -->rotating" (rotating)) + (AMSTeX "amsmath with eqref macro" + ((nil ?e nil "~\\eqref{%s}") + amsmath)) + + ;; Individual package defaults + (amsmath "AMS-LaTeX math environments" + (("align" ?e nil nil eqnarray-like) + ("gather" ?e nil nil eqnarray-like) + ("multline" ?e nil nil t) + ("flalign" ?e nil nil eqnarray-like) + ("alignat" ?e nil nil alignat-like) + ("xalignat" ?e nil nil alignat-like) + ("xxalignat" ?e nil nil alignat-like) + ("subequations" ?e nil nil t))) + + (endnotes "The \\endnote macro" + (("\\endnote[]{}" ?n nil nil 2 ("Endnote")))) + + (fancybox "The Beqnarray environment" + (("Beqnarray" ?e nil nil eqnarray-like))) + + (floatfig "The floatingfigure environment" + (("floatingfigure" ?f nil nil caption))) + + (longtable "The longtable environment" + (("longtable" ?t nil nil caption))) + + (picinpar "The figwindow and tabwindow environments" + (("figwindow" ?f nil nil 1) + ("tabwindow" ?f nil nil 1))) + + (rotating "Sidewaysfigure and table" + (("sidewaysfigure" ?f nil nil caption) + ("sidewaystable" ?t nil nil caption))) + + (subfigure "Subfigure environments/macro" + (("subfigure" ?f nil nil caption) + ("subfigure*" ?f nil nil caption) + ("\\subfigure[]{}" ?f nil nil 1))) + + (supertab "Supertabular environment" + (("supertabular" ?t nil nil "\\tablecaption{"))) + + (wrapfig "The wrapfigure environment" + (("wrapfigure" ?f nil nil caption))) + + ;; The LaTeX core stuff + (LaTeX "LaTeX default environments" + (("section" ?s "sec:" "~\\ref{%s}" (nil . t) + ("Part" "Chapter" "Chap." "Section" "Sec." "Sect." "Paragraph" "Par." + "\\S" "Teil" "Kapitel" "Kap." "Abschnitt" )) + + ("enumerate" ?i "item:" "~\\ref{%s}" item + ("Item" "Punkt")) + + ("equation" ?e "eq:" "~(\\ref{%s})" t + ("Equation" "Eq." "Eqn." "Gleichung" "Gl.")) + ("eqnarray" ?e "eq:" nil eqnarray-like) + + ("figure" ?f "fig:" "~\\ref{%s}" caption + ("Figure" "Fig." "Abbildung" "Abb.")) + ("figure*" ?f nil nil caption) + + ("table" ?t "tab:" "~\\ref{%s}" caption + ("Table" "Tab." "Tabelle")) + ("table*" ?t nil nil caption) + + ("\\footnote[]{}" ?n "note:" "~\\ref{%s}" 2 + ("Footnote" "Note")) + + ("any" ?\ " " "\\ref{%s}" nil))) + + ) + "The default label environment descriptions. +Lower-case symbols correspond to a style file of the same name in the LaTeX +distribution. Mixed-case symbols are convenience aliases.") + +(defconst reftex-cite-format-builtin + '( + (default "Default macro \\cite{%l}" + "\\cite{%l}") + (natbib "The Natbib package" + ((?\C-m . "\\cite{%l}") + (?t . "\\citet{%l}") + (?T . "\\citet*{%l}") + (?p . "\\citep{%l}") + (?P . "\\citep*{%l}") + (?e . "\\citep[e.g.][]{%l}") + (?a . "\\citeauthor{%l}") + (?y . "\\citeyear{%l}"))) + (harvard "The Harvard package" + ((?\C-m . "\\cite{%l}") + (?p . "\\cite{%l}") + (?t . "\\citeasnoun{%l}") + (?n . "\\citeasnoun{%l}") + (?s . "\\possessivecite{%l}") + (?e . "\\citeaffixed{%l}{?}") + (?y . "\\citeyear{%l}") + (?a . "\\citename{%l}"))) + (chicago "The Chicago package" + ((?\C-m . "\\cite{%l}") + (?t . "\\citeN{%l}") + (?T . "\\shortciteN{%l}") + (?p . "\\cite{%l}") + (?P . "\\shortcite{%l}") + (?a . "\\citeA{%l}") + (?A . "\\shortciteA{%l}") + (?y . "\\citeyear{key}"))) + (astron "The Astron package" + ((?\C-m . "\\cite{%l}") + (?p . "\\cite{%l}" ) + (?t . "%2a (\\cite{%l})"))) + (author-year "Do-it-yourself Author-year" + ((?\C-m . "\\cite{%l}") + (?t . "%2a (%y)\\nocite{%l}") + (?p . "(%2a %y\\nocite{%l})"))) + (locally "Full info in parenthesis" + "(%2a %y, %j %v, %P, %e: %b, %u, %s %<)") + ;; undocumented feature: `%<' kills white space and punctuation locally. + ) + "Builtin versions of for the citation format. +The following conventions are valid for all alist entries: +`?\C-m' should always point to a straight \\cite{%l} macro. +`?t' should point to a textual citation (citation as a noun). +`?p' should point to a parenthetical citation.") +) + ;; Configuration Variables and User Options for RefTeX ------------------ (defgroup reftex nil "LaTeX label and citation support." :tag "RefTeX" - :link '(url-link :tag "Home Page" "http://strw.leidenuniv.nl/~dominik/Tools/") + :link '(url-link :tag "Home Page" + "http://strw.leidenuniv.nl/~dominik/Tools/") + :link '(emacs-commentary-link :tag "Commentary in reftex.el" "reftex.el") :prefix "reftex-" :group 'tex) (defun reftex-customize () "Call the customize function with reftex as argument." (interactive) - (if (fboundp 'customize-group) - (customize-group 'reftex) - (customize 'reftex))) + ;; Depending on the customize version we can call different functions. + (cond + ((fboundp 'customize-browse) + (customize-browse 'reftex)) + ((fboundp 'customize-group) + (customize-group 'reftex)) + ((fboundp 'customize) + (customize 'reftex)) + (t (error "Custom.el not available")))) + +(defun reftex-show-commentary () + "Use the finder to view the file documentation from `reftex.el'." + (interactive) + (require 'finder) + (finder-commentary "reftex.el")) ;; Support for \label and \ref -------------------------------------- (defgroup reftex-label-support nil "Support for creation, insertion and referencing of labels in LaTeX." - :prefix "reftex-" :group 'reftex) (defgroup reftex-defining-label-environments nil "Definition of environments and macros to do with label." - :prefix "reftex-" :group 'reftex-label-support) +;; Make a constant for the customization stuff +(eval-and-compile + (defconst reftex-tmp + '((const :tag "Default position" t) + (const :tag "After label" nil) + (number :tag "Macro arg nr" 1) + (regexp :tag "Regexp" "") + (const :tag "Caption in float" caption) + (const :tag "Item in list" item) + (const :tag "Eqnarray-like" eqnarray-like) + (const :tag "Alignat-like" alignat-like) + (symbol :tag "Function" my-func)))) + +(defcustom reftex-default-label-alist-entries + '(amsmath endnotes fancybox floatfig longtable picinpar + rotating subfigure supertab wrapfig LaTeX) + "Default label alist specifications. LaTeX should be the last entry. +This list describes the default label environments RefTeX should always use. +It is probably a mistake to remove the LaTeX symbol from this list. + +The options include: +LaTeX The standard LaTeX environments. +Sideways The sidewaysfigure and sidewaystable environments. +AMSTeX The math environments in the AMS-LaTeX amsmath package. + +For the full list of options, try + +M-x customize-variable RET reftex-default-label-alist-entries RET." + :group 'reftex-defining-label-environments + :set 'reftex-set-dirty + :type `(set + :indent 4 + :inline t + :greedy t + ,@(mapcar + (function + (lambda (x) + (list 'const ':tag (concat (symbol-name (nth 0 x)) + ": " (nth 1 x)) + (nth 0 x)))) + reftex-label-alist-builtin))) (defcustom reftex-label-alist nil "Alist with information on environments for \\label-\\ref use. -See the definition of `reftex-label-alist-builtin' for examples. This variable -should define additions and changes to the default. The only things you MUST -NOT change is that `?s' is the type indicator for section labels and SPACE is -for the `any' label type. These are hard-coded at other places in the code. - -Changes to this variable after RefTeX has been loaded become only -effective when RefTeX is reset with \\[reftex-reset-mode]. - -Each list entry is a list describing an environment or macro carrying a -label. The elements of each list entry are: + +This docstring is easier to understand after reading the configuration +examples in `reftex.el'. Looking at the builtin defaults in the constant +`reftex-label-alist-builtin' may also be instructive. + +Set this variable to define additions and changes to the default. The only +things you MUST NOT change is that `?s' is the type indicator for section +labels, and SPC for the `any' label type. These are hard-coded at other +places in the code. + +Each list entry describes either an environment carrying a counter for use +with \\label and \\ref, or a LaTeX macro defining a label as (or inside) +one of its arguments. The elements of each list entry are: 0. Name of the environment (like \"table\") or macro (like \"\\\\myfig\"). + For macros, indicate the macro arguments for best results, as in + \"\\\\myfig[]{}{}{*}{}\". Use square brackets for optional arguments, + a star to mark the label argument, if any. The macro does not have to + have a label argument - you could also use \\label{..} inside one of + its arguments. Special names: `section' for section labels, `any' to define a group which contains all labels. - This may also be nil if this entry is only meant to change some settings + This may also be nil if the entry is only meant to change some settings associated with the type indicator character (see below). -1. Type indicator character, like `?t'. - The type indicator is a single character used in prompts for - label types. It must be a printable character. The same character - may occur several times in this list, to cover cases in which different - environments carry the same label type (like equation and eqnarray). +1. Type indicator character, like `?t', must be a printable ASCII character. + The type indicator is a single character which defines a label type. + Any label inside the environment or macro is assumed to belong to this + type. The same character may occur several times in this list, to cover + cases in which different environments carry the same label type (like + `equation' and `eqnarray'). 2. Label prefix string, like \"tab:\". The prefix is a short string used as the start of a label. It may be the - empty string. - -3. Format string for reference insert in buffer. Each `%s' will be replaced - by the label (several `%s' can be there to do this: - \"\\ref{%s} on page~\\pageref{%s}\"). + empty string. The prefix may contain the following `%' escapes: + %f Current file name with directory and extension stripped. + %F Current file name relative to directory of master file. + %u User login name, on systems which support this. + + Example: In a file `intro.tex', \"eq:%f:\" will become \"eq:intro:\"). + +3. Format string for reference insert in buffer. `%s' will be replaced by + the label. When the format starts with `~', whitespace before point will be removed so that the reference cannot be separated from the word before it. 4. Indication on how to find the short context. - If nil, use the text following the \\label{...} macro. - If t, use - - text following the \\begin{...} statement of environments - (not a good choice in in eqnarray or enumerate environments!) - the section heading for section labels. - - the begin of the macro for macros. + - text following the \\begin{...} statement of environments. + (not a good choice for environments like eqnarray or enumerate, + where one has several labels in a single environment). + - text after the macro name (stearting with the first arg) for macros. + - If an integer, use the nth argument of the macro. As a special case, + 1000 means to get text after the last macro argument. - If a string, use as regexp to search *backward* from the label. Context is then the text following the end of the match. E.g. putting this to - \"\\\\\\\\caption{\" will use the beginning of the caption in a figure - or table environment. + \"\\\\\\\\caption[[{]\" will use the caption in a figure or table + environment. \"\\\\\\\\begin{eqnarray}\\\\|\\\\\\\\\\\\\\\\\" works for eqnarrays. + - If any of `caption', `item', `eqnarray-like', `alignat-like', this + symbol will internally be translated into an appropriate regexp + (see also the variable `reftex-default-context-regexps'). - If a function, call this function with the name of the environment/macro as argument. On call, point will be just after the \\label macro. The function is expected to return a suitable context string. It should throw an exception (error) when failing to find context. - Consider the following example, which would return the 10 characters - following the label as context: + As an example, here is a function returning the 10 chars following + the label macro as context: (defun my-context-function (env-or-mac) (if (> (point-max) (+ 10 (point))) (buffer-substring (point) (+ 10 (point))) (error \"Buffer too small\"))) + Label context is used in two ways by RefTeX: For display in the label + menu, and to derive a label string. If you want to use a different + method for each of these, specify them as a dotted pair. + E.g. `(nil . t)' uses the text after the label (nil) for display, and + text from the default position (t) to derive a label string. This is + actually used for section labels. + Setting the variable `reftex-use-text-after-label-as-context' to t overrides the setting here. 5. List of magic words which identify a reference to be of this type. If the word before point is equal to one of these words when calling - `reftex-reference', the label list offered will be automatically restricted - to labels of the correct type. + `reftex-reference', the label list offered will be automatically + restricted to labels of the correct type. If the type indicator characters of two or more entries are the same, RefTeX will use @@ -621,77 +1058,81 @@ Any list entry may also be a symbol. If that has an association in `reftex-label-alist-builtin', the cdr of that association is spliced into the -list. See the AMSTeX configuration example in the comment section of -`reftex.el'." +list. However, builtin defaults should normally be set here but with the +variable `reftex-default-label-alist-entries." :group 'reftex-defining-label-environments :set 'reftex-set-dirty - :type '(list - :convert-widget - (lambda (widget) - (let* - ((args - (list - `(repeat - :inline t - (radio - :value ("" ?a nil nil t nil) - (choice - :tag "Builtin" - :value AMSTeX - ,@(mapcar (function (lambda (x) - (list 'const ':tag (nth 1 x) (car x)))) - reftex-label-alist-builtin)) - (list :tag "Detailed custom entry" - (choice :tag "Environment or \\macro " - (const :tag "Ignore, just use typekey" nil) - (string "")) - (character :tag "Typekey character " ?a) - (choice :tag "Label prefix string " - (const :tag "Copy from similar label type" nil) - (string :tag "Specify here" "lab:")) - (choice :tag "Label reference format" - (const :tag "Copy from similar label type" nil) - (string :tag "Specify here" "~\\ref{%s}")) - (choice :tag "Grab context method " - (const :tag "Default position" t) - (const :tag "After label" nil) - (regexp :tag "Regular expression" "") - (symbol :tag "Function" my-context-function)) - (repeat :tag "List of Magic Words" (string)))))))) - (widget-put widget :args args) - widget)))) - -(defcustom reftex-default-label-alist-entries '(Sideways LaTeX) - "Default label alist specifications. LaTeX should be the last entry. -This list describes the default label environments RefTeX should always use -in addition to the specifications in reftex-label-alist. It is probably a -mistake to remove the LaTeX symbol from this list. - -The options include: -LaTeX The standard LaTeX environments -Sideways The sidewaysfigure and sidewaystable environments -AMSTeX The math environments in the AMS_LaTeX amsmath package - -For the full list of options, see the constant `reftex-label-alist-builtin'. -Better still, try - -M-x customize-variable RET reftex-default-label-alist-entries RET." + :type + `(repeat + (choice + :value ("" ?a nil nil nil nil) + (list :tag "Detailed label alist entry" + :value ("" ?a nil nil nil nil) + (choice :tag "Environment or \\macro " + (const :tag "Ignore, just use typekey" nil) + (string "")) + (character :tag "Typekey character " ?a) + (choice :tag "Label prefix string " + (const :tag "Default" nil) + (string :tag "String" "lab:")) + (choice :tag "Label reference format" + (const :tag "Default" nil) + (string :tag "String" "~\\ref{%s}")) + (choice :tag "Context" + (choice + :tag "1 method" + ,@reftex-tmp) + (cons :tag "Split methods" + (choice + :tag " Display context " + ,@reftex-tmp) + (choice + :tag " Derive label context" + ,@reftex-tmp))) + (repeat :tag "List of Magic Words" (string))) + (choice + :tag "Package" + :value AMSTeX + ,@(mapcar + (function + (lambda (x) + (list 'const ':tag (concat (symbol-name (nth 0 x))); ": " (nth 1 x)) + (nth 0 x)))) + reftex-label-alist-builtin))))) + +;; LaTeX section commands and level numbers +(defcustom reftex-section-levels + '( + ("part" . 0) + ("chapter" . 1) + ("section" . 2) + ("subsection" . 3) + ("subsubsection" . 4) + ("paragraph" . 5) + ("subparagraph" . 6) + ("subsubparagraph" . 7) + ) + "Commands and levels used for defining sections in the document. +The car of each cons cell is the name of the section macro. The cdr is a +number indicating its level." :group 'reftex-defining-label-environments - :set 'reftex-set-dirty - :type '(list :indent 4 - :convert-widget - (lambda (widget) - (let* ((args - (list - `(checklist - :inline t - ,@(reverse - (mapcar (lambda (x) - (list 'const ':tag (nth 1 x) (car x))) - reftex-label-alist-builtin)))))) - (widget-put widget :args args) - widget)))) - + :set 'reftex-set-dirty + :type '(repeat + (cons (string :tag "sectioning macro" "") + (number :tag "level " 0)))) + +(defcustom reftex-default-context-regexps + '((caption . "\\\\\\(rot\\)?caption\\*?[[{]") + (item . "\\\\item\\(\\[[^]]*\\]\\)?") + (eqnarray-like . "\\\\begin{%s}\\|\\\\\\\\") + (alignat-like . "\\\\begin{%s}{[0-9]*}\\|\\\\\\\\")) +"Alist with default regular expressions for finding context. +The form (format regexp (regexp-quote environment)) is used to calculate +the final regular expression - so %s will be replaced with the environment +or macro." + :group 'reftex-defining-label-environments + :type '(repeat (cons (symbol) (regexp)))) + (defcustom reftex-use-text-after-label-as-context nil "*t means, grab context from directly after the \\label{..} macro. This is the fastest method for obtaining context of the label definition, but @@ -702,14 +1143,13 @@ :group 'reftex-defining-label-environments :set 'reftex-set-dirty :type '(choice - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types"))) + (const :tag "on" t) (const :tag "off" nil) + (string :tag "Selected label types"))) ;; Label insertion (defgroup reftex-making-and-inserting-labels nil "Options on how to create new labels." - :prefix "reftex-" :group 'reftex-label-support) (defcustom reftex-insert-label-flags '("s" "sft") @@ -720,6 +1160,8 @@ The conversion of the context to a legal label is governed by the specifications given in `reftex-derive-label-parameters'. If RefTeX fails to derive a label, it will prompt the user. +If DERIVE is nil, the label generated will consist of the prefix and a +unique number, like `eq:23'. If PROMPT is t, the user will be prompted for a label string. The prompt will already contain the prefix, and (if DERIVE is t) a default label derived from @@ -746,14 +1188,14 @@ :type '(list (choice :tag "Derive label from context" (const :tag "always" t) (const :tag "never" nil) - (string :tag "for selected label types" "")) + (string :tag "selected label types" "")) (choice :tag "Prompt for label string " :entry-format " %b %v" (const :tag "always" t) (const :tag "never" nil) - (string :tag "for selected label types" "")))) - -(defcustom reftex-derive-label-parameters '(3 20 t 1 "-" ; continue + (string :tag "selected label types" "")))) + +(defcustom reftex-derive-label-parameters '(3 20 t 1 "-" ("the" "on" "in" "off" "a" "for" "by" "of" "and" "is")) "Parameters for converting a string into a label. NWORDS Number of words to use. @@ -768,19 +1210,19 @@ IGNOREWORDS List of words which should not be part of labels." :group 'reftex-making-and-inserting-labels :type '(list (integer :tag "Number of words " 3) - (integer :tag "Maximum label length " 20) - (choice :tag "Illegal characters in words" - (const :tag "throw away entire word" nil) - (const :tag "throw away single chars" t)) - (choice :tag "Abbreviate words " - (const :tag "never" nil) - (const :tag "always" t) - (const :tag "when label is too long" 1)) - (string :tag "Separator between words " "-") - (repeat :tag "Ignore words" - :entry-format " %i %d %v" - (string :tag "")))) - + (integer :tag "Maximum label length " 20) + (choice :tag "Illegal characters in words" + (const :tag "throw away entire word" nil) + (const :tag "throw away single chars" t)) + (choice :tag "Abbreviate words " + (const :tag "never" nil) + (const :tag "always" t) + (const :tag "when label is too long" 1)) + (string :tag "Separator between words " "-") + (repeat :tag "Ignore words" + :entry-format " %i %d %v" + (string :tag "")))) + (defcustom reftex-label-illegal-re "[\000-\040\177-\377\\\\#$%&~^_{}]" "Regexp matching characters not legal in labels. For historic reasons, this character class comes *with* the [] brackets." @@ -795,21 +1237,25 @@ AFTER Character class after abbrev point in word." :group 'reftex-making-and-inserting-labels :type '(list - (integer :tag "Minimum chars per word" 4) - (integer :tag "Shorten by at least " 2) - (string :tag "cut before char class " "^saeiou") - (string :tag "cut after char class " "aeiou"))) - + (integer :tag "Minimum chars per word" 4) + (integer :tag "Shorten by at least " 2) + (string :tag "cut before char class " "^saeiou") + (string :tag "cut after char class " "aeiou"))) ;; Label referencing (defgroup reftex-referencing-labels nil "Options on how to reference labels." - :prefix "reftex-" :group 'reftex-label-support) -(defcustom reftex-label-menu-flags '(t t nil nil nil nil) - "*List of flags governing the label menu makeup. +(eval-and-compile + (defconst reftex-tmp + '((const :tag "on" t) + (const :tag "off" nil) + (string :tag "Selected label types")))) + +(defcustom reftex-label-menu-flags '(t t nil nil nil nil t nil) + "List of flags governing the label menu makeup. The flags are: TABLE-OF-CONTENTS Show the labels embedded in a table of context. @@ -817,8 +1263,9 @@ COUNTERS Show counters. This just numbers the labels in the menu. NO-CONTEXT Non-nil means do NOT show the short context. FOLLOW Follow full context in other window. -SHOW-COMMENTED Show labels from regions which are commented out. RefTeX - sees these labels, but does not normally show them. +SHOW-COMMENTED Show labels from regions which are commented out. +MATCH-IN-TOC Searches in label menu will also match in toc lines. +SHOW FILES Show Begin and end of included files. Each of these flags can be set to t or nil, or to a string of type letters indicating the label types for which it should be true. These strings work @@ -830,25 +1277,37 @@ decide here to not have a table of contents in the label menu, you can still get one interactively during selection from the label menu." :group 'reftex-referencing-labels - :type '(list - (choice :tag "Embed in table of contents " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Show section numbers " - (const :tag "on" t) (const :tag "off" nil)) - (choice :tag "Show individual counters " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Hide short context " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Follow context in other window" - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")) - (choice :tag "Show commented labels " - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types")))) - + :type + `(list + (choice :tag "Embed in table of contents " ,@reftex-tmp) + (choice :tag "Show section numbers " ,@reftex-tmp) + (choice :tag "Show individual counters " ,@reftex-tmp) + (choice :tag "Hide short context " ,@reftex-tmp) + (choice :tag "Follow context in other window " ,@reftex-tmp) + (choice :tag "Show commented labels " ,@reftex-tmp) + (choice :tag "Searches match in toc lines " ,@reftex-tmp) + (choice :tag "Show begin/end of included files" ,@reftex-tmp))) + +(defcustom reftex-level-indent 2 + "*Number of spaces to be used for indentation per section level." + :group 'reftex-referencing-labels + :type '(integer)) + +(defcustom reftex-refontify-context 1 + "*Non-nil means, re-fontify the context in the label menu with font-lock. +This slightly slows down the creation of the label menu. It is only necessay +when you definitely want the context fontified. + +This option may have 3 different values: +nil Never refontify. +t Always refontify. +1 Refontify when absolutly necessary, e.g. when with the x-symbol package. +The option is ignored when `reftex-use-fonts' is nil." + :group 'reftex-referencing-labels + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "When necessary" 1))) (defcustom reftex-guess-label-type t "*Non-nil means, `reftex-reference' will try to guess the label type. @@ -863,7 +1322,6 @@ (defgroup reftex-citation-support nil "Support for referencing bibliographic data with BibTeX." - :prefix "reftex-" :group 'reftex) (defcustom reftex-bibpath-environment-variables '("BIBINPUTS" "TEXBIB") @@ -873,7 +1331,7 @@ :type '(repeat (string :tag "Environment variable"))) (defcustom reftex-bibfile-ignore-list nil - "List of files in \\bibliography{..} RefTeX should *not* parse. + "*List of files in \\bibliography{..} RefTeX should *not* parse. The file names have to be in the exact same form as in the bibliography macro - i.e. without the `.bib' extension. Intended for files which contain only `@string' macro definitions and the @@ -891,85 +1349,180 @@ 'reverse-year Sort entries by decreasing year." :group 'reftex-citation-support :type '(choice (const :tag "not" nil) - (const :tag "by author" author) - (const :tag "by year" year) - (const :tag "by year, reversed" reverse-year))) - -(defcustom reftex-cite-format 'reftex-cite-format-default - "Defines the format of citations to be inserted into the buffer. -It can be a string, a list of strings, or an alist with characters as keys -and a list of strings in the car. In the simplest case, this can just -be the string \"\\cite{KEY}\", which is also the default. See the -definition of the `reftex-cite-format-XXXX' constants for more complex -examples. - If `reftex-cite-format' is a string, it will be used as the format. -In the format, AUTHOR will be replaced by the last name of the -author, YEAR will be replaced by the year and KEY by the citation -key. If AUTHOR is present several times, it will be replaced with -successive author names. -See the constant `reftex-cite-format-default' for an example. - If `reftex-cite-format' is a list of strings, the string used will -depend upon the number of authors of the article. No authors means, -the first string will be used; 1 author means, the second string will -be used etc.. The last string in the list will be used for all articles -with too many authors. See `reftex-cite-format-1-author-simple' for an -example. - If `reftex-cite-format' is a list of cons cells, the car of each cell -needs to be a character. When a selected reference is accepted by -pressing that key, the cdr of the associated list will be used as -described above. See `reftex-cite-format-2-authors' for an example. + (const :tag "by author" author) + (const :tag "by year" year) + (const :tag "by year, reversed" reverse-year))) + +(defcustom reftex-cite-format 'default + "*The format of citations to be inserted into the buffer. +It can be a string or an alist. In the simplest case this is just +the string \"\\cite{%l}\", which is also the default. See the +definition of `reftex-cite-format-builtin' for more complex examples. + +If `reftex-cite-format' is a string, it will be used as the format. +In the format, the following percent escapes will be expanded. + +%l The BibTeX label of the citation. +%a List of author names, see also `reftex-cite-punctuation. +%2a Like %a, but abbreviate more than 2 authors like Jones et al. +%A First author name only. +%e Works like %a, but on list of editor names. (%2e and %E work a well) + +It is also possible to access all other BibTeX database fields: +%b booktitle %c chapter %d edition %h howpublished +%i institution %j journal %k key %m month +%n number %o organization %p pages %P first page +%r address %s school %u publisher %t title +%v volume %y year + +Usually, only %l is needed. Try, however, (setq reftex-comment-citations t). + +If `reftex-cite-format' is an alist of characters and strings, the user +will be prompted for a character to select one of the possible format +strings. In order to configure this variable, you can either set `reftex-cite-format' directly yourself or set it to the SYMBOL of one of -the predefined constants. E.g.: -(setq reftex-cite-format 'reftex-cite-format-2-authors)" - :group 'reftex-citation-support - :type -'(choice - (choice :tag "symbolic defaults" - :value reftex-cite-format-default - (const reftex-cite-format-default) - (const reftex-cite-format-1-author-simple) - (const reftex-cite-format-2-authors)) - (string :tag "format string" "\\cite{KEY}") - (repeat :tag "list of strings" - :value ("\cite{KEY}" "AUTHOR \cite{KEY}" "AUTHOR and AUTHOR \cite{KEY}") - (string :tag "format string" "")) - (repeat :tag "key-ed lists of strings" - :value ((? . ("\cite{KEY}" "AUTHOR \cite{KEY}" "AUTHOR and AUTHOR \cite{KEY}"))) - (cons :tag "Enter a keyed list of format strings" - (character :tag "Key character " ? ) - (repeat - (string :tag "format string" "")))))) +the predefined styles (see `reftex-cite-format-builtin'). E.g.: +(setq reftex-cite-format 'harvard)" + :group 'reftex-citation-support + :type + `(choice + :format "%{%t%}: \n%[Value Menu%] %v" + (radio :tag "Symbolic Builtins" + :indent 4 + :value default + ,@(mapcar + (function + (lambda (x) + (list 'const ':tag (concat (symbol-name (nth 0 x)) + ": " (nth 1 x)) + (nth 0 x)))) + reftex-cite-format-builtin)) + (string :tag "format string" "\\cite{%l}") + (repeat :tag "key-ed format strings" + :value ((?\r . "\\cite{%l}") + (?t . "\\cite{%l}") (?p . "\\cite{%l}")) + (cons (character :tag "Key character" ?\r) + (string :tag "Format string" ""))))) + +(defcustom reftex-comment-citations nil + "*Non-nil means add a comment for each citation describing the full entry. +The comment is formatted according to `reftex-cite-comment-format'." + :group 'reftex-citation-support + :type '(boolean)) + +(defcustom reftex-cite-comment-format + "%% %2a %y, %j %v, %P, %e: %b, %u, %s %<\n" + "Citation format used for commented citations. Must NOT contain %l." + :group 'reftex-citation-support + :type '(string)) + +(defcustom reftex-cite-punctuation '(", " " \\& " " {\\it et al.}") + "Punctuation for formatting of name lists in citations. +This is a list of 3 strings. +1. normal names separator, like \", \" in Jones, Brown and Miller +2. final names separator, like \" and \" in Jones, Brown and Miller +3. The \"et al\" string, like \" {...}\" in Jones {\\it et al.}" + :group 'reftex-citation-support + :type '(list + (string :tag "Separator for names ") + (string :tag "Separator for last name in list") + (string :tag "string used as et al. "))) ;; Table of contents configuration -------------------------------------- (defgroup reftex-table-of-contents-browser nil "A multifile table of contents browser." - :prefix "reftex-" :group 'reftex) (defcustom reftex-toc-follow-mode nil - "Non-nil means, point in *toc* buffer will cause other window to follow. + "*Non-nil means, point in *toc* buffer will cause other window to follow. The other window will show the corresponding part of the document. This flag can be toggled from within the *toc* buffer with the `f' key." :group 'reftex-table-of-contents-browser :type '(boolean)) +;; Tuning the parser ---------------------------------------------------- + +(defgroup reftex-optimizations-for-large-documents nil + "Configuration of parser speed and memory usage." + :group 'reftex) + +(defcustom reftex-keep-temporary-buffers 1 + "*Non-nil means, keep buffers created for parsing and lookup. +RefTeX sometimes needs to visit files related to the current document. +We distinguish files visited for +PARSING: Parts of a multifile document loaded when (re)-parsing the document. +LOOKUP: BibTeX database files and TeX files loaded to find a reference, + to display label context, etc. +The created buffers can be kept for later use, or be thrown away immediately +after use, depending on the value of this variable: + +nil Throw away as much as possible. +t Keep everything. +1 Throw away buffers created for parsing, but keep the ones created + for lookup. + +If a buffer is to be kept, the file is visited normally (which is potentially +slow but will happen only once). +If a buffer is to be thrown away, the initialization of the buffer depends +upon the variable `reftex-initialize-temporary-buffers'." + :group 'reftex-miscellaneous-configurations + :type '(choice + (const :tag "Throw away everything" nil) + (const :tag "Keep everything" t) + (const :tag "Keep lookup buffers only" 1))) + +(defcustom reftex-initialize-temporary-buffers nil + "*Non-nil means do initializations even when visiting file temporarily. +When nil, RefTeX may turn off find-file hooks and other stuff to briefly +visit a file. +When t, the full default initializations are done (find-file-hook etc.). +Instead of t or nil, this variable may also be a list of hook functions to +do a minimal initialization." + :group 'reftex-miscellaneous-configurations + :type '(choice + (const :tag "Read files literally" nil) + (const :tag "Fully initialize buffers" t) + (repeat :tag "Hook functions" :value (nil) + (function-item)))) + +(defcustom reftex-enable-partial-scans nil + "*Non-nil means, re-parse only 1 file when asked to re-parse. +Re-parsing is normally requested with a `C-u' prefix to many RefTeX commands, +or with the `r' key in menus. When this option is t in a multifile document, +we will only parse the current buffer, or the file associated with the label +or section heading near point in a menu. Requesting re-parsing of an entire +multifile document then requires a `C-u C-u' prefix or the capital `R' key +in menus." + :group 'reftex-optimizations-for-large-documents + :type 'boolean) + +(defcustom reftex-save-parse-info nil + "*Non-nil means, save information gathered with parsing in a file. +The file MASTER.rel in the same directory as MASTER.tex is used to save the +information. When this variable is t, +- accessing the parsing information for the first time in an editing session + will read that file (if available) instead of parsing the document. +- each time (part of) the document is rescanned, a new version of the file + is written." + :group 'reftex-optimizations-for-large-documents + :type 'boolean) + ;; Miscellaneous configurations ----------------------------------------- (defgroup reftex-miscellaneous-configurations nil "Collection of further configurations." - :prefix "reftex-" :group 'reftex) (defcustom reftex-extra-bindings nil "Non-nil means, make additional key bindings on startup. These extra bindings are located in the users `C-c letter' map." :group 'reftex-miscellaneous-configurations - :type '(boolean)) + :type '(boolean)) (defcustom reftex-plug-into-AUCTeX nil - "Plug-in flags for AUCTeX interface. + "*Plug-in flags for AUCTeX interface. This variable is a list of 4 boolean flags. When a flag is non-nil, it means: @@ -989,15 +1542,15 @@ may require a restart of Emacs in order to become effective." :group 'reftex-miscellaneous-configurations :type '(choice (const :tag "No plug-ins" nil) - (const :tag "All possible plug-ins" t) - (list - :tag "Individual choice" - :value (nil nil nil nil) - (boolean :tag "Use reftex-label as LaTeX-label-function") - (boolean :tag "Use reftex-arg-label as TeX-arg-label ") - (boolean :tag "Use reftex-arg-ref as TeX-arg-ref ") - (boolean :tag "Use reftex-arg-cite as TeX-arg-cite ") - ))) + (const :tag "All possible plug-ins" t) + (list + :tag "Individual choice" + :value (nil nil nil nil) + (boolean :tag "Use reftex-label as LaTeX-label-function") + (boolean :tag "Use reftex-arg-label as TeX-arg-label ") + (boolean :tag "Use reftex-arg-ref as TeX-arg-ref ") + (boolean :tag "Use reftex-arg-cite as TeX-arg-cite ") + ))) (defcustom reftex-use-fonts t "*Non-nil means, use fonts in label menu and on-the-fly help. @@ -1005,23 +1558,28 @@ :group 'reftex-miscellaneous-configurations :type '(boolean)) -(defcustom reftex-keep-temporary-buffers t - "*Non-nil means, keep any TeX and BibTeX files loaded for lookup. -Nil means, kill it immediately after use unless it was already an existing -buffer before the lookup happened. It is faster to keep the buffers, but can -use a lot of memory, depending on the size of your database and document." +(defcustom reftex-auto-show-entry 'copy + "*Non-nil means, do something when context in other window is hidden. +Some modes like `outline-mode' or `folding-mode' hide parts of buffers. +When RefTeX is asked to show context for a label definition, and the context +is invisible, it can unhide that section permanently (value t), or copy the +context to a temporary buffer (value 'copy)." :group 'reftex-miscellaneous-configurations - :type '(boolean)) - -(defcustom reftex-auto-show-entry t - "*Non-nil means, showing context in another window may unhide a section. -This is important when using outline-minor-mode. If the context to be shown -is in a hidden section, RefTeX will issue a \"show-entry\" command in order -to show it. This is not reversed when the label is selected - so the section -remains shown after command completion." + :type '(radio :value copy + :indent 4 + (const :tag "Do nothing" nil) + (const :tag "Unhide section permanently" t) + (const :tag "Copy context to show" copy))) + +(defcustom reftex-load-hook nil + "Hook which is being run when loading reftex.el." :group 'reftex-miscellaneous-configurations - :type '(boolean)) - + :type 'hook) + +(defcustom reftex-mode-hook nil + "Hook which is being run when turning on RefTeX mode." + :group 'reftex-miscellaneous-configurations + :type 'hook) ;;; End of Configuration Section ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1030,7 +1588,7 @@ ;;; Define the formal stuff for a minor mode named RefTeX. ;;; -(defconst reftex-version "2.14 for Emacs distribution." +(defconst reftex-version "RefTeX version 3.7" "Version string for RefTeX.") (defvar reftex-mode nil @@ -1056,7 +1614,7 @@ context of the label definition. The selected label is inserted as a \\ref macro. -Citations can be made with `\\[reftex-citation]' which will use a regular expression +Citations can be made with `\\[reftex-citation]' which will use a regular expression to pull out a *formatted* list of articles from your BibTeX database. The selected citation is inserted as a \\cite macro. @@ -1066,10 +1624,12 @@ Most command have help available on the fly. This help is accessed by pressing `?' to any prompt mentioning this feature. -Extensive documentation about reftex is in the file header of `reftex.el'. +Extensive documentation about RefTeX is in the file header of `reftex.el'. +You can view this information with `\\[reftex-show-commentary]'. \\{reftex-mode-map} -Under X, these functions will also be available in a menu on the menu bar. +Under X, these and other functions will also be available as `Ref' menu +on the menu bar. ------------------------------------------------------------------------------" @@ -1080,28 +1640,16 @@ ; Add or remove the menu, and run the hook (if reftex-mode (progn - (easy-menu-add reftex-mode-menu) - (reftex-plug-into-AUCTeX) - (run-hooks 'reftex-mode-hook)) + (easy-menu-add reftex-mode-menu) + (reftex-plug-into-AUCTeX) + (run-hooks 'reftex-mode-hook)) (easy-menu-remove reftex-mode-menu))) - + (or (assoc 'reftex-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(reftex-mode " Ref") minor-mode-alist))) + (push '(reftex-mode " Ref") minor-mode-alist)) (or (assoc 'reftex-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'reftex-mode reftex-mode-map) - minor-mode-map-alist))) - - - - - - - - - + (push (cons 'reftex-mode reftex-mode-map) minor-mode-map-alist)) ;;; =========================================================================== ;;; @@ -1119,61 +1667,60 @@ ;;; AUCTeX ;;; ------ -(defun reftex-arg-label (optional &optional prompt definition) +(defun reftex-arg-label (optional &optional prompt definition) "Use `reftex-label' to create label. Insert it with `TeX-argument-insert'. This function is intended for AUCTeX macro support." (let ((label (reftex-label nil t))) - (if (and definition (not (string-equal "" label))) - (LaTeX-add-labels label)) + (if (and definition (not (string-equal "" label))) + (LaTeX-add-labels label)) (TeX-argument-insert label optional optional))) -(defun reftex-arg-ref (optional &optional prompt definition) +(defun reftex-arg-ref (optional &optional prompt definition) "Use `reftex-reference' to select label. Insert with `TeX-argument-insert'. This function is intended for AUCTeX macro support." (let ((label (reftex-reference nil t))) - (if (and definition (not (string-equal "" label))) - (LaTeX-add-labels label)) + (if (and definition (not (string-equal "" label))) + (LaTeX-add-labels label)) (TeX-argument-insert label optional optional))) -(defun reftex-arg-cite (optional &optional prompt definition) +(defun reftex-arg-cite (optional &optional prompt definition) "Use reftex-citation to select a key. Insert with `TeX-argument-insert'. This function is intended for AUCTeX macro support." - (let ((key (reftex-citation nil t))) + (let ((key (reftex-citation t))) (TeX-argument-insert (or key "") optional optional))) (defun reftex-plug-into-AUCTeX () ;; Replace AucTeX functions with RefTeX functions. ;; Which functions are replaced is controlled by the variable ;; `reftex-plug-into-AUCTeX'. - (let ((flags - (cond ((eq reftex-plug-into-AUCTeX t) '(t t t t)) - ((eq reftex-plug-into-AUCTeX nil) '(nil nil nil nil)) - (t reftex-plug-into-AUCTeX)))) + (let ((flags + (cond ((eq reftex-plug-into-AUCTeX t) '(t t t t)) + ((eq reftex-plug-into-AUCTeX nil) '(nil nil nil nil)) + (t reftex-plug-into-AUCTeX)))) (and (nth 0 flags) - (boundp 'LaTeX-label-function) - (setq LaTeX-label-function 'reftex-label)) + (boundp 'LaTeX-label-function) + (setq LaTeX-label-function 'reftex-label)) (and (nth 1 flags) - (fboundp 'TeX-arg-label) - (fset 'TeX-arg-label 'reftex-arg-label)) + (fboundp 'TeX-arg-label) + (fset 'TeX-arg-label 'reftex-arg-label)) (and (nth 2 flags) - (fboundp 'TeX-arg-ref) - (fset 'TeX-arg-ref 'reftex-arg-ref)) + (fboundp 'TeX-arg-ref) + (fset 'TeX-arg-ref 'reftex-arg-ref)) (and (nth 3 flags) - (fboundp 'TeX-arg-cite) - (fset 'TeX-arg-cite 'reftex-arg-cite)))) - + (fboundp 'TeX-arg-cite) + (fset 'TeX-arg-cite 'reftex-arg-cite)))) + (defvar reftex-label-alist-external-add-ons nil "List of label alist entries added with reftex-add-to-label-alist.") -;;;###autoload (defun reftex-add-to-label-alist (entry-list) "Add label environment descriptions to `reftex-label-alist-external-add-ons'. -The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there +The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there for details. This function makes it possible to support RefTeX from AUCTeX style files. The entries in ENTRY-LIST will be processed after the user settings in @@ -1185,10 +1732,9 @@ (while entry-list (setq entry (car entry-list) entry-list (cdr entry-list)) - (if (not (member entry reftex-label-alist-external-add-ons)) - (setq reftex-tables-dirty t - reftex-label-alist-external-add-ons - (cons entry reftex-label-alist-external-add-ons)))))) + (unless (member entry reftex-label-alist-external-add-ons) + (setq reftex-tables-dirty t) + (push entry reftex-label-alist-external-add-ons))))) ;;; =========================================================================== ;;; @@ -1203,8 +1749,7 @@ ;; List of variables which handle the multifile stuff. ;; This list is used to tie, untie, and reset these symbols. (defconst reftex-multifile-symbols - '(reftex-label-numbers-symbol reftex-list-of-labels-symbol - reftex-bibfile-list-symbol)) + '(reftex-docstruct-symbol)) ;; Alist connecting master file names with the corresponding lisp symbols. (defvar reftex-master-index-list nil) @@ -1212,29 +1757,13 @@ ;; Last index used for a master file. (defvar reftex-multifile-index 0) -;; Alist connecting a master file with all included files. -(defvar reftex-master-include-list nil) - -;; Variable holding the symbol with current value of label postfix. -(defvar reftex-label-numbers-symbol nil ) -(make-variable-buffer-local 'reftex-label-numbers-symbol) - ;; Variable holding the symbol with the label list of the document. -;; Each element of the label list is again a list with the following elements: -;; 0: One character label type indicator. -;; 1: Short context to put into label menu. -;; 2: The label. -;; 3: The name of the file where the label is defined. -(defvar reftex-list-of-labels-symbol nil) -(make-variable-buffer-local 'reftex-list-of-labels-symbol) - -;; Variable holding the symbol with a list of library files for this document. -(defvar reftex-bibfile-list-symbol nil) -(make-variable-buffer-local 'reftex-bibfile-list-symbol) +(defvar reftex-docstruct-symbol nil) +(make-variable-buffer-local 'reftex-docstruct-symbol) (defun reftex-next-multifile-index () ;; Return the next free index for multifile symbols. - (setq reftex-multifile-index (1+ reftex-multifile-index))) + (incf reftex-multifile-index)) (defun reftex-tie-multifile-symbols () ;; Tie the buffer-local symbols to globals connected with the master file. @@ -1252,10 +1781,8 @@ (setq index (cdr index)) ;; Get a new index and add info to the alist. (setq index (reftex-next-multifile-index) - reftex-master-index-list (cons - (cons master index) - reftex-master-index-list) - newflag t)) + newflag t) + (push (cons master index) reftex-master-index-list)) ;; Get/create symbols and tie them. (while symlist @@ -1328,146 +1855,33 @@ (error "No such master file %s" master))) (expand-file-name master))) -(defun reftex-make-master-buffer (master-file mode) - "Make a master buffer which contains the MASTER-FILE and all includes. -This is to prepare a buffer containing the entire document in correct -sequence for parsing. Therefore it will even expand includes which are -commented out. -The function returns the number of input/include files not found." - - (interactive "fmaster file: ") - (let ((not-found 0) file file-list tmp (font-lock-maximum-size 1)) - (switch-to-buffer "*reftex-master.tex*") - (erase-buffer) - (if (not (eq major-mode mode)) - (funcall mode)) - ;; First insert the master file. - (if (not (file-exists-p master-file)) - (error "No such master file: %s" master-file)) - (reftex-insert-buffer-or-file master-file) - (subst-char-in-region (point-min) (point-max) ?\r ?\n t) - (setq file-list (cons master-file file-list)) - (goto-char 1) - ;; Remember from which file these lines came. - (put-text-property (point-min) (point-max) 'file - (expand-file-name master-file)) - ;; Make the default directory that of the master file. - ;; All input and include stuff works relative to that directory. - (cd (file-name-directory (expand-file-name master-file))) - ;; Now find recursively all include/input statements and expand them. - (while (re-search-forward - "^[ \t]*\\\\\\(include\\|input\\){\\([^}\n]+\\)}" nil t) - (setq file (reftex-no-props (match-string 2))) - (if (not (and (> (length file) 4) - (string= (substring file -4) ".tex"))) - (setq file (concat file ".tex"))) - (if (file-exists-p file) - (progn - (replace-match - (format "\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% START OF %s FILE: %s\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% END OF %s FILE: %s\n" - (match-string 1) file - (match-string 1) file)) - (beginning-of-line 0) - (narrow-to-region (point) (point)) - ;; Insert the file. - (reftex-insert-buffer-or-file file) - (subst-char-in-region (point-min) (point-max) ?\r ?\n t) - (setq file-list (cons (expand-file-name file) file-list)) - ;; Remember from which file these lines came. - (put-text-property (point-min) (point-max) - 'file (expand-file-name file)) - (goto-char (point-min)) - (widen)) - (message "Input/include file %s not found. Ignored. Continuing..." - file) - (setq not-found (1+ not-found)))) - (setq file-list (nreverse file-list)) - (while (setq tmp (assoc (car file-list) reftex-master-include-list)) - (setq reftex-master-include-list (delq tmp reftex-master-include-list))) - (setq reftex-master-include-list (cons file-list reftex-master-include-list)) - not-found)) - -(defun reftex-insert-buffer-or-file (file) - "If there is a buffer associated with FILE, insert it - otherwise the FILE." - (let ((buffer (reftex-get-buffer-visiting file))) - (if buffer - (let (beg end beg1 end1) - (save-excursion - ;; Make sure we get the whole buffer. - (set-buffer buffer) - (setq beg (point-min) end (point-max)) - (widen) - (setq beg1 (point-min) end1 (point-max))) - (insert-buffer-substring buffer beg1 end1) - (save-excursion - (set-buffer buffer) - (narrow-to-region beg end))) - (insert-file-contents file)))) - - -(defun reftex-parse-document (&optional buffer) - "Rescan the document." +(defun reftex-parse-one () + "Re-parse this file." + (interactive) + (let ((reftex-enable-partial-scans t)) + (reftex-access-scan-info '(4)))) + +(defun reftex-parse-all () + "Re-parse entire document." (interactive) - (save-window-excursion - (save-excursion - (if buffer - (if (not (bufferp buffer)) - (error "No such buffer %s" (buffer-name buffer)) - (set-buffer buffer))) - (reftex-access-scan-info t)))) - -(defun reftex-access-scan-info (&optional rescan) - ;; Access the scanning info. When the multifile symbols are not yet tied, - ;; tie them. When they are have to be created, do a buffer scan to - ;; fill them. - - ;; If RESCAN is non-nil, enforce document scanning - - (catch 'exit - (let ((rescan (or (equal rescan t) (equal rescan '(4))))) - - ;; Reset the mode if we had changes from style hooks. - (and reftex-tables-dirty - (reftex-reset-mode)) - - (if (eq reftex-list-of-labels-symbol nil) - ;; Symbols are not yet tied: Tie them and see if they are set. - (reftex-tie-multifile-symbols)) - - (if (and (symbol-value reftex-list-of-labels-symbol) - (not rescan)) - ;; Lists do already exist and we don't need to rescan. - ;; Return from here. - (throw 'exit t)) - - ;; We need to rescan - ;; ================= - - (unwind-protect - (save-window-excursion - (save-excursion - - ;; Do the scanning. - - (let ((label-list-symbol reftex-list-of-labels-symbol) - (label-numbers-symbol reftex-label-numbers-symbol) - (bibfile-list-symbol reftex-bibfile-list-symbol)) - - (message "Creating master buffer...") - (reftex-make-master-buffer (reftex-TeX-master-file) major-mode) - - (message "Scanning document...") - - (reftex-scan-buffer-for-labels - label-numbers-symbol label-list-symbol) - - (reftex-scan-buffer-for-bibliography-statement - bibfile-list-symbol) - - (message "Scanning document... done")))) - - (if (get-buffer "*reftex-master.tex*") - (kill-buffer "*reftex-master.tex*")))))) + (reftex-access-scan-info '(16))) + +(defun reftex-all-document-files (&optional relative) + ;; Return a list of all files belonging to the current document. + ;; When RELATIVE is non-nil, give file names relative to directory + ;; of master file. + (let* ((all (symbol-value reftex-docstruct-symbol)) + (master-dir (file-name-directory (reftex-TeX-master-file))) + (re (concat "\\`" (regexp-quote master-dir))) + file-list tmp file) + (while (setq tmp (assoc 'bof all)) + (setq file (nth 1 tmp) + all (cdr (memq tmp all))) + (and relative + (string-match re file) + (setq file (substring file (match-end 0)))) + (push file file-list)) + (nreverse file-list))) (defun reftex-create-tags-file () "Create TAGS file by running `etags' on the current document. @@ -1475,8 +1889,8 @@ (interactive) (reftex-access-scan-info current-prefix-arg) (let* ((master (reftex-TeX-master-file)) - (files (assoc master reftex-master-include-list)) - (cmd (format "etags %s" (mapconcat 'identity files " ")))) + (files (reftex-all-document-files)) + (cmd (format "etags %s" (mapconcat 'identity files " ")))) (save-excursion (set-buffer (reftex-get-buffer-visiting master)) (message "Running etags to create TAGS file...") @@ -1495,21 +1909,13 @@ (interactive (list (read-from-minibuffer "Run grep on document (like this): " - reftex-grep-command nil nil + reftex-grep-command nil nil 'reftex-grep-history))) (reftex-access-scan-info current-prefix-arg) - (let* ((master (reftex-TeX-master-file)) - (default-directory (file-name-directory master)) - (re (format "\\`%s\\(.*\\)" (regexp-quote - (expand-file-name default-directory)))) - (files (assoc master reftex-master-include-list)) - (cmd (format - "%s %s" grep-cmd - (mapconcat (function (lambda (x) - (if (string-match re x) - (match-string 1 x) - x))) - files " ")))) + (let* ((files (reftex-all-document-files t)) + (cmd (format + "%s %s" grep-cmd + (mapconcat 'identity files " ")))) (grep cmd))) (defun reftex-search-document (&optional regexp) @@ -1519,14 +1925,13 @@ This works also without an active TAGS table." (interactive) (let ((default (reftex-this-word))) - (if (not regexp) - (setq regexp (read-string (format "Search regexp in document [%s]: " - default)))) + (unless regexp + (setq regexp (read-string (format "Search regexp in document [%s]: " + default)))) (if (string= regexp "") (setq regexp (regexp-quote default))) (reftex-access-scan-info current-prefix-arg) - (tags-search regexp (list 'assoc (reftex-TeX-master-file) - 'reftex-master-include-list)))) + (tags-search regexp (list 'reftex-all-document-files)))) (defun reftex-query-replace-document (&optional from to delimited) "Run a query-replace-regexp of FROM with TO over the entire TeX document. @@ -1536,17 +1941,15 @@ This works also without an active TAGS table." (interactive) (let ((default (reftex-this-word))) - (if (not from) - (progn - (setq from (read-string (format "Replace regexp in document [%s]: " - default))) - (if (string= from "") (setq from (regexp-quote default))))) - (if (not to) - (setq to (read-string (format "Replace regexp %s with: " from)))) + (unless from + (setq from (read-string (format "Replace regexp in document [%s]: " + default))) + (if (string= from "") (setq from (regexp-quote default)))) + (unless to + (setq to (read-string (format "Replace regexp %s with: " from)))) (reftex-access-scan-info current-prefix-arg) (tags-query-replace from to (or delimited current-prefix-arg) - (list 'assoc (reftex-TeX-master-file) - 'reftex-master-include-list)))) + (list 'reftex-all-document-files)))) (defun reftex-change-label (&optional from to) "Query replace FROM with TO in all \\label and \\ref commands. @@ -1556,25 +1959,17 @@ This works also without an active TAGS table." (interactive) (let ((default (reftex-this-word "-a-zA-Z0-9_*.:"))) - (if (not from) - (setq from (read-string (format "Replace label globally [%s]: " - default)))) + (unless from + (setq from (read-string (format "Replace label globally [%s]: " + default)))) (if (string= from "") (setq from default)) - (if (not to) - (setq to (read-string (format "Replace label %s with: " - from)))) + (unless to + (setq to (read-string (format "Replace label %s with: " + from)))) (reftex-query-replace-document (concat "\\\\\\(label\\|[a-z]*ref\\){" (regexp-quote from) "}") (format "\\\\\\1{%s}" to)))) -(defun reftex-this-word (&optional class) -;; Grab the word around point. - (setq class (or class "-a-zA-Z0-9:_/.*;|")) - (save-excursion - (buffer-substring-no-properties - (progn (skip-chars-backward class) (point)) - (progn (skip-chars-forward class) (point))))) - ;;; =========================================================================== ;;; ;;; Functions to create and reference automatic labels. @@ -1614,7 +2009,7 @@ ;; The regular expression used to abbreviate words. (defconst reftex-abbrev-regexp (concat - "^\\(" + "\\`\\(" (make-string (nth 0 reftex-abbrev-parameters) ?.) "[" (nth 2 reftex-abbrev-parameters) "]*" "\\)" @@ -1625,25 +2020,398 @@ (defvar reftex-default-context-position nil) (defvar reftex-location-start nil) (defvar reftex-call-back-to-this-buffer nil) +(defvar reftex-active-toc nil) +(defvar reftex-tex-path nil) +(defvar reftex-bib-path nil) + +;; Internal list with index numbers of labels in the selection menu +(defvar reftex-label-index-list) ;; List of buffers created temporarily for lookup, which should be killed. (defvar reftex-buffers-to-kill nil) -;; The regexp used to find section statements. -(defconst reftex-section-regexp "^[ ]*\\\\\\(part\\|chapter\\|section\\|subsection\\|subsubsection\\|paragraph\\|subparagraph\\|subsubparagraph\\)\\*?\\(\\[[^]]*\\]\\)?{") - -;; LaTeX section commands and level numbers -(defconst reftex-section-levels - '( - ("part" . 0) - ("chapter" . 1) - ("section" . 2) - ("subsection" . 3) - ("subsubsection" . 4) - ("paragraph" . 5) - ("subparagraph" . 6) - ("subsubparagraph" . 7) - )) +;; Regexp to find section statements. Computed from reftex-section-levels. +(defvar reftex-section-regexp nil) +(defvar reftex-section-or-include-regexp nil) +(defvar reftex-everything-regexp nil) +(defvar reftex-find-label-regexp-format nil) +(defvar reftex-find-label-regexp-format2 nil) + +;; The parser functions ---------------------------------- + +(defvar reftex-memory nil + "Memorizes old variable values to indicate changes in these variables.") + +(defun reftex-access-scan-info (&optional rescan file) + ;; Access the scanning info. When the multifile symbols are not yet tied, + ;; tie them. When they are empty or RESCAN is non-nil, scan the document. + + ;; Reset the mode if we had changes to important variables. + (when (or reftex-tables-dirty + (not (eq reftex-label-alist (nth 0 reftex-memory))) + (not (eq reftex-label-alist-external-add-ons + (nth 1 reftex-memory))) + (not (eq reftex-default-label-alist-entries + (nth 2 reftex-memory)))) + (reftex-reset-mode)) + + (if (eq reftex-docstruct-symbol nil) + ;; Symbols are not yet tied: Tie them. + (reftex-tie-multifile-symbols)) + + (if (and (null (symbol-value reftex-docstruct-symbol)) + reftex-save-parse-info) + ;; Try to read the stuff from a file + (reftex-access-parse-file 'read)) + + (cond + ((not (symbol-value reftex-docstruct-symbol)) + (reftex-do-parse 1 file)) + ((member rescan '(t 1 (4) (16))) + (reftex-do-parse rescan file)))) + +(defun reftex-do-parse (rescan &optional file) + ;; Access the scanning info. When the multifile symbols are not yet tied, + ;; tie them. When they are have to be created, do a buffer scan to + ;; fill them. + + ;; If RESCAN is non-nil, enforce document scanning + + ;; Normalize the rescan argument + (setq rescan (cond ((eq rescan t) t) + ((eq rescan 1) 1) + ((equal rescan '(4)) t) + ((equal rescan '(16)) 1) + (t 1))) + + ;; Partial scans only when allowed + (unless reftex-enable-partial-scans + (setq rescan 1)) + + ;; Do the scanning. + + (let* ((old-list (symbol-value reftex-docstruct-symbol)) + (master (reftex-TeX-master-file)) + (master-dir (file-name-as-directory (file-name-directory master))) + (file (or file (buffer-file-name))) + from-file + docstruct tmp) + + ;; Make sure replacement is really an option here + (when (and (eq rescan t) + (not (and (member (list 'bof file) old-list) + (member (list 'eof file) old-list)))) + (message "Scanning whole document (no file section %s)" file) + (setq rescan 1)) + (when (string= file master) + (message "Scanning whole document (%s is master)" file) + (setq rescan 1)) + + ;; From which file do we start? + (setq from-file + (cond ((eq rescan t) (or file master)) + ((eq rescan 1) master) + (t (error "horrible!!")))) + + ;; Find active toc entry and initialize section-numbers + (setq reftex-active-toc + (reftex-last-assoc-before-elt + 'toc (list 'bof from-file) old-list)) + (reftex-init-section-numbers reftex-active-toc) + + (if (eq rescan 1) + (message "Scanning entire document...") + (message "Scanning document from %s..." from-file)) + + (save-window-excursion + (save-excursion + (unwind-protect + (setq docstruct + (reftex-parse-from-file + from-file docstruct master-dir)) + (reftex-kill-temporary-buffers)))) + + (message "Scanning document... done") + + ;; Turn the list around. + (setq docstruct (nreverse docstruct)) + + ;; Set or insert + (setq docstruct (reftex-replace-label-list-segment + old-list docstruct (eq rescan 1))) + + ;; Add all missing information + (unless (assq 'label-numbers docstruct) + (push (cons 'label-numbers nil) docstruct)) + (unless (assq 'master-dir docstruct) + (push (cons 'master-dir master-dir) docstruct)) + (let* ((bof1 (memq (assq 'bof docstruct) docstruct)) + (bof2 (assq 'bof (cdr bof1))) + (is-multi (not (not (and bof1 bof2)))) + (entry (or (assq 'is-multi docstruct) + (car (push (list 'is-multi is-multi) docstruct))))) + (setcdr entry (cons is-multi nil))) + (unless (assq 'xr docstruct) + (let* ((allxr (reftex-all-assq 'xr-doc docstruct)) + (alist (mapcar + '(lambda (x) + (if (setq tmp (reftex-find-tex-file (nth 2 x) + master-dir)) + (cons (nth 1 x) tmp) + (message "Can't find external document %s" + (nth 2 x)) + nil)) + allxr)) + (alist (delete nil alist)) + (allprefix (delete nil (mapcar 'car alist))) + (regexp (concat "\\`\\(" (mapconcat 'identity allprefix "\\|") + "\\)"))) + (push (list 'xr alist regexp) docstruct))) + + (set reftex-docstruct-symbol docstruct) + + ;; Save the parsing informtion into a file? + (if reftex-save-parse-info + (reftex-access-parse-file 'write)))) + +(defun reftex-is-multi () + ;; Tell if this is a multifile document. When not sure, say yes. + (let ((entry (assq 'is-multi (symbol-value reftex-docstruct-symbol)))) + (if entry + (nth 1 entry) + t))) + +(defun reftex-parse-from-file (file docstruct master-dir) + ;; Scan the buffer for labels and save them in a list. + (let ((regexp reftex-everything-regexp) + (bound 0) + file-found tmp + (level 1) + (highest-level 100) + toc-entry next-buf) + + (catch 'exit + (setq file-found (reftex-find-tex-file file master-dir)) + (unless file-found + (push (list 'file-error file) docstruct) + (throw 'exit nil)) + + (save-excursion + + (message "Scanning file %s" file) + (set-buffer + (setq next-buf + (reftex-get-file-buffer-force + file-found + (not (eq t reftex-keep-temporary-buffers))))) + + ;; Begin of file mark + (setq file (buffer-file-name)) + (push (list 'bof file) docstruct) + + (save-excursion + (save-restriction + (widen) + (goto-char 1) + + (while (re-search-forward regexp nil t) + + (cond + + ((match-end 1) + ;; It is a label + (push (reftex-label-info (reftex-match-string 1) file bound) + docstruct)) + + ((match-end 3) + ;; It is a section + (setq bound (point)) + + ;; Insert in List + (setq toc-entry (reftex-section-info file)) + (setq level (nth 5 toc-entry)) + (setq highest-level (min highest-level level)) + (if (= level highest-level) + (message + "Scanning %s %s ..." + (car (nth level reftex-section-levels)) + (nth 6 toc-entry))) + + (push toc-entry docstruct) + (setq reftex-active-toc toc-entry)) + + ((match-end 7) + ;; It's an include or input + (setq docstruct + (reftex-parse-from-file + (reftex-match-string 7) + docstruct master-dir))) + + ((match-end 8) + ;; A macro with label + (save-excursion + (let* ((mac (reftex-match-string 8)) + (label (progn (goto-char (match-end 8)) + (save-match-data + (reftex-no-props + (reftex-nth-arg-wrapper + mac))))) + (entry (progn (goto-char (match-end 0)) + (reftex-label-info + label file bound mac)))) + (push entry docstruct)))) + (t (error "This should not happen (reftex-parse-from-file)"))) + ) + + + ;; Find bibliography statement + (when (setq tmp (reftex-locate-bibliography-files master-dir)) + (push (cons 'bib tmp) docstruct)) + + ;; Find external document specifications + (goto-char 1) + (while (re-search-forward "[\n\r][ \t]*\\\\externaldocument\\(\\[\\([^]]*\\)\\]\\)?{\\([^}]+\\)}" nil t) + (push (list 'xr-doc (reftex-match-string 2) + (reftex-match-string 3)) + docstruct)) + + ;; End of file mark + (push (list 'eof file) docstruct)))) + + ;; Kill the scanned buffer + (reftex-kill-temporary-buffers next-buf)) + + ;; Return the list + docstruct)) + +(defun reftex-locate-bibliography-files (master-dir) + ;; Scan buffer for bibliography macro and return file list. + (let (file-list) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + "\\(\\`\\|[\n\r]\\)[ \t]*\\\\bibliography{[ \t]*\\([^}]+\\)" nil t) + (setq file-list + (mapcar '(lambda (x) (concat x ".bib")) + (reftex-delete-list + reftex-bibfile-ignore-list + (split-string + (reftex-match-string 2) + "[ \t\n\r]*,[ \t\n\r]*"))))) + (delete nil + (mapcar + (function + (lambda (file) (reftex-find-bib-file file master-dir))) + file-list))))) + +(defun reftex-last-assoc-before-elt (key elt list) + ;; Find the last association of KEY in LIST before or at ELT + ;; ELT is found in LIST with equal, not eq. + ;; Returns nil when either KEY or elt are not found in LIST. + ;; On success, returns the association. + (let* ((elt (car (member elt list))) ass last-ass) + + (while (and (setq ass (assoc key list)) + (setq list (memq ass list)) + (memq elt list)) + (setq last-ass ass + list (cdr list))) + last-ass)) + +(defun reftex-replace-label-list-segment (old insert &optional entirely) + ;; Replace the segment in OLD which corresponds to INSERT. + ;; Works with side effects, directly changes old. + ;; If entirely is t, just return INSERT. + ;; This function also makes sure the old toc markers do not point anywhere. + + (cond + (entirely + (reftex-silence-toc-markers old (length old)) + insert) + (t (let* ((new old) + (file (nth 1 (car insert))) + (eof-list (member (list 'eof file) old)) + (bof-list (member (list 'bof file) old)) + n) + (if (not (and bof-list eof-list)) + (error "Cannot splice") + ;; Splice + (reftex-silence-toc-markers bof-list (- (length bof-list) + (length eof-list))) + (setq n (- (length old) (length bof-list))) + (setcdr (nthcdr n new) (cdr insert)) + (setcdr (nthcdr (1- (length new)) new) (cdr eof-list))) + new)))) + +(defun reftex-silence-toc-markers (list n) + ;; Set all markers in list to nil + (while (and list (> (decf n) -1)) + (and (eq (car (car list)) 'toc) + (markerp (nth 4 (car list))) + (set-marker (nth 4 (car list)) nil)) + (pop list))) + +(defun reftex-access-parse-file (action) + (let* ((list (symbol-value reftex-docstruct-symbol)) + (master (reftex-TeX-master-file)) + (enable-local-variables nil) + (file (if (string-match "\\.[a-zA-Z]+\\'" master) + (concat (substring master 0 (match-beginning 0)) ".rel") + (concat master ".rel")))) + (cond + ((eq action 'readable) + (file-readable-p file)) + ((eq action 'restore) + (if (eq reftex-docstruct-symbol nil) + ;; Symbols are not yet tied: Tie them. + (reftex-tie-multifile-symbols)) + (if (file-exists-p file) + ;; load the file and return t for success + (progn (load-file file) t) + ;; return nil for failure + nil)) + ((eq action 'read) + (if (file-exists-p file) + ;; load the file and return t for success + (progn (load-file file) t) + ;; return nil for failure + nil)) + (t + (save-excursion + (if (file-writable-p file) + (progn + (message "Writing parse file %s" (abbreviate-file-name file)) + (find-file file) + (erase-buffer) + (insert (format ";; RefTeX parse info file\n")) + (insert (format ";; File: %s\n" master)) + (insert (format ";; Date: %s\n" + (format-time-string "%D %T" + (current-time)))) + (insert (format ";; User: %s (%s)\n\n" + (user-login-name) (user-full-name))) + (insert "(set reftex-docstruct-symbol '(\n\n") + (let ((standard-output (current-buffer))) + (mapcar + (function + (lambda (x) + (cond ((eq (car x) 'toc) + ;; A toc entry. Do not save the marker. + ;; Save the markers position at position 8 + (print (list 'toc "toc" (nth 2 x) (nth 3 x) + nil (nth 5 x) (nth 6 x) (nth 7 x) + (or (and (markerp (nth 4 x)) + (marker-position (nth 4 x))) + (nth 8 x))))) + (t (print x))))) + list)) + (insert "))") + (save-buffer 0) + (kill-buffer (current-buffer))) + (error "Cannot write to file %s" file))) + t)))) + +;; Creating labels -------------- (defun reftex-label (&optional environment no-insert) "Insert a unique label. Return the label. @@ -1662,22 +2430,34 @@ (if (or (not environment) (not (assoc environment reftex-env-or-mac-alist))) (setq environment (reftex-label-location))) - (if (not environment) - (error "Can't figure out what kind of label should be inserted")) + (unless environment + (error "Can't figure out what kind of label should be inserted")) ;; Ok, go ahead. - (let (label num typekey prefix entry cell lab valid default force-prompt) - (setq typekey (nth 1 (assoc environment - reftex-env-or-mac-alist))) + (let* ((entry (assoc environment reftex-env-or-mac-alist)) + (typekey (nth 1 entry)) + (format (nth 3 entry)) + label prefix valid default force-prompt) + (when (and (eq (string-to-char environment) ?\\) + (nth 4 entry) + (memq (preceding-char) '(?\[ ?\{))) + (setq format "%s")) + (setq prefix (or (cdr (assoc typekey reftex-typekey-to-prefix-alist)) (concat typekey "-"))) + ;; Replace any escapes in the prefix + (setq prefix (reftex-replace-prefix-escapes prefix)) ;; Make a default label. (cond ((reftex-typekey-check typekey (nth 0 reftex-insert-label-flags)) ;; Derive a label from context. - (setq default (nth 2 (reftex-label-info " "))) + (setq reftex-active-toc (reftex-last-assoc-before-elt + 'toc (car (reftex-where-am-I)) + (symbol-value reftex-docstruct-symbol))) + (setq default (reftex-no-props + (nth 2 (reftex-label-info " " nil nil t)))) ;; Catch the cases where the is actually no context available. (if (or (string-match "NO MATCH FOR CONTEXT REGEXP" default) (string-match "ILLEGAL VALUE OF PARSE" default) @@ -1689,11 +2469,7 @@ (setq default (concat prefix (reftex-string-to-label default))) ;; Make it unique. - (setq label default) - (setq num 1) - (while (assoc label (symbol-value reftex-list-of-labels-symbol)) - (setq label (concat default "-" (setq num (1+ num))))) - (setq default label))) + (setq default (reftex-uniquify-label default nil "-")))) ((reftex-typekey-check typekey (nth 1 reftex-insert-label-flags)) ; prompt ;; Minimal default: the user will be prompted. @@ -1701,9 +2477,7 @@ (t ;; Make an automatic label. - (while (assoc - (setq default (concat prefix (reftex-next-label-number typekey))) - (symbol-value reftex-list-of-labels-symbol))))) + (setq default (reftex-uniquify-label prefix t)))) ;; Should we ask the user? (if (or (reftex-typekey-check typekey @@ -1713,7 +2487,9 @@ (while (not valid) ;; iterate until we get a legal label - (setq label (read-string "Label: " default)) + (setq label (read-string + (if (string= format "%s") "Naked Label: " "Label: ") + default)) ;; Lets make sure that this is a legal label (cond @@ -1726,7 +2502,7 @@ ;; Look it up in the label list ((setq entry (assoc label - (symbol-value reftex-list-of-labels-symbol))) + (symbol-value reftex-docstruct-symbol))) (message "Label \"%s\" exists in file %s" label (nth 3 entry)) (ding) (sit-for 2)) @@ -1736,49 +2512,24 @@ (setq valid t)))) (setq label default)) - ;; Insert the label - (if (not no-insert) - (insert "\\label{" label "}")) - ;; Insert the label into the label list - (if (symbol-value reftex-list-of-labels-symbol) - (let ((cnt 0) - (pos (point)) - (all (symbol-value reftex-list-of-labels-symbol)) - (look-for nil) - (note nil) - (text nil) - (file (buffer-file-name))) - - ;; find the previous label in order to know where to insert new label - ;; into label list - (save-excursion - (if (re-search-backward "\\\\label{\\([^}]+\\)}" nil 1 2) - (setq look-for (reftex-no-props (match-string 1)))) - (if (or (re-search-forward - "\\\\\\(include\\|input\\){[^}\n]+}" pos t) - (re-search-forward reftex-section-regexp pos t) - (null look-for)) - (setq note "POSITION UNCERTAIN. RESCAN TO FIX."))) - (if (not look-for) - (set reftex-list-of-labels-symbol - (cons (list label typekey text file note) - (symbol-value reftex-list-of-labels-symbol))) - (while all - (setq cell (car all) - all (cdr all) - cnt (1+ cnt) - lab (nth 0 cell)) - (if (string= lab look-for) - (progn - (setcdr - (nthcdr (1- cnt) - (symbol-value reftex-list-of-labels-symbol)) - (cons (list label typekey text file note) - (nthcdr - cnt (symbol-value reftex-list-of-labels-symbol)))) - ;; to end the loop, set all to nil - (setq all nil))))))) + (let* ((here-I-am-info (reftex-where-am-I)) + (here-I-am (car here-I-am-info)) + (note (if (cdr here-I-am-info) + "" + "POSITION UNCERTAIN. RESCAN TO FIX.")) + (file (buffer-file-name)) + (text nil) + (tail (memq here-I-am (symbol-value reftex-docstruct-symbol)))) + + (if tail + (setcdr tail (cons (list label typekey text file note) + (cdr tail))))) + + ;; Insert the label into the buffer + (unless no-insert + (insert (format format label))) + ;; return value of the function is the label label)) @@ -1788,24 +2539,21 @@ ;; Uses reftex-derive-label-parameters and reftex-abbrev-parameters ;; - (let* ((words0 (reftex-split "[- \t\n\r]+" - (reftex-no-props string))) + (let* ((words0 (split-string string "[- \t\n\r]+")) (ignore-words (nth 5 reftex-derive-label-parameters)) words word) ;; remove words from the ignore list or with funny characters - (while words0 - (setq word (car words0) words0 (cdr words0)) + (while (setq word (pop words0)) (cond ((member (downcase word) ignore-words)) ((string-match reftex-label-illegal-re word) - (if (nth 2 reftex-derive-label-parameters) - (progn - (while (string-match reftex-label-illegal-re word) - (setq word (replace-match "" nil nil word))) - (setq words (cons word words))))) + (when (nth 2 reftex-derive-label-parameters) + (while (string-match reftex-label-illegal-re word) + (setq word (replace-match "" nil nil word))) + (push word words))) (t - (setq words (cons word words))))) + (push word words)))) (setq words (nreverse words)) ;; restrict number of words @@ -1836,10 +2584,35 @@ string)) ;; Delete the final punctuation, if any - (if (string-match "[^a-zA-Z0-9]+$" string) + (if (string-match "[^a-zA-Z0-9]+\\'" string) (setq string (replace-match "" nil nil string))) string)) +(defun reftex-replace-prefix-escapes (prefix) + ;; Replace %escapes in a label prefix + (save-match-data + (let (letter (num 0) replace) + (while (string-match "\\%\\([a-zA-Z]\\)" prefix num) + (setq letter (match-string 1 prefix)) + (setq replace + (cond + ((equal letter "f") + (file-name-sans-extension + (file-name-nondirectory (buffer-file-name)))) + ((equal letter "F") + (let ((masterdir (file-name-directory (reftex-TeX-master-file))) + (file (file-name-sans-extension (buffer-file-name)))) + (if (string-match (concat "\\`" (regexp-quote masterdir)) + file) + (substring file (length masterdir)) + file))) + ((equal letter "u") + (or (user-login-name) "")) + (t ""))) + (setq num (1- (+ (match-beginning 1) (length replace))) + prefix (replace-match replace nil nil prefix))) + prefix))) + (defun reftex-label-location (&optional bound) ;; Return the environment or macro which determines the label type at point. ;; If optional BOUND is an integer, limit backward searches to that point. @@ -1850,46 +2623,59 @@ (p2 (or (cdr loc2) 0))) (setq reftex-location-start (max p1 p2)) - (if (> p1 p2) + (if (>= p1 p2) (progn - (setq reftex-default-context-position p1) - (car loc1)) - (setq reftex-default-context-position - (+ p2 8 (length (car loc2)))) + (setq reftex-default-context-position (+ p1 (length (car loc1)))) + (or (car loc1) "section")) + (setq reftex-default-context-position (+ p2 8 (length (car loc2)))) (or (car loc2) "section")))) - -(defun reftex-next-label-number (type) - ;; Increment value of automatic labels in current buffer. Return new value. +(defun reftex-uniquify-label (label &optional force separator) + ;; Make label unique by appending a number. + ;; Optional FORCE means, force appending a number, even if label is unique. + ;; Optional SEPARATOR is a string to stick between label and number. ;; Ensure access to scanning info (reftex-access-scan-info) - (let ((n (cdr (assoc type (symbol-value reftex-label-numbers-symbol))))) - (if (not (integerp n)) - ;; oops - type not known - make one here - (progn - (set reftex-label-numbers-symbol - (cons (cons type 0) - (symbol-value reftex-label-numbers-symbol))) - (setq n 0))) - (setq n (1+ n)) - (setcdr (assoc type (symbol-value reftex-label-numbers-symbol)) n) - n)) + (cond + ((and (not force) + (not (assoc label (symbol-value reftex-docstruct-symbol)))) + label) + (t + (let* ((label-numbers (assq 'label-numbers + (symbol-value reftex-docstruct-symbol))) + (label-numbers-alist (cdr label-numbers)) + (cell (or (assoc label label-numbers-alist) + (car (setcdr label-numbers + (cons (cons label 0) + label-numbers-alist))))) + (num (1+ (cdr cell))) + (sep (or separator ""))) + (while (assoc (concat label sep (int-to-string num)) + (symbol-value reftex-docstruct-symbol)) + (incf num)) + (setcdr cell num) + (concat label sep (int-to-string num)))))) ;; Help string for the reference label menu -(defconst reftex-reference-label-help +(defconst reftex-select-label-prompt + "Select: [n]ext [p]revious [r]escan [ ]context e[x]tern [q]uit RET [?]HELP+more") + +(defconst reftex-select-label-help " AVAILABLE KEYS IN REFERENCE LABEL MENU - ====================================== - n / p Go to next/previous label (Cursor motion works as well) - r / s Rescan document for labels / Switch label type - t / # Toggle table of contents / Toggle counter mode - c Toggle display of short context - SPACE Show full context for current label in other window - f Toggle follow mode: other window will follow context - a / q Use last referenced label / Quit without accepting label - ? / C-r Display this help message / Recursive Edit into other window - RETURN Accept current label") + -------------------------------------- + n / p Go to next/previous label (Cursor motion works as well) + C-s / C-r Search forward/backward. Use repeated C-s/C-r as in isearch. + r / s Reparse document / Switch label type + x Switch to label menu of external document (with LaTeX package `xr') + t i c # % Toggle: [i]ncl. file borders, [t]able of contents, [c]ontext + [#] label counters, [%] labels in comments + SPC Show full context for current label in other window + f Toggle follow mode: other window will follow context + l / q Reuse last referenced label / Quit without accepting label + e Recursive Edit into other window + RET Accept current label") (defun reftex-reference (&optional type no-insert) "Make a LaTeX reference. Look only for labels of a certain TYPE. @@ -1909,14 +2695,13 @@ ;; Ensure access to scanning info and rescan buffer if prefix are is '(4) (reftex-access-scan-info current-prefix-arg) - (if (not type) - ;; guess type from context - (if (and reftex-guess-label-type - (not (= 16 (prefix-numeric-value current-prefix-arg))) - (setq type (assoc (downcase (reftex-word-before-point)) - reftex-words-to-typekey-alist))) - (setq type (cdr type)) - (setq type (reftex-query-label-type)))) + (unless type + ;; guess type from context + (if (and reftex-guess-label-type + (setq type (assoc (downcase (reftex-word-before-point)) + reftex-words-to-typekey-alist))) + (setq type (cdr type)) + (setq type (reftex-query-label-type)))) (let (label pair (form (or (cdr (assoc type reftex-typekey-to-format-alist)) @@ -1941,320 +2726,343 @@ ;; return the label label)) -(defun reftex-goto-label (&optional arg) - "Go to a LaTeX label. With prefix ARG, go to label in another window." - (interactive "P") - (let (type label file pair) - (if (not type) - (setq type (reftex-query-label-type))) - - (setq pair (reftex-offer-label-menu type) - label (car pair) - file (cdr pair)) - (if (and label file (file-exists-p file)) - (progn - (if arg - (find-file-other-window file) - (find-file file)) - (goto-char (point-min)) - (if (not (search-forward (concat "\\label{" label "}") nil t)) - (error "No such label found: %s" label) - (reftex-highlight 0 (match-beginning 0) (match-end 0)) - (add-hook 'pre-command-hook 'reftex-highlight-shall-die))) - (message "Quit") - nil))) - -;; Internal list with index numbers of labels in the selection menu -(defvar reftex-label-index-list nil) - (defun reftex-offer-label-menu (typekey) ;; Offer a menu with the appropriate labels. Return (label . file). (let* ((buf (current-buffer)) - (near-label (reftex-find-nearby-label)) + (xr-data (assq 'xr (symbol-value reftex-docstruct-symbol))) + (xr-alist (cons (cons "" (buffer-file-name)) (nth 1 xr-data))) + (xr-index 0) + (here-I-am (car (reftex-where-am-I))) (toc (reftex-typekey-check typekey reftex-label-menu-flags 0)) + (files (reftex-typekey-check typekey reftex-label-menu-flags 7)) (context (not (reftex-typekey-check typekey reftex-label-menu-flags 3))) (counter (reftex-typekey-check typekey reftex-label-menu-flags 2)) (follow (reftex-typekey-check typekey reftex-label-menu-flags 4)) - offset rtn key cnt entry) - - (setq reftex-call-back-to-this-buffer buf) + (commented (nth 5 reftex-label-menu-flags)) + (match-everywhere (reftex-typekey-check + typekey reftex-label-menu-flags 6)) + (prefix "") + offset rtn key cnt last-cnt entry) + (setq entry (cons nil nil)) + ;; The following unwind-protect kills temporary buffers after use (unwind-protect (catch 'exit (while t (save-window-excursion + (setq reftex-call-back-to-this-buffer buf) (switch-to-buffer-other-window "*RefTeX Select*") (erase-buffer) (setq truncate-lines t) - (setq reftex-label-index-list (reftex-make-and-insert-label-list - typekey buf toc context counter - near-label)) - (setq near-label "_ ") ; turn off search for near label + (setq mode-line-format + (list "---- " 'mode-line-buffer-identification + " " (abbreviate-file-name + (buffer-file-name buf)) + " -%-")) + + (setq reftex-label-index-list + (reftex-make-and-insert-label-list + typekey buf toc files context counter commented + here-I-am prefix)) + (setq here-I-am nil) ; turn off determination of offset + ;; use only when searched (setq offset (or (car reftex-label-index-list) offset)) - ;; use only when searched - (setq reftex-label-index-list (cdr reftex-label-index-list)) ;; only this is the true list - (if (not reftex-label-index-list) - (error "No labels of type \"%s\"" typekey)) + (pop reftex-label-index-list) (setq rtn (reftex-select-item - nil - "Label: [n]ext [p]rev [r]escan [t]oc [ ]context [q]uit RETURN [?]HELP+more" + reftex-select-label-prompt "^>" - "\n[^.]" 2 - reftex-reference-label-help - '(?r ?g ?c ?t ?s ?# ?a) + reftex-select-label-help + '(?r ?R ?g ?c ?t ?s ?# ?i ?l ?% ?x) offset - 'reftex-select-label-callback follow)) - (setq key (car rtn) - cnt (cdr rtn) - offset (1+ cnt)) - (if (not key) (throw 'exit nil)) + 'reftex-select-label-callback follow + match-everywhere)) + (setq key (car rtn) + cnt (nth 1 rtn) + last-cnt (nth 2 rtn) + offset (1+ (or cnt last-cnt 0))) + (unless key (throw 'exit nil)) (cond - ((or (equal key ?r) - (equal key ?g)) + ((or (eq key ?r) + (eq key ?R) + (eq key ?g)) ;; rescan buffer - (reftex-parse-document buf)) - ((equal key ?c) + (reftex-parse-document buf (or cnt last-cnt) key)) + ((eq key ?c) ;; toggle context mode (setq context (not context))) - ((equal key ?s) + ((eq key ?s) ;; switch type (setq typekey (reftex-query-label-type))) - ((equal key ?t) + ((eq key ?t) ;; toggle tabel of contents display (setq toc (not toc))) - ((equal key ?#) + ((eq key ?i) + ;; toggle display of included file borders + (setq files (not files))) + ((eq key ?#) ;; toggle counter display (setq counter (not counter))) - ((equal key ?a) + ((eq key ?%) + ;; toggle display of commented labels + (setq commented (not commented))) + ((eq key ?l) ;; reuse the last referenced label again (setq entry reftex-last-used-reference) (throw 'exit t)) + ((eq key ?x) + ;; select an external document + (setq xr-index (reftex-select-external-document + xr-alist xr-index)) + (setq buf (or (reftex-get-file-buffer-force + (cdr (nth xr-index xr-alist))) + (error "Cannot switch document")) + prefix (or (car (nth xr-index xr-alist)) "") + offset nil)) (t (set-buffer buf) - (setq entry (nth (nth cnt reftex-label-index-list) - (symbol-value reftex-list-of-labels-symbol))) - (setq reftex-last-used-reference entry) + (if cnt + (progn + (setq entry (nth (nth cnt reftex-label-index-list) + (symbol-value reftex-docstruct-symbol))) + (setq reftex-last-used-reference entry)) + (setq entry nil)) (throw 'exit t)))))) (kill-buffer "*RefTeX Select*") + (and (get-buffer "*RefTeX Context Copy*") + (kill-buffer "*RefTeX Context Copy*")) (reftex-kill-temporary-buffers)) - (cons (reftex-no-props (nth 0 entry)) (nth 3 entry)))) - -;; Indentation for table of context lines in the menu -(defconst reftex-toc-indent " ") -;; Indentation for the lines containing the label -(defconst reftex-label-indent "> ") -;; Indentation for context lines -(defconst reftex-context-indent ". ") -;; Indentation per section level -(defvar reftex-level-indent 2 - "*Number of spaces to be used for indentation per section level. -With more indentation, the label menu looks nicer, but shows less context. -Changing this is only fully operational after the next buffer scan.") - -(defun reftex-make-and-insert-label-list (typekey0 buf toc context - counter near-label) + (cons (if (nth 0 entry) (concat prefix (nth 0 entry)) nil) + (nth 3 entry)))) + +(defun reftex-select-external-document (xr-alist xr-index) + ;; Return index of an external document. + (cond + ((= (length xr-alist) 1) + (message "No external douments available") + (ding) 0) + ((= (length xr-alist) 2) + (- 1 xr-index)) + (t + (save-window-excursion + (let* ((fmt " [%c] %-5s %s\n") (n (1- ?0)) key) + (with-output-to-temp-buffer "*RefTeX Select*" + (princ + (concat "Select a document by pressing a number key:\n KEY PREFIX DOCUMENT\n----------------------\n" + (mapconcat '(lambda (x) + (format fmt (incf n) (or (car x) "") + (abbreviate-file-name (cdr x)))) + xr-alist "")))) + (setq key (read-char)) + (if (< (- key ?1) (length xr-alist)) + (- key ?0) + (error "Illegal document selection [%c]" key))))))) + +(defun reftex-make-and-insert-label-list + (typekey0 buf toc files context counter show-commented here-I-am xr-prefix) ;; Insert a menu of all labels in buffer BUF into current buffer. - ;; Return the list of labels, with the index of NEAR-LABEL as extra car. - (let (ins-list index-list offset) + ;; Return the list of labels, with the index of HERE-I-AM as extra car. + (let* ((font (reftex-use-fonts)) + (refont (reftex-refontify)) + (cnt 0) + (index -1) + (toc-indent " ") + (label-indent + (concat "> " + (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) + (context-indent + (concat ". " + (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) + all cell text label typekey note comment master-dir-re + index-list offset docstruct-symbol from from1 to) + + ;; Pop to buffer buf to get the correct buffer-local variables (save-excursion (set-buffer buf) - (let* ((all nil) - (font (reftex-use-fonts)) - (cnt 0) - (file nil) - (index -1) - (toc-indent reftex-toc-indent) - (label-indent - (concat reftex-label-indent - (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) - (context-indent - (concat reftex-context-indent - (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) - cell text label typekey note comment) - - ; Ensure access to scanning info - (reftex-access-scan-info) - - (setq all (symbol-value reftex-list-of-labels-symbol)) - - (while all - - (setq index (1+ index) - cell (car all) - all (cdr all)) - - (if (null (nth 2 cell)) - ;; No context yet. Quick update - (progn - (setq cell (reftex-label-info-update cell)) - (setcar (nthcdr index - (symbol-value reftex-list-of-labels-symbol)) - cell))) - - ;; in the following setq we *copy* the label, since we will change - ;; its properties, and we cannot have any properties in the list - ;; (because of assoc searches) - (setq label (copy-sequence (nth 0 cell)) - typekey (nth 1 cell) - text (nth 2 cell) - file (nth 3 cell) - note (nth 4 cell) - comment (get-text-property 0 'in-comment text)) - - (if (string= label near-label) - (setq offset (1+ cnt))) - - (cond - ((and toc (string= typekey "toc")) - (setq ins-list - (cons (concat toc-indent text "\n") - ins-list))) - ((string= typekey "toc")) - ((and (or (string= typekey typekey0) (string= typekey0 " ")) - (or (nth 5 reftex-label-menu-flags) ; show-commented? - (null comment))) - (setq cnt (1+ cnt)) - (if comment (setq label (concat "% " label))) - (if font - (put-text-property - 0 (length label) - 'face - (if comment - 'font-lock-comment-face - 'font-lock-reference-face) - label)) - (setq index-list (cons index index-list)) - (setq ins-list - (cons (concat - label-indent - label - (if counter (format " (%d) " cnt)) - (if comment " LABEL IS COMMENTED OUT ") - (if note (concat " " note) "") - "\n" - (if context (concat context-indent text "\n"))) - ins-list)))) - ))) - - (apply 'insert (nreverse ins-list)) + + ;; Ensure access to scanning info + (reftex-access-scan-info) + + (setq docstruct-symbol reftex-docstruct-symbol + all (symbol-value reftex-docstruct-symbol) + reftex-active-toc nil + master-dir-re + (concat "\\`" (regexp-quote + (file-name-directory (reftex-TeX-master-file)))))) + + (when refont + ;; Calculate font-lock-defaults as in LaTeX mode. + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults nil) + (let ((major-mode 'latex-mode)) + (font-lock-set-defaults)) + ;; The following is only needed for XEmacs, but does not hurt Emacs. + (setq font-lock-mode nil)) + + ;; Walk the docstruct and insert the appropriate stuff + + (while (setq cell (pop all)) + + (incf index) + (setq from (point)) + + (if (eq cell here-I-am) (setq offset (1+ cnt))) + + (cond + + ((memq (car cell) '(bib label-numbers master-dir is-multi + xr xr-doc))) + ;; These are currently ignored + + ((memq (car cell) '(bof eof file-error)) + ;; Beginning or end of a file + (when files + (insert + " " (if (string-match master-dir-re (nth 1 cell)) + (substring (nth 1 cell) (match-end 0)) + (nth 1 cell)) + (cond ((eq (car cell) 'bof) " starts here\n") + ((eq (car cell) 'eof) " ends here\n") + ((eq (car cell) 'file-error) " was not found\n"))) + (when font + (put-text-property from (point) + 'face 'font-lock-function-name-face)))) + + ((eq (car cell) 'toc) + ;; a table of contents entry + (when toc + (setq reftex-active-toc cell) + (insert (concat toc-indent (nth 2 cell) "\n")))) + + ((stringp (car cell)) + ;; a label + (when (null (nth 2 cell)) + ;; No context yet. Quick update. + (setq cell (reftex-label-info-update cell)) + (setcar (nthcdr index (symbol-value docstruct-symbol)) + cell)) + + (setq label (car cell) + typekey (nth 1 cell) + text (nth 2 cell) + note (nth 4 cell) + comment (get-text-property 0 'in-comment text)) + + (when (and (or (string= typekey typekey0) (string= typekey0 " ")) + (or show-commented (null comment))) + + ;; Yes we want this one + (incf cnt) + (push index index-list) + + (setq label (concat xr-prefix label)) + (when comment (setq label (concat "% " label))) + (insert label-indent label) + (when font + (put-text-property + (- (point) (length label)) (point) + 'face (if comment + 'font-lock-comment-face + 'font-lock-reference-face))) + + (insert (if counter (format " (%d) " cnt) "") + (if comment " LABEL IS COMMENTED OUT " "") + (if note (concat " " note) "") + "\n") + (setq to (point)) + + (when context + (setq from1 to) + (insert context-indent text "\n") + (setq to (point)) + (when refont + (font-lock-fontify-region from1 to) + (goto-char to))) + (put-text-property from to 'cnt (1- cnt)) + (goto-char to))))) + + ;; Return the index list (cons offset (nreverse index-list)))) +(defun reftex-parse-document (&optional buffer cnt key) + "Rescan the document." + (interactive) + (save-window-excursion + (save-excursion + (if buffer + (if (not (bufferp buffer)) + (error "No such buffer %s" (buffer-name buffer)) + (set-buffer buffer))) + (let ((arg (if (eq key ?R) '(16) '(4))) + (file (if cnt + (nth 3 + (nth (nth cnt reftex-label-index-list) + (symbol-value reftex-docstruct-symbol)))))) + (reftex-access-scan-info arg file))))) + (defun reftex-query-label-type () ;; Ask for label type (message reftex-type-query-prompt) (let ((key (read-char))) - (if (equal key ?\?) - (progn - (save-window-excursion - (with-output-to-temp-buffer "*RefTeX Help*" - (princ reftex-type-query-help)) - (setq key (read-char)) - (kill-buffer "*RefTeX Help*")))) - (if (not (member (char-to-string key) reftex-typekey-list)) - (error "No such label type: %s" (char-to-string key))) + (when (eq key ?\?) + (save-window-excursion + (with-output-to-temp-buffer "*RefTeX Help*" + (princ reftex-type-query-help)) + (setq key (read-char)) + (kill-buffer "*RefTeX Help*"))) + (unless (member (char-to-string key) reftex-typekey-list) + (error "No such label type: %s" (char-to-string key))) (char-to-string key))) -(defun reftex-find-nearby-label () - ;; Find a nearby label. - (save-excursion - (if (or (re-search-backward "\\\\label{\\([^}]+\\)}" nil t) - (re-search-forward "\\\\label{\\([^}]+\\)}" nil t)) - (reftex-no-props (match-string 1)) - nil))) - ;; Variable holding the vector with section numbers (defvar reftex-section-numbers [0 0 0 0 0 0 0 0]) -(defun reftex-scan-buffer-for-labels (label-numbers-symbol label-list-symbol) - ;; Scan the buffer for labels and save them in a list. - (save-excursion - (let ((regexp (concat "\\\\label{\\([^}]*\\)}" "\\|" - reftex-section-regexp)) - (font (reftex-use-fonts)) - (bound 0) - (highest-level 100) - file (level 1) star text text1 label section-number macro find) - (set label-list-symbol nil) - (goto-char 0) - - ;; reset label numbers - (set label-numbers-symbol - (mapcar '(lambda(x) (cons x 0)) reftex-typekey-list)) - - ;; reset section numbers - (reftex-section-number reftex-section-numbers -1) - - (while (re-search-forward regexp nil t) - (setq file (get-text-property (match-beginning 0) 'file)) - (if (string= (buffer-substring (match-beginning 0) - (+ 7 (match-beginning 0))) "\\label{") - ;; It is a label - (progn - (setq label (reftex-no-props (match-string 1))) - (set label-list-symbol - (cons (reftex-label-info label file bound) - (symbol-value label-list-symbol)))) - - ;; It is a section - (setq bound (point)) - (setq star (= ?* (char-after (match-end 2)))) - (setq find (buffer-substring-no-properties - (1- (match-beginning 2)) (match-end 0))) - (setq macro (reftex-no-props (match-string 2))) - (setq level (cdr (assoc macro reftex-section-levels))) - - (setq section-number (reftex-section-number - reftex-section-numbers level star)) - (setq highest-level (min highest-level level)) - (if (= level highest-level) - (message - "Scanning %s %s ..." - (car (nth level reftex-section-levels)) - section-number)) - - ;; get the title - (save-match-data - (setq text1 (reftex-context-substring)) - (setq text (reftex-nicify-text text1))) - - (setq find (reftex-allow-for-ctrl-m (concat find text1))) - - ;; add section number and indentation - (setq text - (concat - (make-string (* reftex-level-indent level) ?\ ) - (if (nth 1 reftex-label-menu-flags) ; section number flag - (concat section-number " ")) - text)) - ;; fontify - (if font (put-text-property 0 (length text) - 'face 'font-lock-comment-face text)) - - ;; insert in list - (set label-list-symbol - (cons (list nil "toc" text file find) - (symbol-value label-list-symbol))))) - (set label-list-symbol - (nreverse (symbol-value label-list-symbol)))))) - +(defun reftex-section-info (file) + ;; Return a section entry for the current match. + ;; Carefull: This function expects the match-data to be still in place! + (let* ((marker (set-marker (make-marker) (1- (match-beginning 3)))) + (macro (reftex-match-string 3)) + (star (= ?* (char-after (match-end 3)))) + (level (cdr (assoc macro reftex-section-levels))) + (section-number (reftex-section-number + reftex-section-numbers level star)) + (text1 (save-match-data (save-excursion (reftex-context-substring)))) + (literal (buffer-substring-no-properties + (1- (match-beginning 3)) + (min (point-max) (+ (match-end 0) (length text1) 1)))) + ;; Literal can be too short since text1 too short. No big problem. + (text (reftex-nicify-text text1))) + + ;; Add section number and indentation + (setq text + (concat + (make-string (* reftex-level-indent level) ?\ ) + (if (nth 1 reftex-label-menu-flags) ; section number flag + (concat section-number " ")) + text)) + ;; Fontify + (if (reftex-use-fonts) + (put-text-property 0 (length text) + 'face 'font-lock-comment-face text)) + (list 'toc "toc" text file marker level section-number + literal (marker-position marker)))) (defun reftex-label-info-update (cell) ;; Update information about just one label in a different file. ;; CELL contains the old info list (let* ((label (nth 0 cell)) (typekey (nth 1 cell)) - (text (nth 2 cell)) + ;; (text (nth 2 cell)) (file (nth 3 cell)) (note (nth 4 cell)) (buf (reftex-get-file-buffer-force - file (not reftex-keep-temporary-buffers)))) + file (not (eq t reftex-keep-temporary-buffers))))) (if (not buf) (list label typekey "" file "LOST LABEL. RESCAN TO FIX.") (save-excursion @@ -2263,21 +3071,29 @@ (widen) (goto-char 1) - (if (re-search-forward (concat "\\\\label{" (regexp-quote label) "}") - nil t) - (append (reftex-label-info label file) (list note)) + (if (or (re-search-forward + (format reftex-find-label-regexp-format + (regexp-quote label)) nil t) + (re-search-forward + (format reftex-find-label-regexp-format2 + (regexp-quote label)) nil t)) + + (progn + (backward-char 1) + (append (reftex-label-info label file) (list note))) (list label typekey "" file "LOST LABEL. RESCAN TO FIX."))))))) -(defun reftex-label-info (label &optional file bound) +(defun reftex-label-info (label &optional file bound derive env-or-mac) ;; Return info list on LABEL at point. - (let* ((env-or-mac (reftex-label-location bound)) + (let* ((env-or-mac (or env-or-mac (reftex-label-location bound))) (typekey (nth 1 (assoc env-or-mac reftex-env-or-mac-alist))) (file (or file (buffer-file-name))) (parse (if (reftex-typekey-check typekey reftex-use-text-after-label-as-context) nil (nth 2 (assoc env-or-mac reftex-env-or-mac-alist)))) - (text (reftex-short-context env-or-mac parse reftex-location-start))) + (text (reftex-short-context env-or-mac parse reftex-location-start + derive))) (if (reftex-in-comment) (put-text-property 0 1 'in-comment t text)) (list label typekey text file))) @@ -2285,11 +3101,14 @@ (defun reftex-in-comment () (save-excursion (skip-chars-backward "^%\n\r") - (= (preceding-char) ?%))) - -(defun reftex-short-context (env parse &optional bound) + (eq (preceding-char) ?%))) + +(defun reftex-short-context (env parse &optional bound derive) ;; Get about one line of useful context for the label definition at point. + (if (consp parse) + (setq parse (if derive (cdr parse) (car parse)))) + (reftex-nicify-text (cond @@ -2302,13 +3121,21 @@ (if (string= env "section") ;; special treatment for section labels (save-excursion - (if (re-search-backward reftex-section-regexp (point-min) t) + (if (and (re-search-backward reftex-section-or-include-regexp + (point-min) t) + (match-end 2)) (progn (goto-char (match-end 0)) (reftex-context-substring)) - "SECTION HEADING NOT FOUND")) + (if reftex-active-toc + (progn + (string-match "{\\([^}]*\\)" (nth 7 reftex-active-toc)) + (match-string 1 (nth 7 reftex-active-toc))) + "SECTION HEADING NOT FOUND"))) (save-excursion - (goto-char reftex-default-context-position) + (goto-char reftex-default-context-position) + (unless (eq (string-to-char env) ?\\) + (reftex-move-over-touching-args)) (reftex-context-substring)))) ((stringp parse) @@ -2318,60 +3145,249 @@ (goto-char (match-end 0)) (reftex-context-substring)) "NO MATCH FOR CONTEXT REGEXP"))) + + ((integerp parse) + (or (save-excursion + (goto-char reftex-default-context-position) + (reftex-nth-arg + parse + (nth 6 (assoc env reftex-env-or-mac-alist)))) + "")) + ((fboundp parse) ;; A hook function. Call it. (save-excursion (condition-case error-var (funcall parse env) - ('error (format "HOOK ERROR: %s" (cdr error-var)))))) + (error (format "HOOK ERROR: %s" (cdr error-var)))))) (t "ILLEGAL VALUE OF PARSE")))) +(defun reftex-where-am-I () + ;; Return the docstruct entry above point. Actually returns a cons + ;; cell in which the cdr is a flag indicating if the information is + ;; exact (t) or approximate (nil). + (interactive) + + (let ((docstruct (symbol-value reftex-docstruct-symbol)) + (cnt 0) rtn + found) + (save-excursion + (while (not rtn) + (incf cnt) + (setq found (re-search-backward reftex-everything-regexp nil t)) + (setq rtn + (cond + ((not found) + ;; no match + (or + (car (member (list 'bof (buffer-file-name)) docstruct)) + (not (setq cnt 2)) + (assq 'bof docstruct) ;; for safety reasons + 'corrupted)) + ((match-end 1) + ;; Label + (assoc (reftex-match-string 1) + (symbol-value reftex-docstruct-symbol))) + ((match-end 3) + ;; Section + (goto-char (1- (match-beginning 3))) + (let* ((list (member (list 'bof (buffer-file-name)) + docstruct)) + (endelt (car (member (list 'eof (buffer-file-name)) + list))) + rtn1) + (while (and list (not (eq endelt (car list)))) + (if (and (eq (car (car list)) 'toc) + (string= (buffer-file-name) + (nth 3 (car list)))) + (cond + ((equal (point) + (or (and (markerp (nth 4 (car list))) + (marker-position (nth 4 (car list)))) + (nth 8 (car list)))) + ;; Fits with marker position or recorded position + (setq rtn1 (car list) list nil)) + ((looking-at (reftex-make-regexp-allow-for-ctrl-m + (nth 7 (car list)))) + ;; Same title + (setq rtn1 (car list) list nil cnt 2)))) + (pop list)) + rtn1)) + ((match-end 7) + ;; Input or include... + (car + (member (list 'eof (reftex-find-tex-file + (reftex-match-string 7) + (cons + (cdr (assq 'master-dir docstruct)) + reftex-tex-path))) + docstruct))) + ((match-end 8) + (save-excursion + (goto-char (match-end 8)) + (assoc (reftex-no-props + (reftex-nth-arg-wrapper + (reftex-match-string 8))) + (symbol-value reftex-docstruct-symbol)))) + (t + (error "This should not happen (reftex-where-am-I)")))))) + (cons rtn (eq cnt 1)))) + +(defun reftex-parse-args (macro) + ;; Return a list of macro name, nargs, arg-nr which is label and a list of + ;; optional argument indices. + (if (string-match "[[{]\\*?[]}]" macro) + (progn + (let ((must-match (substring macro 0 (match-beginning 0))) + (args (substring macro (match-beginning 0))) + opt-list nlabel (cnt 0)) + (while (string-match "\\`[[{]\\(\\*\\)?[]}]" args) + (incf cnt) + (when (eq ?\[ (string-to-char args)) + (push cnt opt-list)) + (when (and (match-end 1) + (not nlabel)) + (setq nlabel cnt)) + (setq args (substring args (match-end 0)))) + (list must-match cnt nlabel opt-list))) + nil)) + +(defsubst reftex-move-to-next-arg (&optional ignore) + ;; Assuming that we are at the end of a macro name or a macro argument, + ;; move forward to the opening parenthesis of the next argument. + ;; This function understands the splitting of macros over several lines + ;; in TeX. + (cond + ;; Just to be quick: + ((memq (following-char) '(?\[ ?\{))) + ;; Do a search + ((looking-at "[ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*[[{]") + (goto-char (1- (match-end 0))) + t) + (t nil))) + +(defsubst reftex-move-to-previous-arg (&optional bound) + ;; Assuming that we are in front of a macro argument, + ;; move backward to the closing parenthesis of the previous argument. + ;; This function understands the splitting of macros over several lines + ;; in TeX. + (cond + ;; Just to be quick: + ((memq (preceding-char) '(?\] ?\}))) + ;; Do a search + ((re-search-backward + "[]}][ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*\\=" bound t) + (goto-char (1+ (match-beginning 0))) + t) + (t nil))) + +(defun reftex-nth-arg-wrapper (key) + (let ((entry (assoc key reftex-env-or-mac-alist))) + (reftex-nth-arg (nth 5 entry) (nth 6 entry)))) + +(defun reftex-nth-arg (n &optional opt-args) + ;; Return the nth following {} or [] parentheses content. + ;; OPT-ARGS is a list of argument numbers which are optional. + + ;; If we are sitting at a macro start, skip to end of macro name. + (and (eq (following-char) ?\\) (skip-chars-forward "a-zA-Z*\\\\")) + + (if (= n 1000) + ;; Special case: Skip all touching arguments + (progn + (reftex-move-over-touching-args) + (reftex-context-substring)) + + ;; Do the real thing. + (let ((cnt 1)) + + (when (reftex-move-to-next-arg) + + (while (< cnt n) + (while (and (member cnt opt-args) + (eq (following-char) ?\{)) + (incf cnt)) + (when (< cnt n) + (unless (and (condition-case nil + (or (forward-list 1) t) + (error nil)) + (reftex-move-to-next-arg) + (incf cnt)) + (setq cnt 1000)))) + + (while (and (memq cnt opt-args) + (eq (following-char) ?\{)) + (incf cnt))) + (if (and (= n cnt) + (> (skip-chars-forward "{\\[") 0)) + (reftex-context-substring) + nil)))) + +(defun reftex-move-over-touching-args () + (condition-case nil + (while (memq (following-char) '(?\[ ?\{)) + (forward-list 1)) + (error nil))) + (defun reftex-context-substring () ;; Return up to 100 chars from point ;; When point is just after a { or [, limit string to matching parenthesis (cond ((or (= (preceding-char) ?\{) (= (preceding-char) ?\[)) - ;; inside a list - get only the list, with modified syntax to be perfect - (buffer-substring + ;; Inside a list - get only the list. + (buffer-substring-no-properties (point) - (min (+ 100 (point)) - (point-max) - (condition-case nil - (progn - (up-list 1) - (1- (point))) - ('error (point-max)))))) + (min (reftex-fp 150) + (point-max) + (condition-case nil + (progn + (up-list 1) + (1- (point))) + (error (point-max)))))) (t ;; no list - just grab 100 characters - (buffer-substring (point) (min (+ 100 (point)) (point-max)))))) + (buffer-substring-no-properties (point) (min (reftex-fp 150) (point-max)))))) + +(defun reftex-init-section-numbers (&optional toc-entry) + ;; Initialize the section numbers with zeros or with what is found + ;; in the toc entry. + (let* ((level (or (nth 5 toc-entry) -1)) + (numbers (nreverse (split-string (or (nth 6 toc-entry) "") "\\."))) + (depth (1- (length reftex-section-numbers))) + (i depth)) + (while (>= i 0) + (if (> i level) + (aset reftex-section-numbers i 0) + (aset reftex-section-numbers i (string-to-int (or (car numbers) "0"))) + (pop numbers)) + (decf i)))) (defun reftex-section-number (section-numbers &optional level star) ;; Return a string with the current section number. ;; When LEVEL is non-nil, increase section numbers on that level. - (let* ((depth 6) idx n (string "")) - (if level - (progn - (if (and (> level -1) (not star)) - (aset section-numbers level (1+ (aref section-numbers level)))) - (setq idx (1+ level)) - (while (<= idx depth) - (aset section-numbers idx 0) - (setq idx (1+ idx))))) + (let* ((depth (1- (length section-numbers))) idx n (string "")) + (when level + (when (and (> level -1) (not star)) + (aset section-numbers level (1+ (aref section-numbers level)))) + (setq idx (1+ level)) + (while (<= idx depth) + (aset section-numbers idx 0) + (incf idx))) (setq idx 0) (while (<= idx depth) (setq n (aref section-numbers idx)) (setq string (concat string (if (not (string= string "")) "." "") (int-to-string n))) - (setq idx (1+ idx))) + (incf idx)) (save-match-data (if (string-match "\\`\\(0\\.\\)+" string) (setq string (replace-match "" nil nil string))) (if (string-match "\\(\\.0\\)+\\'" string) (setq string (replace-match "" nil nil string)))) - (if star - (concat (make-string (1- (length string)) ?\ ) "*") + (if star + (concat (make-string (1- (length string)) ?\ ) "*") string))) ;; A variable to remember the index of the last label context shown @@ -2381,13 +3397,13 @@ ;; Callback function called from the label selection in order to ;; show context in another window (let* ((this-window (selected-window)) - index entry label file buffer) + index entry label file buffer re) ;; pop to original buffer in order to get correct variables (catch 'exit (save-excursion (set-buffer reftex-call-back-to-this-buffer) (setq index (nth (or cnt 1) reftex-label-index-list) - entry (nth index (symbol-value reftex-list-of-labels-symbol)) + entry (nth index (symbol-value reftex-docstruct-symbol)) label (nth 0 entry) file (nth 3 entry))) @@ -2404,42 +3420,49 @@ ;; search for that label - (if (not (and (integerp cnt) - (integerp reftex-last-cnt) - (if (> cnt reftex-last-cnt) - (search-forward (concat "\\label{" label "}") nil t) - (search-backward (concat "\\label{" label "}") nil t)))) - (progn - (goto-char 1) - (search-forward (concat "\\label{" label "}") nil t))) - (reftex-highlight 0 (match-beginning 0) (match-end 0)) - (reftex-show-entry) - (recenter (/ (window-height) 2)) + (setq re (format reftex-find-label-regexp-format (regexp-quote label))) + (unless (and (integerp cnt) + (integerp reftex-last-cnt) + (if (> cnt reftex-last-cnt) + (re-search-forward re nil t) + (re-search-backward re nil t))) + (goto-char (point-min)) + (unless (re-search-forward re nil t) + ;; Ooops. Must be in a macro with distributed args. + (re-search-forward (format reftex-find-label-regexp-format2 + (regexp-quote label)) nil t))) + (when (match-end 3) + (reftex-highlight 0 (match-beginning 3) (match-end 3)) + (reftex-show-entry (- (point) (match-beginning 3)) + (- (point) (match-end 3))) + (recenter (/ (window-height) 2))) (select-window this-window)))) (defun reftex-pop-to-label (label file-list &optional mark-to-kill highlight) ;; Find LABEL in any file in FILE-LIST in another window. ;; If mark-to-kill is non-nil, mark new buffer for killing. ;; If HIGHLIGHT is non-nil, highlight the label definition. - (let* ((re (concat "\\\\label{" (regexp-quote label) "}")) + (let* ((re1 (format reftex-find-label-regexp-format (regexp-quote label))) + (re2 (format reftex-find-label-regexp-format2 (regexp-quote label))) + (re-list (list re1 re2)) re + (file-list-1 file-list) file buf) (catch 'exit - (while file-list - (setq file (car file-list) - file-list (cdr file-list)) - (if (not (setq buf (reftex-get-file-buffer-force file mark-to-kill))) - (error "No such file %s" file)) - (set-buffer buf) - (widen) - (goto-char (point-min)) - (if (re-search-forward re nil t) - (progn - (switch-to-buffer-other-window buf) - (goto-char (match-beginning 0)) - (recenter (/ (window-height) 2)) - (if highlight - (reftex-highlight 0 (match-beginning 0) (match-end 0))) - (throw 'exit (selected-window))))) + (while (setq re (pop re-list)) + (setq file-list file-list-1) + (while (setq file (pop file-list)) + (unless (setq buf (reftex-get-file-buffer-force file mark-to-kill)) + (error "No such file %s" file)) + (set-buffer buf) + (widen) + (goto-char (point-min)) + (when (re-search-forward re nil t) + (switch-to-buffer-other-window buf) + (goto-char (match-beginning 0)) + (recenter (/ (window-height) 2)) + (if highlight + (reftex-highlight 0 (match-beginning 3) (match-end 3))) + (throw 'exit (selected-window))))) (error "Label %s not found" label)))) (defun reftex-find-duplicate-labels () @@ -2451,21 +3474,26 @@ (reftex-access-scan-info t) (let ((master (reftex-TeX-master-file)) - (dlist + (cnt 0) + (dlist (mapcar '(lambda(x) (let (x1) (cond - ((car x) + ((memq (car x) + '(toc bof eof bib label-numbers xr xr-doc + master-dir file-error is-multi)) + nil) + (t (setq x1 (reftex-all-assoc-string - (car x) (symbol-value reftex-list-of-labels-symbol))) + (car x) (symbol-value reftex-docstruct-symbol))) (if (< 1 (length x1)) - (append (list (reftex-no-props (car x))) + (append (list (car x)) (mapcar '(lambda(x) (abbreviate-file-name (nth 3 x))) x1)) - (list nil))) - (t nil)))) - (reftex-uniquify (symbol-value reftex-list-of-labels-symbol))))) + (list nil)))))) + (reftex-uniquify (symbol-value reftex-docstruct-symbol))))) + (setq dlist (reftex-uniquify dlist)) (if (null dlist) (error "No duplicate labels in document")) (switch-to-buffer-other-window "*Duplicate Labels*") @@ -2473,82 +3501,125 @@ (setq TeX-master master) (erase-buffer) (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") - (insert " Move point to label and type `M-x reftex-change-label'\n" - " This will run a query-replace on the label and its references\n") + (insert + " Move point to label and type `r' to run a query-replace on the label\n" + " and its references. Type `q' to exit this buffer.\n\n") (insert " LABEL FILE\n") (insert " -------------------------------------------------------------\n") + (use-local-map (make-sparse-keymap)) + (local-set-key [?q] '(lambda () (interactive) + (kill-buffer (current-buffer)) (delete-window))) + (local-set-key [?r] 'reftex-change-label) (while dlist - (if (and (car (car dlist)) - (cdr (car dlist))) - (progn - (insert (mapconcat '(lambda(x) x) (car dlist) "\n ") "\n"))) - (setq dlist (cdr dlist))) - (goto-char (point-min)))) + (when (and (car (car dlist)) + (cdr (car dlist))) + (incf cnt) + (insert (mapconcat '(lambda(x) x) (car dlist) "\n ") "\n")) + (pop dlist)) + (goto-char (point-min)) + (when (= cnt 0) + (kill-buffer (current-buffer)) + (delete-window) + (message "Document does not contain duplicate labels.")))) + +(defun reftex-all-assq (key list) + ;; Return a list of all associations of KEY in LIST. Comparison with string= + (let (rtn) + (while (setq list (memq (assq key list) list)) + (push (car list) rtn) + (pop list)) + (nreverse rtn))) (defun reftex-all-assoc-string (key list) ;; Return a list of all associations of KEY in LIST. Comparison with string= (let (rtn) (while list (if (string= (car (car list)) key) - (setq rtn (cons (car list) rtn))) - (setq list (cdr list))) + (push (car list) rtn)) + (pop list)) (nreverse rtn))) -(defun reftex-kill-temporary-buffers () +(defun reftex-kill-temporary-buffers (&optional buffer) ;; Kill all buffers in the list reftex-kill-temporary-buffers. - (while reftex-buffers-to-kill - (if (bufferp (car reftex-buffers-to-kill)) - (progn - (and (buffer-modified-p (car reftex-buffers-to-kill)) - (y-or-n-p (format "Save file %s? " - (buffer-file-name - (car reftex-buffers-to-kill)))) - (save-excursion - (set-buffer (car reftex-buffers-to-kill)) - (save-buffer))) - (kill-buffer (car reftex-buffers-to-kill)))) - (setq reftex-buffers-to-kill (cdr reftex-buffers-to-kill)))) - -(defun reftex-show-entry () + (cond + (buffer + (when (member buffer reftex-buffers-to-kill) + (kill-buffer buffer) + (setq reftex-buffers-to-kill + (delete buffer reftex-buffers-to-kill)))) + (t + (while (setq buffer (pop reftex-buffers-to-kill)) + (when (bufferp buffer) + (and (buffer-modified-p buffer) + (y-or-n-p (format "Save file %s? " + (buffer-file-name buffer))) + (save-excursion + (set-buffer buffer) + (save-buffer))) + (kill-buffer buffer)) + (pop reftex-buffers-to-kill))))) + +(defun reftex-show-entry (beg-hlt end-hlt) ;; Show entry if point is hidden by outline mode - (let ((pos (point))) + (let* ((pos (point)) + (n (/ (window-height) 2)) + (beg (save-excursion + (re-search-backward "[\n\r]" nil 1 n) (point))) + (end (save-excursion + (re-search-forward "[\n\r]" nil 1 n) (point)))) (if (and reftex-auto-show-entry - (boundp 'outline-minor-mode) - outline-minor-mode - (looking-at "[^\n\r]*\r")) - (progn - (outline-back-to-heading) - (show-entry) - (goto-char pos))))) - + (string-match + "\r" (buffer-substring beg end))) + (cond + ((eq t reftex-auto-show-entry) + (subst-char-in-region + (save-excursion (search-backward "\n" nil t) (point)) + (save-excursion (search-forward "\n" nil t) (point)) + ?\r ?\n t)) + ((eq reftex-auto-show-entry 'copy) + (let ((string (buffer-substring beg end))) + (switch-to-buffer "*RefTeX Context Copy*") + (setq buffer-read-only nil) + (erase-buffer) + (insert string) + (subst-char-in-region (point-min) (point-max) ?\r ?\n t) + (goto-char (- pos beg)) + (reftex-highlight 0 (1+ (- (point) beg-hlt)) + (1+ (- (point) end-hlt))) + (when (reftex-refontify) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults nil) + (let ((major-mode 'latex-mode)) + (font-lock-set-defaults) + (font-lock-fontify-buffer))) + (setq buffer-read-only t))) + )))) (defun reftex-nicify-text (text) - ;; Make TEXT nice for inclusion into label menu + ;; Make TEXT nice for inclusion as context into label menu (while (string-match "[\n\r\t]\\|[ \t][ \t]+" text) ; remove extra whitespace (setq text (replace-match " " nil t text))) (if (string-match "\\\\end{.*" text) ; nothing beyond \end{ (setq text (replace-match "" nil t text))) (if (string-match "\\\\label{[^}]*}" text) ; kill the label (setq text (replace-match "" nil t text))) - (if (string-match "^ +" text) ; leading whitespace + (if (string-match "\\`[ }]+" text) ; leading whitespace, `}' (setq text (replace-match "" nil t text))) (cond - ((> (length text) 100) ; not to long - (setq text (substring text 0 100))) - ((= (length text) 0) ; not empty - (setq text " "))) - text) + ((> (length text) 100) (substring text 0 100)) + ((= (length text) 0) " ") + (t text))) (defun reftex-typekey-check (typekey conf-variable &optional n) ;; Check if CONF-VARIABLE is true or contains TYPEKEY (and n (setq conf-variable (nth n conf-variable))) - (or (equal conf-variable t) + (or (eq conf-variable t) (and (stringp conf-variable) (string-match (concat "[" conf-variable "]") typekey)))) ;;; =========================================================================== ;;; -;;; Table of contents (contributed from Stephen Eglen, changed by C. Dominik) +;;; Table of contents ;; We keep at most one *toc* buffer - it is easy to make them @@ -2558,68 +3629,73 @@ (defvar reftex-last-toc-file nil "Stores the file name from which `reftex-toc' was called. For redo command.") +(defvar reftex-last-window-height nil) + (defvar reftex-toc-return-marker (make-marker) "Marker which makes it possible to return from toc to old position.") +(defconst reftex-toc-help +" AVAILABLE KEYS IN TOC BUFFER + ============================ +SPC Show the corresponding section of the LaTeX document. +TAB Goto the section. +RET Goto the section and hide the *toc* buffer (also on mouse-2). +q / Q Hide/Kill *toc* buffer, return to position of last reftex-toc command. +f Toggle follow mode on and off. +r / g Reparse the LaTeX document. +x Switch to TOC of external document (with LaTeX package `xr').") + (defun reftex-toc () "Show the table of contents for the current document. -To see the corresponding part of the LaTeX document, use within the -*toc* buffer: - -SPC Show the corresponding section of the LaTeX document. -RET Goto the section and hide the *toc* buffer. -q Hide the *toc* window and return to position of last reftex-toc command. -Q Kill the *toc* buffer and return to position of last reftex-toc command. -f Toggle follow mode on and off. -r Reparse the LaTeX document. -g Revert buffer (like `r'). - When called with a raw C-u prefix, rescan the document first." (interactive) - (and (not (string= reftex-last-toc-master (reftex-TeX-master-file))) - (get-buffer "*toc*") - (kill-buffer "*toc*")) + (if (or (not (string= reftex-last-toc-master (reftex-TeX-master-file))) + current-prefix-arg) + (reftex-empty-toc-buffer)) (setq reftex-last-toc-file (buffer-file-name)) (setq reftex-last-toc-master (reftex-TeX-master-file)) (set-marker reftex-toc-return-marker (point)) - ;; if follow mode is active, arrange to delay it one command + ;; If follow mode is active, arrange to delay it one command (if reftex-toc-follow-mode (setq reftex-toc-follow-mode 1)) - (if (and current-prefix-arg - (get-buffer "*toc*")) - (kill-buffer "*toc*")) - ;; Ensure access to scanning info and rescan buffer if prefix are is '(4) (reftex-access-scan-info current-prefix-arg) - (let* ((all (symbol-value reftex-list-of-labels-symbol)) + (let* ((all (symbol-value reftex-docstruct-symbol)) + (xr-data (assq 'xr all)) + (xr-alist (cons (cons "" (buffer-file-name)) (nth 1 xr-data))) (where (reftex-nearest-section)) - toc toc1 cell label file find startpos) - - (if (and (get-buffer "*toc*") - (get-buffer-window (get-buffer "*toc*"))) - (select-window (get-buffer-window (get-buffer "*toc*"))) - (delete-other-windows) - (switch-to-buffer-other-window (current-buffer)) - (switch-to-buffer-other-window (get-buffer-create "*toc*"))) + toc1 cell startpos) + + (if (get-buffer-window "*toc*") + (select-window (get-buffer-window "*toc*")) + (setq reftex-last-window-height (window-height)) ; remember + (split-window-vertically) + (switch-to-buffer (get-buffer-create "*toc*"))) (cond ;; buffer is empty - fill it with the table of contents ((= (buffer-size) 0) - (local-set-key " " 'reftex-toc-view-line) - (local-set-key "\C-m" 'reftex-toc-goto-line-and-hide) - (local-set-key "r" 'reftex-toc-redo) - (local-set-key "g" 'revert-buffer) - (local-set-key "q" 'reftex-toc-quit) - (local-set-key "Q" 'reftex-toc-quit-and-kill) - (local-set-key "f" 'reftex-toc-toggle-follow) + (local-set-key "?" 'reftex-toc-show-help) + (local-set-key " " 'reftex-toc-view-line) + (local-set-key "\C-m" 'reftex-toc-goto-line-and-hide) + (local-set-key "\C-i" 'reftex-toc-goto-line) + (local-set-key "r" 'reftex-toc-redo) + (local-set-key "R" 'reftex-toc-Redo) + (local-set-key "g" 'revert-buffer) + (local-set-key "q" 'reftex-toc-quit) + (local-set-key "Q" 'reftex-toc-quit-and-kill) + (local-set-key "f" 'reftex-toc-toggle-follow) + (local-set-key "x" 'reftex-toc-external) + (local-set-key [(mouse-2)] 'reftex-toc-mouse-goto-line-and-hide); Emacs + (local-set-key [(button2)] 'reftex-toc-mouse-goto-line-and-hide); XEmacs (make-local-variable 'revert-buffer-function) (setq revert-buffer-function 'reftex-toc-redo) (setq truncate-lines t) @@ -2630,7 +3706,7 @@ (insert (format "TABLE-OF-CONTENTS on %s -MENU: SPC=view RET=goto [q]uit [Q]uit+kill [r]escan [f]ollow-mode +SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [f]ollow-mode e[x]tern [?]Help ------------------------------------------------------------------------------- " (abbreviate-file-name reftex-last-toc-master))) (setq startpos (point)) @@ -2638,23 +3714,15 @@ (if (reftex-use-fonts) (put-text-property 1 (point) 'face 'font-lock-keyword-face)) (put-text-property 1 (point) 'intangible t) + (put-text-property 1 2 'xr-alist xr-alist) (while all (setq cell (car all) all (cdr all)) - (setq label (nth 0 cell) - toc (nth 2 cell) - file (nth 3 cell) - find (nth 4 cell)) - (if (not label) - (progn - (setq toc1 (concat toc "\n")) - (put-text-property 0 (length toc1) - 'file file toc1) - (put-text-property 0 (length toc1) - 'find find toc1) - (insert toc1) - ))) + (when (eq (car cell) 'toc) + (setq toc1 (concat (nth 2 cell) "\n")) + (put-text-property 0 (length toc1) 'toc cell toc1) + (insert toc1))) (backward-delete-char 1) @@ -2668,37 +3736,14 @@ (goto-char (point-max)) (beginning-of-line) (while (and (> (point) startpos) - (or (not (string= (get-text-property (point) 'file) - (car where))) - (not (string= (get-text-property (point) 'find) - (cdr where))))) + (not (eq (get-text-property (point) 'toc) where))) (beginning-of-line 0)))) (defun reftex-nearest-section () ;; Return (file . find) of nearest section command - (let (cell label rest) - (save-excursion - (cond - ;; Try to find a section heading - ((or (re-search-backward reftex-section-regexp nil t) - (re-search-forward reftex-section-regexp nil t)) - (goto-char (match-end 0)) - (cons (buffer-file-name) - (reftex-allow-for-ctrl-m - (concat (buffer-substring-no-properties - (1- (match-beginning 1)) (match-end 0)) - (reftex-context-substring))))) - ;; Try to find a label - ((and (or (re-search-backward "\\\\label{\\([^}]+\\)}" nil t) - (re-search-forward "\\\\label{\\([^}]+\\)}" nil t)) - (setq label (reftex-no-props (match-string 1))) - (setq cell (assoc label (symbol-value - reftex-list-of-labels-symbol))) - (setq rest (memq cell (symbol-value reftex-list-of-labels-symbol))) - (setq cell (car (memq (assoc nil rest) rest))) - (null (car cell))) - (cons (nth 3 cell) (nth 4 cell))) - (t nil))))) + (let* ((here-I-am (car (reftex-where-am-I)))) + (reftex-last-assoc-before-elt + 'toc here-I-am (symbol-value reftex-docstruct-symbol)))) (defun reftex-toc-pre-command-hook () ;; used as pre command hook in *toc* buffer @@ -2709,9 +3754,9 @@ ;; used in the post-command-hook for the *toc* buffer (and (> (point) 1) (save-excursion - (reftex-highlight 1 - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))))) + (reftex-highlight 1 + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))))) (cond ((integerp reftex-toc-follow-mode) ;; remove delayed action @@ -2720,7 +3765,27 @@ ;; show context in other window (condition-case nil (reftex-toc-visit-line) - ('error t))))) + (error (ding) t))))) + +(defun reftex-empty-toc-buffer () + (if (get-buffer "*toc*") + (save-excursion + (set-buffer "*toc*") + (setq buffer-read-only nil) + (erase-buffer)))) + +(defun reftex-re-enlarge () + (enlarge-window + (max 0 (- (or reftex-last-window-height (window-height)) + (window-height))))) + +(defun reftex-toc-show-help () + (interactive) + (with-output-to-temp-buffer "*RefTeX Help*" + (princ reftex-toc-help)) + ;; If follow mode is active, arrange to delay it one command + (if reftex-toc-follow-mode + (setq reftex-toc-follow-mode 1))) (defun reftex-toc-toggle-follow () "Toggle toc-follow mode. @@ -2735,70 +3800,132 @@ "Go to document location in other window. Hide the *toc* window." (interactive) (reftex-toc-visit-line 'hide)) +(defun reftex-toc-goto-line () + "Go to document location in other window. Hide the *toc* window." + (interactive) + (reftex-toc-visit-line t)) +(defun reftex-toc-mouse-goto-line-and-hide (ev) + "Go to document location in other window. Hide the *toc* window." + (interactive "e") + (mouse-set-point ev) + (reftex-toc-visit-line 'hide)) (defun reftex-toc-quit () "Hide the *toc* window and do not move point." (interactive) - (delete-window) + (or (one-window-p) (delete-window)) (switch-to-buffer (marker-buffer reftex-toc-return-marker)) - (goto-char (marker-position reftex-toc-return-marker))) + (reftex-re-enlarge) + (goto-char (or (marker-position reftex-toc-return-marker) (point)))) (defun reftex-toc-quit-and-kill () "Kill the *toc* buffer." (interactive) (kill-buffer "*toc*") - (delete-window) + (or (one-window-p) (delete-window)) (switch-to-buffer (marker-buffer reftex-toc-return-marker)) + (reftex-re-enlarge) (goto-char (marker-position reftex-toc-return-marker))) (defun reftex-toc-redo (&rest ignore) - "Regenerate the *toc* buffer. Call only from within the *toc* buffer" + "Regenerate the *toc* buffer by reparsing file of last reftex-toc command." + (interactive) + (if reftex-enable-partial-scans + (let ((file (nth 3 (get-text-property (point) 'toc)))) + (if (not file) + (error "Don't know which file to rescan. Try `R'.") + (switch-to-buffer-other-window + (reftex-get-file-buffer-force file)) + (setq current-prefix-arg '(4)) + (reftex-toc))) + (reftex-toc-Redo)) + (reftex-kill-temporary-buffers)) +(defun reftex-toc-Redo (&rest ignore) + "Regenerate the *toc* buffer by reparsing the entire document." (interactive) - (switch-to-buffer (reftex-get-file-buffer-force reftex-last-toc-file)) - (delete-other-windows) - (setq current-prefix-arg '(4)) + (switch-to-buffer-other-window + (reftex-get-file-buffer-force reftex-last-toc-file)) + (setq current-prefix-arg '(16)) (reftex-toc)) +(defun reftex-toc-external (&rest ignore) + "Switch to table of contents of an external document." + (interactive) + (let* ((xr-alist (get-text-property 1 'xr-alist)) + (xr-index (reftex-select-external-document + xr-alist 0))) + (switch-to-buffer-other-window (or (reftex-get-file-buffer-force + (cdr (nth xr-index xr-alist))) + (error "Cannot switch document"))) + (reftex-toc))) (defun reftex-toc-visit-line (&optional final) ;; Visit the tex file corresponding to the toc entry on the current line. ;; If FINAL is t, stay there ;; If FINAL is 'hide, hide the *toc* window. - ;; Otherwise, move cursor back into *toc* window - - (let (file find beg end (toc-window (selected-window)) show-window) - (save-excursion - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq end (point))) - - ;; get the file and the search string - (setq file (get-text-property (point) 'file)) - (setq find (get-text-property (point) 'find)) - (if (or (not file) (not find)) - (error "Cannot visit line")) - - (switch-to-buffer-other-window (reftex-get-file-buffer-force file)) - (setq show-window (selected-window)) - (goto-char (point-min)) - - (if (not (re-search-forward find nil t)) - (error "Cannot visit line")) - - (setq beg (match-beginning 0) - end (match-end 0)) - - (goto-char beg) + ;; Otherwise, move cursor back into *toc* window. + ;; This function is pretty clever about finding back a section heading, + ;; even if the buffer is not live, or things like outline, x-symbol etc. + ;; have been active. + + (let* ((toc (get-text-property (point) 'toc)) + (file (nth 3 toc)) + (marker (nth 4 toc)) + (level (nth 5 toc)) + (literal (nth 7 toc)) + (emergency-point (nth 8 toc)) + (toc-window (selected-window)) + show-window show-buffer match) + + (unless toc (error "Don't know which toc line to visit")) + + (setq match + (cond + ((and (markerp marker) (marker-buffer marker)) + ;; Buffer is still live and we have the marker. Should be easy. + (switch-to-buffer-other-window (marker-buffer marker)) + (goto-char (marker-position marker)) + (or (looking-at (regexp-quote literal)) + (looking-at (reftex-make-regexp-allow-for-ctrl-m literal)) + (looking-at (reftex-make-desparate-section-regexp literal)) + (looking-at (concat "\\\\" + (regexp-quote + (car (rassq level reftex-section-levels))) + "[[{]")))) + (t + ;; Marker is lost. Use the backup method. + (switch-to-buffer-other-window + (reftex-get-file-buffer-force file nil)) + (goto-char (or emergency-point (point-min))) + (or (looking-at (regexp-quote literal)) + (let ((pos (point))) + (re-search-backward "\\`\\|[\r\n][ \t]*[\r\n]" nil t) + (or (reftex-nearest-match (regexp-quote literal) pos) + (reftex-nearest-match + (reftex-make-regexp-allow-for-ctrl-m literal) pos) + (reftex-nearest-match + (reftex-make-desparate-section-regexp literal) pos))))) + )) + + (setq show-window (selected-window) + show-buffer (current-buffer)) + + (unless match + (select-window toc-window) + (error "Cannot find line")) + + (goto-char (match-beginning 0)) (recenter 1) - (reftex-highlight 0 beg end (current-buffer)) + (reftex-highlight 0 (match-beginning 0) (match-end 0) (current-buffer)) (select-window toc-window) ;; use the `final' parameter to decide what to do next (cond - ((equal final t) + ((eq final t) (reftex-unhighlight 0) (select-window show-window)) ((eq final 'hide) (reftex-unhighlight 0) - (delete-window)) + (or (one-window-p) (delete-window)) + (switch-to-buffer show-buffer) + (reftex-re-enlarge)) (t nil)))) ;;; =========================================================================== @@ -2809,131 +3936,87 @@ ;; Define variable to silence compiler warnings (defvar reftex-found-list) - -;; Internal variable, but used from different functions -(defvar reftex-cite-format1 nil) +(defvar reftex-cite-format-builtin) ;; The history list of regular expressions used for citations (defvar reftex-cite-regexp-hist nil) -;; Help string for citation selection +;; Prompt and help string for citation selection +(defconst reftex-citation-prompt + "Select: [n]ext [p]revious [r]estrict [ ]full_entry [q]uit RET [?]Help+more") + (defconst reftex-citation-help "AVAILABLE KEYS IN MAKE CITATION MENU --------------------------------------- - n / p Go to next/previous entry (Cursor motion works as well). - r Restrict selection with another regexp. - SPACE Show full database entry in other window. - f Toggle follow mode: Other window will follow with full db entry. - q Quit without inserting \\cite macro into buffer. - ? Display this help message. - C-r Recursive edit into other window. - RETURN ... Accept current entry and insert in format according to - `reftex-cite-format'") - -(defconst reftex-cite-format-default "\\cite{KEY}" - "The default value for reftex-cite-format. -Uses the string version of `reftex-cite-format'.") - -(defconst reftex-cite-format-1-author-simple - '( "\\cite{KEY}" "AUTHOR \\cite{KEY}" "AUTHOR {\it et al.} \\cite{KEY}") - "Value for reftex-cite format establishing a simple citation with name -of the first author. -Uses the list version of `reftex-cite-format'.") - -(defconst reftex-cite-format-2-authors - '((?\C-m - . ( "\\cite{KEY}" "AUTHOR \\cite{KEY}" - "AUTHOR \\& AUTHOR \\cite{KEY}" "AUTHOR \\etal{} \\cite{KEY}")) - (?\, - . ("\\cite{KEY}" "AUTHOR, \\cite{KEY}" - "AUTHOR \\& AUTHOR, \\cite{KEY}" "AUTHOR \\etal{}, \\cite{KEY}")) - (?\; - . ("\\cite{KEY}" "AUTHOR; \\cite{KEY}" - "AUTHOR \\& AUTHOR; \\cite{KEY}" "AUTHOR \\etal{}; \\cite{KEY}")) - (?\: - . ("\\cite{KEY}" "AUTHOR: \\cite{KEY}" - "AUTHOR \\& AUTHOR: \\cite{KEY}" "AUTHOR \\etal{}: \\cite{KEY}")) - (?\( - . ("(\\cite{KEY})" "AUTHOR (\\cite{KEY})" - "AUTHOR \\& AUTHOR (\\cite{KEY})" "AUTHOR \\etal{} (\\cite{KEY})")) - (?\[ - . ("[\\cite{KEY}]" "AUTHOR [\\cite{KEY}]" - "AUTHOR \\& AUTHOR [\\cite{KEY}]" "AUTHOR \\etal{} [\\cite{KEY}]"))) - "Value for `reftex-cite-format' that estabishes an Author/Year citation -where the year is supplied from BibTeX. Depending on which character -is used during selection to accept the label, an extra ,;: or pair of -parenthesis will be inserted. -Uses the list-of-cons-cells version of `reftex-cite-format'.") + n / p Go to next/previous entry (Cursor motion works as well). + C-s / C-r Search forward/backward. Use repeated C-s/C-r as in isearch. + g / r Start over with new regexp / Restrict with additional regexp. + SPC Show full database entry in other window. + f Toggle follow mode: Other window will follow with full db entry. + q Quit without inserting \\cite macro into buffer. + e Recursive edit into other window. + RET / a Accept current entry / Accept all entries.") ;; Find bibtex files (defun reftex-get-bibfile-list () - ;; Return list of bibfiles for current document + ;; Return list of bibfiles for current document. + ;; When using the chapterbib or bibunits package you should either + ;; use the same database files everywhere, or separate parts using + ;; different databases into different files (included into the mater file). + ;; Then this function will return the applicable database files. ;; Ensure access to scanning info (reftex-access-scan-info) - - (or (symbol-value reftex-bibfile-list-symbol) - (error "No BibTeX files to parse. Add \\bibliography statment to document and reparse."))) - -(defun reftex-scan-buffer-for-bibliography-statement (bib-list-symbol) - ;; Scan buffer for bibliography macro and store file list in bib-list-symbol. - (let (file-list dir-list) - (setq dir-list - (reftex-split - (concat path-separator "+") - (mapconcat '(lambda(x) - (if (getenv x) (getenv x) "")) - reftex-bibpath-environment-variables - path-separator))) - (goto-char (point-min)) - (if (re-search-forward "^[ \t]*\\\\bibliography{[ \t]*\\([^}]+\\)" nil t) - (progn - (setq dir-list - (cons (file-name-directory - (get-text-property (match-beginning 0) 'file)) - dir-list)) - (setq file-list - (mapcar '(lambda (x) (concat x ".bib")) - (reftex-delete-list - reftex-bibfile-ignore-list - (reftex-split - "[ \t\n]*,[ \t\n]*" - (reftex-no-props (match-string 1))))))) - (message "No \\bibliography command in document.")) - (set bib-list-symbol - (if file-list - (reftex-find-files-on-path file-list dir-list - "While parsing \\bibliography:") - nil)))) - -(defun reftex-find-files-on-path (file-list path-list &optional error-string) - ;; Search for all files in FILE-LIST on the PATH-LIST. Return absolute names. - ;; A missing file throws an exception with the error message ERROR-STRING. - (let (found-list found file) - (while file-list - (setq file (car file-list) - file-list (cdr file-list) - found nil) - (if (file-name-absolute-p file) - (setq found (expand-file-name file)) - (let ((dirs path-list)) - (while (and dirs (not found)) - (if (and (not (string= (car dirs) "")) - (file-exists-p (expand-file-name file (car dirs)))) - (setq found (expand-file-name file (car dirs)))) - (setq dirs (cdr dirs))))) - (if (and found - (file-exists-p found)) - (add-to-list 'found-list (expand-file-name found)) - (error "%s No such file %s." - (or error-string "") file))) - (nreverse found-list))) + (or + ;; Try inside this file (and its includes) + (cdr (reftex-last-assoc-before-elt + 'bib (list 'eof (buffer-file-name)) + (member (list 'bof (buffer-file-name)) + (symbol-value reftex-docstruct-symbol)))) + ;; Try after the beginning of this file + (cdr (assq 'bib (member (list 'bof (buffer-file-name)) + (symbol-value reftex-docstruct-symbol)))) + ;; Anywhere in the entire document + (cdr (assq 'bib (symbol-value reftex-docstruct-symbol))) + (error "\\bibliography statment missing or .bib files not found."))) + +(defun reftex-find-tex-file (file master-dir &optional die) + ;; Find FILE in MASTER-DIR or on reftex-tex-path. + ;; FILE may be given without the .tex extension. + (reftex-access-search-path "tex") + (let* ((path (cons master-dir reftex-tex-path)) + file1) + (setq file1 + (or (reftex-find-file-on-path (concat file ".tex") path) + (reftex-find-file-on-path file path))) + (unless file1 + (reftex-access-search-path "tex" t file) + (setq path (cons master-dir reftex-tex-path)) + (setq file1 + (or (reftex-find-file-on-path (concat file ".tex") path) + (reftex-find-file-on-path file path)))) + (cond (file1 file1) + (die (error "No such file: %s" file) nil) + (t (message "No such file: %s (ignored)" file) nil)))) + +(defun reftex-find-bib-file (file master-dir &optional die) + ;; Find FILE in MASTER-DIR or on reftex-bib-path + (reftex-access-search-path "bib") + (let ((file1 (reftex-find-file-on-path + file (cons master-dir reftex-bib-path)))) + (unless file1 + (reftex-access-search-path "bib" t file) + (setq file1 (reftex-find-file-on-path + file (cons master-dir reftex-bib-path)))) + (cond (file1 file1) + (die (error "No such file: %s" file) nil) + (t (message "No such file: %s (ignored)" file) nil)))) ;; Find a certain reference in any of the BibTeX files. (defun reftex-pop-to-bibtex-entry (key file-list - &optional mark-to-kill highlight) + &optional mark-to-kill highlight) ;; Find BibTeX KEY in any file in FILE-LIST in another window. ;; If mark-to-kill is non-nil, mark new buffer to kill." @@ -2945,18 +4028,17 @@ (while file-list (setq file (car file-list) file-list (cdr file-list)) - (if (not (setq buf (reftex-get-file-buffer-force file mark-to-kill))) - (error "No such file %s" file)) + (unless (setq buf (reftex-get-file-buffer-force file mark-to-kill)) + (error "No such file %s" file)) (switch-to-buffer buf) (widen) - (goto-char 0) - (if (re-search-forward re nil t) - (progn - (goto-char (match-beginning 0)) - (recenter 0) - (if highlight - (reftex-highlight 0 (match-beginning 0) (match-end 0))) - (throw 'exit (selected-window))))) + (goto-char (point-min)) + (when (re-search-forward re nil t) + (goto-char (match-beginning 0)) + (recenter 0) + (if highlight + (reftex-highlight 0 (match-beginning 0) (match-end 0))) + (throw 'exit (selected-window)))) (set-window-configuration window-conf) (beep) (message "No BibTeX entry with citation key %s" key)))) @@ -2968,15 +4050,14 @@ ;; BUFFERS is a list of buffers or file names. ;; Return list with entries." (let* (re-list first-re rest-re - ;; avoid fontification of lookup buffers - (lazy-lock-minimum-size 1) (buffer-list (if (listp buffers) buffers (list buffers))) found-list entry buffer1 buffer alist key-point start-point end-point) - (setq re-list (reftex-split "[ \t]*&&[ \t]*" - (read-string "RegExp [ && RegExp...]: " - nil 'reftex-cite-regexp-hist))) + (setq re-list (split-string + (read-string "RegExp [ && RegExp...]: " + nil 'reftex-cite-regexp-hist) + "[ \t]*&&[ \t]*")) (setq first-re (car re-list) ; We'll use the first re to find things, rest-re (cdr re-list)) ; the other to narrow down. @@ -2986,7 +4067,7 @@ (save-excursion (save-window-excursion - ;; walk through all bibtex files + ;; Walk through all bibtex files (while buffer-list (setq buffer (car buffer-list) buffer-list (cdr buffer-list)) @@ -3000,68 +4081,64 @@ (message "Scanning bibliography database %s" buffer1)) (set-buffer buffer1) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward first-re nil t) - (catch 'search-again - (setq key-point (point)) - (if (not (re-search-backward - "^[ \t]*@\\([a-zA-Z]+\\)[ \t\n\r]*[{(]" nil t)) - (throw 'search-again nil)) - (setq start-point (point)) - (goto-char (match-end 0)) - (condition-case nil - (up-list 1) - ('error (goto-char key-point) - (throw 'search-again nil))) - (setq end-point (point)) - - ;; Ignore @string, @comment and @c entries or things - ;; outside entries - (if (or (string= (downcase (match-string 1)) "string") - (string= (downcase (match-string 1)) "comment") - (string= (downcase (match-string 1)) "c") - (< (point) key-point)) ; this means match not in {} - (progn - (goto-char key-point) - (throw 'search-again nil))) - - ;; Well, we have got a match - (setq entry (concat - (buffer-substring start-point (point)) "\n")) - - ;; Check if other regexp match as well - (setq re-list rest-re) - (while re-list - (if (not (string-match (car re-list) entry)) - ;; nope - move on - (throw 'search-again nil)) - (setq re-list (cdr re-list))) - - (setq alist (reftex-parse-bibtex-entry - nil start-point end-point)) - (setq alist (cons (cons "&entry" entry) alist)) - - ;; check for crossref entries - (if (assoc "crossref" alist) - (setq alist - (append - alist (reftex-get-crossref-alist alist)))) - - ;; format the entry - (setq alist - (cons - (cons "&formatted" - (reftex-format-bib-entry alist)) - alist)) - - ;; add it to the list - (setq found-list (cons alist found-list))))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward first-re nil t) + (catch 'search-again + (setq key-point (point)) + (unless (re-search-backward + "\\(\\`\\|[\n\r]\\)[ \t]*@\\([a-zA-Z]+\\)[ \t\n\r]*[{(]" nil t) + (throw 'search-again nil)) + (setq start-point (point)) + (goto-char (match-end 0)) + (condition-case nil + (up-list 1) + (error (goto-char key-point) + (throw 'search-again nil))) + (setq end-point (point)) + + ;; Ignore @string, @comment and @c entries or things + ;; outside entries + (when (or (string= (downcase (match-string 2)) "string") + (string= (downcase (match-string 2)) "comment") + (string= (downcase (match-string 2)) "c") + (< (point) key-point)) ; this means match not in {} + (goto-char key-point) + (throw 'search-again nil)) + + ;; Well, we have got a match + (setq entry (concat + (buffer-substring start-point (point)) "\n")) + + ;; Check if other regexp match as well + (setq re-list rest-re) + (while re-list + (unless (string-match (car re-list) entry) + ;; nope - move on + (throw 'search-again nil)) + (pop re-list)) + + (setq alist (reftex-parse-bibtex-entry + nil start-point end-point)) + (push (cons "&entry" entry) alist) + + ;; check for crossref entries + (if (assoc "crossref" alist) + (setq alist + (append + alist (reftex-get-crossref-alist alist)))) + + ;; format the entry + (push (cons "&formatted" (reftex-format-bib-entry alist)) + alist) + + ;; add it to the list + (push alist found-list)))) (reftex-kill-temporary-buffers)))) (setq found-list (nreverse found-list)) - + ;; Sorting - (cond + (cond ((eq 'author reftex-sort-bibtex-matches) (sort found-list 'reftex-bib-sort-author)) ((eq 'year reftex-sort-bibtex-matches) @@ -3071,13 +4148,14 @@ (t found-list)))) (defun reftex-bib-sort-author (e1 e2) - (let ((al1 (reftex-get-bib-authors e1)) (al2 (reftex-get-bib-authors e2))) + (let ((al1 (reftex-get-bib-names "author" e1)) + (al2 (reftex-get-bib-names "author" e2))) (while (and al1 al2 (string= (car al1) (car al2))) - (setq al1 (cdr al1) - al2 (cdr al2))) + (pop al1) + (pop al2)) (if (and (stringp (car al1)) - (stringp (car al2))) - (string< (car al1) (car al2)) + (stringp (car al2))) + (string< (car al1) (car al2)) (not (stringp (car al1)))))) (defun reftex-bib-sort-year (e1 e2) @@ -3096,32 +4174,32 @@ (save-restriction (widen) (if (re-search-forward - (concat "@\\w+[{(][ \t\n\r]*" (regexp-quote crkey) "[ \t\n\r]*,") nil t) + (concat "@\\w+[{(][ \t\n\r]*" (regexp-quote crkey) + "[ \t\n\r]*,") nil t) (progn (setq start (match-beginning 0)) (condition-case nil (up-list 1) - ('error nil)) + (error nil)) (reftex-parse-bibtex-entry nil start (point))) nil))))) ;; Parse and format individual entries -(defun reftex-get-bib-authors (entry) - ;; Return a list with the author names in ENTRY - (let (authors) - (setq authors (reftex-get-bib-field "author" entry)) - (if (equal "" authors) - (setq authors (reftex-get-bib-field "editor" entry))) - (while (string-match "\\band\\b[ \t]*" authors) - (setq authors (replace-match "\n" nil t authors))) - (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" authors) - (setq authors (replace-match "" nil t authors))) - (while (string-match "^[ \t]+\\|[ \t]+$" authors) - (setq authors (replace-match "" nil t authors))) - (while (string-match "[ \t][ \t]+" authors) - (setq authors (replace-match " " nil t authors))) - (reftex-split "\n" authors))) +(defun reftex-get-bib-names (field entry) + ;; Return a list with the author or editor anmes in ENTRY + (let ((names (reftex-get-bib-field field entry))) + (if (equal "" names) + (setq names (reftex-get-bib-field "editor" entry))) + (while (string-match "\\band\\b[ \t]*" names) + (setq names (replace-match "\n" nil t names))) + (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" names) + (setq names (replace-match "" nil t names))) + (while (string-match "^[ \t]+\\|[ \t]+$" names) + (setq names (replace-match "" nil t names))) + (while (string-match "[ \t][ \t]+" names) + (setq names (replace-match " " nil t names))) + (split-string names "\n"))) (defun reftex-parse-bibtex-entry (entry &optional from to) (let (alist key start field) @@ -3137,21 +4215,21 @@ (narrow-to-region from to)) (goto-char (point-min)) - (if (re-search-forward + (if (re-search-forward "@\\(\\w+\\)[ \t\n\r]*[{(][ \t\n\r]*\\([^ \t\n\r,]+\\)" nil t) (setq alist (list - (cons "&type" (downcase (reftex-no-props (match-string 1)))) - (cons "&key" (reftex-no-props (match-string 2)))))) + (cons "&type" (downcase (reftex-match-string 1))) + (cons "&key" (reftex-match-string 2))))) (while (re-search-forward "\\(\\w+\\)[ \t\n\r]*=[ \t\n\r]*" nil t) - (setq key (reftex-no-props (downcase (match-string 1)))) + (setq key (downcase (reftex-match-string 1))) (cond ((= (following-char) ?{) (forward-char 1) (setq start (point)) (condition-case nil (up-list 1) - ('error nil))) + (error nil))) ((= (following-char) ?\") (forward-char 1) (setq start (point)) @@ -3170,8 +4248,8 @@ ;; remove trailing garbage (if (string-match "[ \t}]+$" field) (setq field (replace-match "" nil t field))) - (setq alist (cons (cons key field) alist))) - alist)))) + (push (cons key field) alist)))) + alist)) (defun reftex-get-bib-field (fieldname entry) ;; Extract the field FIELDNAME from an ENTRY @@ -3181,8 +4259,7 @@ (defun reftex-format-bib-entry (entry) ;; Format a BibTeX ENTRY so that it is nice to look at (let* - ((rtn nil) - (auth-list (reftex-get-bib-authors entry)) + ((auth-list (reftex-get-bib-names "author" entry)) (authors (mapconcat '(lambda (x) x) auth-list ", ")) (year (reftex-get-bib-field "year" entry)) (title (reftex-get-bib-field "title" entry)) @@ -3208,33 +4285,19 @@ (equal type "inproceedings")) (concat "in: " (reftex-get-bib-field "booktitle" entry))) (t "")))) - (setq authors - (if (> (length authors) 30) - (concat (substring authors 0 27) "...") - (format "%-30s" authors)) - title - (if (> (length title) 70) - (concat (substring title 0 67) "...") - (format "%-70s" title)) - extra - (if (> (length extra) 40) - (concat (substring extra 0 37) "...") - (format "%-40s" extra))) - (if (reftex-use-fonts) - (progn - (put-text-property 0 (length authors) 'face 'font-lock-keyword-face - authors) - (put-text-property 0 (length title) 'face 'font-lock-comment-face - title) - (put-text-property 0 (length extra) 'face 'font-lock-reference-face - extra))) - (setq rtn (concat key "\n " authors " " year " " extra - "\n " title "\n\n")) - rtn)) + (setq authors (reftex-truncate authors 30 t t)) + (when (reftex-use-fonts) + (put-text-property 0 (length authors) 'face 'font-lock-keyword-face + authors) + (put-text-property 0 (length title) 'face 'font-lock-comment-face + title) + (put-text-property 0 (length extra) 'face 'font-lock-reference-face + extra)) + (concat key "\n " authors " " year " " extra "\n " title "\n\n"))) ;; Make a citation -(defun reftex-citation (&optional arg no-insert) +(defun reftex-citation (&optional no-insert) "Make a citation using BibTeX database files. After asking for a Regular Expression, it scans the buffers with bibtex entries (taken from the \\bibliography command) and offers the @@ -3250,196 +4313,272 @@ When called with just C-u as prefix, enforces rescan of buffer for bibliography statement (e.g. if it was changed)." - (interactive "P") + (interactive) ;; check for recursive edit (reftex-check-recursive-edit) ;; if there is just 1 C-u prefix arg, force to rescan buffer - (if (and current-prefix-arg - (listp current-prefix-arg) - (= 4 (prefix-numeric-value arg))) - (reftex-reset-scanning-information)) - - ;; check if there is already a cite command at point and change cite format + (reftex-access-scan-info current-prefix-arg) + + ;; Call reftex-do-citation, but protected + (unwind-protect + (reftex-do-citation current-prefix-arg no-insert) + (reftex-kill-temporary-buffers))) + +(defun reftex-do-citation (&optional arg no-insert) + ;; This really does the work of reftex-citation. + + ;; Check if there is already a cite command at point and change cite format ;; in order to only add another reference in the same cite command. - (let ((pos (point))) - (search-backward "\\" (point-min) 1) - (if (and (looking-at "\\\\[a-zA-Z]*cite\\*?\\(\\[[^]]*\\]\\)*{\\([^}]*\\)") - (>= (match-end 0) pos) - (>= pos (match-beginning 2))) + (let (key format (macro (car (car (reftex-what-macro t))))) + (if (and (stringp macro) + (string-match "\\`\\\\cite\\|cite\\'" macro)) (progn - (goto-char pos) (cond ((or (not arg) (not (listp arg))) - (setq reftex-cite-format1 + (setq format (concat (if (not (or (= (preceding-char) ?{) (= (preceding-char) ?,))) "," "") - "KEY" + "%l" (if (not (or (= (following-char) ?}) (= (following-char) ?,))) "," "")))) (t - (setq reftex-cite-format1 "KEY")))) - (setq reftex-cite-format1 - (if (symbolp reftex-cite-format) - (symbol-value reftex-cite-format) - reftex-cite-format)) - (goto-char pos))) - - (let* (key entry cnt rtn ins-string re-list re - ;; scan bibtex files - (lazy-lock-minimum-size 1) - (reftex-found-list (reftex-extract-bib-entries - (reftex-get-bibfile-list))) - (found-list-r nil) - (accept-keys - (if (and (listp reftex-cite-format1) - (listp (car reftex-cite-format1))) - (mapcar 'car reftex-cite-format1) - '(?\C-m)))) - (if (not reftex-found-list) + (setq format "%l")))) + ;; else: figure out the correct format + (setq format + (cond + ((stringp reftex-cite-format) reftex-cite-format) + ((and (symbolp reftex-cite-format) + (assq reftex-cite-format reftex-cite-format-builtin)) + (nth 2 (assq reftex-cite-format reftex-cite-format-builtin))) + (t reftex-cite-format))) + (if (listp format) + (save-window-excursion + (with-output-to-temp-buffer "*RefTeX Select*" + (princ "SELECT A CITATION FORMAT\n\n") + (princ + (mapconcat + (function (lambda (x) + (format "[%c] %s %s" (car x) + (if (> (car x) 31) " " "") + (cdr x)))) + format "\n"))) + (setq key (read-char)) + (if (assq key format) + (setq format (cdr (assq key format))) + (error "No citation format associated with key `%c'" key))))) + + (let* (entry cnt rtn ins-string re-list re + ;; scan bibtex files + (reftex-found-list (reftex-extract-bib-entries + (reftex-get-bibfile-list))) + (found-list-r nil)) + (unless reftex-found-list (error "Sorry, no matches found")) - ;; remember where we came from - (setq reftex-call-back-to-this-buffer (current-buffer)) - - ;; offer selection - (save-window-excursion - (switch-to-buffer-other-window "*RefTeX Select*") - (erase-buffer) - (mapcar '(lambda (x) (insert (cdr (assoc "&formatted" x)))) - reftex-found-list) - (if (= 0 (buffer-size)) - (error "Sorry, no matches found")) - (setq truncate-lines t) - (goto-char 1) - (if (catch 'exit - (while t - (setq rtn - (reftex-select-item - nil - (concat - "Select: [n]ext [p]rev [r]estrict [q]uit [?]Help ||" - " RETURN " - (condition-case nil - (mapconcat 'char-to-string accept-keys " ") - (error (error "Illegal reftex-cite-format")))) - "^[^ \t\n]" - "\n\n" - 4 - reftex-citation-help - (cons ?r accept-keys) - nil - 'reftex-bibtex-selection-callback nil)) - (setq key (car rtn) - cnt (cdr rtn)) - (if (not key) (throw 'exit nil)) + ;; remember where we came from + (setq reftex-call-back-to-this-buffer (current-buffer)) + + ;; offer selection + (save-window-excursion + (switch-to-buffer-other-window "*RefTeX Select*") + (erase-buffer) + (reftex-insert-bib-matches reftex-found-list) + (if (= 0 (buffer-size)) + (error "Sorry, no matches found")) + (setq truncate-lines t) + (goto-char 1) + (if (catch 'exit + (while t + (setq rtn + (reftex-select-item + reftex-citation-prompt + "^[^ \t\n\r]" + 4 + reftex-citation-help + '(?r ?a ?g ?\C-m) + nil + 'reftex-bibtex-selection-callback nil)) + (setq key (car rtn) + cnt (nth 1 rtn)) + (unless key (throw 'exit nil)) + (cond + ((eq key ?g) + (setq reftex-found-list + (save-excursion + (set-buffer reftex-call-back-to-this-buffer) + (reftex-extract-bib-entries + (reftex-get-bibfile-list)))) + (erase-buffer) + (reftex-insert-bib-matches reftex-found-list) + (if (= 0 (buffer-size)) + (error "Sorry, no matches found")) + (goto-char 1)) + + ((eq key ?r) + ;; restrict with new regular expression + (setq re-list + (split-string (read-string + "RegExp [ && RegExp...]: " + nil 'reftex-cite-regexp-hist) + "[ \t]*&&[ \t]*")) + (while re-list + (setq re (car re-list) + re-list (cdr re-list)) + (setq found-list-r + (delete "" + (mapcar + '(lambda (x) + (if (string-match + re (cdr (assoc "&entry" x))) + x + "")) + reftex-found-list)))) + (if found-list-r + (setq reftex-found-list found-list-r) + (ding)) + (erase-buffer) + (reftex-insert-bib-matches reftex-found-list) + (goto-char 1)) + ((eq key ?a) + (setq entry 'all) + (throw 'exit t)) + ((or (eq key ?\C-m) + (eq key 'return)) + (if cnt + (setq entry (nth cnt reftex-found-list)) + (setq entry nil)) + (throw 'exit t)) + (t + (ding))))) + (progn + ;; format the entry + (if (eq entry 'all) + (setq ins-string + (mapconcat + '(lambda (entry) + (reftex-format-citation entry format)) + reftex-found-list "\n")) + (setq ins-string (reftex-format-citation entry format)))) + (setq ins-string "") + (message "Quit"))) + (kill-buffer "*RefTeX Select*") + + (unless no-insert + (insert ins-string) + (when (string-match "\\?" ins-string) + (search-backward "?") + (delete-char 1))) + (message "") + + ;; Check if the prefix arg was numeric, and call recursively + (when (and (integerp arg) + (> arg 1) + (re-search-backward + "\\\\\\([a-zA-Z]*cite\\|cite[a-zA-Z]*\\)\\**\\(\\[[^]]*\\]\\)*{\\([^}]*\\)" nil t)) + (goto-char (match-end 0)) + (decf arg) + (reftex-do-citation arg)) + + ;; Return the citation key + (or (eq entry 'all) + (reftex-get-bib-field "&key" entry))))) + +(defun reftex-insert-bib-matches (list) + ;; Insert the bib matches and number them correctly + (let ((cnt -1) tmp) + (mapcar '(lambda (x) + (setq tmp (cdr (assoc "&formatted" x))) + (incf cnt) + (put-text-property 0 (length tmp) 'cnt cnt tmp) + (insert tmp)) + list))) + +(defun reftex-format-names (namelist n) + (interactive) + (let (last (len (length namelist))) + (cond + ((= 1 len) (car namelist)) + ((> len n) (concat (car namelist) (nth 2 reftex-cite-punctuation))) + (t + (setq n (min len n) + last (nth (1- n) namelist)) + (setcdr (nthcdr (- n 2) namelist) nil) + (concat + (mapconcat 'identity namelist (nth 0 reftex-cite-punctuation)) + (nth 1 reftex-cite-punctuation) + last))))) + +(defun reftex-format-citation (entry format) + ;; Format a citation from the info in the BibTeX ENTRY + + (unless (stringp format) (setq format "\\cite{%l}")) + + (if (and reftex-comment-citations + (string-match "%l" reftex-cite-comment-format)) + (error "reftex-cite-comment-format contains illeagal %%l")) + + (while (string-match + "\\(\\`\\|[^%]\\)\\(\\(%\\([0-9]*\\)\\([a-zA-Z]\\)\\)[.,;: ]*\\)" + format) + (let ((n (string-to-int (match-string 4 format))) + (l (string-to-char (match-string 5 format))) + rpl b e) + (save-match-data + (setq rpl (cond - ((equal key ?r) - ;; restrict with new regular expression - (setq re-list - (reftex-split "[ \t]*&&[ \t]*" - (read-string "RegExp [ && RegExp...]: " - nil 'reftex-cite-regexp-hist))) - (while re-list - (setq re (car re-list) - re-list (cdr re-list)) - (setq found-list-r - (delete "" - (mapcar - '(lambda (x) - (if (string-match re - (cdr (assoc "&entry" x))) - x - "")) - reftex-found-list)))) - (if found-list-r - (setq reftex-found-list found-list-r) - (ding)) - (erase-buffer) - (mapcar '(lambda (x) (insert (cdr (assoc "&formatted" x)))) - reftex-found-list) - (goto-char 1)) - ((or (member key accept-keys) - (equal key ?\C-m) - (equal key 'return)) - (setq entry (nth cnt reftex-found-list)) - (throw 'exit t)) - (t - (ding))))) - (progn - ;; format the entry - (if (not (integerp key)) (setq key ?\C-m)) - (setq ins-string (reftex-format-citation entry key))) - (setq ins-string "") - (message "Quit"))) - (kill-buffer "*RefTeX Select*") - - (if (not no-insert) - (insert ins-string)) - (message "") - - ;; Check if the prefix arg was numeric, and call reftex-citation recursively - (if (and (integerp arg) - (> arg 1) - (re-search-backward - "\\\\[a-zA-Z]*cite\\*?\\(\\[[^]]*\\]\\)*{\\([^}]*\\)" nil t)) - (progn - (goto-char (match-end 0)) - (setq arg (1- arg)) - (reftex-citation arg)) - (reftex-kill-temporary-buffers)) - ;; Return the citation key - (reftex-get-bib-field "&key" entry))) - -(defun reftex-format-citation (entry key) - ;; Format a citation from the info in the BibTeX ENTRY - (let* ((cite-key (reftex-get-bib-field "&key" entry)) - (year (reftex-get-bib-field "year" entry)) - (auth-list (reftex-get-bib-authors entry)) - (nauthors (length auth-list)) - format) - - (save-excursion - ;; Find the correct format - (if (and (listp reftex-cite-format1) - (listp (car reftex-cite-format1))) - (if (integerp (car (car reftex-cite-format1))) - (if (assoc key reftex-cite-format1) - (setq format (cdr (assoc key reftex-cite-format1))) - (if (or (equal key ?\C-m) - (equal key 'return)) - (setq format (cdr (car reftex-cite-format1))) - (error "Error in reftex-cite-format"))) - (error "Error in reftex-cite-format")) - (setq format reftex-cite-format1)) - - (if (listp format) - (let ((nn (min nauthors (1- (length format))))) - (while (and (> nn 0) (string= "" (nth nn format))) - (setq nn (1- nn))) - (setq format (nth nn format)))) - (if (stringp format) - (setq format format) - (setq format "\\cite{KEY}")) - - ;; Insert the author names - (while (string-match "\\bAUTHOR\\b" format) - (setq format (replace-match (car auth-list) t t format)) - (setq auth-list (cdr auth-list))) - (while (string-match "\\bKEY\\b" format) - (setq format (replace-match cite-key t t format))) - (while (string-match "\\bYEAR\\b" format) - (setq format (replace-match year t t format))) - format))) - -;; this is slow and not recommended for follow mode + ((= l ?l) (concat + (reftex-get-bib-field "&key" entry) + (if reftex-comment-citations + reftex-cite-comment-format + ""))) + ((= l ?a) (reftex-format-names + (reftex-get-bib-names "author" entry) + (or n 2))) + ((= l ?A) (car (reftex-get-bib-names "author" entry))) + ((= l ?b) (reftex-get-bib-field "booktitle" entry)) + ((= l ?c) (reftex-get-bib-field "chapter" entry)) + ((= l ?d) (reftex-get-bib-field "edition" entry)) + ((= l ?e) (reftex-format-names + (reftex-get-bib-names "editor" entry) + (or n 2))) + ((= l ?E) (car (reftex-get-bib-names "editor" entry))) + ((= l ?h) (reftex-get-bib-field "howpublished" entry)) + ((= l ?i) (reftex-get-bib-field "institution" entry)) + ((= l ?j) (reftex-get-bib-field "journal" entry)) + ((= l ?k) (reftex-get-bib-field "key" entry)) + ((= l ?m) (reftex-get-bib-field "month" entry)) + ((= l ?n) (reftex-get-bib-field "number" entry)) + ((= l ?o) (reftex-get-bib-field "organization" entry)) + ((= l ?p) (reftex-get-bib-field "pages" entry)) + ((= l ?P) (car (split-string + (reftex-get-bib-field "pages" entry) + "[- .]+"))) + ((= l ?s) (reftex-get-bib-field "school" entry)) + ((= l ?u) (reftex-get-bib-field "publisher" entry)) + ((= l ?r) (reftex-get-bib-field "address" entry)) + ((= l ?t) (reftex-get-bib-field "title" entry)) + ((= l ?v) (reftex-get-bib-field "volume" entry)) + ((= l ?y) (reftex-get-bib-field "year" entry))))) + + (if (string= rpl "") + (setq b (match-beginning 2) e (match-end 2)) + (setq b (match-beginning 3) e (match-end 3))) + (setq format (concat (substring format 0 b) rpl (substring format e))))) + (while (string-match "%%" format) + (setq format (replace-match "%" t t format))) + (while (string-match "[ ,.;:]*%<" format) + (setq format (replace-match "" t t format))) + format) + +;; This is slow and not recommended for follow mode (defun reftex-bibtex-selection-callback (cnt) ;; Callback function to be called from the BibTeX selection, in ;; order to display context. This function is relatively slow and not @@ -3468,124 +4607,175 @@ (substitute-command-keys "In unfinished recursive edit. Finish (\\[exit-recursive-edit]) or abort (\\[abort-recursive-edit]).")))) -(defun reftex-select-item (buffer prompt next-re end-re size help-string +(defun reftex-select-item (prompt next-re size help-string event-list &optional offset - call-back cb-flag) -;; Select an item from the buffer BUFFER. Show PROMPT to user, find -;; next item with NEXT-RE regular expression, return on any of the -;; events listed in EVENT-LIST. The function returns the event along -;; with an integer indicating which item was selected. When OFFSET is -;; specified, starts at that item in the list. When CALL-BACK is -;; given, it is a function which is called with the match of the -;; NEXT-RE match and the index of the element. - (let* (key key-sq b e ev cnt cmd - (offset1 (or offset 1))) + call-back cb-flag match-everywhere) +;; Select an item. Show PROMPT to user, find next item with NEXT-RE +;; regular expression, return on any of the events listed in +;; EVENT-LIST. The function returns the event along with an integer +;; indicating which item was selected. When OFFSET is specified, +;; starts at that item in the list. When CALL-BACK is given, it is a +;; function which is called with the index of the element. + + (let* (key key-sq b e ev cnt last-cnt cmd skip-callback + (search-str "") tmp search-start matched forward mini-map last-key + (offset1 (or offset 1)) win1 win2) + + ;; Set up a minibuffer keymap for the search stuff + (setq mini-map (copy-keymap minibuffer-local-map)) + (define-key mini-map "\C-s" + '(lambda () (interactive) (setq forward t) (exit-minibuffer))) + (define-key mini-map "\C-r" + '(lambda () (interactive) (setq forward nil) (exit-minibuffer))) + (define-key mini-map "\C-m" 'exit-minibuffer) + (setq ev (catch 'exit (save-window-excursion - (if buffer - (switch-to-buffer-other-window buffer)) - (if (= 0 (buffer-size)) - (throw 'exit nil)) (setq truncate-lines t) (goto-char 1) - (if (not (re-search-forward next-re nil t offset1)) - (progn ; in case the offset is illegal - (setq offset1 1) - (if (not (re-search-forward next-re nil t offset1)) - (throw 'exit nil)))) + (unless (re-search-forward next-re nil t offset1) + ;; in case the offset is illegal + (setq offset1 1) + (re-search-forward next-re nil t offset1)) (beginning-of-line 1) - (setq cnt (if offset1 (1- offset1) 0)) (while t - (if (and cb-flag call-back) + (setq last-cnt (or cnt last-cnt)) + (setq cnt (get-text-property (point) 'cnt)) + (if (and cnt cb-flag call-back (not skip-callback)) (funcall call-back cnt)) - (setq b (point) - e (save-excursion - (save-match-data - (re-search-forward end-re nil 1)) - (point))) + (setq skip-callback nil) + (if cnt + (setq b (or (previous-single-property-change + (1+ (point)) 'cnt) + (point-min)) + e (or (next-single-property-change + (point) 'cnt) + (point-max))) + (setq b (point) e (point))) (reftex-highlight 1 b e) (if (or (not (pos-visible-in-window-p b)) (not (pos-visible-in-window-p e))) (recenter (/ (window-height) 2))) (setq key-sq (read-key-sequence prompt)) + (setq last-key key) (setq key (car (cond + ((fboundp 'event-to-character) ; XEmacs + (mapcar 'event-to-character key-sq)) ((fboundp 'listify-key-sequence) ; Emacs (listify-key-sequence key-sq)) - ((fboundp 'event-to-character) ; XEmacs - (mapcar 'event-to-character key-sq)) (t (error "Please report this problem to dominik@strw.leidenuniv.nl"))))) (setq cmd (key-binding key-sq)) + (reftex-unhighlight 2) (reftex-unhighlight 0) (cond - ((or (equal key ?n) - (equal key ?\C-i) - (equal cmd 'next-line)) - (if (re-search-forward next-re nil t 2) - (setq cnt (1+ cnt))) + ;; Single line motions + ((or (eq key ?n) + (eq key ?\C-i) + (eq cmd 'next-line)) + (or (eobp) (forward-char 1)) + (re-search-forward next-re nil t 1) (beginning-of-line 1)) - - ((equal cmd 'scroll-up) - (setq cnt (1- cnt)) + ((or (eq key ?p) + (eq cmd 'previous-line)) + (re-search-backward next-re nil t)) + + ;; Page motions + ((eq cmd 'scroll-up) (while (and (pos-visible-in-window-p) - (re-search-forward next-re nil t)) - (setq cnt (1+ cnt))) + (re-search-forward next-re nil t))) (beginning-of-line 1) (recenter 1)) - - ((or (equal key ?p) - (equal cmd 'previous-line)) - (if (re-search-backward next-re nil t) - (setq cnt (1- cnt)))) - - ((equal cmd 'scroll-down) + ((eq cmd 'scroll-down) (while (and (pos-visible-in-window-p) - (re-search-backward next-re nil t)) - (setq cnt (1- cnt))) + (re-search-backward next-re nil t))) (recenter (- (window-height) size 2))) - ((equal key ?q) + ;; Begin and end of buffer + ((eq cmd 'beginning-of-buffer) + (goto-char (point-min)) + (re-search-forward next-re nil t) + (beginning-of-line 1)) + ((eq cmd 'end-of-buffer) + (goto-char (point-max)) + (re-search-backward next-re nil t)) + + ;; Exit + ((eq key ?q) (throw 'exit nil)) - - ((equal key ?\C-g) - (bury-buffer) - (error "Abort")) - - ((or (equal key ?\C-m) - (equal key 'return) - (equal cmd 'newline)) + ((eq key ?\C-g) + (if (or (eq last-key ?\C-s) (eq last-key ?\C-r)) + (ding) + (bury-buffer) + (error "Abort"))) + ((or (eq key ?\C-m) + (eq key 'return) + (eq cmd 'newline)) (throw 'exit 'return)) - - ((or (equal key ?C) ; backward compatibility - (equal key ?f)) + ((memq key event-list) + (throw 'exit key)) + + ;; Callback + ((or (eq key ?C) ; backward compatibility + (eq key ?f)) (setq cb-flag (not cb-flag))) - - ((equal key ?\ ) - (funcall call-back cnt)) - - ((equal key ?\?) - (save-window-excursion - (with-output-to-temp-buffer "*RefTeX Help*" - (princ help-string)) - (setq unread-command-events - (cons - (cond - ((fboundp 'read-event) ; Emacs - (read-event)) - ((fboundp 'next-command-event) ; XEmacs - (next-command-event)) - (t (error "Please report this problem to dominik@strw.leidenuniv.nl"))) - nil))) - (kill-buffer "*RefTeX Help*")) - - ((equal key ?\C-r) - ;; sje - code copied from ispell.el for - ;; performing recursive edit + ((eq key ?\ ) + (if cnt (funcall call-back cnt) (ding))) + + ;; Help + ((eq key ?\?) + (with-output-to-temp-buffer "*RefTeX Help*" + (princ help-string)) + (setq win1 (selected-window) + win2 (get-buffer-window "*RefTeX Help*" t)) + (select-window win2) + (unless (and (pos-visible-in-window-p 1) + (pos-visible-in-window-p (point-max))) + (enlarge-window (1+ (- (count-lines 1 (point-max)) + (window-height))))) + (select-window win1) + (setq skip-callback t)) + + ;; Searching + ((or (setq forward (eq key ?\C-s)) (eq key ?\C-r)) + (if (or (and (not (eq last-key ?\C-s)) + (not (eq last-key ?\C-r))) + (string= search-str "")) + (setq tmp ; get a new string + (read-from-minibuffer + (if (string= search-str "") + "Search: " + (format "Search [%s]:" search-str)) + nil mini-map) + search-str (if (string= tmp "") + search-str tmp))) + (setq search-start (point)) + (and (not (string= search-str "")) + (progn + (while + (and (setq matched + (if forward + (search-forward search-str nil 1) + (search-backward search-str nil 1))) + (or (>= (save-excursion + (goto-char (match-beginning 0)) + (current-column)) + (window-width)) + (not (or (get-text-property (point) 'cnt) + match-everywhere))))) + (if matched + (reftex-highlight 2 (match-beginning 0) + (match-end 0)) + (ding) + (goto-char search-start))))) + + ;; Recursive edit + ((eq key ?e) (set-marker reftex-recursive-edit-marker (point)) (unwind-protect (progn @@ -3596,20 +4786,18 @@ (substitute-command-keys "Recursive edit. Return to selection with \\[exit-recursive-edit]")) (recursive-edit))) - (if (not (equal (marker-buffer - reftex-recursive-edit-marker) - (current-buffer))) - (error - "Cannot continue RefTeX from this buffer.")) + (unless (equal (marker-buffer + reftex-recursive-edit-marker) + (current-buffer)) + (error "Cannot continue RefTeX from this buffer.")) (goto-char reftex-recursive-edit-marker)) (set-marker reftex-recursive-edit-marker nil))) - ((member key event-list) - (throw 'exit key)) (t (ding))))))) + (and (get-buffer "*RefTeX Help*") (kill-buffer "*RefTeX Help*")) (message "") - (cons ev cnt))) + (list ev cnt last-cnt))) ;;; =========================================================================== ;;; @@ -3622,56 +4810,89 @@ If there is no such macro at point, search forward to find one. When you call this function several times in direct successtion, point will move to view subsequent cross references further down in the buffer. +To cope with the plethora of variations in packages, this function +assumes any macro either starting with ending in `ref' or `cite' to contain +cross references. With argument, actually select the window showing the cross reference." (interactive "P") ;; See where we are. - (let* ((pos (point)) - (re "\\\\[a-z]*\\(cite\\|ref\\)\\(\\[[^{}]*\\]\\)?{\\([^}]+\\)}") - (my-window (get-buffer-window (current-buffer))) - pop-window cmd args macro label key-start point) - - (if (save-excursion - (forward-char 1) - (and (search-backward "\\" nil t) - (looking-at re) - (< pos (match-end 0)))) - (setq macro (match-string 1) - key-start (match-beginning 3))) + (let* ((re "\\\\\\([a-z]*\\(cite\\|ref\\)\\|\\(cite\\|ref\\)[a-z]*\\)\\**\\(\\[[^{}]*\\]\\)?{") + (macro (car (car (reftex-what-macro t)))) + (this-word (reftex-this-word "*a-zA-Z\\\\")) + (my-window (selected-window)) + pop-window cmd args point) + + (if (and macro + (string-match "\\`\\\\cite\\|\\`\\\\ref\\|cite\\'\\|ref\\'" + macro)) + (and (setq macro (match-string 0 macro)) + (string-match "\\`\\\\" macro) + (setq macro (substring macro 1))) + (setq macro nil)) (if (and macro (eq last-command this-command)) - (if (and (string= macro "cite") - (skip-chars-forward "^}, \t\n\r") - (= (following-char) ?,)) - (setq key-start (1+ (point))) - (setq macro nil))) - - (if (not macro) - (if (re-search-forward re nil t) - (setq macro (match-string 1) - key-start (match-beginning 3)) - (error "No further cross references in buffer"))) - - (goto-char key-start) + (if (string= macro "cite") + (progn + (skip-chars-forward "^},%") + (while (and (eq (following-char) ?%) + (or (beginning-of-line 2) t) + (skip-chars-forward " \t\n\r"))) + (skip-chars-forward ",") + (if (eq (following-char) ?}) + (setq macro nil))) + (setq macro nil))) + + (if (and (not macro) + (or (not (string-match "\\`\\\\" this-word)) + (eq (following-char) ?\\) + (search-backward "\\" nil t) + t)) + (if (interactive-p) + ;; Only move far if this function was called directly + (and (re-search-forward re nil t) + (setq macro (or (match-string 2) (match-string 3)))) + ;; The macro needs to be at point + (and (looking-at re) + (setq macro (or (match-string 2) (match-string 3))) + (goto-char (match-end 0))))) + + + (unless macro + (error "No cross reference to display")) ;; Ensure access to scanning info (reftex-access-scan-info) - (cond + (cond ((string= macro "cite") (setq cmd 'reftex-pop-to-bibtex-entry - args (list - (reftex-no-props (reftex-this-word "^{},")) - (reftex-get-bibfile-list) nil t))) + args (list + (reftex-this-word "^{},%\n\r") + (reftex-get-bibfile-list) nil t))) ((string= macro "ref") - (let ((label (reftex-no-props (reftex-this-word "^{}"))) - (entry (assoc label (symbol-value reftex-list-of-labels-symbol)))) + (let* ((label (reftex-this-word "^{}%\n\r")) + (xr-data (assoc 'xr (symbol-value reftex-docstruct-symbol))) + (xr-re (nth 2 xr-data)) + (entry (assoc label (symbol-value reftex-docstruct-symbol)))) + (if (and (not entry) (string-match xr-re label)) + ;; Label is defined in external document + (save-excursion + (save-match-data + (set-buffer + (or (reftex-get-file-buffer-force + (cdr (assoc (match-string 1 label) (nth 1 xr-data)))) + (error "Problem with external label %s" label)))) + (setq label (substring label (match-end 1))) + (reftex-access-scan-info) + (setq entry + (assoc label (symbol-value reftex-docstruct-symbol))))) (if entry (setq cmd 'reftex-pop-to-label - args (list label (list (nth 3 entry)) nil t)) - (error "Label %s not known - reparse document might help" label)))) - (t (error "This should not happen"))) + args (list label (list (nth 3 entry)) nil t)) + (error "Label %s not known - reparse document might help" label)))) + (t (error "This should not happen (reftex-view-crossref)"))) (setq point (point)) (apply cmd args) (setq pop-window (selected-window)) @@ -3688,6 +4909,7 @@ With argument, actually select the window showing the cross reference." (interactive "e") (mouse-set-point ev) + (setq last-command 'self-insert-command) ;; make sure we do not move! (reftex-view-crossref current-prefix-arg)) ;;; =========================================================================== @@ -3716,7 +4938,7 @@ (let ((bound (or bound (save-excursion (re-search-backward reftex-section-regexp nil 1) (point)))) - pos cmd-list cmd) + pos cmd-list cmd cnt cnt-opt entry) (save-restriction (save-excursion (narrow-to-region (max 1 bound) (point-max)) @@ -3724,22 +4946,32 @@ (while (condition-case nil (progn (up-list -1) t) (error nil)) + (setq cnt 1 cnt-opt 0) ;; move back over any touching sexps - (while (or (= (preceding-char) ?\]) - (= (preceding-char) ?\})) - (backward-sexp)) + (while (and (reftex-move-to-previous-arg bound) + (condition-case nil + (progn (backward-sexp) t) + (error nil))) + (if (eq (following-char) ?\[) (incf cnt-opt)) + (incf cnt)) (setq pos (point)) - (if (and (or (= (following-char) ?\[) - (= (following-char) ?\{)) - (and (re-search-backward "\\(\\\\[a-zA-Z]+\\)" nil t) - (= (match-end 0) pos))) - (progn - (setq cmd (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (if (eq t which) - (setq cmd-list (cons (cons cmd (point)) cmd-list)) - (if (member cmd which) - (throw 'exit (cons cmd (point))))))) + (when (and (or (= (following-char) ?\[) + (= (following-char) ?\{)) + (re-search-backward "\\\\[*a-zA-Z]+\\=" nil t)) + (setq cmd (reftex-match-string 0)) + (when (looking-at "\\\\begin{[^}]*}") + (setq cmd (reftex-match-string 0) + cnt (1- cnt))) + ;; This does ignore optional arguments. Very hard to fix. + (when (setq entry (assoc cmd reftex-env-or-mac-alist)) + (if (> cnt (or (nth 4 entry) 100)) + (setq cmd nil))) + (cond + ((null cmd)) + ((eq t which) + (push (cons cmd (point)) cmd-list)) + ((member cmd which) + (throw 'exit (cons cmd (point)))))) (goto-char pos))) (nreverse cmd-list))))) @@ -3774,7 +5006,7 @@ ((member env end-list) (setq end-list (delete env end-list))) ((eq t which) - (setq env-list (cons (cons env (point)) env-list))) + (push (cons env (point)) env-list)) ((member env which) (throw 'exit (cons env (point)))))) (nreverse env-list))))) @@ -3785,7 +5017,7 @@ (let ((pos (point))) (save-excursion (re-search-backward "[^ \t\n\r]" (point-min) 1) - (setq pos (1+ (point))) + (setq pos (min (1+ (point)) (point-max))) (if (re-search-backward "[^a-zA-Z0-9\\\.:]" (point-min) 1) (forward-char 1)) (buffer-substring-no-properties (point) pos)))) @@ -3800,22 +5032,169 @@ (set-text-properties 0 (length string) nil string)) string) -(defun reftex-split (regexp string) - ;; Split like perl - (let ((start 0) list) - (while (string-match regexp string start) - (setq list (cons (substring string start (match-beginning 0)) list)) - (setq start (match-end 0))) - (setq list (nreverse (cons (substring string start) list))))) - -(defun reftex-allow-for-ctrl-m (string) - ;; convert STRING into a regexp, allowing ^M for \n +(defun reftex-match-string (n) + ;; Match string without properties + (when (match-beginning n) + (buffer-substring-no-properties (match-beginning n) (match-end n)))) + +(defun reftex-this-word (&optional class) + ;; Grab the word around point. + (setq class (or class "-a-zA-Z0-9:_/.*;|")) + (save-excursion + (buffer-substring-no-properties + (progn (skip-chars-backward class) (point)) + (progn (skip-chars-forward class) (point))))) + +(defvar enable-multibyte-characters) +(defun reftex-truncate (string ncols &optional ellipses padding) + ;; Truncate a string to NCHAR characters. + ;; Works fast with ASCII and correctly with Mule characters. + ;; When ELLIPSES is non-nil, put three dots at the end of the string. + (setq string + (cond + ((and (boundp 'enable-multibyte-characters) + enable-multibyte-characters) + (if (<= (string-width string) ncols) + string + (if ellipses + (concat (truncate-string-to-width string (- ncols 3)) "...") + (truncate-string-to-width string ncols)))) + (t + (if (<= (length string) ncols) + string + (if ellipses + (concat (substring string 0 (- ncols 3)) "...") + (substring string 0 ncols)))))) + (if padding + (format (format "%%-%ds" ncols) string) + string)) + +(defun reftex-nearest-match (regexp &optional pos) + ;; Find the nearest match of REGEXP. Set the match data. + ;; If POS is given, calculate distances relative to it. + ;; Return nil if there is no match. + (let ((start (point)) (pos (or pos (point))) match1 match2 match) + (goto-char start) + (when (re-search-backward regexp nil t) + (setq match1 (match-data))) + (goto-char start) + (when (re-search-forward regexp nil t) + (setq match2 (match-data))) + (goto-char start) + (setq match + (cond + ((not match1) match2) + ((not match2) match1) + ((< (abs (- pos (car match1))) (abs (- pos (car match2)))) match1) + (t match2))) + (if match (progn (store-match-data match) t) nil))) + +(defun reftex-auto-mode-alist () + ;; Return an `auto-mode-alist' with only the .gz (etc) thingies. + ;; Stolen from gnus nnheader. + (let ((alist auto-mode-alist) + out) + (while alist + (when (listp (cdr (car alist))) + (push (car alist) out)) + (pop alist)) + (nreverse out))) + +(defun reftex-access-search-path (which &optional recurse file) + ;; Access path from environment variables. WHICH is either "tex" or "bib". + ;; When RECURSE is t, expand recursive paths, ending in double slash + ;; FILE is just for the message. + (let* ((pathvar (intern (concat "reftex-" which "-path"))) + (status (get pathvar 'status))) + (cond + ((eq status 'recursed)) + ((and status (null recurse))) + ((null status) + (let ((env-vars (if (equal which "tex") (list "TEXINPUTS") + reftex-bibpath-environment-variables))) + (set pathvar (reftex-parse-colon-path + (mapconcat '(lambda(x) (or (getenv x) "")) + env-vars path-separator)))) + (put pathvar 'status 'split)) + ((and (eq 'split status) recurse) + (message "Expanding search path to find %s file: %s ..." which file) + (set pathvar (reftex-expand-path (symbol-value pathvar))) + (put pathvar 'status 'recursed))))) + +(defun reftex-find-file-on-path (file path) + ;; Find FILE along the directory list PATH. + (catch 'exit + (when (file-name-absolute-p file) + (if (file-exists-p file) + (throw 'exit file) + (throw 'exit nil))) + (let* ((thepath path) file1 dir + (doubleslash (concat "/" "/"))) + (while (setq dir (pop thepath)) + (when (string= (substring dir -2) doubleslash) + (setq dir (substring dir 0 -1))) + (setq file1 (expand-file-name file dir)) + (if (file-exists-p file1) + (throw 'exit file1))) + ;; No such file + nil))) + +(defun reftex-parse-colon-path (path) + ;; Like parse-colon-parse, but // or /~ have no effects. + (mapcar 'file-name-as-directory + (delete "" (split-string path (concat path-separator "+"))))) + +(defun reftex-expand-path (path) + ;; Expand parts of path ending in a double slash + (let (path1 dir dirs (doubleslash (concat "/" "/"))) + (while (setq dir (pop path)) + (if (string= (substring dir -2) doubleslash) + (progn + (setq dir (substring dir 0 -1)) + (setq dirs (reftex-recursive-directory-list dir)) + (setq path1 (append dirs path1))) + (push dir path1))) + (nreverse path1))) + +(defun reftex-recursive-directory-list (dir) + (let ((path (list dir)) dirs path1) + (while (setq dir (pop path)) + (setq dirs + (delete nil + (mapcar (function + (lambda (x) + (if (and (file-directory-p x) + (not (string-match "/\\.+\\'" x))) + (file-name-as-directory x) + nil))) + (directory-files dir t)))) + (setq path (append dirs path)) + (push dir path1)) + path1)) + +(defun reftex-make-regexp-allow-for-ctrl-m (string) + ;; convert STRING into a regexp, allowing ^M for \n and vice versa (let ((start -2)) (setq string (regexp-quote string)) (while (setq start (string-match "[\n\r]" string (+ 3 start))) (setq string (replace-match "[\n\r]" nil t string))) string)) +(defun reftex-make-desparate-section-regexp (old) + ;; Return a regexp which will still match a section statement even if + ;; x-symbol or isotex or the like have been at work in the mean time. + (let* ((n (1+ (string-match "[[{]" old))) + (new (regexp-quote (substring old 0 (1+ (string-match "[[{]" old))))) + (old (substring old n))) + (while (string-match + "\\([\r\n]\\)\\|\\(\\`\\|[ \t\n\r]\\)\\([a-zA-Z0-9]+\\)\\([ \t\n\r]\\|}\\'\\)" + old) + (if (match-beginning 1) + (setq new (concat new "[^\n\r]*[\n\r]")) + (setq new (concat new "[^\n\r]*" (match-string 3 old)))) + (setq old (substring old (match-end 0)))) + new)) + (defun reftex-delete-list (elt-list list) ;; like delete, but with a list of things to delete ;; (original code from Rory Molinari) @@ -3827,44 +5206,76 @@ (defun reftex-get-buffer-visiting (file) ;; return a buffer visiting FILE (cond - ((fboundp 'find-buffer-visiting) ; Emacs - (find-buffer-visiting file)) ((boundp 'find-file-compare-truenames) ; XEmacs (let ((find-file-compare-truenames t)) (get-file-buffer file))) + ((fboundp 'find-buffer-visiting) ; Emacs + (find-buffer-visiting file)) (t (error "Please report this problem to dominik@strw.leidenuniv.nl")))) (defun reftex-get-file-buffer-force (file &optional mark-to-kill) ;; Return a buffer visiting file. Make one, if necessary. - ;; If neither such a buffer no the file exist, return nil. - ;; If MARK-TO-KILL in non-nil, put any new buffers into the kill list." + ;; If neither such a buffer nor the file exist, return nil. + ;; If MARK-TO-KILL is t and there is no live buffer, load the file with + ;; initializations according to `reftex-initialize-temporary-buffers', + ;; and mark the buffer to be killed after use. (let ((buf (reftex-get-buffer-visiting file))) - (cond - (buf buf) - ((file-exists-p file) - (setq buf (find-file-noselect file)) - (if mark-to-kill - (add-to-list 'reftex-buffers-to-kill buf)) - buf) - (t nil)))) + + (cond (buf + ;; We have it already as a buffer - just return it + buf) + + ((file-readable-p file) + ;; At least there is such a file and we can read it. + + (if (or (not mark-to-kill) + (eq t reftex-initialize-temporary-buffers)) + + ;; Visit the file with full magic + (setq buf (find-file-noselect file)) + + ;; Else: Visit the file just briefly, without or + ;; with limited Magic + + ;; The magic goes away + (let ((format-alist nil) + (auto-mode-alist (reftex-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (after-insert-file-functions nil)) + (setq buf (find-file-noselect file))) + + ;; Is there a hook to run? + (when (listp reftex-initialize-temporary-buffers) + (save-excursion + (set-buffer buf) + (run-hooks 'reftex-initialize-temporary-buffers)))) + + ;; Lets see if we got a license to kill :-| + (and mark-to-kill + (add-to-list 'reftex-buffers-to-kill buf)) + + ;; Return the new buffer + buf) + + ;; If no such file exists, return nil + (t nil)))) (defun reftex-splice-symbols-into-list (list alist) ;; Splice the association in ALIST of any symbols in LIST into the list. ;; Return new list. (let (rtn tmp) (while list - (while (and (not (null (car list))) - (symbolp (car list))) + (while (and (not (null (car list))) ;; keep list elements nil + (symbolp (car list))) (setq tmp (car list)) (cond ((assoc tmp alist) - (setq list (append (cdr (cdr (assoc tmp alist))) (cdr list)))) + (setq list (append (nth 2 (assoc tmp alist)) (cdr list)))) (t (error "Cannot treat symbol %s in reftex-label-alist" (symbol-name tmp))))) - (setq rtn (cons (car list) rtn) - list (cdr list))) + (push (pop list) rtn)) (nreverse rtn))) (defun reftex-uniquify (alist &optional keep-list) @@ -3872,36 +5283,44 @@ ;; Elements of KEEP-LIST are not removed even if duplicate. (let (new elm) (while alist - (setq elm (car alist) - alist (cdr alist)) + (setq elm (pop alist)) (if (or (member (car elm) keep-list) - (not (assoc (car elm) new))) - (setq new (cons elm new)))) - (setq new (nreverse new)) - new)) + (not (assoc (car elm) new))) + (push elm new))) + (nreverse new))) (defun reftex-use-fonts () ;; Return t if we can and want to use fonts. (and window-system reftex-use-fonts - (boundp 'font-lock-keyword-face))) + (featurep 'font-lock))) + +(defun reftex-refontify () + ;; Return t if we need to refontify context + (and (reftex-use-fonts) + (or (eq t reftex-refontify-context) + (and (eq 1 reftex-refontify-context) + (or (featurep 'x-symbol)))))) ;; Highlighting uses overlays. If this is for XEmacs, we need to load ;; the overlay library, available in version 19.15 (and (not (fboundp 'make-overlay)) (condition-case nil (require 'overlay) - ('error + (error (error "RefTeX needs overlay emulation (available in XEmacs 19.15)")))) ;; We keep a vector with several different overlays to do our highlighting. -(defvar reftex-highlight-overlays [nil nil]) +(defvar reftex-highlight-overlays [nil nil nil]) ;; Initialize the overlays (aset reftex-highlight-overlays 0 (make-overlay 1 1)) (overlay-put (aref reftex-highlight-overlays 0) 'face 'highlight) (aset reftex-highlight-overlays 1 (make-overlay 1 1)) (overlay-put (aref reftex-highlight-overlays 1) 'face 'highlight) +(aset reftex-highlight-overlays 2 (make-overlay 1 1)) +(overlay-put (aref reftex-highlight-overlays 2) 'face + (if (string-match "XEmacs" emacs-version) 'zmacs-region 'region)) ;; Two functions for activating and deactivation highlight overlays (defun reftex-highlight (index begin end &optional buffer) @@ -3919,137 +5338,49 @@ ;;; --------------------------------------------------------------------------- ;;; -;;; Cursor position after insertion of forms - -(defun reftex-position-cursor () - ;; Search back to question mark, delete it, leave point there - (if (search-backward "\?" (- (point) 100) t) - (delete-char 1))) - -(defun reftex-item () - "Insert an \\item and provide a label if the environments supports that." - (interactive) - (let ((env (car - (reftex-what-environment '("itemize" "enumerate" "eqnarray"))))) - - (if (and env (not (bolp))) (newline)) - - (cond - - ((string= env "eqnarray") - (if (not (bolp)) - (newline)) - (reftex-label env) - (insert "\n & & ") - (beginning-of-line 1)) - - ((string= env "itemize") - (newline) - (insert "\\item ")) - - ((string= env "enumerate") - (newline) - (insert "\\item") - (reftex-label env) - (insert " ")) - (t - (error "\\item command does not make sense here..."))))) - -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- -;;; --------------------------------------------------------------------------- -;;; -;;; Data Section: Definition of large constants - - -(defconst reftex-label-alist-builtin - '( - (LaTeX - "LaTeX default environments" - ("section" ?s "sec:" "~\\ref{%s}" t - ("Part" "Chapter" "Chap." "Section" "Sec." "Sect." "Paragraph" "Par." - "\\S" "Teil" "Kapitel" "Kap." "Abschnitt" )) - - ("enumerate" ?n "item:" "~\\ref{%s}" "\\\\item\\(\\[[^]]*\\]\\)?" - ("Item" "Punkt")) - - ("equation" ?e "eq:" "~(\\ref{%s})" t - ("Equation" "Eq." "Eqn." "Gleichung" "Gl.")) - ("eqnarray" ?e "eq:" nil "\\\\begin{eqnarray}\\|\\\\\\\\") - - ("figure" ?f "fig:" "~\\ref{%s}" "\\\\caption\\(\\[[^]]*\\]\\)?{" - ("Figure" "Fig." "Abbildung" "Abb.")) - ("figure*" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - - ("table" ?t "tab:" "~\\ref{%s}" "\\\\caption\\(\\[[^]]*\\]\\)?{" - ("Table" "Tab." "Tabelle")) - ("table*" ?t nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - - ("any" ?\ " " "\\ref{%s}" nil)) - - (Sideways - "Sidewaysfigure and sidewaystable" - ("sidewaysfigure" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - ("sidewaystable" ?t nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{")) - - (Subfigure - "Subfigure environments and macro" - ("subfigure" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - ("subfigure*" ?f nil nil "\\\\caption\\(\\[[^]]*\\]\\)?{") - ("\\subfigure" ?f nil nil "\\\\subfigure[[{]")) - - (AMSTeX - "AMS-LaTeX: amsmath package environents" - ("align" ?e "eq:" "~\\eqref{%s}" "\\\\begin{align}\\|\\\\\\\\") - ("gather" ?e "eq:" nil "\\\\begin{gather}\\|\\\\\\\\") - ("multline" ?e "eq:" nil t) - ("flalign" ?e "eq:" nil "\\\\begin{flalign}\\|\\\\\\\\") - ("alignat" ?e "eq:" nil "\\\\begin{alignat}{[0-9]*}\\|\\\\\\\\")) - - (AASTeX - "AAS deluxetable environment" - ("deluxetable" ?t "tab:" nil "\\\\caption{"))) - "The default label environment descriptions.") - -;;; --------------------------------------------------------------------------- -;;; ;;; Functions to compile the tables, reset the mode etc. (defun reftex-reset-mode () "Reset RefTeX Mode. Required to implement changes to some list variables. This function will compile the information in `reftex-label-alist' and similar variables. It is called when RefTeX is first used, and after changes to -these variables via `reftex-add-to-label-alist'." +these variables." (interactive) ;; Record that we have done this (setq reftex-tables-dirty nil) + (setq reftex-memory + (list reftex-label-alist reftex-label-alist-external-add-ons + reftex-default-label-alist-entries)) + + ;; Reset the file search path variables + (put 'reftex-tex-path 'status nil) + (put 'reftex-bib-path 'status nil) ;; Kill temporary buffers associated with RefTeX - just in case they ;; were not cleaned up properly - (let ((buffer-list '("*reftex-master.tex*" "*RefTeX Help*" "*RefTeX Select*" - "*Duplicate Labels*" "*toc*" "*RefTeX-scratch*"))) - (while buffer-list - (if (get-buffer (car buffer-list)) - (kill-buffer (car buffer-list))) - (setq buffer-list (cdr buffer-list)))) - - ;; Plug functions into AUCTeX if the user option says so + (let ((buffer-list '("*RefTeX Master*" "*RefTeX Help*" "*RefTeX Select*" + "*Duplicate Labels*" "*toc*" "*RefTeX-scratch*")) + buf) + (while (setq buf (pop buffer-list)) + (if (get-buffer buf) + (kill-buffer buf)))) + + ;; Make sure the current document will be rescanned soon. + (reftex-reset-scanning-information) + + ;; Plug functions into AUCTeX if the user option says so. (reftex-plug-into-AUCTeX) - ;; To update buffer-local variables - (hack-local-variables) (message "updating internal tables...") (reftex-compute-ref-cite-tables) - (message "updating internal tables... done") - (reftex-reset-scanning-information)) + (message "updating internal tables... done")) (defun reftex-reset-scanning-information () "Reset the symbols containing information from buffer scanning. This enforces rescanning the buffer on next use." - (if (and (string= reftex-last-toc-master (reftex-TeX-master-file)) - (get-buffer "*toc*")) - (kill-buffer "*toc*")) + (if (string= reftex-last-toc-master (reftex-TeX-master-file)) + (reftex-empty-toc-buffer)) (let ((symlist reftex-multifile-symbols) symbol) (while symlist @@ -4066,14 +5397,15 @@ ;; Compile information in reftex-label-alist (let ((tmp (reftex-uniquify (reftex-splice-symbols-into-list - (append - reftex-label-alist - reftex-label-alist-external-add-ons - reftex-default-label-alist-entries) - reftex-label-alist-builtin) - '(nil))) - entry env-or-mac typekeychar typekey prefix regexp - fmt wordlist cmd qh-list) + (append + reftex-label-alist + reftex-label-alist-external-add-ons + reftex-default-label-alist-entries) + reftex-label-alist-builtin) + '(nil))) + entry env-or-mac typekeychar typekey prefix context word + fmt reffmt labelfmt wordlist qh-list macros-with-labels + nargs nlabel opt-args cell sum) (setq reftex-words-to-typekey-alist nil reftex-typekey-list nil @@ -4084,65 +5416,86 @@ reftex-label-mac-list nil) (while tmp (catch 'next-entry - (setq entry (car tmp) - env-or-mac (car entry) - entry (cdr entry) - tmp (cdr tmp)) - (if (null env-or-mac) - (setq env-or-mac "")) - (if (stringp (car entry)) - ;; This is before version 2.00 - convert entry to new format - ;; This is just to keep old users happy - (setq entry (cons (string-to-char (car entry)) - (cons (concat (car entry) ":") - (cdr entry))))) - (setq typekeychar (nth 0 entry) - typekey (char-to-string typekeychar) - prefix (nth 1 entry) - fmt (nth 2 entry) - regexp (nth 3 entry) - wordlist (nth 4 entry)) - (if (stringp wordlist) - ;; This is before version 2.04 - convert to new format - (setq wordlist (nthcdr 4 entry))) - (if typekey - (add-to-list 'reftex-typekey-list typekey)) - (if (and typekey prefix) - (add-to-list 'reftex-typekey-to-prefix-alist (cons typekey prefix))) - (cond - ((string-match "\\`\\\\" env-or-mac) - ;; It's a macro - (add-to-list 'reftex-label-mac-list env-or-mac)) - (t - (or (string= env-or-mac "any") - (string= env-or-mac "") - (add-to-list 'reftex-label-env-list env-or-mac)))) - (and fmt - (not (assoc typekey reftex-typekey-to-format-alist)) - (setq reftex-typekey-to-format-alist - (cons (cons typekey fmt) - reftex-typekey-to-format-alist))) - (and (not (string= env-or-mac "any")) - (not (string= env-or-mac "")) - (not (assoc env-or-mac reftex-env-or-mac-alist)) - (setq reftex-env-or-mac-alist - (cons (list env-or-mac typekey regexp) - reftex-env-or-mac-alist))) - (while (and wordlist (stringp (car wordlist))) - (or (assoc (car wordlist) reftex-words-to-typekey-alist) - (setq reftex-words-to-typekey-alist - (cons (cons (downcase (car wordlist)) typekey) - reftex-words-to-typekey-alist))) - (setq wordlist (cdr wordlist))) - (cond - ((string= "" env-or-mac) nil) - ((assoc typekey qh-list) - (setcdr (assoc typekey qh-list) - (concat (cdr (assoc typekey qh-list)) " " env-or-mac))) - (t - (setq qh-list (cons (cons typekey env-or-mac) qh-list)))))) - - (setq qh-list (nreverse qh-list)) + (setq entry (car tmp) + env-or-mac (car entry) + entry (cdr entry) + tmp (cdr tmp)) + (if (null env-or-mac) + (setq env-or-mac "")) + (if (stringp (car entry)) + ;; This is before version 2.00 - convert entry to new format + ;; This is just to keep old users happy + (setq entry (cons (string-to-char (car entry)) + (cons (concat (car entry) ":") + (cdr entry))))) + (setq typekeychar (nth 0 entry) + typekey (char-to-string typekeychar) + prefix (nth 1 entry) + fmt (nth 2 entry) + context (nth 3 entry) + wordlist (nth 4 entry)) + (if (stringp wordlist) + ;; This is before version 2.04 - convert to new format + (setq wordlist (nthcdr 4 entry))) + + (if (and (stringp fmt) + (string-match "@" fmt)) + ;; special syntax for specifying a label format + (setq fmt (split-string fmt "@+")) + (setq fmt (list "\\label{%s}" fmt))) + (setq labelfmt (car fmt) + reffmt (nth 1 fmt)) + (if typekey + (add-to-list 'reftex-typekey-list typekey)) + (if (and typekey prefix + (not (assoc typekey reftex-typekey-to-prefix-alist))) + (add-to-list 'reftex-typekey-to-prefix-alist + (cons typekey prefix))) + (cond + ((string-match "\\`\\\\" env-or-mac) + ;; It's a macro + (let ((result (reftex-parse-args env-or-mac))) + (setq env-or-mac (or (first result) env-or-mac) + nargs (second result) + nlabel (third result) + opt-args (fourth result)) + (if nlabel (add-to-list 'macros-with-labels env-or-mac))) + (add-to-list 'reftex-label-mac-list env-or-mac)) + (t + (setq nargs nil nlabel nil opt-args nil) + (cond ((string= env-or-mac "any")) + ((string= env-or-mac "")) + ((string= env-or-mac "section")) + (t + (add-to-list 'reftex-label-env-list env-or-mac) + ;; Translate some special context cases + (when (assq context reftex-default-context-regexps) + (setq context + (format + (cdr (assq context reftex-default-context-regexps)) + (regexp-quote env-or-mac)))))))) + (and reffmt + (not (assoc typekey reftex-typekey-to-format-alist)) + (push (cons typekey reffmt) reftex-typekey-to-format-alist)) + (and (not (string= env-or-mac "any")) + (not (string= env-or-mac "")) + (not (assoc env-or-mac reftex-env-or-mac-alist)) + (push (list env-or-mac typekey context labelfmt + nargs nlabel opt-args) + reftex-env-or-mac-alist)) + (while (and (setq word (pop wordlist)) + (stringp word)) + (setq word (downcase word)) + (or (assoc word reftex-words-to-typekey-alist) + (push (cons word typekey) reftex-words-to-typekey-alist))) + (cond + ((string= "" env-or-mac) nil) + ((setq cell (assoc typekey qh-list)) + (push env-or-mac (cdr cell))) + (t + (push (list typekey env-or-mac) qh-list))))) + + (setq qh-list (sort qh-list '(lambda (x1 x2) (string< (car x1) (car x2))))) (setq reftex-typekey-to-prefix-alist (nreverse reftex-typekey-to-prefix-alist)) (setq reftex-type-query-prompt @@ -4153,14 +5506,51 @@ " (?=Help)")) (setq reftex-type-query-help (concat "SELECT A LABEL TYPE:\n--------------------\n" - (mapconcat '(lambda(x) - (format " [%s] %s" - (car x) (cdr x))) - qh-list "\n"))))) + (mapconcat + '(lambda(x) + (setq sum 0) + (format " [%s] %s" + (car x) + (mapconcat + '(lambda(x) + (setq sum (+ sum (length x))) + (if (< sum 60) + x + (setq sum 0) + (concat "\n " x))) + (cdr x) " "))) + qh-list "\n"))) + + ;; Calculate the regular expressions + (let ((label-re "\\\\label{\\([^}]*\\)}") + (include-re "\\(\\`\\|[\n\r]\\)[ \t]*\\\\\\(include\\|input\\)[{ \t]+\\([^} \t\n\r]+\\)") + (section-re + (concat "\\(\\`\\|[\n\r]\\)[ \t]*\\\\\\(" + (mapconcat 'car reftex-section-levels "\\|") + "\\)\\*?\\(\\[[^]]*\\]\\)?{")) + (macro-re + (if macros-with-labels + (concat "\\(" + (mapconcat 'regexp-quote macros-with-labels "\\|") + "\\)[[{]") + "")) + (find-label-re-format + (concat "\\(" + (mapconcat 'regexp-quote (append '("\\label") + macros-with-labels) "\\|") + "\\)\\([[{][^]}]*[]}]\\)*[[{]\\(%s\\)[]}]"))) + (setq reftex-section-regexp section-re + reftex-section-or-include-regexp + (concat section-re "\\|" include-re) + reftex-everything-regexp + (concat label-re "\\|" section-re "\\|" include-re + (if macros-with-labels "\\|" "") macro-re) + reftex-find-label-regexp-format find-label-re-format + reftex-find-label-regexp-format2 + "\\([]} \t\n\r]\\)\\([[{]\\)\\(%s\\)[]}]")))) ;;; Keybindings -------------------------------------------------------------- -(define-key reftex-mode-map "\C-c-" 'reftex-item) (define-key reftex-mode-map "\C-c=" 'reftex-toc) (define-key reftex-mode-map "\C-c(" 'reftex-label) (define-key reftex-mode-map "\C-c)" 'reftex-reference) @@ -4184,30 +5574,72 @@ (require 'easymenu) -(easy-menu-define +(easy-menu-define reftex-mode-menu reftex-mode-map "Menu used in RefTeX mode" - '("Ref" - ["Table of Contents" reftex-toc t] + `("Ref" + ["Table of Contents" reftex-toc t] "----" - ["\\label" reftex-label t] - ["\\ref" reftex-reference t] - ["\\cite" reftex-citation t] - ["View crossref" reftex-view-crossref t] + ["\\label" reftex-label t] + ["\\ref" reftex-reference t] + ["\\cite" reftex-citation t] + ["View Crossref" reftex-view-crossref t] "----" - ("Search and Replace" - ["Search whole document" reftex-search-document t] - ["Replace in document" reftex-query-replace-document t] - ["Grep on document" reftex-grep-document t] + ("Parse Document" + ["Only this File" reftex-parse-one t] + ["Entire Document" reftex-parse-all (reftex-is-multi)] + ["Save to File" (reftex-access-parse-file 'write) + (> (length (symbol-value reftex-docstruct-symbol)) 0)] + ["Restore from File" (reftex-access-parse-file 'restore) + (reftex-access-parse-file 'readable)] + "----" + ["Enable Partial Scans" + (setq reftex-enable-partial-scans (not reftex-enable-partial-scans)) + :style toggle :selected reftex-enable-partial-scans] + ["Auto-Save Parse Info" + (setq reftex-save-parse-info (not reftex-save-parse-info)) + :style toggle :selected reftex-save-parse-info] + "---" + ["Reset RefTeX Mode" reftex-reset-mode t]) + ("Multifile" + ["Search Whole Document" reftex-search-document t] + ["Replace in Document" reftex-query-replace-document t] + ["Grep on Document" reftex-grep-document t] + "----" + ["Create TAGS File" reftex-create-tags-file t] "----" - ["Find duplicate labels" reftex-find-duplicate-labels t] - ["Change label and refs" reftex-change-label t] + ["Find Duplicate Labels" reftex-find-duplicate-labels t] + ["Change Label and Refs" reftex-change-label t]) + ("Citation Options" + "Citation Style" + ,@(mapcar + (function + (lambda (x) + (vector + (symbol-name (car x)) + (list 'setq 'reftex-cite-format (list 'quote (car x))) + :style 'radio :selected + (list 'eq 'reftex-cite-format (list 'quote (car x)))))) + reftex-cite-format-builtin) "----" - ["Create TAGS file" reftex-create-tags-file t]) + "Bibinfo in Comments" + ["Attach Comments" + (setq reftex-comment-citations (not reftex-comment-citations)) + :style toggle :selected reftex-comment-citations] + "---" + "Sort Database Matches" + ["by Author" (setq reftex-sort-bibtex-matches 'author) + :style radio :selected (eq reftex-sort-bibtex-matches 'author)] + ["by Year" (setq reftex-sort-bibtex-matches 'year) + :style radio :selected (eq reftex-sort-bibtex-matches 'year)] + ["by Year, reversed" (setq reftex-sort-bibtex-matches 'reverse-year) + :style radio :selected (eq reftex-sort-bibtex-matches 'reverse-year)] + ["Not" (setq reftex-sort-bibtex-matches nil) + :style radio :selected (eq reftex-sort-bibtex-matches nil)]) "----" - ["Parse document" reftex-parse-document t] - ["Reset RefTeX Mode" reftex-reset-mode t] - ["Customize RefTeX" reftex-customize t])) + ["Customize RefTeX" reftex-customize t] + "----" + ["Show Documentation" reftex-show-commentary t])) ;;; Run Hook ------------------------------------------------------------------ @@ -4215,14 +5647,15 @@ ;;; That's it! ---------------------------------------------------------------- +(provide 'reftex) + ; Make sure tabels are compiled (message "updating internal tables...") (reftex-compute-ref-cite-tables) (message "updating internal tables...done") (setq reftex-tables-dirty nil) -(provide 'reftex) - ;;;============================================================================ -;;; reftex.el end here +;;; reftex.el ends here +
--- a/lisp/mu/latex-math-symbol.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -;;; latex-math-symbol.el --- LaTeX math symbol decoder - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/7/1 -;; Version: -;; $Id: latex-math-symbol.el,v 1.3 1997/01/30 02:22:35 steve Exp $ -;; Keywords: LaTeX, math, mule - -;; This file is part of MU (Message Utilities). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to install -;; bytecompile this file and copy it to the apropriate directory. -;; - How to use -;; If you use tm, please put following to your ~/.emacs: -;; (autoload 'latex-math-decode-buffer "latex-math-symbol" nil t) -;; (add-hook 'mime-viewer/plain-text-preview-hook -;; 'latex-math-decode-buffer) -;; Of course, it may be available for other hooks to filter messages. - -;;; Code: - -(defvar latex-math-symbol-table-alist - '(("\\alpha" . ",Fa(B") - ("\\beta" . ",Fb(B") - ("\\gamma" . ",Fc(B")("\\Gamma" . "$B&#(B") - ("\\delta" . ",Fd(B")("\\Delta" . "$B&$(B") - ("\\epsilon" . ",Fe(B")("\\varepsilon" . "$B&E(B") - ("\\zeta" . ",Ff(B") - ("\\eta" . ",Fg(B") - ("\\theta" . ",Fh(B")("\\Theta" . "$B&((B") - ("\\iota" . ",Fi(B") - ("\\kappa" . ",Fj(B") - ("\\lambda" . ",Fk(B")("\\Lambda" . "$B&+(B") - ("\\mu" . ",Fl(B") - ("\\nu" . ",Fm(B") - ("\\xi" . ",Fn(B")("\\Xi" . "$B&.(B") - ("\\pi" . ",Fp(B")("\\Pi" . "$B&0(B") - ("\\rho" . ",Fq(B") - ("\\sigma" . ",Fs(B")("\\Sigma" . "$B&2(B") - ("\\varsigma" . ",Fr(B") - ("\\tau" . ",Ft(B") - ("\\upsilon" . ",Fu(B")("\\Upsilon" . "$B&4(B") - ("\\phi" . "$B&U(B")("\\Phi" . "$B&5(B") - ("\\varphi" . ",Fv(B") - ("\\chi" . ",Fw(B") - ("\\psi" . ",Fx(B")("\\Psi" . "$B&7(B") - ("\\omega" . ",Fy(B")("\\Omega" . "$B&8(B") - - ("\\{" . "$B!P(B")("\\}" . "$B!Q(B") - ("\\langle\\!\\langle" . "$B!T(B")("\\rangle\\!\\rangle" . "$B!U(B") - ("\\langle" . "$B!R(B")("\\rangle" . "$B!S(B") - - ("\\cdots" . "$B!D(B") - - ("\\ln" . "$(G"L(B") - ("\\log" . "$(G"K(B") - - ("\\pm" . "$B!^(B") - ("\\cdot" . "$B!&(B") - ("\\times" . "$B!_(B")("\\ast" . "$B!v(B") - ("\\star" . "$B!z(B") - ("\\bullet" . "$B!&(B") - ("\\div" . "$B!`(B") - ("\\cap" . "$B"A(B")("\\cup" . "$B"@(B") - ("\\lhd" . "$(C"7(B")("\\rhd" . "$(C"9(B") - ("\\bigcirc" . "$B"~(B") - ("\\vee" . "$B"K(B")("\\lor" . "$B"K(B") - ("\\wedge" . "$B"J(B")("\\land" . "$B"J(B") - ("\\oplus" . "$(G"S(B") - ("\\odot" . "$(G"T(B") - ("\\dagger" . "$B"w(B")("\\ddagger" . "$B"x(B") - - ("\\leq" . "$(C!B(B")("\\geq" . "$(C!C(B") - ("\\le" . "$(C!B(B")("\\ge" . "$(C!C(B") - ("\\ll" . "$B"c(B")("\\gg" . "$B"d(B") - ("\\subseteq" . "$B"<(B")("\\supseteq" . "$B"=(B") - ("\\subset" . "$B">(B")("\\supset" . "$B"?(B") - ("\\in" . "$B":(B") - ("\\ni" . "$B";(B")("\\owns" . "$B";(B") - ("\\frown" . "$B"^(B") - ("\\mid" . "$B!C(B")("\\parallel" . "$B!B(B") - ("\\sim" . "$B!A(B") - ("\\equiv" . "$B"a(B") - ("\\approx" . "$A!V(B") - ("\\not=" . "$B!b(B") - ("\\neq" . "$B!b(B")("\\ne" . "$B!b(B") - ("\\perp" . "$B"](B") - - ("\\triangleup" . "$B"$(B") - ("\\forall" . "$B"O(B") - - ("\\hbar" . ",C1(B")("\\imath" . ",C9(B") - ("\\ell" . "$(C'$(B") - ("\\partial" . "$B"_(B") - ("\\infty" . "$B!g(B") - ("\\smallint" . "$B"i(B") - ("\\P" . "$B"y(B") - ("\\prime" . "$B!l(B") - ("\\nabla" . "$B"`(B") - ("\\top" . "$(D0#(B")("\\bot" . "$(D0"(B") - ("\\vert" . "$B!C(B")("\\Vert" . "$B!B(B") - ("\\angle" . "$B"\(B") - ("\\triangle" . "$B"$(B") - ("\\backslash" . "$B!@(B") - ("\\S" . "$B!x(B") - ("\\forall" . "$B"O(B") - ("\\exists" . "$B"P(B") - ("\\neg" . "$B"L(B")("\\lnot" . "$B"L(B") - ("\\flat" . "$B"u(B")("\\sharp" . "$B"t(B") - ("\\clubsuit" . "$(C"@(B") - ("\\diamondsuit" . "$B!~(B") - ("\\heartsuit" . "$(C"=(B") - ("\\spadesuit" . "$(C"<(B") - - ("\\leftarrow" . "$B"+(B")("\\rightarrow" . "$B"*(B") - ("\\gets" . "$B"+(B")("\\to" . "$B"*(B") - - ("^1" . ",A9(B")("^{1}" . ",A9(B") - ("^2" . ",A2(B")("^{2}" . ",A2(B") - ("^3" . ",A3(B")("^{3}" . ",A3(B") - ("^4" . "$(C)y(B")("^{4}" . "$(C)y(B") - ("^n" . "$(C)z(B")("^{n}" . "$(C)z(B") - ("_1" . "$(C){(B")("_{1}" . "$(C){(B") - ("_2" . "$(C)|(B")("_{2}" . "$(C)|(B") - ("_3" . "$(C)}(B")("_{3}" . "$(C)}(B") - ("_4" . "$(C)~(B")("_{4}" . "$(C)~(B") - )) - -(defun latex-math-decode-region (beg end) - (interactive "r") - (save-restriction - (narrow-to-region beg end) - (let ((rest latex-math-symbol-table-alist) - (case-fold-search nil) - cell) - (while rest - (setq cell (car rest)) - (goto-char beg) - (while (re-search-forward - (concat "\\(" - (regexp-quote (car cell)) - "\\)\\([^a-zA-Z]\\|$\\)") - nil t) - (delete-region (match-beginning 1)(match-end 1)) - (goto-char (match-beginning 0)) - (insert (cdr cell)) - ) - (setq rest (cdr rest)) - )))) - -(defun latex-math-decode-buffer () - (interactive) - (latex-math-decode-region (point-min)(point-max)) - ) - - -;;; @ end -;;; - -(provide 'latex-math-symbol) - -;;; latex-math-symbol.el ends here
--- a/lisp/mu/mu-bbdb.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -;;; mu-bbdb.el --- `attribution' function for mu-cite with BBDB. - -;; Copyright (C) 1996 Shuhei KOBAYASHI - -;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Version: $Id: mu-bbdb.el,v 1.1.1.2 1996/12/21 20:50:53 steve Exp $ - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to use -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; (require 'tl-misc) -;; (call-after-loaded 'mu-cite -;; (function -;; (lambda () -;; (require 'mu-bbdb) -;; ))) - - -;;; Code: - -(require 'mu-cite) -(if (module-installed-p 'bbdb) - (require 'bbdb)) - -(defvar mu-bbdb-load-hook nil - "*List of functions called after mu-bbdb is loaded.") - -;;; @@ prefix and registration using BBDB -;;; - -(defun mu-cite/get-bbdb-prefix-method () - (or (mu-cite/get-bbdb-attr (mu-cite/get-value 'address)) - ">") - ) - -(defun mu-cite/get-bbdb-attr (addr) - "Extract attribute information from BBDB." - (let ((record (bbdb-search-simple nil addr))) - (and record - (bbdb-record-getprop record 'attribution)) - )) - -(defun mu-cite/set-bbdb-attr (attr addr) - "Add attribute information to BBDB." - (let* ((bbdb-notice-hook nil) - (record (bbdb-annotate-message-sender - addr t - (bbdb-invoke-hook-for-value - bbdb/mail-auto-create-p) - t))) - (if record - (progn - (bbdb-record-putprop record 'attribution attr) - (bbdb-change-record record nil)) - ))) - -(defun mu-cite/get-bbdb-prefix-register-method () - (let ((addr (mu-cite/get-value 'address))) - (or (mu-cite/get-bbdb-attr addr) - (let ((return - (read-string "Citation name? " - (or (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history) - )) - (if (and (not (string-equal return "")) - (y-or-n-p (format "Register \"%s\"? " return))) - (mu-cite/set-bbdb-attr return addr) - ) - return)))) - -(defun mu-cite/get-bbdb-prefix-register-verbose-method () - (let* ((addr (mu-cite/get-value 'address)) - (attr (mu-cite/get-bbdb-attr addr)) - (return (read-string "Citation name? " - (or attr - (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history)) - ) - (if (and (not (string-equal return "")) - (not (string-equal return attr)) - (y-or-n-p (format "Register \"%s\"? " return)) - ) - (mu-cite/set-bbdb-attr return addr) - ) - return)) - -(or (assoc 'bbdb-prefix mu-cite/default-methods-alist) - (setq mu-cite/default-methods-alist - (append mu-cite/default-methods-alist - (list - (cons 'bbdb-prefix - (function mu-cite/get-bbdb-prefix-method)) - (cons 'bbdb-prefix-register - (function mu-cite/get-bbdb-prefix-register-method)) - (cons 'bbdb-prefix-register-verbose - (function - mu-cite/get-bbdb-prefix-register-verbose-method)) - )))) - - -;;; @ end -;;; - -(provide 'mu-bbdb) - -(run-hooks 'mu-bbdb-load-hook) - -;;; mu-bbdb.el ends here
--- a/lisp/mu/mu-cite.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,536 +0,0 @@ -;;; mu-cite.el --- yet another citation tool for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; MINOURA Makoto <minoura@netlaputa.or.jp> -;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Version: $Revision: 1.6 $ -;; Keywords: mail, news, citation - -;; This file is part of MU (Message Utilities). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to use -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; for EMACS 19 or later and XEmacs -;; (autoload 'mu-cite/cite-original "mu-cite" nil t) -;; ;; for all but message-mode -;; (add-hook 'mail-citation-hook 'mu-cite/cite-original) -;; ;; for message-mode only -;; (setq message-cite-function (function mu-cite/cite-original)) -;; for EMACS 18 -;; ;; for all but mh-e -;; (add-hook 'mail-yank-hooks (function mu-cite/cite-original)) -;; ;; for mh-e only -;; (add-hook 'mh-yank-hooks (function mu-cite/cite-original)) - -;;; Code: - -(require 'std11) -(require 'tl-str) -(require 'tl-list) - - -;;; @ version -;;; - -(defconst mu-cite/RCS-ID - "$Id: mu-cite.el,v 1.6 1997/03/22 06:02:28 steve Exp $") -(defconst mu-cite/version (get-version-string mu-cite/RCS-ID)) - - -;;; @ formats -;;; - -(defvar mu-cite/cited-prefix-regexp "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)" - "*Regexp to match the citation prefix. -If match, mu-cite doesn't insert citation prefix.") - -(defvar mu-cite/prefix-format '(prefix-register-verbose "> ") - "*List to represent citation prefix. -Each elements must be string or method name.") - -(defvar mu-cite/top-format '(in-id - ">>>>> " from " wrote:\n") - "*List to represent top string of citation. -Each elements must be string or method name.") - - -;;; @ hooks -;;; - -(defvar mu-cite-load-hook nil - "*List of functions called after mu-cite is loaded. -Use this hook to add your own methods to `mu-cite/default-methods-alist'.") - -(defvar mu-cite/instantiation-hook nil - "*List of functions called just before narrowing to the message.") - -(defvar mu-cite/pre-cite-hook nil - "*List of functions called before citing a region of text.") - -(defvar mu-cite/post-cite-hook nil - "*List of functions called after citing a region of text.") - - -;;; @ field -;;; - -(defvar mu-cite/get-field-value-method-alist nil - "Alist major-mode vs. function to get field-body of header.") - -(defun mu-cite/get-field-value (name) - (or (std11-field-body name) - (let ((method (assq major-mode mu-cite/get-field-value-method-alist))) - (if method - (funcall (cdr method) name) - )))) - - -;;; @ prefix registration -;;; - -(defvar mu-cite/registration-file (expand-file-name "~/.mu-cite.el") - "*The name of the user environment file for mu-cite.") - -(defvar mu-cite/allow-null-string-registration nil - "*If non-nil, null-string citation-name is registered.") - -(defvar mu-cite/registration-symbol 'mu-cite/citation-name-alist) - -(defvar mu-cite/citation-name-alist nil) -(or (eq 'mu-cite/citation-name-alist mu-cite/registration-symbol) - (setq mu-cite/citation-name-alist - (symbol-value mu-cite/registration-symbol)) - ) -(defvar mu-cite/minibuffer-history nil) - -;; get citation-name from the database -(defun mu-cite/get-citation-name (from) - (assoc-value from mu-cite/citation-name-alist) - ) - -;; register citation-name to the database -(defun mu-cite/add-citation-name (name from) - (setq mu-cite/citation-name-alist - (put-alist from name mu-cite/citation-name-alist)) - (mu-cite/save-registration-file) - ) - -;; load/save registration file -(defun mu-cite/load-registration-file () - (let* ((file mu-cite/registration-file) - (buffer (get-buffer-create " *mu-register*"))) - (if (file-readable-p file) - (unwind-protect - (save-excursion - (set-buffer buffer) - (erase-buffer) - (insert-file-contents file) - ;; (eval-buffer) - (eval-current-buffer)) - (kill-buffer buffer)) - ))) -(add-hook 'mu-cite-load-hook (function mu-cite/load-registration-file)) - -(defun mu-cite/save-registration-file () - (let* ((file mu-cite/registration-file) - (buffer (get-buffer-create " *mu-register*"))) - (unwind-protect - (save-excursion - (set-buffer buffer) - (setq buffer-file-name file) - (erase-buffer) - (insert ";;; " (file-name-nondirectory file) "\n") - (insert ";;; This file is generated automatically by mu-cite " - mu-cite/version "\n\n") - (insert "(setq " - (symbol-name mu-cite/registration-symbol) - "\n '(") - (insert (mapconcat - (function prin1-to-string) - mu-cite/citation-name-alist "\n ")) - (insert "\n ))\n\n") - (insert ";;; " - (file-name-nondirectory file) - " ends here.\n") - (save-buffer)) - (kill-buffer buffer)))) - - -;;; @ item methods -;;; - -;;; @@ ML count -;;; - -(defvar mu-cite/ml-count-field-list - '("X-Ml-Count" "X-Mail-Count" "X-Seqno" "X-Sequence" "Mailinglist-Id") - "*List of header fields which contain sequence number of mailing list.") - -(defun mu-cite/get-ml-count-method () - (let ((field-list mu-cite/ml-count-field-list)) - (catch 'tag - (while field-list - (let* ((field (car field-list)) - (ml-count (mu-cite/get-field-value field))) - (if (and ml-count (string-match "[0-9]+" ml-count)) - (throw 'tag - (substring ml-count - (match-beginning 0)(match-end 0)) - )) - (setq field-list (cdr field-list)) - ))))) - - -;;; @@ prefix and registration -;;; - -(defun mu-cite/get-prefix-method () - (or (mu-cite/get-citation-name (mu-cite/get-value 'address)) - ">") - ) - -(defun mu-cite/get-prefix-register-method () - (let ((addr (mu-cite/get-value 'address))) - (or (mu-cite/get-citation-name addr) - (let ((return - (read-string "Citation name? " - (or (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history) - )) - (if (and (or mu-cite/allow-null-string-registration - (not (string-equal return ""))) - (y-or-n-p (format "Register \"%s\"? " return))) - (mu-cite/add-citation-name return addr) - ) - return)))) - -(defun mu-cite/get-prefix-register-verbose-method () - (let* ((addr (mu-cite/get-value 'address)) - (return1 (mu-cite/get-citation-name addr)) - (return (read-string "Citation name? " - (or return1 - (mu-cite/get-value 'x-attribution) - (mu-cite/get-value 'full-name)) - 'mu-cite/minibuffer-history)) - ) - (if (and (or mu-cite/allow-null-string-registration - (not (string-equal return ""))) - (not (string-equal return return1)) - (y-or-n-p (format "Register \"%s\"? " return)) - ) - (mu-cite/add-citation-name return addr) - ) - return)) - - -;;; @@ set up -;;; - -(defvar mu-cite/default-methods-alist - (list (cons 'from - (function - (lambda () - (mu-cite/get-field-value "From") - ))) - (cons 'date - (function - (lambda () - (mu-cite/get-field-value "Date") - ))) - (cons 'message-id - (function - (lambda () - (mu-cite/get-field-value "Message-Id") - ))) - (cons 'subject - (function - (lambda () - (mu-cite/get-field-value "Subject") - ))) - (cons 'ml-name - (function - (lambda () - (mu-cite/get-field-value "X-Ml-Name") - ))) - (cons 'ml-count (function mu-cite/get-ml-count-method)) - (cons 'address-structure - (function - (lambda () - (car - (std11-parse-address-string (mu-cite/get-value 'from)) - )))) - (cons 'full-name - (function - (lambda () - (std11-full-name-string - (mu-cite/get-value 'address-structure)) - ))) - (cons 'address - (function - (lambda () - (std11-address-string - (mu-cite/get-value 'address-structure)) - ))) - (cons 'id - (function - (lambda () - (let ((ml-name (mu-cite/get-value 'ml-name))) - (if ml-name - (concat "[" - ml-name - " : No." - (mu-cite/get-value 'ml-count) - "]") - (mu-cite/get-value 'message-id) - ))))) - (cons 'in-id - (function - (lambda () - (let ((id (mu-cite/get-value 'id))) - (if id - (format ">>>>> In %s \n" id) - ""))))) - (cons 'prefix (function mu-cite/get-prefix-method)) - (cons 'prefix-register - (function mu-cite/get-prefix-register-method)) - (cons 'prefix-register-verbose - (function mu-cite/get-prefix-register-verbose-method)) - (cons 'x-attribution - (function - (lambda () - (mu-cite/get-field-value "X-Attribution") - ))) - )) - - -;;; @ fundamentals -;;; - -(defvar mu-cite/methods-alist nil) - -(defun mu-cite/make-methods () - (setq mu-cite/methods-alist - (copy-alist mu-cite/default-methods-alist)) - (run-hooks 'mu-cite/instantiation-hook) - ) - -(defun mu-cite/get-value (item) - (let ((ret (assoc-value item mu-cite/methods-alist))) - (if (functionp ret) - (prog1 - (setq ret (funcall ret)) - (set-alist 'mu-cite/methods-alist item ret) - ) - ret))) - -(defun mu-cite/eval-format (list) - (mapconcat (function - (lambda (elt) - (cond ((stringp elt) elt) - ((symbolp elt) (mu-cite/get-value elt)) - ))) - list "") - ) - - -;;; @ main function -;;; - -(defun mu-cite/cite-original () - "Citing filter function. -This is callable from the various mail and news readers' reply -function according to the agreed upon standard." - (interactive) - (mu-cite/make-methods) - (save-restriction - (if (< (mark t) (point)) - (exchange-point-and-mark)) - (narrow-to-region (point)(point-max)) - (run-hooks 'mu-cite/pre-cite-hook) - (let ((last-point (point)) - (top (mu-cite/eval-format mu-cite/top-format)) - (prefix (mu-cite/eval-format mu-cite/prefix-format)) - ) - (if (re-search-forward "^-*$" nil nil) - (forward-line 1) - ) - (widen) - (delete-region last-point (point)) - (insert top) - (setq last-point (point)) - (while (< (point)(mark t)) - (or (looking-at mu-cite/cited-prefix-regexp) - (insert prefix)) - (forward-line 1)) - (goto-char last-point) - ) - (run-hooks 'mu-cite/post-cite-hook) - )) - - -;;; @ message editing utilities -;;; - -(defvar citation-mark-chars ">}|" - "*String of characters for citation delimiter. [mu-cite.el]") - -(defvar citation-disable-chars "<{" - "*String of characters not allowed as citation-prefix.") - -(defun detect-paragraph-cited-prefix () - (save-excursion - (goto-char (point-min)) - (let ((i 0) - (prefix - (buffer-substring - (progn (beginning-of-line)(point)) - (progn (end-of-line)(point)) - )) - str ret) - (while (and (= (forward-line) 0) - (setq str (buffer-substring - (progn (beginning-of-line)(point)) - (progn (end-of-line)(point)))) - (setq ret (string-compare-from-top prefix str)) - ) - (setq prefix - (if (stringp ret) - ret - (second ret))) - (setq i (1+ i)) - ) - (cond ((> i 1) prefix) - ((> i 0) - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point) - (+ (point)(length prefix))) - (goto-char (point-max)) - (if (re-search-backward - (concat "[" citation-mark-chars "]") nil t) - (progn - (goto-char (match-end 0)) - (if (looking-at "[ \t]+") - (goto-char (match-end 0)) - ) - (buffer-substring (point-min)(point)) - ) - prefix))) - ((progn - (goto-char (point-max)) - (re-search-backward - (concat "[" citation-disable-chars "]") nil t) - (re-search-backward - (concat "[" citation-mark-chars "]") nil t) - ) - (goto-char (match-end 0)) - (if (looking-at "[ \t]+") - (goto-char (match-end 0)) - ) - (buffer-substring (point-min)(point)) - ) - (t "")) - ))) - -(defun fill-cited-region (beg end) - (interactive "*r") - (save-excursion - (save-restriction - (goto-char end) - (and (search-backward "\n" nil t) - (setq end (match-end 0)) - ) - (narrow-to-region beg end) - (let* ((fill-prefix (detect-paragraph-cited-prefix)) - (pat (concat fill-prefix "\n")) - ) - (goto-char (point-min)) - (while (search-forward pat nil t) - (let ((b (match-beginning 0)) - (e (match-end 0)) - ) - (delete-region b e) - (if (and (> b (point-min)) - (let ((cat (char-category - (char-before b)))) - (or (string-match "a" cat) - (string-match "l" cat) - )) - ) - (insert " ") - )) - ) - (goto-char (point-min)) - (fill-region (point-min) (point-max)) - )))) - -(defun compress-cited-prefix () - (interactive) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") nil t) - (while (re-search-forward - (concat "^\\([ \t]*[^ \t\n" citation-mark-chars "]*[" - citation-mark-chars "]\\)+") nil t) - (let* ((b (match-beginning 0)) - (e (match-end 0)) - (prefix (buffer-substring b e)) - ps pe (s 0) - (nest (let ((i 0)) - (if (string-match "<[^<>]+>" prefix) - (setq prefix (substring prefix 0 (match-beginning 0))) - ) - (while (string-match - (concat "\\([" citation-mark-chars "]+\\)[ \t]*") - prefix s) - (setq i (+ i (- (match-end 1)(match-beginning 1))) - ps s - pe (match-beginning 1) - s (match-end 0) - )) - i))) - (if (and ps (< ps pe)) - (progn - (delete-region b e) - (insert (concat (substring prefix ps pe) (make-string nest ?>))) - )))))) - -(defun replace-top-string (old new) - (interactive "*sOld string: \nsNew string: ") - (while (re-search-forward - (concat "^" (regexp-quote old)) nil t) - (replace-match new) - )) - - -;;; @ end -;;; - -(provide 'mu-cite) - -(run-hooks 'mu-cite-load-hook) - -;;; mu-cite.el ends here
--- a/lisp/mule/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -37,14 +37,11 @@ ;;;*** -;;;### (autoloads (dump-coding-systems dump-charsets mule-diag list-fontset describe-fontset list-font describe-font list-coding-system list-coding-system-briefly describe-coding-system list-charsets) "mule-debug" "mule/mule-debug.el") +;;;### (autoloads (dump-coding-systems dump-charsets mule-diag list-fontset describe-fontset list-font describe-font list-coding-system list-coding-system-briefly list-charsets) "mule-debug" "mule/mule-debug.el") (autoload 'list-charsets "mule-debug" "\ Display a list of existing character sets." t nil) -(autoload 'describe-coding-system "mule-debug" "\ -Display documentation of the coding-system CS." t nil) - (autoload 'list-coding-system-briefly "mule-debug" "\ Display coding-systems currently used with a brief format in mini-buffer." t nil) @@ -74,6 +71,105 @@ ;;;*** +;;;### (autoloads (dump-codings dump-charsets mule-diag list-input-methods list-fontsets describe-fontset describe-font list-coding-systems describe-current-coding-system describe-current-coding-system-briefly describe-coding-system list-character-sets) "mule-diag" "mule/mule-diag.el") + +(autoload 'list-character-sets "mule-diag" "\ +Display a list of all character sets. + +The ID column contains a charset identification number for internal use. +The B column contains a number of bytes occupied in a buffer. +The W column contains a number of columns occupied in a screen. + +With prefix arg, the output format gets more cryptic +but contains full information about each character sets." t nil) + +(autoload 'describe-coding-system "mule-diag" "\ +Display information of CODING-SYSTEM." t nil) + +(autoload 'describe-current-coding-system-briefly "mule-diag" "\ +Display coding systems currently used in a brief format in echo area. + +The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\", +where mnemonics of the following coding systems come in this order +at the place of `..': + buffer-file-coding-system (of the current buffer) + eol-type of buffer-file-coding-system (of the current buffer) + (keyboard-coding-system) + eol-type of (keyboard-coding-system) + (terminal-coding-system) + eol-type of (terminal-coding-system) + process-coding-system for read (of the current buffer, if any) + eol-type of process-coding-system for read (of the current buffer, if any) + process-coding-system for write (of the current buffer, if any) + eol-type of process-coding-system for write (of the current buffer, if any) + default-buffer-file-coding-system + eol-type of default-buffer-file-coding-system + default-process-coding-system for read + eol-type of default-process-coding-system for read + default-process-coding-system for write + eol-type of default-process-coding-system" t nil) + +(autoload 'describe-current-coding-system "mule-diag" "\ +Display coding systems currently used in a detailed format." t nil) + +(autoload 'list-coding-systems "mule-diag" "\ +Display a list of all coding systems. +It prints mnemonic letter, name, and description of each coding systems. + +With prefix arg, the output format gets more cryptic, +but contains full information about each coding systems." t nil) + +(autoload 'describe-font "mule-diag" "\ +Display information about fonts which partially match FONTNAME." t nil) + +(autoload 'describe-fontset "mule-diag" "\ +Display information of FONTSET. + +It prints name, size, and style of FONTSET, and lists up fonts +contained in FONTSET. + +The column WDxHT contains width and height (pixels) of each fontset +\(i.e. those of ASCII font in the fontset). The letter `-' in this +column means that the corresponding fontset is not yet used in any +frame. + +The O column of each font contains one of the following letters. + o -- font already opened + - -- font not yet opened + x -- font can't be opened + ? -- no font specified + +The Charset column of each font contains a name of character set +displayed by the font." t nil) + +(autoload 'list-fontsets "mule-diag" "\ +Display a list of all fontsets. + +It prints name, size, and style of each fontset. +With prefix arg, it also lists up fonts contained in each fontset. +See the function `describe-fontset' for the format of the list." t nil) + +(autoload 'list-input-methods "mule-diag" "\ +Print information of all input methods." t nil) + +(autoload 'mule-diag "mule-diag" "\ +Display diagnosis of the multilingual environment (MULE). + +It prints various information related to the current multilingual +environment, including lists of input methods, coding systems, +character sets, and fontsets (if Emacs running under some window +system)." t nil) + +(autoload 'dump-charsets "mule-diag" "\ +Dump information of all charsets into the file \"CHARSETS\". +The file is saved in the directory `data-directory'." nil nil) + +(autoload 'dump-codings "mule-diag" "\ +Dump information of all coding systems into the file \"CODINGS\". +The file is saved in the directory `data-directory'." nil nil) + +;;;*** + ;;;### (autoloads (set-keyboard-coding-system) "mule-keyboard" "mule/mule-keyboard.el") (defvar keyboard-allow-latin-input nil "\ @@ -212,21 +308,5 @@ even if WITH-COMPOSITION-RULE is t." nil nil) ;;;*** - -;;;### (autoloads (vn-decompose-viqr-buffer vn-decompose-viqr vn-compose-viqr-buffer vn-compose-viqr) "mule-vietnamese" "mule/mule-vietnamese.el") - -(autoload 'vn-compose-viqr "mule-vietnamese" "\ -Convert 'VIQR' mnemonics of the current region to -pre-composed Vietnamese characaters." t nil) - -(autoload 'vn-compose-viqr-buffer "mule-vietnamese" nil t nil) - -(autoload 'vn-decompose-viqr "mule-vietnamese" "\ -Convert pre-composed Vietnamese characaters of the current region to -'VIQR' mnemonics." t nil) - -(autoload 'vn-decompose-viqr-buffer "mule-vietnamese" nil t nil) - -;;;*** (provide 'mule-autoloads)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mule/canna-leim.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,53 @@ +;;; canna-leim.el --- Canna-related code for LEIM +;; Copyright (C) 1997 Stephen Turnbull <turnbull@sk.tsukuba.ac.jp> +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Shamelessly ripped off from +;; +;; skk-leim.el --- SKK related code for LEIM +;; Copyright (C) 1997 +;; Murata Shuuichirou <mrt@mickey.ai.kyutech.ac.jp> +;; +;; Author: Stephen Turnbull <turnbull@sk.tsukuba.ac.jp> +;; Version: canna-leim.el,v 1.2 1997/10/27 10:08:49 steve Exp +;; Keywords: japanese, input method, LEIM +;; Last Modified: 1997/10/27 10:08:49 + +;; This program 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 versions 2, or (at your option) +;; any later version. + +;; This program 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. + +;;; TODO +;; +;; Add pointers to Canna documentation in LEIM format + +(defun canna-activate (&optional name) + (if (featurep 'CANNA) + (require 'canna) + (error "Canna is not built into this XEmacs")) + (setq inactivate-current-input-method-function 'canna-inactivate) + (canna) + (canna-toggle-japanese-mode)) + +(defun canna-inactivate () + (cond (canna:*japanese-mode* (canna-toggle-japanese-mode))) ) + +(register-input-method + 'japanese-canna "Japanese" + 'canna-activate nil + "Canna - a kana to kanji conversion program" ) + +(provide 'canna-leim) + +;;; canna-leim.el ends here
--- a/lisp/mule/canna.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/canna.el Mon Aug 13 10:03:52 2007 +0200 @@ -5,7 +5,7 @@ ;; Author: Akira Kon <kon@d1.bs2.mt.nec.co.jp> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Revision: 1.7 $ +;; Version: $Revision: 1.8 $ ;; Keywords: Canna, Japanese, input method, mule, multilingual ;; This file is not a part of Emacs yet. @@ -50,7 +50,7 @@ ;; end (defconst canna-rcs-version - "$Id: canna.el,v 1.7 1997/06/21 20:02:46 steve Exp $") + "$Id: canna.el,v 1.8 1997/10/31 14:52:58 steve Exp $") (defun canna-version () "Display version of canna.el in mini-buffer." @@ -1057,7 +1057,14 @@ (define-key global-map (make-string 1 ch) 'canna-self-insert-command) (setq ch (1+ ch)) )) - (cond ((let ((keys (car init-val)) (ok nil)) + (cond + ;; #### I'm just guessing that this should come before the + ;; init-val setting + ;; if registered with LEIM, no-op + ((featurep 'canna-leim) t) + ;; check to see if an X resource or the like is available in + ;; init-val + ((let ((keys (car init-val)) (ok nil)) (while keys (cond ((< (car keys) 128) (global-set-key @@ -1066,9 +1073,13 @@ (setq ok t) )) (setq keys (cdr keys)) ) ok)) - (t ; $B%G%U%)%k%H$N@_Dj(B - (global-set-key "\C-o" 'canna-toggle-japanese-mode) )) + ;; $B%G%U%)%k%H$N@_Dj(B + ;; Since XEmacs provides canna-leim.el, we should leave this + ;; as is. + (t (global-set-key "\C-o" 'canna-toggle-japanese-mode)) ) + ;; #### should these global bindings be conditional on LEIM? + ;; LEIM doesn't use kanji key yet AFAIK, so leave them. (if (not (keymapp (global-key-binding "\e["))) (global-unset-key "\e[") ) (global-set-key "\e[210z" 'canna-toggle-japanese-mode) ; XFER
--- a/lisp/mule/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,9 +1,8 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:17 1997 ;;; Code: -(custom-put 'mule 'custom-loads '("mule-cmds")) +(custom-add-loads 'mule '("mule-cmds")) ;;; custom-load.el ends here
--- a/lisp/mule/hebrew-hooks.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/hebrew-hooks.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,68 +0,0 @@ -;;; hebrew-hooks.el --- pre-loaded support for Hebrew. - -;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: Mule 2.3. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; HEBREW -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Syntax of Hebrew characters -(loop for c from 96 to 122 - do (modify-syntax-entry (make-char 'hebrew-iso8859-8 c) "w")) -(modify-syntax-entry (make-char 'hebrew-iso8859-8 32) "w") ; no-break space - -(make-coding-system - 'iso-8859-8 'iso2022 - "MIME ISO-8859-8" - '(charset-g0 ascii - charset-g1 hebrew-iso8859-8 - charset-g2 t - charset-g3 t - no-iso6429 t - mnemonic "MIME/Hbrw" -)) - -(make-coding-system - 'ctext-hebrew 'iso2022 - "Coding-system of Hebrew." - '(charset-g0 ascii - charset-g1 hebrew-iso8859-8 - charset-g2 t - charset-g3 t - mnemonic "CText/Hbrw" -)) - -(add-hook 'quail-package-alist '("hebrew" "quail-hebrew")) - -(define-language-environment 'hebrew - "Hebrew" - (lambda () - (set-coding-category-system 'iso-8-designate 'iso-8859-8) - (set-coding-priority-list '(iso-8-designate iso-8-1)) - (set-default-buffer-file-coding-system 'iso-8859-8) - (setq terminal-coding-system 'iso-8859-8) - (setq keyboard-coding-system 'iso-8859-8) - (setq-default quail-current-package - (assoc "hebrew" quail-package-alist)) - ))
--- a/lisp/mule/mule-cmds.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-cmds.el Mon Aug 13 10:03:52 2007 +0200 @@ -29,19 +29,18 @@ (defvar mule-keymap (make-sparse-keymap "MULE") "Keymap for MULE (Multilingual environment) specific commands.") -(fset 'mule-prefix mule-keymap) ;; Keep "C-x C-m ..." for mule specific commands. -(define-key ctl-x-map "\C-m" 'mule-prefix) +(define-key ctl-x-map "\C-m" mule-keymap) (define-key mule-keymap "f" 'set-buffer-file-coding-system) (define-key mule-keymap "F" 'set-default-buffer-file-coding-system) ; XEmacs (define-key mule-keymap "t" 'set-terminal-coding-system) (define-key mule-keymap "k" 'set-keyboard-coding-system) -(define-key mule-keymap "p" 'set-current-process-coding-system) -(define-key mule-keymap "P" 'set-default-process-coding-system) ; XEmacs +(define-key mule-keymap "p" 'set-buffer-process-coding-system) (define-key mule-keymap "\C-\\" 'select-input-method) -(define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs +(define-key mule-keymap "c" 'universal-coding-system-argument) +;;(define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs (define-key mule-keymap "C" 'list-coding-system) ; XEmacs (define-key mule-keymap "r" 'toggle-display-direction) ; XEmacs (define-key mule-keymap "l" 'set-language-environment) @@ -50,7 +49,7 @@ (define-key help-map "L" 'describe-language-environment) (define-key help-map "\C-\\" 'describe-input-method) (define-key help-map "I" 'describe-input-method) -(define-key help-map "C" 'describe-current-coding-system) +(define-key help-map "C" 'describe-coding-system) (define-key help-map "h" 'view-hello-file) ;; Menu for XEmacs were moved to x11/x-menubar.el. @@ -71,13 +70,72 @@ (let ((coding-system-for-read 'iso-2022-7)) (find-file-read-only (expand-file-name "HELLO" data-directory)))) +(defun universal-coding-system-argument () + "Execute an I/O command using the specified coding system." + (interactive) + (let* ((coding-system + (read-coding-system "Coding system for following command: ")) + (keyseq (read-key-sequence + (format "Command to execute with %s:" coding-system))) + (cmd (key-binding keyseq))) + (let ((coding-system-for-read coding-system) + (coding-system-for-write coding-system)) + (message "") + (call-interactively cmd)))) + +(defun set-default-coding-systems (coding-system) + "Set default value of various coding systems to CODING-SYSTEM. +The follwing coding systems are set: + o coding system of a newly created buffer + o default coding system for terminal output + o default coding system for keyboard input + o default coding system for subprocess I/O" + (check-coding-system coding-system) + ;;(setq-default buffer-file-coding-system coding-system) + (set-default-buffer-file-coding-system coding-system) + ;;(setq default-terminal-coding-system coding-system) + (setq terminal-coding-system coding-system) + ;;(setq default-keyboard-coding-system coding-system) + (setq keyboard-coding-system coding-system) + ;;(setq default-process-coding-system (cons coding-system coding-system)) + (add-hook 'comint-exec-hook + (lambda () + (let ((proc (get-buffer-process (current-buffer)))) + (set-process-input-coding-system proc coding-system) + (set-process-output-coding-system proc coding-system) + ))) + (setq file-name-coding-system coding-system) + ) + +(defun prefer-coding-system (coding-system) + "Add CODING-SYSTEM at the front of the priority list for automatic detection. +This also sets the following coding systems to CODING-SYSTEM: + o coding system of a newly created buffer + o default coding system for terminal output + o default coding system for keyboard input + o default coding system for subprocess I/O" + (interactive "zPrefer coding system: ") + (if (not (and coding-system (coding-system-p coding-system))) + (error "Invalid coding system `%s'" coding-system)) + (let ((coding-category (coding-system-category coding-system)) + (parent (coding-system-parent coding-system))) + (if (not coding-category) + ;; CODING-SYSTEM is no-conversion or undecided. + (error "Can't prefer the coding system `%s'" coding-system)) + (set coding-category (or parent coding-system)) + (if (not (eq coding-category (car coding-category-list))) + ;; We must change the order. + (setq coding-category-list + (cons coding-category + (delq coding-category coding-category-list)))) + (if (and parent (interactive-p)) + (message "Highest priority is set to %s (parent of %s)" + parent coding-system)) + (set-default-coding-systems (or parent coding-system)))) + ;;; Language support staffs. -(defvar primary-language "English" - "Name of a user's primary language. -Emacs provide various language supports based on this variable.") - (defvar language-info-alist nil "Alist of language names vs the corresponding information of various kind. Each element looks like: @@ -141,23 +199,43 @@ (setcdr lang-slot (cons key-slot (cdr lang-slot))))) ;; Setup menu. (cond ((eq key 'documentation) - ;; (define-key-after mule-describe-language-support-map + ;; (define-key-after + ;; (if (consp info) + ;; (prog1 (symbol-value (cdr info)) + ;; (setq info (car info))) + ;; describe-language-environment-map) ;; (vector (intern language-name)) - ;; (cons language-name info) + ;; (cons language-name 'describe-specified-language-support) ;; t) + (if (consp info) + (setq info (car info))) (eval-after-load "x-menubar" - `(add-menu-button '("Mule" "Describe Language Support") - (vector ,language-name ',info t))) + `(add-menu-button + '("Mule" "Describe Language Support") + (vector ,language-name + '(describe-language-environment ,language-name) + t))) ) ((eq key 'setup-function) - ;; (define-key-after mule-set-language-environment-map + ;; (define-key-after + ;; (if (consp info) + ;; (prog1 (symbol-value (cdr info)) + ;; (setq info (car info))) + ;; setup-language-environment-map) ;; (vector (intern language-name)) - ;; (cons language-name info) + ;; (cons language-name 'setup-specified-language-environment) ;; t) + (if (consp info) + (setq info (car info))) (eval-after-load "x-menubar" - `(add-menu-button '("Mule" "Set Language Environment") - (vector ,language-name ',info t))) + `(add-menu-button + '("Mule" "Set Language Environment") + (vector ,language-name + '(set-language-environment ,language-name) + t))) )) + + (setcdr key-slot info) )) (defun set-language-info-alist (language-name alist) @@ -178,7 +256,7 @@ (name (completing-read prompt language-info-alist (function (lambda (elm) (assq key elm))) - t nil nil default))) + t nil default))) (if (and (> (length name) 0) (get-language-info name key)) name))) @@ -311,11 +389,8 @@ )) (if (> (length input-method) 0) input-method - ;; If we have a default, use it, otherwise check inhibit-null - (if default - default - (if inhibit-null - (error "No valid input method is specified")))))) + (if inhibit-null + (error "No valid input method is specified"))))) (defun activate-input-method (input-method) "Turn INPUT-METHOD on. @@ -373,8 +448,6 @@ When there's no input method to turn on, turn on what read from minibuffer." (interactive "P") - (if (eq arg 1) - (setq arg nil)) (let* ((default (or (car input-method-history) default-input-method))) (if (and current-input-method (not arg)) (inactivate-input-method) @@ -428,7 +501,9 @@ (if (and input-method (symbolp input-method)) (setq input-method (symbol-name input-method))) (let ((current-input-method input-method)) - (read-string prompt initial-input nil nil t))) + ;; FSFmacs + ;; (read-string prompt initial-input nil nil t))) + (read-string prompt initial-input nil))) ;; Variables to control behavior of input methods. All input methods ;; should react to these variables. @@ -479,80 +554,109 @@ But, if this flag is non-nil, the input method is never back on.") -;;; Language specific setup functions. -;; (defun set-language-environment (language-name) -;; "Setup a user's environment for LANGUAGE-NAME. -;; -;; To setup, a fucntion returned by: -;; (get-language-info LANGUAGE-NAME 'setup-function) -;; is called." -;; (interactive (list (read-language-name 'setup-function "Language: "))) -;; (let (func) -;; (if (or (null language-name) -;; (null (setq func -;; (get-language-info language-name 'setup-function)))) -;; (error "No way to setup environment for the specified language")) -;; (funcall func))) +(defun setup-specified-language-environment () + "Set up multi-lingual environment convenient for the specified language." + (interactive) + (let (language-name) + (if (and (symbolp last-command-event) + (or (not (eq last-command-event 'Default)) + (setq last-command-event 'English)) + (setq language-name (symbol-name last-command-event))) + (set-language-environment language-name) + (error "Bogus calling sequence")))) + +(defvar current-language-environment "English" + "The last language environment specified with `set-language-environment'.") + +(defun set-language-environment (language-name) + "Set up multi-lingual environment for using LANGUAGE-NAME. +This sets the coding system priority and the default input method +and sometimes other things." + (interactive (list (read-language-name 'setup-function + "Set language environment: "))) + (if language-name + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (setq language-name "English")) + (if (null (get-language-info language-name 'setup-function)) + (error "Language environment not defined: %S" language-name)) + (funcall (get-language-info language-name 'setup-function)) + (setq current-language-environment language-name) + (force-mode-line-update t)) ;; Print all arguments with `princ', then print "\n". (defsubst princ-list (&rest args) (while args (princ (car args)) (setq args (cdr args))) (princ "\n")) -(defun describe-language-support (language-name) - "Describe how Emacs supports LANGUAGE-NAME. +;; Print a language specific information such as input methods, +;; charsets, and coding systems. This function is intended to be +;; called from the menu: +;; [menu-bar mule describe-language-environment LANGUAGE] +;; and should not run it by `M-x describe-current-input-method-function'. +(defun describe-specified-language-support () + "Describe how Emacs supports the specified language environment." + (interactive) + (let (language-name) + (if (not (and (symbolp last-command-event) + (setq language-name (symbol-name last-command-event)))) + (error "Bogus calling sequence")) + (describe-language-environment language-name))) -For that, a function returned by: - (get-language-info LANGUAGE-NAME 'describe-function) -is called." - (interactive (list (read-language-name 'documentation "Language: "))) - (let (func) - (if (or (null language-name) - (null (setq func - (get-language-info language-name 'describe-function)))) - (error "No documentation for the specified language")) - (funcall func))) - -;; Print LANGUAGE-NAME specific information such as input methods, -;; charsets, and coding systems. This function is intended to be -;; called from various describe-LANGUAGE-support functions defined in -;; lisp/language/LANGUAGE.el. -(defun describe-language-support-internal (language-name) - (with-output-to-temp-buffer "*Help*" - (let ((doc (get-language-info language-name 'documentation))) +(defun describe-language-environment (language-name) + "Describe how Emacs supports language environment LANGUAGE-NAME." + (interactive + (list (read-language-name + 'documentation + "Describe language environment (default, current choise): "))) + (if (null language-name) + (setq language-name current-language-environment)) + (if (or (null language-name) + (null (get-language-info language-name 'documentation))) + (error "No documentation for the specified language")) + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (let ((doc (get-language-info language-name 'documentation))) + (with-output-to-temp-buffer "*Help*" (if (stringp doc) - (princ-list doc))) - (princ "-----------------------------------------------------------\n") - (princ-list "List of items specific to " - language-name - " support") - (princ "-----------------------------------------------------------\n") - (let ((str (get-language-info language-name 'sample-text))) - (if (stringp str) - (progn - (princ "<sample text>\n") - (princ-list " " str)))) - (princ "<input methods>\n") - (let ((l (get-language-info language-name 'input-method))) - (while l - (princ-list " " (car (car l))) - (setq l (cdr l)))) - (princ "<character sets>\n") - (let ((l (get-language-info language-name 'charset))) - (if (null l) - (princ-list " nothing specific to " language-name) - (while l - (princ-list " " (car l) ": " - (charset-description (car l))) - (setq l (cdr l))))) - (princ "<coding systems>\n") - (let ((l (get-language-info language-name 'coding-system))) - (if (null l) - (princ-list " nothing specific to " language-name) - (while l - (princ-list " " (car l) ":\n\t" - (coding-system-docstring (car l))) - (setq l (cdr l))))))) + (progn + (princ-list doc) + (terpri))) + (let ((str (get-language-info language-name 'sample-text))) + (if (stringp str) + (progn + (princ "Sample text:\n") + (princ-list " " str) + (terpri)))) + (princ "Input methods:\n") + (let ((l input-method-alist)) + (while l + (if (string= language-name (nth 1 (car l))) + (princ-list " " (car (car l)) + (format " (`%s' in mode line)" (nth 3 (car l))))) + (setq l (cdr l)))) + (terpri) + (princ "Character sets:\n") + (let ((l (get-language-info language-name 'charset))) + (if (null l) + (princ-list " nothing specific to " language-name) + (while l + (princ-list " " (car l) ": " + (charset-description (car l))) + (setq l (cdr l))))) + (terpri) + (princ "Coding systems:\n") + (let ((l (get-language-info language-name 'coding-system))) + (if (null l) + (princ-list " nothing specific to " language-name) + (while l + (princ ; (format " %s (`%c' in mode line):\n\t%s\n" + ;; In XEmacs, `coding-system-mnemonic' returns string. + (format " %s (`%s' in mode line):\n\t%s\n" + (car l) + (coding-system-mnemonic (car l)) + (coding-system-doc-string (car l)))) + (setq l (cdr l)))))))) ;;; Charset property @@ -568,29 +672,30 @@ ;; (set-charset-plist charset ;; (plist-put (charset-plist charset) propname value))) -;;; Character code property -;; (put 'char-code-property-table 'char-table-extra-slots 0) - -;; (defvar char-code-property-table -;; (make-char-table 'char-code-property-table) -;; "Char-table containing a property list of each character code. +(defvar char-code-property-table + (make-char-table 'generic) + "Char-table containing a property list of each character code. ;; -;; See also the documentation of `get-char-code-property' and -;; `put-char-code-property'") +See also the documentation of `get-char-code-property' and +`put-char-code-property'") +;; (let ((plist (aref char-code-property-table char))) +(defun get-char-code-property (char propname) + "Return the value of CHAR's PROPNAME property in `char-code-property-table'." + (let ((plist (get-char-table char char-code-property-table))) + (if (listp plist) + (car (cdr (memq propname plist)))))) -;; (defun get-char-code-property (char propname) -;; "Return the value of CHAR's PROPNAME property in `char-code-property-table'." -;; (let ((plist (aref char-code-property-table char))) -;; (if (listp plist) -;; (car (cdr (memq propname plist)))))) - -;; (defun put-char-code-property (char propname value) -;; "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. -;; It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." -;; (let ((plist (aref char-code-property-table char))) -;; (if plist -;; (let ((slot (memq propname plist))) -;; (if slot +(defun put-char-code-property (char propname value) + "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. +It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." + (let ((plist (get-char-table char char-code-property-table))) + (if plist + (let ((slot (memq propname plist))) + (if slot + (setcar (cdr slot) value) + (nconc plist (list propname value)))) + (put-char-table char (list propname value) char-code-property-table) + ))) ;; (setcar (cdr slot) value) ;; (nconc plist (list propname value)))) ;; (aset char-code-property-table char (list propname value)))))
--- a/lisp/mule/mule-coding.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-coding.el Mon Aug 13 10:03:52 2007 +0200 @@ -84,6 +84,10 @@ (cons (cons regexp coding-system) network-coding-system-alist))))))) +(defsubst keyboard-coding-system () + "Return coding-system of what is sent from terminal keyboard." + keyboard-coding-system) + (defun set-keyboard-coding-system (coding-system) "Set the coding system used for TTY keyboard input. Currently broken." (interactive "zkeyboard-coding-system: ") @@ -91,6 +95,10 @@ (setq keyboard-coding-system coding-system) (redraw-modeline t)) +(defsubst terminal-coding-system () + "Return coding-system of your terminal." + terminal-coding-system) + (defun set-terminal-coding-system (coding-system) "Set the coding system used for TTY display output. Currently broken." (interactive "zterminal-coding-system: ") @@ -156,19 +164,6 @@ "Return the 'pre-write-conversion property of CODING-SYSTEM." (coding-system-property coding-system 'pre-write-conversion)) -(defun coding-system-charset (coding-system register) - "Return the 'charset property of CODING-SYSTEM for the specified REGISTER." - (unless (integerp register) - (signal 'wrong-type-argument (list 'integerp register))) - (coding-system-property - coding-system - (case register - (0 'charset-g0) - (1 'charset-g1) - (2 'charset-g2) - (3 'charset-g3) - (t (signal 'args-out-of-range (list register 0 3)))))) - (defun coding-system-force-on-output (coding-system register) "Return the 'force-on-output property of CODING-SYSTEM for the specified REGISTER." (unless (integerp register) @@ -226,10 +221,13 @@ ;;;; Definitions of predefined coding systems (make-coding-system - 'automatic-conversion 'automatic-conversion + 'undecided 'undecided "Automatic conversion." '(mnemonic "Auto")) +;; compatibility for old XEmacsen (don't use it) +(copy-coding-system 'undecided 'automatic-conversion) + (make-coding-system 'ctext 'iso2022 "Coding-system used in X as Compound Text Encoding."
--- a/lisp/mule/mule-debug.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-debug.el Mon Aug 13 10:03:52 2007 +0200 @@ -73,67 +73,6 @@ ; (charset-list)) ; )) -(defun describe-designation (cs register) - (let ((charset - (coding-system-property - cs (intern (format "charset-g%d" register)))) - (force - (coding-system-property - cs (intern (format "force-g%d-on-output" register))))) - (princ - (format - " G%d: %s%s\n" - register - (cond ((null charset) "never used") - ((eq t charset) "none") - (t (charset-name charset))) - (if force " (explicit designation required)" ""))))) - -;;;###autoload -(defun describe-coding-system (cs) - "Display documentation of the coding-system CS." - (interactive "zCoding-system: ") - (setq cs (get-coding-system cs)) - (with-output-to-temp-buffer "*Help*" - (princ (format "Coding-system %s [%s]:\n" - (coding-system-name cs) - (coding-system-mnemonic cs))) - (princ (format " %s\n" (coding-system-doc-string cs))) - (let ((type (coding-system-type cs))) - (princ "Type: ") (princ type) (terpri) - (case type - ('iso2022 - (princ "\nInitial designations:\n") - (dolist (register '(0 1 2 3)) - (describe-designation cs register)) - (princ "\nOther properties: \n") - (dolist (prop '(short no-ascii-eol no-ascii-cntl seven lock-shift no-iso6429)) - (princ (format " %s: " (symbol-name prop))) - (princ (coding-system-property cs prop)) - (terpri))) - ;;(princ " short: ") (princ (coding-system-short)) - ;;(princ (if (aref flags 4) "ShortForm" "LongForm")) - ;;(if (aref flags 5) (princ ", ASCII@EOL")) - ;;(if (aref flags 6) (princ ", ASCII@CNTL")) - ;;(princ (if (coding-system-seven cs) ", 7bit" ", 8bit")) - ;;(if (aref flags 8) (princ ", UseLockingShift")) - ;;(if (aref flags 9) (princ ", UseRoman")) - ;;(if (aref flags 10) (princ ", UseOldJIS")) - ;;(if (aref flags 11) (princ ", No ISO6429")) - ;;(terpri)) - - ('big5 - ;;(princ (if flags "Big-ETen\n" "Big-HKU\n"))) - )) - (princ (format "\nEOL-Type: %s\n" - (case (coding-system-eol-type cs) - ('nil "null (= LF)") - ('lf "LF") - ('crlf "CRLF") - ('cr "CR") - (t "invalid")))) - ))) - ;;;###autoload (defun list-coding-system-briefly () "Display coding-systems currently used with a brief format in mini-buffer."
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mule/mule-diag.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,772 @@ +;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE) + +;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. +;; Copyright (C) 1997 MORIOKA Tomohiko + +;; Keywords: multilingual, charset, coding system, fontset, diagnosis + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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. + +;;; General utility function + +;; Print all arguments with single space separator in one line. +(defun print-list (&rest args) + (while (cdr args) + (when (car args) + (princ (car args)) + (princ " ")) + (setq args (cdr args))) + (princ (car args)) + (princ "\n")) + +;; Re-order the elements of charset-list. +(defun sort-charset-list () + (setq charset-list + (sort charset-list + (function (lambda (x y) (< (charset-id x) (charset-id y))))))) + +;;; CHARSET + +;;;###autoload +(defun list-character-sets (&optional arg) + "Display a list of all character sets. + +The ID column contains a charset identification number for internal use. +The B column contains a number of bytes occupied in a buffer. +The W column contains a number of columns occupied in a screen. + +With prefix arg, the output format gets more cryptic +but contains full information about each character sets." + (interactive "P") + (sort-charset-list) + (with-output-to-temp-buffer "*Help*" + (save-excursion + (set-buffer standard-output) + (let ((l charset-list) + charset) + (if (null arg) + (progn + (insert "ID Name B W Description\n") + (insert "-- ---- - - -----------\n") + (while l + (setq charset (car l) l (cdr l)) + (insert (format "%03d %s" (charset-id charset) charset)) + (indent-to 28) + (insert (format "%d %d %s\n" + (charset-bytes charset) + (charset-width charset) + (charset-description charset))))) + (insert "\ +######################### +## LIST OF CHARSETS +## Each line corresponds to one charset. +## The following attributes are listed in this order +## separated by a colon `:' in one line. +## CHARSET-ID, +## CHARSET-SYMBOL-NAME, +## DIMENSION (1 or 2) +## CHARS (94 or 96) +## BYTES (of multibyte form: 1, 2, 3, or 4), +## WIDTH (occupied column numbers: 1 or 2), +## DIRECTION (0:left-to-right, 1:right-to-left), +## ISO-FINAL-CHAR (character code of ISO-2022's final character) +## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR) +## DESCRIPTION (describing string of the charset) +") + (while l + (setq charset (car l) l (cdr l)) + (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n" + (charset-id charset) + charset + (charset-dimension charset) + (charset-chars charset) + (charset-bytes charset) + (charset-width charset) + (charset-direction charset) + (charset-iso-final-char charset) + (charset-iso-graphic-plane charset) + (charset-description charset)))))) + (help-mode) + (setq truncate-lines t)))) + +;;; CODING-SYSTEM + +(defun describe-designation (cs register) + (let ((charset + (coding-system-property + cs (intern (format "charset-g%d" register)))) + (force + (coding-system-property + cs (intern (format "force-g%d-on-output" register))))) + (princ + (format + " G%d: %s%s\n" + register + (cond ((null charset) "never used") + ((eq t charset) "none") + (t (charset-name charset))) + (if force " (explicit designation required)" ""))))) + +;;;###autoload +(defun describe-coding-system (coding-system) + "Display information of CODING-SYSTEM." + (interactive "zDescribe coding system (default, current choices): ") + (if (or (null coding-system) + (string= (symbol-name coding-system) "")) + (describe-current-coding-system) + (with-output-to-temp-buffer "*Help*" + (print-coding-system-briefly coding-system 'doc-string) + (let ((type (coding-system-type coding-system))) + (princ (format "Type: %s" type)) + (when (eq type 'iso2022) + (princ " (variant of ISO-2022)\n") + (princ "Initial designations:\n") + ;;(print-designation flags) + (describe-designation coding-system 0) + (describe-designation coding-system 1) + (describe-designation coding-system 2) + (describe-designation coding-system 3) + (princ "Other Form: \n ") + (princ (if (coding-system-short coding-system) + "short-form" + "long-form")) + (if (coding-system-no-ascii-eol coding-system) + (princ ", ASCII@EOL")) + (if (coding-system-no-ascii-cntl coding-system) + (princ ", ASCII@CNTL")) + (princ (if (coding-system-seven coding-system) + ", 7-bit" + ", 8-bit")) + (if (coding-system-lock-shift coding-system) + (princ ", use-locking-shift") + (princ ", use-single-shift")) + ;;(if (aref flags 10) (princ ", use-roman")) + ;;(if (aref flags 10) (princ ", use-old-jis")) + (if (coding-system-no-iso6429 coding-system) + (princ ", no-ISO6429")) + ) + (princ "\nEOL type:") + (let ((eol-type (coding-system-eol-type coding-system))) + (cond ((null eol-type) + (princ "\n Automatic selection from\n ") + (princ (format "%s-unix, %s-dos or %s-mac.\n" + coding-system coding-system coding-system)) + ) + ((symbolp eol-type) + (princ " ") + (princ eol-type)) + (t (princ "invalid\n"))))) + (save-excursion + (set-buffer standard-output) + (help-mode))))) + +;;;###autoload +(defun describe-current-coding-system-briefly () + "Display coding systems currently used in a brief format in echo area. + +The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\", +where mnemonics of the following coding systems come in this order +at the place of `..': + buffer-file-coding-system (of the current buffer) + eol-type of buffer-file-coding-system (of the current buffer) + (keyboard-coding-system) + eol-type of (keyboard-coding-system) + (terminal-coding-system) + eol-type of (terminal-coding-system) + process-coding-system for read (of the current buffer, if any) + eol-type of process-coding-system for read (of the current buffer, if any) + process-coding-system for write (of the current buffer, if any) + eol-type of process-coding-system for write (of the current buffer, if any) + default-buffer-file-coding-system + eol-type of default-buffer-file-coding-system + default-process-coding-system for read + eol-type of default-process-coding-system for read + default-process-coding-system for write + eol-type of default-process-coding-system" + (interactive) + (let* ((proc (get-buffer-process (current-buffer))) + (process-coding-systems (if proc (process-coding-system proc)))) + (message + "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]" + (coding-system-mnemonic buffer-file-coding-system) + (coding-system-eol-type-mnemonic buffer-file-coding-system) + (coding-system-mnemonic (keyboard-coding-system)) + (coding-system-eol-type-mnemonic (keyboard-coding-system)) + (coding-system-mnemonic (terminal-coding-system)) + (coding-system-eol-type-mnemonic (terminal-coding-system)) + (coding-system-mnemonic (car process-coding-systems)) + (coding-system-eol-type-mnemonic (car process-coding-systems)) + (coding-system-mnemonic (cdr process-coding-systems)) + (coding-system-eol-type-mnemonic (cdr process-coding-systems)) + (coding-system-mnemonic default-buffer-file-coding-system) + (coding-system-eol-type-mnemonic default-buffer-file-coding-system) + (coding-system-mnemonic (car default-process-coding-system)) + (coding-system-eol-type-mnemonic (car default-process-coding-system)) + (coding-system-mnemonic (cdr default-process-coding-system)) + (coding-system-eol-type-mnemonic (cdr default-process-coding-system)) + ))) + +;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'. +(defun print-coding-system-briefly (coding-system &optional doc-string) + (if (not coding-system) + (princ "nil\n") + ;; In XEmacs, coding-system has own type. + (if (coding-system-p coding-system) + (setq coding-system (coding-system-name coding-system)) + ) + ;; In XEmacs, coding-system-mnemonic returns string. + (princ (format "%s -- %s" + (coding-system-mnemonic coding-system) + coding-system)) + ;; Current XEmacs does not have `coding-system-parent'. + ;; (let ((parent (coding-system-parent coding-system))) + ;; (if parent + ;; (princ (format " (alias of %s)" parent)))) + (let ((aliases (get coding-system 'alias-coding-systems))) + (if aliases + (princ (format " %S" (cons 'alias: aliases))))) + (princ "\n") + (if (and doc-string + (setq doc-string (coding-system-doc-string coding-system))) + (princ (format " %s\n" doc-string))))) + +;;;###autoload +(defun describe-current-coding-system () + "Display coding systems currently used in a detailed format." + (interactive) + (with-output-to-temp-buffer "*Help*" + (let* ((proc (get-buffer-process (current-buffer))) + (process-coding-systems (if proc (process-coding-system proc)))) + (princ "Coding system for saving this buffer:\n ") + ;; local-variable-p of XEmacs requires 2 arguments. + (if (local-variable-p 'buffer-file-coding-system (current-buffer)) + (print-coding-system-briefly buffer-file-coding-system) + (princ "Not set locally, use the default.\n")) + (princ "Default coding system (for new files):\n ") + (print-coding-system-briefly default-buffer-file-coding-system) + (princ "Coding system for keyboard input:\n ") + (print-coding-system-briefly (keyboard-coding-system)) + (princ "Coding system for terminal output:\n ") + (print-coding-system-briefly (terminal-coding-system)) + (when (get-buffer-process (current-buffer)) + (princ "Coding systems for process I/O:\n") + (princ " encoding input to the process: ") + (print-coding-system-briefly (cdr process-coding-systems)) + (princ " decoding output from the process: ") + (print-coding-system-briefly (car process-coding-systems))) + ;;(princ "Defaults for subprocess I/O:\n") + ;;(princ " decoding: ") + ;;(print-coding-system-briefly (car default-process-coding-system)) + ;;(princ " encoding: ") + ;;(print-coding-system-briefly (cdr default-process-coding-system)) + ) + (save-excursion + (set-buffer standard-output) + + (princ + "\nPriority order for recognizing coding systems when reading files:\n") + (let ((l (coding-category-list)) ; It is function in XEmacs. + (i 1) + (coding-list nil) + coding aliases) + (while l + (setq coding (coding-category-system (car l))) ; for XEmacs + (when (not (memq coding coding-list)) + (setq coding-list (cons coding coding-list)) + (princ (format " %d. %s" i coding)) + (when (setq aliases (get coding 'alias-coding-systems)) + (princ " ") + (princ (cons 'alias: aliases))) + (terpri) + (setq i (1+ i))) + (setq l (cdr l)))) + (princ "\n Other coding systems cannot be distinguished automatically + from these, and therefore cannot be recognized automatically + with the present coding system priorities.\n\n") + + (let ((categories '(iso-7)) ; for XEmacs + ;; '(coding-category-iso-7 coding-category-iso-7-else)) + coding-system codings) + (while categories + ;; for XEmacs + (setq coding-system (coding-category-system (car categories))) + (mapcar + (function + (lambda (x) + (if (and (not (eq x coding-system)) + (get x 'no-initial-designation) + (let ((flags (coding-system-flags x))) + (not (or (aref flags 10) (aref flags 11))))) + (setq codings (cons x codings))))) + (get (car categories) 'coding-systems)) + (if codings + (let ((max-col (frame-width)) + pos) + (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system)) + (while codings + (setq pos (point)) + (insert (format " %s" (car codings))) + (when (> (current-column) max-col) + (goto-char pos) + (insert "\n ") + (goto-char (point-max))) + (setq codings (cdr codings))) + (insert "\n\n"))) + (setq categories (cdr categories)))) + + (princ "Particular coding systems specified for certain file names:\n") + (terpri) + (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n") + (princ " ---------\t--------------\t\t----------------\n") + (let ((func (lambda (operation alist) + (princ " ") + (princ operation) + (if (not alist) + (princ "\tnothing specified\n") + (while alist + (indent-to 16) + (prin1 (car (car alist))) + (indent-to 40) + (princ (cdr (car alist))) + (princ "\n") + (setq alist (cdr alist))))))) + (funcall func "File I/O" file-coding-system-alist) + (funcall func "Process I/O" process-coding-system-alist) + (funcall func "Network I/O" network-coding-system-alist)) + (help-mode)))) + +;; Print detailed information on CODING-SYSTEM. +(defun print-coding-system (coding-system &optional aliases) + (let ((type (coding-system-type coding-system)) + (eol-type (coding-system-eol-type coding-system)) + (flags (coding-system-flags coding-system)) + (base (coding-system-base coding-system))) + (if (not (eq base coding-system)) + (princ (format "%s (alias of %s)\n" coding-system base)) + (princ coding-system) + (while aliases + (princ ",") + (princ (car aliases)) + (setq aliases (cdr aliases))) + (princ (format ":%s:%c:%d:" + type + (coding-system-mnemonic coding-system) + (if (integerp eol-type) eol-type 3))) + (cond ((eq type 2) ; ISO-2022 + (let ((idx 0) + charset) + (while (< idx 4) + (setq charset (aref flags idx)) + (cond ((null charset) + (princ -1)) + ((eq charset t) + (princ -2)) + ((charsetp charset) + (princ charset)) + ((listp charset) + (princ "(") + (princ (car charset)) + (setq charset (cdr charset)) + (while charset + (princ ",") + (princ (car charset)) + (setq charset (cdr charset))) + (princ ")"))) + (princ ",") + (setq idx (1+ idx))) + (while (< idx 12) + (princ (if (aref flags idx) 1 0)) + (princ ",") + (setq idx (1+ idx))) + (princ (if (aref flags idx) 1 0)))) + ((eq type 4) ; CCL + (let (i len) + (setq i 0 len (length (car flags))) + (while (< i len) + (princ (format " %x" (aref (car flags) i))) + (setq i (1+ i))) + (princ ",") + (setq i 0 len (length (cdr flags))) + (while (< i len) + (princ (format " %x" (aref (cdr flags) i))) + (setq i (1+ i))))) + (t (princ 0))) + (princ ":") + (princ (coding-system-doc-string coding-system)) + (princ "\n")))) + +;;;###autoload +(defun list-coding-systems (&optional arg) + "Display a list of all coding systems. +It prints mnemonic letter, name, and description of each coding systems. + +With prefix arg, the output format gets more cryptic, +but contains full information about each coding systems." + (interactive "P") + (with-output-to-temp-buffer "*Help*" + (if (null arg) + (princ "\ +############################################### +# List of coding systems in the following format: +# MNEMONIC-LETTER -- CODING-SYSTEM-NAME +# DOC-STRING +") + (princ "\ +######################### +## LIST OF CODING SYSTEMS +## Each line corresponds to one coding system +## Format of a line is: +## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION +## :PRE-WRITE-CONVERSION:DOC-STRING, +## where +## NAME = coding system name +## ALIAS = alias of the coding system +## TYPE = nil (no conversion), t (undecided or automatic detection), +## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL) +## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection) +## FLAGS = +## if TYPE = 2 then +## comma (`,') separated data of the followings: +## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN, +## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429 +## else if TYPE = 4 then +## comma (`,') separated CCL programs for read and write +## else +## 0 +## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called +## +")) + (let ((bases (coding-system-list)) + ;;(coding-system-list 'base-only)) + coding-system) + (while bases + (setq coding-system (car bases)) + (if (null arg) + (print-coding-system-briefly coding-system 'doc-string) + (print-coding-system coding-system)) + (setq bases (cdr bases)))))) + +;;;###automatic +(defun list-coding-categories () + "Display a list of all coding categories." + (with-output-to-temp-buffer "*Help*" + (princ "\ +############################ +## LIST OF CODING CATEGORIES (ordered by priority) +## CATEGORY:CODING-SYSTEM +## +") + (let ((l coding-category-list)) + (while l + (princ (format "%s:%s\n" (car l) (symbol-value (car l)))) + (setq l (cdr l)))))) + +;;; FONT + +;; Print information of a font in FONTINFO. +(defun describe-font-internal (font-info &optional verbose) + (print-list "name (opened by):" (aref font-info 0)) + (print-list " full name:" (aref font-info 1)) + (let ((charset (aref font-info 2))) + (print-list " charset:" + (format "%s (%s)" charset (charset-description charset)))) + (print-list " size:" (format "%d" (aref font-info 3))) + (print-list " height:" (format "%d" (aref font-info 4))) + (print-list " baseline-offset:" (format "%d" (aref font-info 5))) + (print-list "relative-compose:" (format "%d" (aref font-info 6)))) + +;;;###autoload +(defun describe-font (fontname) + "Display information about fonts which partially match FONTNAME." + (interactive "sFontname (default, current choise for ASCII chars): ") + (or window-system + (error "No window system being used")) + (when (or (not fontname) (= (length fontname) 0)) + (setq fontname (cdr (assq 'font (frame-parameters)))) + (if (query-fontset fontname) + (setq fontname + (nth 2 (assq 'ascii (aref (fontset-info fontname) 2)))))) + (let ((font-info (font-info fontname))) + (if (null font-info) + (message "No matching font") + (with-output-to-temp-buffer "*Help*" + (describe-font-internal font-info 'verbose))))) + +;; Print information of FONTSET. If optional arg PRINT-FONTS is +;; non-nil, print also names of all fonts in FONTSET. This function +;; actually INSERT such information in the current buffer. +(defun print-fontset (fontset &optional print-fonts) + (let* ((fontset-info (fontset-info fontset)) + (size (aref fontset-info 0)) + (height (aref fontset-info 1)) + (fonts (and print-fonts (aref fontset-info 2))) + (xlfd-fields (x-decompose-font-name fontset)) + style) + (if xlfd-fields + (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum)) + (slant (aref xlfd-fields xlfd-regexp-slant-subnum))) + (if (string-match "^bold$\\|^demibold$" weight) + (setq style (concat weight " ")) + (setq style "medium ")) + (cond ((string-match "^i$" slant) + (setq style (concat style "italic"))) + ((string-match "^o$" slant) + (setq style (concat style "slant"))) + ((string-match "^ri$" slant) + (setq style (concat style "reverse italic"))) + ((string-match "^ro$" slant) + (setq style (concat style "reverse slant"))))) + (setq style " ? ")) + (beginning-of-line) + (insert fontset) + (indent-to 58) + (insert (if (> size 0) (format "%2dx%d" size height) " -")) + (indent-to 64) + (insert style "\n") + (when print-fonts + (insert " O Charset / Fontname\n" + " - ------------------\n") + (sort-charset-list) + (let ((l charset-list) + charset font-info opened fontname) + (while l + (setq charset (car l) l (cdr l)) + (setq font-info (assq charset fonts)) + (if (null font-info) + (setq opened ?? fontname "not specified") + (if (nth 2 font-info) + (if (stringp (nth 2 font-info)) + (setq opened ?o fontname (nth 2 font-info)) + (setq opened ?- fontname (nth 1 font-info))) + (setq opened ?x fontname (nth 1 font-info)))) + (insert (format " %c %s\n %s\n" + opened charset fontname))))))) + +;;;###autoload +(defun describe-fontset (fontset) + "Display information of FONTSET. + +It prints name, size, and style of FONTSET, and lists up fonts +contained in FONTSET. + +The column WDxHT contains width and height (pixels) of each fontset +\(i.e. those of ASCII font in the fontset). The letter `-' in this +column means that the corresponding fontset is not yet used in any +frame. + +The O column of each font contains one of the following letters. + o -- font already opened + - -- font not yet opened + x -- font can't be opened + ? -- no font specified + +The Charset column of each font contains a name of character set +displayed by the font." + (interactive + (if (not window-system) + (error "No window system being used") + (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))) + (completion-ignore-case t)) + (list (completing-read + "Fontset (default, used by the current frame): " + fontset-list nil t))))) + (if (= (length fontset) 0) + (setq fontset (cdr (assq 'font (frame-parameters))))) + (if (not (query-fontset fontset)) + (error "Current frame is using font, not fontset")) + (let ((fontset-info (fontset-info fontset))) + (with-output-to-temp-buffer "*Help*" + (save-excursion + (set-buffer standard-output) + (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n") + (insert "------------\t\t\t\t\t\t ----- -----\n") + (print-fontset fontset t))))) + +;;;###autoload +(defun list-fontsets (arg) + "Display a list of all fontsets. + +It prints name, size, and style of each fontset. +With prefix arg, it also lists up fonts contained in each fontset. +See the function `describe-fontset' for the format of the list." + (interactive "P") + (with-output-to-temp-buffer "*Help*" + (save-excursion + (set-buffer standard-output) + (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n") + (insert "------------\t\t\t\t\t\t ----- -----\n") + (let ((fontsets (fontset-list))) + (while fontsets + (print-fontset (car fontsets) arg) + (setq fontsets (cdr fontsets))))))) + +;;;###autoload +(defun list-input-methods () + "Print information of all input methods." + (interactive) + (with-output-to-temp-buffer "*Help*" + (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n") + (princ " SHORT-DESCRIPTION\n------------------------------\n") + (setq input-method-alist + (sort input-method-alist + (function (lambda (x y) (string< (nth 1 x) (nth 1 y)))))) + (let ((l input-method-alist) + language elt) + (while l + (setq elt (car l) l (cdr l)) + (when (not (equal language (nth 1 elt))) + (setq language (nth 1 elt)) + (princ language) + (terpri)) + (princ (format " %s (`%s' in mode line)\n %s\n" + (car elt) (nth 3 elt) + (let ((title (nth 4 elt))) + (string-match ".*" title) + (match-string 0 title)))))))) + +;;; DIAGNOSIS + +;; Insert a header of a section with SECTION-NUMBER and TITLE. +(defun insert-section (section-number title) + (insert "########################################\n" + "# Section " (format "%d" section-number) ". " title "\n" + "########################################\n\n")) + +;;;###autoload +(defun mule-diag () + "Display diagnosis of the multilingual environment (MULE). + +It prints various information related to the current multilingual +environment, including lists of input methods, coding systems, +character sets, and fontsets (if Emacs running under some window +system)." + (interactive) + (with-output-to-temp-buffer "*Mule-Diagnosis*" + (save-excursion + (set-buffer standard-output) + (insert "\t###############################\n" + "\t### Diagnosis of your Emacs ###\n" + "\t###############################\n\n" + "CONTENTS: Section 1. General Information\n" + " Section 2. Display\n" + " Section 3. Input methods\n" + " Section 4. Coding systems\n" + " Section 5. Character sets\n") + (if window-system + (insert " Section 6. Fontsets\n")) + (insert "\n") + + (insert-section 1 "General Information") + (insert "Version of this emacs:\n " (emacs-version) "\n\n") + + (insert-section 2 "Display") + (if window-system + (insert "Window-system: " + (symbol-name window-system) + (format "%s" window-system-version)) + (insert "Terminal: " (getenv "TERM"))) + (insert "\n\n") + + (if (eq window-system 'x) + (let ((font (cdr (assq 'font (frame-parameters))))) + (insert "The selected frame is using the " + (if (query-fontset font) "fontset" "font") + ":\n\t" font)) + (insert "Coding system of the terminal: " + (symbol-name (terminal-coding-system)))) + (insert "\n\n") + + (insert-section 3 "Input methods") + (save-excursion (list-input-methods)) + (insert-buffer-substring "*Help*") + (insert "\n") + (if default-input-method + (insert "Default input method: " default-input-method "\n") + (insert "No default input method is specified\n")) + + (insert-section 4 "Coding systems") + (save-excursion (list-coding-systems t)) + (insert-buffer-substring "*Help*") + (save-excursion (list-coding-categories)) + (insert-buffer-substring "*Help*") + (insert "\n") + + (insert-section 5 "Character sets") + (save-excursion (list-character-sets t)) + (insert-buffer-substring "*Help*") + (insert "\n") + + (when window-system + (insert-section 6 "Fontsets") + (save-excursion (list-fontsets t)) + (insert-buffer-substring "*Help*")) + (help-mode)))) + + +;;; DUMP DATA FILE + +;;;###autoload +(defun dump-charsets () + "Dump information of all charsets into the file \"CHARSETS\". +The file is saved in the directory `data-directory'." + (let ((file (expand-file-name "CHARSETS" data-directory)) + buf) + (or (file-writable-p file) + (error "Can't write to file %s" file)) + (setq buf (find-file-noselect file)) + (save-window-excursion + (save-excursion + (set-buffer buf) + (setq buffer-read-only nil) + (erase-buffer) + (list-character-sets t) + (insert-buffer-substring "*Help*") + (let (make-backup-files + coding-system-for-write) + (save-buffer)))) + (kill-buffer buf)) + (if noninteractive + (kill-emacs))) + +;;;###autoload +(defun dump-codings () + "Dump information of all coding systems into the file \"CODINGS\". +The file is saved in the directory `data-directory'." + (let ((file (expand-file-name "CODINGS" data-directory)) + buf) + (or (file-writable-p file) + (error "Can't write to file %s" file)) + (setq buf (find-file-noselect file)) + (save-window-excursion + (save-excursion + (set-buffer buf) + (setq buffer-read-only nil) + (erase-buffer) + (list-coding-systems t) + (insert-buffer-substring "*Help*") + (list-coding-categories) + (insert-buffer-substring "*Help*") + (let (make-backup-files + coding-system-for-write) + (save-buffer)))) + (kill-buffer buf)) + (if noninteractive + (kill-emacs))) + +;;; mule-diag.el ends here
--- a/lisp/mule/mule-files.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-files.el Mon Aug 13 10:03:52 2007 +0200 @@ -26,18 +26,10 @@ ;;; Derived from mule.el in the original Mule but heavily modified ;;; by Ben Wing. -;; 1997/3/11 modified by MORIOKA Tomohiko to sync with Emacs/mule API. +;; 1997/3/11 modified by MORIOKA Tomohiko to sync with Emacs 20 API. ;;; Code: -;;;; #### also think more about `binary' vs. `no-conversion' - -;; Use `no-conversion' instead of `binary', because Emacs/mule does -;; not have `binary' coding-system. - -;; also think more about `internal'. - - (setq-default buffer-file-coding-system 'iso-2022-8) (put 'buffer-file-coding-system 'permanent-local t) @@ -49,7 +41,7 @@ 'overriding-file-coding-system 'coding-system-for-read) -(defvar buffer-file-coding-system-for-read 'automatic-conversion +(defvar buffer-file-coding-system-for-read 'undecided "Coding system used when reading a file. This provides coarse-grained control; for finer-grained control, use `file-coding-system-alist'. From a Lisp program, if you wish to @@ -66,6 +58,7 @@ '(("\\.elc$" . (binary . binary)) ("loaddefs.el$" . (binary . binary)) ("\\.tar$" . (binary . binary)) + ("TUTORIAL\\.hr$" . iso-8859-2) ;; ("\\.\\(el\\|emacs\\|info\\(-[0-9]+\\)?\\|texi\\)$" . iso-2022-8) ;; ("\\(ChangeLog\\|CHANGES-beta\\)$" . iso-2022-8) ("\\.\\(gz\\|Z\\)$" . binary) @@ -194,7 +187,7 @@ (if (re-search-forward "^From" nil 'move) (beginning-of-line)) (setq end (point)) - (decode-coding-region start end 'automatic-conversion)))))) + (decode-coding-region start end 'undecided)))))) (defun find-coding-system-magic-cookie () "Look for the coding-system magic cookie in the current buffer.\n" @@ -209,15 +202,38 @@ "charsets." (save-excursion (goto-char (point-min)) - (let ((case-fold-search nil)) - (if (search-forward ";;;###coding system: " (+ (point-min) 3000) t) - (let ((start (point)) - (end (progn - (skip-chars-forward "^ \t\n\r") - (point)))) - (if (> end start) - (let ((codesys (intern (buffer-substring start end)))) - (if (find-coding-system codesys) codesys)))))))) + (or (and (looking-at "^-\\*-[^\n]*coding: \\([^ \t\n;]+\\);[^\n]*-\\*-") + (let ((codesys (intern (buffer-substring + (match-beginning 1)(match-end 1))))) + (if (find-coding-system codesys) codesys))) + ;; (save-excursion + ;; (let (start end) + ;; (and (re-search-forward "^;+[ \t]*Local Variables:" nil t) + ;; (setq start (match-end 0)) + ;; (re-search-forward "\n;+[ \t]*End:") + ;; (setq end (match-beginning 0)) + ;; (save-restriction + ;; (narrow-to-region start end) + ;; (goto-char start) + ;; (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t) + ;; ) + ;; (let ((codesys + ;; (intern (buffer-substring + ;; (match-beginning 1)(match-end 1))))) + ;; (if (find-coding-system codesys) codesys)) + ;; ))) + (let ((case-fold-search nil)) + (if (search-forward + ";;;###coding system: " (+ (point-min) 3000) t) + (let ((start (point)) + (end (progn + (skip-chars-forward "^ \t\n\r") + (point)))) + (if (> end start) + (let ((codesys (intern (buffer-substring start end)))) + (if (find-coding-system codesys) codesys))) + ))) + ))) (defun load (file &optional noerror nomessage nosuffix) "Execute a file of Lisp code named FILE. @@ -251,20 +267,24 @@ ;; use string= instead of string-match to keep match-data. (if (string= ".elc" (downcase (substring path -4))) ;; if reading a byte-compiled file and we didn't find - ;; a coding-system magic cookie, then use `no-conversion'. + ;; a coding-system magic cookie, then use `binary'. ;; We need to guarantee that we never do autodetection ;; on byte-compiled files because confusion here would ;; be a very bad thing. Pre-existing byte-compiled - ;; files are always in the `no-conversion' system. + ;; files are always in the `binary' coding system. ;; Also, byte-compiled files always use `lf' to terminate ;; a line; don't risk confusion here either. - (if (not __codesys__) - (setq __codesys__ 'no-conversion)) + (or __codesys__ + (setq __codesys__ 'binary)) ;; otherwise use `buffer-file-coding-system-for-read', as normal ;; #### need to do some looking up in ;; #### file-coding-system-alist! - (if (not __codesys__) - (setq __codesys__ buffer-file-coding-system-for-read))) + (or __codesys__ + (setq __codesys__ + (or (find-file-coding-system-for-read-from-filename + file) + buffer-file-coding-system-for-read))) + ) ;; now use the internal load to actually load the file. (load-internal file noerror nomessage nosuffix __codesys__)))))) @@ -378,9 +398,9 @@ (if (null (find-coding-system coding-system)) (progn (message - "Invalid coding-system (%s), using 'automatic-conversion" + "Invalid coding-system (%s), using 'undecided" coding-system) - (setq coding-system 'automatic-conversion))) + (setq coding-system 'undecided))) (setq return-val (insert-file-contents-internal filename visit beg end replace coding-system
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mule/mule-help.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,77 @@ +;;; mule-help.el --- Mule-ized Help functions + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Author: SL Baur <steve@altair.xemacs.org> +;; Keywords: help, internal + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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: Emacs 20.1 + +;;; Commentary: + +;; + +;;; Code: + +;; TUTORIAL arg is XEmacs addition +(defun help-with-tutorial (&optional arg tutorial) + "Select the Emacs learn-by-doing tutorial. +If there is a tutorial version written in the language +of the selected language environment, that version is used. +If there's no tutorial in that language, `TUTORIAL' is selected. +With arg, you are asked to select which language." + (interactive "P") + (let (lang filename file) + (if arg + (or (setq lang (read-language-name 'tutorial "Language: ")) + (error "No tutorial file of the specified language")) + (setq lang current-language-environment)) + (setq filename (or (get-language-info lang 'tutorial) + (or tutorial "TUTORIAL"))) + (setq file (expand-file-name (concat "~/" filename))) + (delete-other-windows) + (if (get-file-buffer file) + (switch-to-buffer (get-file-buffer file)) + (switch-to-buffer (create-file-buffer file)) + (setq buffer-file-name file) + (setq default-directory (expand-file-name "~/")) + (setq buffer-auto-save-file-name nil) + (insert-file-contents (expand-file-name filename data-directory)) + (goto-char (point-min)) + (search-forward "\n<<") + (beginning-of-line) + (delete-region (point) (progn (end-of-line) (point))) + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point)) + 6))) + (if (< n 12) + (newline n) + ;; Some people get confused by the large gap. + (newline (/ n 2)) + (insert "[Middle of page left blank for didactic purposes. " + "Text continues below]") + (newline (- n (/ n 2))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)))) + + +(provide 'mule-help) + +;;; mule-help.el ends here \ No newline at end of file
--- a/lisp/mule/mule-init.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-init.el Mon Aug 13 10:03:52 2007 +0200 @@ -42,8 +42,8 @@ (require 'cl) -(setq language-environment-list - (sort (language-environment-list) 'string-lessp)) +;; (setq language-environment-list +;; (sort (language-environment-list) 'string-lessp)) ;; MULE keymap codes were moved to mule-cmds.el. @@ -84,34 +84,36 @@ (help-with-tutorial (concat "mule/TUTORIAL" (or language "")))) (defvar auto-language-alist - '(("^ja" . japanese) - ("^zh" . chinese) - ("^ko" . korean)) + '(("^ja" . "Japanese") + ("^zh" . "Chinese") + ("^ko" . "Korean")) "Alist of LANG patterns vs. corresponding language environment. Each element looks like (REGEXP . LANGUAGE-ENVIRONMENT). It the value of the environment variable LANG matches the regexp REGEXP, then `set-language-environment' is called with LANGUAGE-ENVIRONMENT.") - + (defun init-mule () "Initialize MULE environment at startup. Don't call this." (let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")))) (unless (or (null lang) (string-equal "C" lang)) (let ((case-fold-search t)) - (loop for elt in auto-language-alist - if (string-match (car elt) lang) - return (set-language-environment (cdr elt)))) - + (loop for elt in auto-language-alist + if (string-match (car elt) lang) + return (progn + (setq lang (substring lang 0 (match-end 0))) + (set-language-environment (cdr elt)) + ))) ;; Load a (localizable) locale-specific init file, if it exists. (load (format "locale/%s/locale-start" lang) t t))) - - (when (current-language-environment) + + (when current-language-environment ;; Translate remaining args on command line using file-name-coding-system (loop for arg in-ref command-line-args-left do (setf arg (decode-coding-string arg file-name-coding-system))) - + ;; rman seems to be incompatible with encoded text (setq Manual-use-rosetta-man nil) - + ;; Make sure ls -l output is readable by dired and encoded using ;; file-name-coding-system (add-hook @@ -120,7 +122,7 @@ (make-local-variable 'process-environment) (setenv "LC_MESSAGES" "C") (setenv "LC_TIME" "C")))) - + ;; Register avairable input methods by loading LEIM list file. (load "leim-list.el" 'noerror 'nomessage 'nosuffix) )
--- a/lisp/mule/mule-misc.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-misc.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,5 +1,7 @@ ;; mule-misc.el --- Miscellaneous Mule functions. +;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. ;; Copyright (C) 1995 Amdahl Corporation. ;; Copyright (C) 1995 Sun Microsystems. @@ -190,52 +192,89 @@ because its `find-charset-string' ignores ASCII charset." (delq 'ascii (charsets-in-region start end))) +(defun split-char (char) + "Return list of charset and one or two position-codes of CHAR." + (let ((charset (char-charset char))) + (if (eq charset 'ascii) + (list charset char) + (let ((i 0) + (len (charset-dimension charset)) + (code (if (integerp char) + char + (char-int char))) + dest) + (while (< i len) + (setq dest (cons (logand code 127) dest) + code (lsh code -7) + i (1+ i))) + (cons charset dest) + )))) + + +;;; Commands + +(defun set-buffer-process-coding-system (decoding encoding) + "Set coding systems for the process associated with the current buffer. +DECODING is the coding system to be used to decode input from the process, +ENCODING is the coding system to be used to encode output to the process. + +For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]." + (interactive + "zCoding-system for process input: \nzCoding-system for process output: ") + (let ((proc (get-buffer-process (current-buffer)))) + (if (null proc) + (error "no process") + (check-coding-system decoding) + (check-coding-system encoding) + (set-process-coding-system proc decoding encoding))) + (force-mode-line-update)) + ;;; Language environments -(defvar current-language-environment nil) +;; (defvar current-language-environment nil) -(defvar language-environment-list nil) +;; (defvar language-environment-list nil) -(defun current-language-environment () - "Return the current language environment as a symbol. -Returns nil if `set-language-environment' has not been called." - current-language-environment) +;; (defun current-language-environment () +;; "Return the current language environment as a symbol. +;; Returns nil if `set-language-environment' has not been called." +;; current-language-environment) -(defun language-environment-list () - "Return a list of all currently defined language environments." - language-environment-list) +;; (defun language-environment-list () +;; "Return a list of all currently defined language environments." +;; language-environment-list) -(defun language-environment-p (sym) - "True if SYM names a defined language environment." - (memq sym (language-environment-list))) +;; (defun language-environment-p (sym) +;; "True if SYM names a defined language environment." +;; (memq sym (language-environment-list))) -(defun set-language-environment (env) - "Set the current language environment to ENV." - (interactive - (list (intern (completing-read "Language environment: " - obarray 'language-environment-p - 'require-match)))) - (when (not (string= (charset-registry 'ascii) "iso8859-1")) - (set-charset-registry 'ascii "iso8859-1")) - (let ((func (get env 'set-lang-environ))) - (if (not (null func)) - (funcall func))) - (setq current-language-environment env) - (if (featurep 'egg) - (egg-lang-switch-callback)) -;; (if (featurep 'quail) -;; (quail-lang-switch-callback)) -) +;; (defun set-language-environment (env) +;; "Set the current language environment to ENV." +;; (interactive +;; (list (intern (completing-read "Language environment: " +;; obarray 'language-environment-p +;; 'require-match)))) +;; (when (not (string= (charset-registry 'ascii) "iso8859-1")) +;; (set-charset-registry 'ascii "iso8859-1")) +;; (let ((func (get env 'set-lang-environ))) +;; (if (not (null func)) +;; (funcall func))) +;; (setq current-language-environment env) +;; (if (featurep 'egg) +;; (egg-lang-switch-callback)) +;; ;; (if (featurep 'quail) +;; ;; (quail-lang-switch-callback)) +;; ) -(defun define-language-environment (env-sym doc-string enable-function) - "Define a new language environment, named by ENV-SYM. -DOC-STRING should be a string describing the environment. -ENABLE-FUNCTION should be a function of no arguments that will be called -when the language environment is made current." - (put env-sym 'lang-environ-doc-string doc-string) - (put env-sym 'set-lang-environ enable-function) - (setq language-environment-list (cons env-sym language-environment-list))) +;; (defun define-language-environment (env-sym doc-string enable-function) +;; "Define a new language environment, named by ENV-SYM. +;; DOC-STRING should be a string describing the environment. +;; ENABLE-FUNCTION should be a function of no arguments that will be called +;; when the language environment is made current." +;; (put env-sym 'lang-environ-doc-string doc-string) +;; (put env-sym 'set-lang-environ enable-function) +;; (setq language-environment-list (cons env-sym language-environment-list))) (defun define-egg-environment (env-sym doc-string enable-function) "Define a new language environment for egg, named by ENV-SYM. @@ -245,11 +284,12 @@ (put env-sym 'egg-environ-doc-string doc-string) (put env-sym 'set-egg-environ enable-function)) -(defun define-quail-environment (env-sym doc-string enable-function) - "Define a new language environment for quail, named by ENV-SYM. -DOC-STRING should be a string describing the environment. -ENABLE-FUNCTION should be a function of no arguments that will be called -when the language environment is made current." - (put env-sym 'quail-environ-doc-string doc-string) - (put env-sym 'set-quail-environ enable-function)) +;; (defun define-quail-environment (env-sym doc-string enable-function) +;; "Define a new language environment for quail, named by ENV-SYM. +;; DOC-STRING should be a string describing the environment. +;; ENABLE-FUNCTION should be a function of no arguments that will be called +;; when the language environment is made current." +;; (put env-sym 'quail-environ-doc-string doc-string) +;; (put env-sym 'set-quail-environ enable-function)) +;;; mule-misc.el ends here
--- a/lisp/mule/mule-process.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/mule/mule-process.el Mon Aug 13 10:03:52 2007 +0200 @@ -72,7 +72,7 @@ (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'call-process filename)) + (setq ret (funcall ret 'call-process program)) ) (cond ((consp ret) (car ret)) ((find-coding-system ret) ret) @@ -116,7 +116,7 @@ (t (make-temp-name "/tmp/emacs"))))) (unwind-protect - (let (cs-r cd-w) + (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist process-coding-system-alist) @@ -127,7 +127,7 @@ (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'call-process-region filename))) + (setq ret (funcall ret 'call-process-region program))) (cond ((consp ret) (setq cs-r (car ret) cs-w (cdr ret))) @@ -162,7 +162,7 @@ Remaining arguments are strings to give program as arguments. INCODE and OUTCODE specify the coding-system objects used in input/output from/to the process." - (let (cs-r cd-w) + (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist process-coding-system-alist) @@ -173,7 +173,7 @@ (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'start-process filename))) + (setq ret (funcall ret 'start-process program))) (cond ((consp ret) (setq cs-r (car ret) cs-w (cdr ret))) @@ -216,18 +216,29 @@ Third arg is name of the host to connect to, or its IP address. Fourth arg SERVICE is name of the service desired, or an integer specifying a port number to connect to." - (let (cs-r cd-w) + (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist network-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search (eq system-type 'vax-vms)) + pattern) (while alist - (if (string-match (car (car alist)) program) - (throw 'found (setq ret (cdr (car alist))))) + (setq pattern (car (car alist))) + (and + (cond ((numberp pattern) + (and (numberp service) + (eq pattern service))) + ((stringp pattern) + (or (and (stringp service) + (string-match pattern service)) + (and (numberp service) + (string-match pattern + (number-to-string service)))))) + (throw 'found (setq ret (cdr (car alist))))) (setq alist (cdr alist)) ))) (if (functionp ret) - (setq ret (funcall ret 'open-network-stream filename))) + (setq ret (funcall ret 'open-network-stream service))) (cond ((consp ret) (setq cs-r (car ret) cs-w (cdr ret)))
--- a/lisp/mule/mule-vietnamese.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -;; Vietnamese language specific setup for Mule -;; Copyright (C) 1992 Free Software Foundation, Inc. -;; This file is part of Mule (MULtilingual Enhancement of GNU Emacs). -;; This file contains European characters. - -;; Mule is free software distributed in the form of patches to GNU Emacs. -;; 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 1, or (at your option) -;; any later version. - -;; Mule 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; 93.5.25 created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp> -;;; 93.7.22 modified for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp> - -(defconst viqr-regexp - "[aeiouyAEIOUY]\\([(^+]?['`?~.]\\|[(^+]\\)\\|[Dd][Dd]") - -;;;###autoload -(defun vn-compose-viqr (from to) - "Convert 'VIQR' mnemonics of the current region to -pre-composed Vietnamese characaters." - (interactive "r") - (let (quail-current-package map key def) - (quail-use-package "viqr") - (setq map (quail-map)) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward viqr-regexp 0 t) - (setq key (buffer-substring (match-beginning 0) (match-end 0))) - (setq def (lookup-key map key)) - (if (numberp def) - (if (> def 2) - (setq key (substring key 0 (1- def)) - def (lookup-key map key)))) - (if (keymapp def) - (progn - (goto-char (match-beginning 0)) - (delete-region (point) (+ (point) (length key))) - (insert (quail-get-candidate def t)))))))) - -;;;###autoload -(defun vn-compose-viqr-buffer () - (interactive) - (vn-compose-viqr (point-min) (point-max))) - -;;;###autoload -(defun vn-decompose-viqr (from to) - "Convert pre-composed Vietnamese characaters of the current region to -'VIQR' mnemonics." - (interactive "r") - (let (quail-current-package decode-map key def) - (quail-use-package "viqr") - (setq decode-map (quail-decode-map)) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward "\\cv" 0 t) - (setq def (preceding-char)) - (if (setq key (assq def decode-map)) - (progn - (delete-char -1) - (insert (cdr key)))))))) - -;;;###autoload -(defun vn-decompose-viqr-buffer () - (interactive) - (vn-decompose-viqr (point-min) (point-max))) - -;;; -(provide 'viet) -(provide 'vietnamese)
--- a/lisp/mule/vietnamese-hooks-1.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -;;; vietnamese-hooks-1.el --- pre-loaded support for Vietnamese, part 1. - -;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: Mule 2.3. - -;; We have to split up the Vietnamese stuff into two files because -;; we are registering new charsets and then immediately using characters -;; from those sets. We cannot reliably expect this to work if they -;; are in the same file because of the buffering that happens while -;; reading -- the place where we use the newly-defined sets may be -;; read in before the code that creates those sets is evaluated. - -;; Vietnamese VISCII with two tables. -(make-charset 'vietnamese-lower "VISCII lower (Vietnamese)" - '(registry "VISCII1.1" - dimension 1 - chars 96 - final ?1 - graphic 1 - )) - -(make-charset 'vietnamese-upper "VISCII upper (Vietnamese)" - '(registry "VISCII1.1" - dimension 1 - chars 96 - final ?2 - graphic 1 - )) - -(modify-syntax-entry 'vietnamese-lower "w") -(modify-syntax-entry 'vietnamese-upper "w") - -(define-category ?v "Vietnamese character.") -(modify-category-entry 'vietnamese-lower ?v) -(modify-category-entry 'vietnamese-upper ?v)
--- a/lisp/mule/vietnamese-hooks-2.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,270 +0,0 @@ -;;; vietnamese-hooks-2.el --- pre-loaded support for Vietnamese, part 2. - -;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. -;; Copyright (C) 1995 Amdahl Corporation. -;; Copyright (C) 1995 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: Mule 2.3. - -;; See comment in vietnamese-hooks-1.el for why we split up the Vietnamese -;; stuff into two files. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; VIETNAMESE -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-ccl-program ccl-read-viscii - '(((read r0) - (loop - (write-read-repeat - r0 - [ 0 1 ?-2Æ 3 4 ?Ç ?ç 7 8 9 10 11 12 13 14 15-A - 16 17 18 19 ?-2Ö 21 22 23 24 ?Û 26 27 28 29 ?Ü 31-A - 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 - 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 - 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 - 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 - 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 - ?-2Õ ?¡ ?¢ ?£ ?¤ ?¥ ?¦ ?§ ?¨ ?© ?ª ?« ?¬ ? ?® ?¯-A - ?-2° ?± ?² ?µ ?þ ?¾ ?¶ ?· ?¸ ?ö ?÷ ?ï ?ü ?û ?ø ?Ï-A - ?-2õ ?-1¡ ?¢ ?£ ?¤ ?¥ ?¦ ?§ ?¨ ?© ?ª ?« ?¬ ? ?® ?¯-A - ?-1° ?± ?² ?-2Þ ?½ ?-1µ ?¶ ?· ?¸ ?-2ñ ?Ñ ?× ?Ø ?-1½ ?¾ ?-2ß-A - ?-2à ?á ?â ?ã ?ä ?å ?-1Æ ?Ç ?-2è ?é ?ê ?ë ?ì ?í ?î ?-1Ï-A - ?-2ð ?-1Ñ ?-2ò ?ó ?ô ?-1Õ ?Ö ?× ?Ø ?-2ù ?ú ?-1Û ?Ü ?-2ý ?-1Þ ?ß-A - ?-1à ?á ?â ?ã ?ä ?å ?æ ?ç ?è ?é ?ê ?ë ?ì ?í ?î ?ï-A - ?-1ð ?ñ ?ò ?ó ?ô ?õ ?ö ?÷ ?ø ?ù ?ú ?û ?ü ?ý ?þ ?-2æ ]))))-A - "CCL program to read VISCII 1.1") - -(define-ccl-program ccl-write-viscii - '(((read r0) - (loop - (if (r0 < 128) - (write-read-repeat r0) - (if (r0 != 154) - (write-read-repeat r0) - ((read-if (r0 == 163) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 - 176 177 178 0 0 181 182 183 184 0 0 0 0 189 190 0 - 0 0 0 0 0 0 198 199 0 0 0 0 0 0 0 207 - 0 209 0 0 0 213 214 215 216 0 0 219 220 0 222 223 - 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 - 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 0 - ])) - (if (r0 == 164) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 129 130 131 132 165 134 135 136 137 138 139 140 141 142 143 - 144 145 146 0 0 147 150 151 152 0 0 0 0 180 149 0 - 0 0 0 0 0 0 2 5 0 0 0 0 0 0 0 159 - 0 186 0 0 0 128 20 187 188 0 0 25 30 0 179 191 - 192 193 194 195 196 197 255 6 200 201 202 203 204 205 206 155 - 208 185 210 211 212 160 153 154 158 217 218 157 156 221 148 0 - ])) - (write-read-repeat r0))))))))) - "CCL program to write VISCII 1.1") - -(make-coding-system - 'viscii 'ccl - "Coding-system used for VISCII 1.1." - `(mnemonic "VISCII" - decode ,ccl-read-viscii - encode ,ccl-write-viscii)) - -(make-coding-system - 'viqr 'no-conversion - "Coding-system used for VIQR." - '(mnemonic "VIQR" - eol-type lf - post-read-conversion vn-compose-viqr - pre-write-conversion vn-decompose-viqr)) - -(define-ccl-program ccl-read-vscii - '(((read r0) - (loop - (write-read-repeat r0 - [0 ?-2ú ?ø 3 ?× ?Ø ?æ 7 8 9 10 11 12 13 14 15-A - 16 ?-2Ñ ?ß ?Ï ?Ö ?Û ?ý ?Ü 24 25 26 27 28 29 30 31-A - 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 - 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 - 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 - 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 - 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 - ?-2à ?ä ?ã ?á ?Õ ?£ ?§ ?è ?ë ?¨ ?é ?© ?® ?ì ?ï ?î-A - ?-2í ?¸ ?ò ?ö ?õ ?ó ?÷ ?µ ?¶ ?· ?Þ ?¾ ?þ ?ù ?ü ?û-A - 160 ?-2å ?â ?ê ?ô ?½ ?ß ?ð ?-1å ?â ?ê ?ô ?¾ ?ù ?ð ?-2¢-A - 192 193 194 195 196 ?-1à ?ä ?ã ?á ?Õ ?-2Æ ?-1¢ ?Æ ?Ç ?¡ ?-2Ç-A - ?-2¡ ?¥ ?¦ ?ç ?¥ ?« ?-1£ ?¥ ?¦ ?ç ?¤ ?§ ?è ?-2¬ ?-1ë ?¨-A - ?-1é ?© ?« ?¬ ? ?ª ?® ?ì ?ï ?-2 ?ª ?° ?-1î ?í ?¸ ?ò-A - ?-2± ?-1ö ?õ ?ó ?÷ ?° ?± ?² ?¯ ?µ ?¶ ?· ?Þ ?¾ ?þ ?ù-A - ?-2² ?-1ü ?û ?ú ?ø ?× ?Ø ?æ ?Ñ ?ñ ?Ï ?Ö ?Û ?ý ?Ü ?-2¯]))))-A - "CCL program to read VSCII-1.") - -(define-ccl-program ccl-write-vscii - '(((read r0) - (loop - (if (r0 < 128) - (write-read-repeat r0) - (if (r0 != 154) - (write-read-repeat r0) - (read-if (r0 == 163) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 190 187 198 202 199 200 203 207 209 213 210 211 212 214 232 - 229 230 231 0 0 233 234 235 222 0 0 0 0 0 237 0 - 0 0 0 0 0 0 188 189 0 0 0 0 0 0 0 250 - 0 248 0 0 0 185 251 245 246 0 0 252 254 0 236 0 - 181 184 169 183 182 168 247 201 204 208 170 206 215 221 220 216 - 174 249 223 227 171 226 225 228 244 239 243 242 241 253 238 0 - ])) - (if (r0 == 164) - ((read r0) - (r0 -= 160) - (write-read-repeat - r0 - [ 0 192 175 133 0 196 194 134 137 139 218 197 205 217 140 255 - 219 224 240 0 0 151 152 153 145 0 0 0 0 165 155 0 - 0 0 0 0 0 0 186 191 0 0 0 0 0 0 0 19 - 0 17 0 0 0 132 20 4 5 0 0 21 23 0 154 166 - 128 131 162 130 129 161 6 195 135 138 163 136 141 144 143 142 - 167 0 146 149 164 148 147 150 2 157 1 159 158 22 156 0 - ])) - (write-read-repeat r0)))))))) - "CCL program to write VSCII-1.") - -(make-coding-system - 'vscii 'ccl - "Coding-system used for VSCII 1.1." - `(mnemonic "VSCII" - decode ,ccl-read-vscii - encode ,ccl-write-vscii)) - -(define-ccl-program ccl-vietnamese-lower-to-viscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 - 176 177 178 0 0 181 182 183 184 0 0 0 0 189 190 0 - 0 0 0 0 0 0 198 199 0 0 0 0 0 0 0 207 - 0 209 0 0 0 213 214 215 216 0 0 219 220 0 222 223 - 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 - 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 0 - ]))) - "CCL program to convert chars of 'vietnamese-lower to VISCII 1.1 font") - -(define-ccl-program ccl-vietnamese-upper-to-viscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 - 144 145 146 0 0 147 150 151 152 0 0 0 0 180 149 0 - 0 0 0 0 0 0 2 5 0 0 0 0 0 0 0 159 - 0 186 0 0 0 128 20 187 188 0 0 25 30 0 179 191 - 192 193 194 195 196 197 255 6 200 201 202 203 204 205 206 155 - 208 185 210 211 212 160 153 154 158 217 218 157 156 221 148 0 - ]))) - "CCL program to convert chars of 'vietnamese-upper to VISCII 1.1 font") - -(define-ccl-program ccl-vietnamese-lower-to-vscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 190 187 198 202 199 200 203 207 209 213 210 211 212 214 232 - 229 230 231 0 0 233 234 235 222 0 0 0 0 0 237 0 - 0 0 0 0 0 0 188 189 0 0 0 0 0 0 0 250 - 0 248 0 0 0 185 251 245 246 0 0 252 254 0 236 0 - 181 184 169 183 182 168 247 201 204 208 170 206 215 221 220 216 - 174 249 223 227 171 226 225 228 244 239 243 242 241 253 238 0 - ]))) - "CCL program to convert chars of 'vietnamese-lower to VSCII-1 font.") - -(define-ccl-program ccl-vietnamese-upper-to-vscii - '(((r1 = r1 - [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 192 175 133 0 196 194 134 137 139 218 197 205 217 140 255 - 219 224 240 0 0 151 152 153 145 0 0 0 0 165 155 0 - 0 0 0 0 0 0 186 191 0 0 0 0 0 0 0 19 - 0 17 0 0 0 132 20 4 5 0 0 21 23 0 154 166 - 128 131 162 130 129 161 6 195 135 138 163 136 141 144 143 142 - 167 0 146 149 164 148 147 150 2 157 1 159 158 22 156 0 - ]))) - "CCL program to convert chars of 'vietnamese-upper to VSCII-1 font.") - -;; For VISCII users -(set-charset-ccl-program 'vietnamese-lower ccl-vietnamese-lower-to-viscii) -(set-charset-ccl-program 'vietnamese-upper ccl-vietnamese-upper-to-viscii) -;; For VSCII users -;; (set-charset-ccl-program 'vietnamese-lower ccl-vietnamese-lower-to-vscii) -;; (set-charset-ccl-program 'vietnamese-upper ccl-vietnamese-upper-to-vscii) - -(add-hook 'quail-package-alist '("viqr" "quail-viet")) - -(define-language-environment 'vietnamese - "Vietnamese" - (lambda () - ;; For VISCII users - (set-coding-category-system 'no-conversion 'viscii) - ;; For VSCII users - ;; (setq coding-category-system 'binary 'vscii) - (set-coding-priority-list '(no-conversion)) - (set-default-buffer-file-coding-system 'viscii) - (setq-default quail-current-package (assoc "viqr" quail-package-alist))))
--- a/lisp/packages/add-log.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/add-log.el Mon Aug 13 10:03:52 2007 +0200 @@ -113,7 +113,9 @@ "Keymap for Change Log major mode.") (if change-log-mode-map nil - (setq change-log-mode-map (make-sparse-keymap))) + (setq change-log-mode-map (make-sparse-keymap)) + (define-key change-log-mode-map "\C-c\C-c" 'change-log-exit) + (define-key change-log-mode-map "\C-c\C-k" 'change-log-cancel)) (defvar change-log-time-zone-rule nil "Time zone used for calculating change log time stamps. @@ -270,6 +272,8 @@ (substring buffer-file-name (match-end 0)) (file-name-nondirectory buffer-file-name)))) + (push-window-configuration) + (if (and other-window (not (equal file-name buffer-file-name))) (find-file-other-window file-name) (find-file file-name)) @@ -387,8 +391,30 @@ (set (make-local-variable 'adaptive-fill-regexp) "\\s *") ;;(set (make-local-variable 'font-lock-defaults) ;;'(change-log-font-lock-keywords t)) + (when (boundp 'filladapt-mode) + ;; Filladapt works badly with ChangeLogs. Still, we disable it + ;; before change-log-mode-hook, so the users can override this + ;; choice. + (setq filladapt-mode nil)) (run-hooks 'change-log-mode-hook)) +(defun change-log-exit () + "Save the change-log buffer, and restores the old window configuration. +Buries the buffer." + (interactive) + (save-buffer) + (let ((buf (current-buffer))) + (pop-window-configuration) + (bury-buffer buf))) + +(defun change-log-cancel () + "Cancel the changes to change-log buffer. +This kills the buffer without saving, and restores the old window + configuration." + (interactive) + (kill-buffer (current-buffer)) + (pop-window-configuration)) + ;; It might be nice to have a general feature to replace this. The idea I ;; have is a variable giving a regexp matching text which should not be ;; moved from bol by filling. change-log-mode would set this to "^\\s *\\s(".
--- a/lisp/packages/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -1112,7 +1112,7 @@ ;;;### (autoloads (gnuserv-start gnuserv-running-p) "gnuserv" "packages/gnuserv.el") -(defcustom gnuserv-frame nil "*The frame to be used to display all edited files.\nIf nil, then a new frame is created for each file edited.\nIf t, then the currently selected frame will be used.\nIf a function, then this will be called with a symbol `x' or `tty' as the\nonly argument, and its return value will be interpreted as above." :tag "Gnuserv Frame" :type '(radio (const :tag "Create new frame each time" nil) (const :tag "Use selected frame" t) (function-item :tag "Use main Emacs frame" gnuserv-main-frame-function) (function-item :tag "Use visible frame, otherwise create new" gnuserv-visible-frame-function) (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) :group 'gnuserv) +(defcustom gnuserv-frame nil "*The frame to be used to display all edited files.\nIf nil, then a new frame is created for each file edited.\nIf t, then the currently selected frame will be used.\nIf a function, then this will be called with a symbol `x' or `tty' as the\nonly argument, and its return value will be interpreted as above." :tag "Gnuserv Frame" :type '(radio (const :tag "Create new frame each time" nil) (const :tag "Use selected frame" t) (function-item :tag "Use main Emacs frame" gnuserv-main-frame-function) (function-item :tag "Use visible frame, otherwise create new" gnuserv-visible-frame-function) (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) :group 'gnuserv :group 'frames) (autoload 'gnuserv-running-p "gnuserv" "\ Return non-nil if a gnuserv process is running from this XEmacs session." nil nil)
--- a/lisp/packages/backup-dir.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/backup-dir.el Mon Aug 13 10:03:52 2007 +0200 @@ -96,7 +96,6 @@ ;;; It does not work under ms-dos. - (byte-compiler-options (optimize t) (warnings (- free-vars)) ; Don't warn about free variables @@ -106,23 +105,42 @@ ;;; New variables affecting backup file behavior ;;; This is the only user-customizable variable for this package. ;;; -(defvar bkup-backup-directory-info nil - "Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) +(defcustom bkup-backup-directory-info nil + "*Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) If the filename to be backed up matches FILE-REGEXP, or FILE-REGEXP is t, -then BACKUP-DIR is used as the path for its backups. Directories may -begin with \"/\" to specify an absolute pathname. If BACKUP-DIR does -not exist and OPTIONS contains the symbol `ok-create', then it is created if possible. -Otherwise the usual behavior (backup in the same directory as the file) -results. If OPTIONS contains the symbol `full-path', then the full path of the file +then BACKUP-DIR is used as the path for its backups. + +Directories may begin with \"/\" to specify an absolute pathname. + +If BACKUP-DIR does not exist and OPTIONS contains the symbol `ok-create', +then it is created if possible. Otherwise the usual behavior (backup in the +same directory as the file) results. + +If OPTIONS contains the symbol `full-path', then the full path of the file being backed up is prepended to the backup file name, with each \"/\" -replaced by a \"!\". This is intended for cases where an absolute backup path -is used. If OPTIONS contains the symbol `search-upward' and the backup -directory BACKUP-DIR is a relative path, then a directory with that name is -searched for starting at the current directory and proceeding upward (.., -../.., etc) until one is found of that name or the root is reached, and if -one is found it is used as the backup directory. Finally, if no FILE-REGEXP -matches the file name being backed up, then the usual behavior results.") +replaced by a \"!\". This is intended for cases where an absolute backup +path is used. + +If OPTIONS contains the symbol `search-upward' and the backup directory +BACKUP-DIR is a relative path, then a directory with that name is searched +for starting at the current directory and proceeding upward (.., ../.., etc) +until one is found of that name, or the root is reached, and if one is found +it is used as the backup directory. + +Finally, if no FILE-REGEXP matches the file name being backed up, then the +usual behavior results. +Once you save this variable with `M-x customize-variable', +`backup-dir' will be loaded for you each time you start XEmacs." + :type '(repeat + (list (regexp :tag "File regexp") + (string :tag "Backup Dir") + (set :inline t + (const ok-create) + (const full-path) + (const search-upward)))) + :require 'backup-dir + :group 'backup) ;;; New functions ;;;
--- a/lisp/packages/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,99 +1,100 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:22 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("iswitchb" "page-ext" "time-stamp")) -(custom-put 'change-log 'custom-loads '("add-log")) -(custom-put 'filladapt 'custom-loads '("filladapt")) -(custom-put 'copyright 'custom-loads '("upd-copyr")) -(custom-put 'recent-files-menu 'custom-loads '("recent-files")) -(custom-put 'mouse 'custom-loads '("avoid")) -(custom-put 'tex 'custom-loads '("texnfo-tex")) -(custom-put 'tar 'custom-loads '("tar-mode")) -(custom-put 'etags 'custom-loads '("etags")) -(custom-put 'igrep 'custom-loads '("igrep")) -(custom-put 'menu 'custom-loads '("recent-files")) -(custom-put 'minibuffer 'custom-loads '("icomplete")) -(custom-put 'environment 'custom-loads '("gnuserv")) -(custom-put 'texinfo 'custom-loads '("texnfo-tex")) -(custom-put 'terminals 'custom-loads '("gnuserv")) -(custom-put 'auto-save 'custom-loads '("auto-save")) -(custom-put 'ispell 'custom-loads '("ispell")) -(custom-put 'mail 'custom-loads '("feedmail" "metamail" "supercite")) -(custom-put 'ps-print-face 'custom-loads '("ps-print")) -(custom-put 'crypt 'custom-loads '("crypt")) -(custom-put 'object 'custom-loads '("gopher")) -(custom-put 'man 'custom-loads '("man")) -(custom-put 'lpr 'custom-loads '("lpr")) -(custom-put 'ps-print-header 'custom-loads '("ps-print")) -(custom-put 'docs 'custom-loads '("hyper-apropos" "info" "makeinfo")) -(custom-put 'completion 'custom-loads '("completion")) -(custom-put 'tools 'custom-loads '("add-log" "autoinsert" "compile" "diff" "etags" "func-menu" "generic-sc" "hyper-apropos" "rcompile")) -(custom-put 'recent-files 'custom-loads '("recent-files")) -(custom-put 'display-time-balloon 'custom-loads '("time")) -(custom-put 'dabbrev 'custom-loads '("dabbrev")) -(custom-put 'display-time 'custom-loads '("time")) -(custom-put 'hypermedia 'custom-loads '("gopher" "metamail")) -(custom-put 'save-place 'custom-loads '("saveplace")) -(custom-put 'lisp 'custom-loads '("func-menu" "hyper-apropos")) -(custom-put 'jka-compr 'custom-loads '("jka-compr")) -(custom-put 'diff 'custom-loads '("diff")) -(custom-put 'supercite-cite 'custom-loads '("supercite")) -(custom-put 'applications 'custom-loads '("time")) -(custom-put 'paren-matching 'custom-loads '("paren")) -(custom-put 'time-stamp 'custom-loads '("time-stamp")) -(custom-put 'avoid 'custom-loads '("avoid")) -(custom-put 'help 'custom-loads '("hyper-apropos" "info" "man")) -(custom-put 'supercite 'custom-loads '("supercite")) -(custom-put 'generic-sc 'custom-loads '("generic-sc")) -(custom-put 'local 'custom-loads '("gopher")) -(custom-put 'keyboard 'custom-loads '("pending-del")) -(custom-put 'hyper-apropos-faces 'custom-loads '("hyper-apropos")) -(custom-put 'data 'custom-loads '("auto-save" "jka-compr" "saveplace" "tar-mode" "time-stamp")) -(custom-put 'ps-print 'custom-loads '("ps-print")) -(custom-put 'compression 'custom-loads '("jka-compr")) -(custom-put 'comm 'custom-loads '("gopher")) -(custom-put 'ps-print-font 'custom-loads '("ps-print")) -(custom-put 'frames 'custom-loads '("balloon-help" "desktop")) -(custom-put 'supercite-attr 'custom-loads '("supercite")) -(custom-put 'bookmarks 'custom-loads '("bookmark")) -(custom-put 'desktop 'custom-loads '("desktop")) -(custom-put 'abbrev 'custom-loads '("dabbrev")) -(custom-put 'remote-compile 'custom-loads '("rcompile")) -(custom-put 'programming 'custom-loads '("compile")) -(custom-put 'metamail 'custom-loads '("metamail")) -(custom-put 'icomplete 'custom-loads '("icomplete")) -(custom-put 'compilation 'custom-loads '("compile")) -(custom-put 'iswitchb 'custom-loads '("iswitchb")) -(custom-put 'makeinfo 'custom-loads '("makeinfo")) -(custom-put 'fume 'custom-loads '("func-menu")) -(custom-put 'auto-insert 'custom-loads '("autoinsert")) -(custom-put 'files 'custom-loads '("auto-save" "recent-files")) -(custom-put 'fast-lock 'custom-loads '("fast-lock")) -(custom-put 'gnuserv 'custom-loads '("gnuserv")) -(custom-put 'ps-print-horizontal 'custom-loads '("ps-print")) -(custom-put 'maint 'custom-loads '("add-log" "upd-copyr")) -(custom-put 'fill 'custom-loads '("filladapt")) -(custom-put 'balloon-help 'custom-loads '("balloon-help")) -(custom-put 'supercite-hooks 'custom-loads '("supercite")) -(custom-put 'texinfo-tex 'custom-loads '("texnfo-tex")) -(custom-put 'faces 'custom-loads '("fast-lock" "hyper-apropos" "ps-print")) -(custom-put 'pages 'custom-loads '("page-ext")) -(custom-put 'supercite-frames 'custom-loads '("supercite")) -(custom-put 'feedmail 'custom-loads '("feedmail")) -(custom-put 'processes 'custom-loads '("compile" "gnuserv" "igrep" "ispell" "metamail" "rcompile")) -(custom-put 'news 'custom-loads '("supercite")) -(custom-put 'hyper-apropos 'custom-loads '("hyper-apropos")) -(custom-put 'wp 'custom-loads '("lpr" "ps-print")) -(custom-put 'ps-print-vertical 'custom-loads '("ps-print")) -(custom-put 'gopher 'custom-loads '("gopher")) -(custom-put 'editing 'custom-loads '("bookmark")) -(custom-put 'matching 'custom-loads '("paren" "completion" "hyper-apropos")) -(custom-put 'ps-print-color 'custom-loads '("ps-print")) -(custom-put 'info 'custom-loads '("info")) -(custom-put 'unix 'custom-loads '("tar-mode")) -(custom-put 'c 'custom-loads '("func-menu")) +(custom-add-loads 'extensions '("iswitchb" "page-ext" "time-stamp")) +(custom-add-loads 'change-log '("add-log")) +(custom-add-loads 'filladapt '("filladapt")) +(custom-add-loads 'copyright '("upd-copyr")) +(custom-add-loads 'info-faces '("info")) +(custom-add-loads 'recent-files-menu '("recent-files")) +(custom-add-loads 'mouse '("avoid")) +(custom-add-loads 'tex '("texnfo-tex")) +(custom-add-loads 'tar '("tar-mode")) +(custom-add-loads 'etags '("etags")) +(custom-add-loads 'igrep '("igrep")) +(custom-add-loads 'menu '("recent-files")) +(custom-add-loads 'minibuffer '("icomplete")) +(custom-add-loads 'environment '("gnuserv")) +(custom-add-loads 'texinfo '("texnfo-tex")) +(custom-add-loads 'terminals '("gnuserv")) +(custom-add-loads 'auto-save '("auto-save")) +(custom-add-loads 'ispell '("ispell")) +(custom-add-loads 'mail '("feedmail" "metamail" "supercite")) +(custom-add-loads 'ps-print-face '("ps-print")) +(custom-add-loads 'crypt '("crypt")) +(custom-add-loads 'object '("gopher")) +(custom-add-loads 'man '("man")) +(custom-add-loads 'lpr '("lpr")) +(custom-add-loads 'ps-print-header '("ps-print")) +(custom-add-loads 'docs '("hyper-apropos" "info" "makeinfo")) +(custom-add-loads 'completion '("completion")) +(custom-add-loads 'tools '("add-log" "autoinsert" "compile" "diff" "etags" "func-menu" "generic-sc" "hyper-apropos" "rcompile")) +(custom-add-loads 'recent-files '("recent-files")) +(custom-add-loads 'display-time-balloon '("time")) +(custom-add-loads 'dabbrev '("dabbrev")) +(custom-add-loads 'display-time '("time")) +(custom-add-loads 'hypermedia '("gopher" "metamail")) +(custom-add-loads 'save-place '("saveplace")) +(custom-add-loads 'lisp '("func-menu" "hyper-apropos")) +(custom-add-loads 'jka-compr '("jka-compr")) +(custom-add-loads 'diff '("diff")) +(custom-add-loads 'supercite-cite '("supercite")) +(custom-add-loads 'applications '("time")) +(custom-add-loads 'paren-matching '("paren")) +(custom-add-loads 'time-stamp '("time-stamp")) +(custom-add-loads 'avoid '("avoid")) +(custom-add-loads 'help '("hyper-apropos" "info" "man")) +(custom-add-loads 'supercite '("supercite")) +(custom-add-loads 'generic-sc '("generic-sc")) +(custom-add-loads 'local '("gopher")) +(custom-add-loads 'keyboard '("pending-del")) +(custom-add-loads 'hyper-apropos-faces '("hyper-apropos")) +(custom-add-loads 'data '("auto-save" "jka-compr" "saveplace" "tar-mode" "time-stamp")) +(custom-add-loads 'ps-print '("ps-print")) +(custom-add-loads 'compression '("jka-compr")) +(custom-add-loads 'comm '("gopher")) +(custom-add-loads 'ps-print-font '("ps-print")) +(custom-add-loads 'backup '("backup-dir")) +(custom-add-loads 'frames '("gnuserv" "balloon-help" "desktop")) +(custom-add-loads 'supercite-attr '("supercite")) +(custom-add-loads 'bookmarks '("bookmark")) +(custom-add-loads 'desktop '("desktop")) +(custom-add-loads 'abbrev '("dabbrev")) +(custom-add-loads 'remote-compile '("rcompile")) +(custom-add-loads 'programming '("compile")) +(custom-add-loads 'metamail '("metamail")) +(custom-add-loads 'icomplete '("icomplete")) +(custom-add-loads 'compilation '("compile")) +(custom-add-loads 'iswitchb '("iswitchb")) +(custom-add-loads 'makeinfo '("makeinfo")) +(custom-add-loads 'fume '("func-menu")) +(custom-add-loads 'auto-insert '("autoinsert")) +(custom-add-loads 'files '("recent-files")) +(custom-add-loads 'fast-lock '("fast-lock")) +(custom-add-loads 'gnuserv '("gnuserv")) +(custom-add-loads 'ps-print-horizontal '("ps-print")) +(custom-add-loads 'maint '("add-log" "upd-copyr")) +(custom-add-loads 'fill '("filladapt")) +(custom-add-loads 'balloon-help '("balloon-help")) +(custom-add-loads 'supercite-hooks '("supercite")) +(custom-add-loads 'texinfo-tex '("texnfo-tex")) +(custom-add-loads 'faces '("fast-lock" "hyper-apropos" "info" "ps-print")) +(custom-add-loads 'pages '("page-ext")) +(custom-add-loads 'supercite-frames '("supercite")) +(custom-add-loads 'feedmail '("feedmail")) +(custom-add-loads 'processes '("compile" "gnuserv" "igrep" "ispell" "metamail" "rcompile")) +(custom-add-loads 'news '("supercite")) +(custom-add-loads 'hyper-apropos '("hyper-apropos")) +(custom-add-loads 'wp '("lpr" "ps-print")) +(custom-add-loads 'ps-print-vertical '("ps-print")) +(custom-add-loads 'gopher '("gopher")) +(custom-add-loads 'editing '("bookmark")) +(custom-add-loads 'matching '("paren" "completion" "hyper-apropos")) +(custom-add-loads 'ps-print-color '("ps-print")) +(custom-add-loads 'info '("info")) +(custom-add-loads 'unix '("tar-mode")) +(custom-add-loads 'c '("func-menu")) ;;; custom-load.el ends here
--- a/lisp/packages/etags.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/etags.el Mon Aug 13 10:03:52 2007 +0200 @@ -1061,7 +1061,7 @@ (defun emacs-lisp-default-tag () "Function to return a default tag for Emacs-Lisp mode." (let ((tag (or (variable-at-point) - (function-called-at-point)))) + (function-at-point)))) (if tag (symbol-name tag))))
--- a/lisp/packages/gnuserv.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/gnuserv.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,7 +1,7 @@ ;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv ;; Copyright (C) 1989-1997 Free Software Foundation, Inc. -;; Version: 3.9 +;; Version: 3.10 ;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el ;; Hrvoje Niksic <hniksic@srce.hr> ;; Maintainer: Jan Vroonhof <vroonhof@math.ethz.ch>, @@ -58,10 +58,11 @@ ;; gnudoit and gnuserv, distributed with XEmacs. ;; gnuserv.el was originally written by Andy Norman as an improvement -;; over William Sommerfeld's server.el. Since then, a number of people -;; have worked on it, including Bob Weiner, Darell Kindred, Arup -;; Mukherjee, Ben Wing and Jan Vroonhof. It was completely rewritten -;; (labeled as version 3) by Hrvoje Niksic in May 1997. +;; over William Sommerfeld's server.el. Since then, a number of +;; people have worked on it, including Bob Weiner, Darell Kindred, +;; Arup Mukherjee, Ben Wing and Jan Vroonhof. It was completely +;; rewritten (labeled as version 3) by Hrvoje Niksic in May 1997. The +;; new code will not run on GNU Emacs. ;; Jan Vroonhof <vroonhof@math.ethz.ch> July/1996 ;; ported the server-temp-file-regexp feature from server.el @@ -131,7 +132,16 @@ (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) - :group 'gnuserv) + :group 'gnuserv + :group 'frames) + +(defcustom gnuserv-frame-plist nil + "*Plist of frame properties for creating a gnuserv frame." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'gnuserv + :group 'frames) (defcustom gnuserv-done-function 'kill-buffer "*Function used to remove a buffer after editing. @@ -281,7 +291,7 @@ (defun gnuserv-special-frame-function (type) "Creates a special frame for Gnuserv and returns it on later invocations." (unless (frame-live-p gnuserv-special-frame) - (setq gnuserv-special-frame (make-frame))) + (setq gnuserv-special-frame (make-frame gnuserv-frame-plist))) gnuserv-special-frame) @@ -406,7 +416,9 @@ (dest-frame (if (functionp gnuserv-frame) (funcall gnuserv-frame (car type)) gnuserv-frame)) - ;; The gnuserv-frame dependencies are ugly. + ;; The gnuserv-frame dependencies are ugly, but it's + ;; extremely hard to make that stuff cleaner without + ;; breaking everything in sight. (device (cond ((frame-live-p dest-frame) (frame-device dest-frame)) ((null dest-frame) @@ -419,7 +431,8 @@ (frame (cond ((frame-live-p dest-frame) dest-frame) ((null dest-frame) - (setq new-frame (make-frame nil device)) + (setq new-frame (make-frame gnuserv-frame-plist + device)) new-frame) (t (selected-frame)))) (client (make-gnuclient :id gnuserv-current-client
--- a/lisp/packages/hyper-apropos.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/hyper-apropos.el Mon Aug 13 10:03:52 2007 +0200 @@ -533,7 +533,7 @@ (let ((fn (hyper-apropos-this-symbol)) val) (or (fboundp fn) - (setq fn (function-called-at-point))) + (setq fn (function-at-point))) (setq val (let ((enable-recursive-minibuffers t)) (completing-read (if fn (format "%s (default %s): " prompt fn)
--- a/lisp/packages/info.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/info.el Mon Aug 13 10:03:52 2007 +0200 @@ -311,6 +311,11 @@ :group 'help :group 'docs) +(defgroup info-faces nil + "The faces used by info browser." + :group 'info + :group 'faces) + (defcustom Info-inhibit-toolbar nil "*Non-nil means don't use the specialized Info toolbar." @@ -408,6 +413,14 @@ :type 'regexp :group 'info) +(defface info-node '((t (:bold t :italic t))) + "Face used for node links in info." + :group 'info-faces) + +(defface info-xref '((t (:bold t))) + "Face used for cross-references in info." + :group 'info-faces) + ;; Is this right for NT? .zip, with -c for to stdout, right? (defvar Info-suffix-list '( ("" . nil) (".info" . nil) @@ -916,6 +929,9 @@ (while buffers (kill-buffer (car buffers)) (setq buffers (cdr buffers))) + (while lbuffers + (kill-buffer (car lbuffers)) + (setq lbuffers (cdr lbuffers))) (message "Composing main Info directory...done")) (setq Info-dir-contents (buffer-string))) (setq default-directory Info-dir-contents-directory) @@ -2429,18 +2445,7 @@ (make-local-variable 'Info-current-annotation-completions) (make-local-variable 'Info-index-alternatives) (make-local-variable 'Info-history) - (if t ;; XEmacs: remove v19 test - (progn - (or (and (fboundp 'find-face) (find-face 'info-node)) - (make-face 'info-node "used for node links in info")) - (or (and (fboundp 'find-face) (find-face 'info-xref)) - (make-face 'info-xref "used for cross-references in info")) - (or (face-differs-from-default-p 'info-node) - (if (face-differs-from-default-p 'bold-italic) - (copy-face 'bold-italic 'info-node) - (copy-face 'bold 'info-node))) - (or (face-differs-from-default-p 'info-xref) - (copy-face 'bold 'info-xref)))) + ;; Faces are now defined by `defface'... (make-local-variable 'mouse-track-click-hook) (add-hook 'mouse-track-click-hook 'Info-maybe-follow-clicked-node) (add-hook 'mouse-track-click-hook 'Info-mouse-track-double-click-hook)
--- a/lisp/packages/jka-compr.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/jka-compr.el Mon Aug 13 10:03:52 2007 +0200 @@ -139,7 +139,11 @@ ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'" "zipping" "gzip" ("-c" "-q") "unzipping" "gzip" ("-c" "-q" "-d") - t t]) + t t] + ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'" + "bzipping" "bzip2" ("-f") + "unbzipping" "bzip2" ("-d") + nil t]) "List of vectors that describe available compression techniques. Each element, which describes a compression technique, is a vector of @@ -164,8 +168,8 @@ uncompress-args is a list of args to pass to the uncompress program - append-flag is non-nil if this compression technique can be - appended + append-flag is non-nil if files compressed with this technique can + be appended to without decompressing them first. auto-mode flag non-nil means strip the regexp from file names before attempting to set the mode.
--- a/lisp/packages/man.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/packages/man.el Mon Aug 13 10:03:52 2007 +0200 @@ -202,7 +202,7 @@ (let ((bufname (concat "Man" (when apropos-mode " apropos") ": " topic - (when section (concat "(" section ")") ""))) + (when section (concat "(" section ")")))) (temp-buffer-show-function (cond ((eq 't Manual-buffer-view-mode) 'view-buffer)
--- a/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 10:03:52 2007 +0200 @@ -42,6 +42,7 @@ ["Diff against Repository" cvs-mode-diff-cvs t] ["Diff against Backup Version" cvs-mode-diff-backup t] "----" + ["Update sources from Repository" cvs-mode-update-no-prompt t] ["Commit Changes to Repository" cvs-mode-commit t] ["Revert File from Repository" cvs-mode-undo-local-changes t] ["Add File to Repository" cvs-mode-add t]
--- a/lisp/pcl-cvs/pcl-cvs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/pcl-cvs/pcl-cvs.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,10 +1,10 @@ ;;; ;;;#ident "@(#)OrigId: pcl-cvs.el,v 1.93 1993/05/31 22:44:00 ceder Exp " ;;; -;;;#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-3b28 $:$Id: pcl-cvs.el,v 1.6 1997/10/12 01:39:46 steve Exp $" +;;;#ident "@(#)cvs/contrib/pcl-cvs:$Name: r20-4b2 $:$Id: pcl-cvs.el,v 1.7 1997/10/31 14:53:04 steve Exp $" ;;; ;;; pcl-cvs.el -- A Front-end to CVS 1.3 or later. -;;; Release 1.05-CVS-$Name: r20-3b28 $. +;;; Release 1.05-CVS-$Name: r20-4b2 $. ;;; Copyright (C) 1991, 1992, 1993 Per Cederqvist ;;; This program is free software; you can redistribute it and/or modify @@ -126,7 +126,7 @@ ;;; END OF THINGS TO CHECK WHEN INSTALLING ;;; -------------------------------------------------------- -(defconst pcl-cvs-version "1.05-CVS-$Name: r20-3b28 $" +(defconst pcl-cvs-version "1.05-CVS-$Name: r20-4b2 $" "A string denoting the current release version of pcl-cvs.") ;; You are NOT allowed to disable this message by default. However, you @@ -139,8 +139,8 @@ (defconst cvs-startup-message (if cvs-inhibit-copyright-message - "PCL-CVS release 1.05-CVS-$Name: r20-3b28 $" - "PCL-CVS release 1.05 from CVS release $Name: r20-3b28 $. + "PCL-CVS release 1.05-CVS-$Name: r20-4b2 $" + "PCL-CVS release 1.05 from CVS release $Name: r20-4b2 $. Copyright (C) 1992, 1993 Per Cederqvist Pcl-cvs comes with absolutely no warranty; for details consult the manual. This is free software, and you are welcome to redistribute it under certain @@ -727,7 +727,7 @@ \\[cvs-mode-undo-local-changes] Revert the last checked in version - discard your changes to the file. Entry to this mode runs cvs-mode-hook. -This description is updated for release 1.05-CVS-$Name: r20-3b28 $ of pcl-cvs. +This description is updated for release 1.05-CVS-$Name: r20-4b2 $ of pcl-cvs. All bindings: \\{cvs-mode-map}" @@ -1016,7 +1016,7 @@ (insert "Pcl-cvs Version: " "@(#)OrigId: pcl-cvs.el,v 1.93 1993/05/31 22:44:00 ceder Exp\n") (insert "CVS Version: " - "@(#)lisp/pcl-cvs:$Name: r20-3b28 $:$Id: pcl-cvs.el,v 1.6 1997/10/12 01:39:46 steve Exp $\n\n") + "@(#)lisp/pcl-cvs:$Name: r20-4b2 $:$Id: pcl-cvs.el,v 1.7 1997/10/31 14:53:04 steve Exp $\n\n") (insert (format "--- Contents of stdout buffer (%d chars) ---\n" (length stdout))) (insert stdout) @@ -1469,6 +1469,10 @@ "^$") (forward-line 1)) + ((looking-at + "^Executing ssh-askpass to query the password") + (forward-line 1)) + ;; top-level parser (cond) default clause (t
--- a/lisp/pcl-cvs/string.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,160 +0,0 @@ -;;;; $Id: string.el,v 1.1.1.1 1996/12/18 22:42:58 steve Exp $ -;;;; This file contains some miscellaneous string functions - -;; Copyright (C) 1991-1995 Free Software Foundation - -;; Author: Sebastian Kremer <sk@thp.Uni-Koeln.DE> -;; Per Cederqvist <ceder@lysator.liu.se> -;; Inge Wallin <inge@lysator.liu.se> -;; Maintainer: elib-maintainers@lysator.liu.se -;; Created: before 9 May 1991 -;; Keywords: extensions, lisp - -;;;; This file is part of the GNU Emacs lisp library, Elib. -;;;; -;;;; GNU Elib 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. -;;;; -;;;; GNU Elib 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 GNU Elib; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;;;; Boston, MA 02111-1307, USA -;;;; -;;;; Author: Sebastian Kremer -;;;; sk@thp.Uni-Koeln.DE -;;;; - - -;;; Commentary: - -;;; -;;; This file is part of the elisp library Elib. -;;; It implements simple generic string functions for use in other -;;; elisp code: replace regexps in strings, split strings on regexps. -;;; - - -;;; Code: - -(provide 'string) - - -;; This function is a near-equivalent of the elisp function replace-match -;; which work on strings instead of a buffer. The FIXEDCASE parameter -;; of replace-match is not implemented. - -(defun string-replace-match (regexp string newtext &optional literal global) - "Replace first match of REGEXP in STRING with NEWTEXT. -If no match is found, nil is returned instead of the new string. - -Optional arg LITERAL non-nil means to take NEWTEXT literally. If LITERAL is -nil, character `\\' is the start of one of the following sequences: - \\\\ will be replaced by a single \\. - \\& will be replaced by the text which matched the regexp. - \\N where N is a number and 1 <= N <= 9, will be replaced - by the Nth subexpression in REGEXP. Subexpressions are grouped - inside \\( \\). - -Optional arg GLOBAL means to replace all matches instead of only the first." - - (let ((data (match-data))) - (unwind-protect - - (if global - (let ((result "") - (start 0) - matchbeginning - matchend) - (while (string-match regexp string start) - (setq matchbeginning (match-beginning 0) - matchend (match-end 0) - result (concat result - (substring string start matchbeginning) - (if literal - newtext - (elib-string-expand-newtext))) - start matchend)) - - (if matchbeginning ; matched at least once - (concat result (substring string start)) - nil)) - - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (elib-string-expand-newtext)) - (substring string (match-end 0))))) - (store-match-data data)))) - - -(defun elib-string-expand-newtext () - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT. - ;; Uses match data and fluid vars `newtext', `string'. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) - (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - - -(defun string-split (pattern string &optional limit) - "Splitting on regexp PATTERN, turn string STRING into a list of substrings. -Optional third arg LIMIT (>= 1) is a limit to the length of the -resulting list." - - (let ((data (match-data))) - (unwind-protect - (let* ((start (string-match pattern string)) - (result (list (substring string 0 start))) - (count 1) - (end (if start (match-end 0)))) - (if end ; else nothing left - (while (and (or (not (integerp limit)) - (< count limit)) - (string-match pattern string end)) - (setq start (match-beginning 0) - count (1+ count) - result (cons (substring string end start) result) - end (match-end 0) - start end))) - (if (and (or (not (integerp limit)) - (< count limit)) - end) ; else nothing left - (setq result - (cons (substring string end) result))) - (nreverse result)) - (store-match-data data)))) - -;;; string.el ends here
--- a/lisp/prim/about.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/about.el Mon Aug 13 10:03:52 2007 +0200 @@ -69,17 +69,20 @@ (kazz "IENAGA Kazuyuki" "ienaga@jsys.co.jp") (kyle "Kyle Jones" "kyle_jones@wonderworks.com") (larsi "Lars Magne Ingebrigtsen" "larsi@gnus.org") + (marcpa "Marc Paquette" "marcpa@CAM.ORG") (mly "Richard Mlynarik" "mly@adoc.xerox.com") (morioka "MORIOKA Tomohiko" "morioka@jaist.ac.jp") (mrb "Martin Buchholz" "mrb@sun.eng.com") + (ograf "Oliver Graf" "ograf@fga.de") (pez "Peter Pezaris" "pez@dwwc.com") (piper "Andy Piper" "andy@parallax.co.uk") (rickc "Rick Campbell" "rickc@lehman.com") (rossini "Anthony Rossini" "rossini@stat.sc.edu") - (shelton "Vin Shelton" "acs@acm.org") + (vin "Vin Shelton" "acs@acm.org") (sperber "Michael Sperber" "sperber@informatik.uni-tuebingen.de") (slb "SL Baur" "steve@xemacs.org") (stig "Jonathan Stigelman" "stig@hackvan.com") + (stigb "Stig Bjorlykke" "stigb@tihlde.hist.no") (thiessel "Marcus Thiessel" "thiessel@rhrk.uni-kl.de") (vladimir "Vladimir Ivanovic" "vladimir@mri.com") (wing "Ben Wing" "wing@xemacs.org") @@ -100,8 +103,11 @@ (kazz . "http://www.imasy.or.jp/~kazz/") (kyle . "http://www.wonderworks.com/kyle/") (larsi . "http://www.ifi.uio.no/~larsi/") + (marcpa . "http://www.positron911.com/products/power.htm") + (ograf . "http://www.fga.de/~ograf/") (pez . "http://www.dwwc.com/") - (shelton . "http://www.upa.org/") + (vin . "http://www.upa.org/") + (stigb . "http://www.tihlde.hist.no/~stigb/") (wget . "ftp://gnjilux.cc.fer.hr/pub/unix/util/wget/") (xemacs . "http://www.xemacs.org/")) "Some of the more important URLs.") @@ -157,7 +163,7 @@ "Remove") (widget-create 'link :help-echo "Kill buffer" :action (lambda (&rest ignore) - (bury-buffer)) + (kill-buffer (current-buffer))) "Kill")) (widget-insert " this buffer.\n") (use-local-map (make-sparse-keymap)) @@ -512,7 +518,7 @@ '(color grayscale)) "" "m") ".xpm") - data-directory)) + (locate-data-directory "photos"))) (data nil)) (unless (file-exists-p file) ;; Maybe the file is compressed? @@ -668,6 +674,14 @@ Stig likes to perch, hang from the ceiling, and climb on the walls. Stig has a cool van. Stig would like to be able to telecommute from, say, the north rim of the Grand Canyon or the midst of Baja.\n")) + (stigb + (widget-insert "\ +Currently studying computer science in Trondheim, Norway. Full time +Linux user and proud of it. XEmacs hacker light. Maintainer of the +RPM package. + +See:\t") + (about-url-link 'stigb "Visit Stig's home page")) (baw (widget-insert "\ @@ -738,6 +752,19 @@ See ") (about-url-link 'larsi "Visit the Larsissistic pages") (widget-insert ".\n")) + (marcpa + (widget-insert "\ +I work for Positron Industries Inc., Public Safety Division. +I'm part of the team producing POWER 911, a 911 emergency response +system written in Modula3:\n") + (about-url-link 'marcpa "Visit POWER 911") + (widget-insert "\ +Previously, I worked at Softimage Inc., now a Microsoft company +(eeekkk!), as a UNIX system administrator. This is where I've been +converted to NT. + +In a previous life, I was a programmer/sysadmin at CRIM (Centre de +Recherche Informatique de Montreal) for the speech recognition group.\n")) (jens (widget-insert "\ Jens did the artwork for graphics added to XEmacs 20.2 and 19.15. @@ -799,7 +826,7 @@ installed or changing his hairstyle, he does research in modern programming languages and their implementation, and hopes that one day XEmacs will speak Scheme.\n")) - (shelton + (vin (widget-insert "\ Vin maintains the XEmacs patch pages in order to bring a more stable XEmacs. (Actually, he does it 'cause it's fun and he's been @@ -813,7 +840,7 @@ to play competitive Ultimate any more, so now I've gotten roped into serving on the board of directors of the Ultimate Players Association. See ") - (about-url-link 'shelton "Visit the UPA homepage") + (about-url-link 'vin "Visit the UPA homepage") (widget-insert ".\n")) (ajc (widget-insert "\ @@ -890,6 +917,25 @@ language/package one might want. In spare time, acts as a Ph.D. (bio)statistician for money and amusement. Current position: Assistant Professor of Statistics at the University of South Carolina.\n")) + (ograf + (widget-insert "\ +I'm a student of computer sciences at the University of Koblenz. My +major is computational linguistics (human language generation and +analysis). + +I make my living as a managing director of a small but fine company +which I started two years ago with one of my friends. We provide +business network solutions based on linux servers and various other +networking products. + +Most of my spare time I spent on the development of the XEmacs DnD +events, a enhanced version of Tk called TkStep (better looks, DnD, +and more), and various other minor hacks: ISDN-tools, cd players, +python, etc... + +To see some of these have a look at ") + (about-url-link 'ograf "one of my homepages") + (widget-insert ".\n")) )) @@ -1060,11 +1106,13 @@ Otherwise, I'm, say, 35.82% professional Jazz guitar player, which means that's not the way I earn my crust, but things may very well reverse in the future ...\n") + (about-show-linked-info 'marcpa "\ +I work for Positron Industries Inc., Public Safety Division.\n") (about-show-linked-info 'pez "\ Author of SQL Mode, edit-toolbar, mailtool-mode, and various other small packages with varying degrees of usefulness.\n") (about-show-linked-info 'rickc "\ -The hacker formerly known as Rick Busdiecker, author of ILISP.\n") +The hacker formerly known as Rick Busdiecker, maintainer of ILISP.\n") (about-show-linked-info 'rossini "\ Author of the first XEmacs FAQ, as well as minor priest in the movement to get every statistician in the world to use XEmacs for @@ -1074,7 +1122,14 @@ XLispStat; configurable for nearly any other statistical language/package one might want. In spare time, acts as a Ph.D. (bio)statistician for money and amusement. Current position: -Assistant Professor of Statistics at the University of South Carolina.") +Assistant Professor of Statistics at the University of South Carolina.\n") + (about-show-linked-info 'stigb "\ +Currently studying computer science in Trondheim, Norway. Full time +Linux user and proud of it. XEmacs hacker light. Maintainer of the +RPM package.\n") + (about-show-linked-info 'ograf "\ +Is currently working on the integration of OffiX and CDE drag-and-drop +into the event system of XEmacs.\n") (flet ((print-short (name addr &optional shortinfo) (concat (about-with-face name 'italic) (about-tabs name) @@ -1273,7 +1328,6 @@ (print-short "Achim Oppelt" "aoppelt@theorie3.physik.uni-erlangen.de") (print-short "Rebecca Ore" "rebecca.ore@op.net") (print-short "Sudeep Kumar Palat" "palat@idt.unit.no") - (print-short "Marc Paquette" "Marc.Paquette@Softimage.com") (print-short "Jens-U H Petersen" "petersen@kurims.kyoto-u.ac.jp") (print-short "Joel Peterson" "tarzan@aosi.com") (print-short "Thomas A. Peterson" "tap@src.honeywell.com") @@ -1299,9 +1353,9 @@ (print-short "Cotton Seed" "cottons@cybercom.net") (print-short "Axel Seibert" "seiberta@informatik.tu-muenchen.de") (print-short "Odd-Magne Sekkingstad" "oddms@ii.uib.no") - (print-short "Vinnie Shelton" "shelton@icd.teradyne.com") (print-short "John Shen" "zfs60@cas.org") (print-short "Murata Shuuichirou" "mrt@mickey.ai.kyutech.ac.jp") + (print-short "Matt Simmons" "simmonmt@acm.org") (print-short "Dinesh Somasekhar" "somasekh@ecn.purdue.edu") (print-short "Jeffrey Sparkes" "jsparkes@bnr.ca") (print-short "Manoj Srivastava" "srivasta@pilgrim.umass.edu") @@ -1314,6 +1368,7 @@ (print-short "Raymond L. Toy" "toy@rtp.ericsson.se") (print-short "Remek Trzaska" "remek@npac.syr.edu") (print-short "TSUTOMU Nakamura" "tsutomu@rs.kyoto.omronsoft.co.jp") + (print-short "Stephen Turnbull" "turnbull@sk.tsukuba.ac.jp") (print-short "John Turner" "turner@xdiv.lanl.gov") (print-short "UENO Fumihiro" "7m2vej@ritp.ye.IHI.CO.JP") (print-short "Juan E. Villacis" "jvillaci@cs.indiana.edu")
--- a/lisp/prim/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -126,7 +126,7 @@ Find the definition of the function near point in the current window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -137,7 +137,7 @@ Find the definition of the function near point in the other window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -148,7 +148,7 @@ Find the definition of the function near point in the another frame. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -300,9 +300,9 @@ ;;;*** -;;;### (autoloads (profile-key-sequence profile profiling-results) "profile" "prim/profile.el") +;;;### (autoloads (profile-key-sequence profile profile-results) "profile" "prim/profile.el") -(autoload 'profiling-results "profile" "\ +(autoload 'profile-results "profile" "\ Print profiling info INFO to STREAM in a pretty format. If INFO is omitted, the current profiling info is retrieved using `get-profiling-info'.
--- a/lisp/prim/cmdloop.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/cmdloop.el Mon Aug 13 10:03:52 2007 +0200 @@ -88,10 +88,14 @@ nil) ((region-active-p) (zmacs-deactivate-region)) + ((> (recursion-depth) 0) + (exit-recursive-edit)) (buffer-quit-function (funcall buffer-quit-function)) ((not (one-window-p t)) - (delete-other-windows)))) + (delete-other-windows)) + ((string-match "^ \\*" (buffer-name (current-buffer))) + (bury-buffer)))) ;;#### This should really be a ring of last errors. (defvar last-error nil
--- a/lisp/prim/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,39 +1,38 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:25 1997 ;;; Code: -(custom-put 'mouse 'custom-loads '("mouse")) -(custom-put 'minibuffer 'custom-loads '("simple" "minibuf")) -(custom-put 'log-message 'custom-loads '("simple")) -(custom-put 'environment 'custom-loads '("frame" "minibuf" "modeline" "sound")) -(custom-put 'sound 'custom-loads '("sound")) -(custom-put 'auto-save 'custom-loads '("files")) -(custom-put 'mail 'custom-loads '("simple")) -(custom-put 'editing-basics 'custom-loads '("cmdloop" "simple" "files" "lisp")) -(custom-put 'help-appearance 'custom-loads '("help")) -(custom-put 'lisp 'custom-loads '("lisp" "find-func")) -(custom-put 'help 'custom-loads '("help")) -(custom-put 'keyboard 'custom-loads '("cmdloop")) -(custom-put 'warnings 'custom-loads '("simple")) -(custom-put 'backup 'custom-loads '("files")) -(custom-put 'frames 'custom-loads '("frame" "window-xemacs" "gui")) -(custom-put 'abbrev 'custom-loads '("files")) -(custom-put 'find-function 'custom-loads '("find-func")) -(custom-put 'dired 'custom-loads '("files")) -(custom-put 'killing 'custom-loads '("simple")) -(custom-put 'paren-blinking 'custom-loads '("simple")) -(custom-put 'find-file 'custom-loads '("files")) -(custom-put 'files 'custom-loads '("files")) -(custom-put 'fill-comments 'custom-loads '("simple")) -(custom-put 'windows 'custom-loads '("window" "window-xemacs")) -(custom-put 'fill 'custom-loads '("simple")) -(custom-put 'faces 'custom-loads '("faces")) -(custom-put 'vc 'custom-loads '("files")) -(custom-put 'isearch 'custom-loads '("isearch-mode")) -(custom-put 'modeline 'custom-loads '("modeline")) -(custom-put 'editing 'custom-loads '("simple")) -(custom-put 'matching 'custom-loads '("simple" "isearch-mode")) +(custom-add-loads 'mouse '("mouse")) +(custom-add-loads 'minibuffer '("simple" "minibuf")) +(custom-add-loads 'log-message '("simple")) +(custom-add-loads 'environment '("frame" "minibuf" "modeline" "sound")) +(custom-add-loads 'sound '("sound")) +(custom-add-loads 'auto-save '("files")) +(custom-add-loads 'mail '("simple")) +(custom-add-loads 'editing-basics '("cmdloop" "simple" "files" "lisp")) +(custom-add-loads 'help-appearance '("help")) +(custom-add-loads 'lisp '("lisp" "find-func")) +(custom-add-loads 'help '("help")) +(custom-add-loads 'keyboard '("cmdloop")) +(custom-add-loads 'warnings '("simple")) +(custom-add-loads 'backup '("files")) +(custom-add-loads 'frames '("frame" "window-xemacs" "gui")) +(custom-add-loads 'abbrev '("files")) +(custom-add-loads 'find-function '("find-func")) +(custom-add-loads 'dired '("files")) +(custom-add-loads 'killing '("simple")) +(custom-add-loads 'paren-blinking '("simple")) +(custom-add-loads 'find-file '("files")) +(custom-add-loads 'files '("files")) +(custom-add-loads 'fill-comments '("simple")) +(custom-add-loads 'windows '("window" "window-xemacs")) +(custom-add-loads 'fill '("simple")) +(custom-add-loads 'faces '("faces")) +(custom-add-loads 'vc '("files")) +(custom-add-loads 'isearch '("isearch-mode")) +(custom-add-loads 'modeline '("modeline")) +(custom-add-loads 'editing '("simple")) +(custom-add-loads 'matching '("simple" "isearch-mode")) ;;; custom-load.el ends here
--- a/lisp/prim/dumped-lisp.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/dumped-lisp.el Mon Aug 13 10:03:52 2007 +0200 @@ -50,6 +50,7 @@ ; `emacs-user-extension-dir' "misc" ;; (load-gc "profile") + #-mule "help-nomule" "help" ;; (load-gc "hyper-apropos") Soon... #-mule "files-nomule" @@ -111,6 +112,7 @@ #+mule "mule-files" ;; Handle process with encoding/decoding non-ascii coding-system. #+mule "mule-process" + #+mule "mule-help" ;; Load the remaining basic files. #+mule "mule-category" #+mule "mule-ccl" @@ -139,16 +141,20 @@ #+mule "language/chinese" #+mule "language/cyrillic" #+mule "language/english" - #+mule "language/ethiopic" +;; #+mule "language/ethiopic" #+mule "language/european" #+mule "language/greek" - #+mule "hebrew-hooks" + #+mule "language/hebrew" #+mule "language/japanese" #+mule "language/korean" #+mule "language/misc-lang" - #+mule "language/thai" - #+mule "vietnamese-hooks-1" - #+mule "vietnamese-hooks-2" +;; #+mule "language/thai" + #+mule "language/viet-chars" + #+mule "language/vietnamese" + + ;; Specialized language support + #+(and mule CANNA) "canna-leim" + #+(and mule wnn) "egg-leim" ;; Set up the XEmacs environment for Mule. ;; Assumes the existence of various stuff above. @@ -178,7 +184,7 @@ #+tooltalk "tooltalk/tooltalk-util" #+tooltalk "tooltalk/tooltalk-init" ;; "vc-hooks" ; Packaged. Available in two versions. - "ediff-hook" + ;; "ediff-hook" ; Packaged. "fontl-hooks" "auto-show" ;; #+energize "energize/energize-load.el"
--- a/lisp/prim/faces.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/faces.el Mon Aug 13 10:03:52 2007 +0200 @@ -1127,8 +1127,9 @@ (if (< (apply '+ (color-instance-rgb-components color-instance)) 65536) 'dark 'light) - ;; We'll get an error on a TTY; TTY-s are generally - ;; dark. ### That's a good one. + ;; Here, we get an error on a TTY. As we don't have + ;; a good way of detecting whether a TTY is light or + ;; dark, we'll guess it's dark. (error 'dark)))) (set-frame-property frame 'background-mode mode) mode)) @@ -1225,16 +1226,13 @@ entries (cdr entries) req (car entry) options (cdr entry) - match (cond ((eq req 'type) - (memq type options)) - ((eq req 'class) - (memq class options)) - ((eq req 'background) - (memq background options)) - (t - (warn "Unknown req `%S' with options `%S'" - req options) - nil)))) + match (case req + (type (memq type options)) + (class (memq class options)) + (background (memq background options)) + (t (warn "Unknown req `%S' with options `%S'" + req options) + nil)))) match))) (defun relevant-custom-frames () @@ -1268,7 +1266,6 @@ (get-custom-frame-properties frame)) (initialize-custom-faces frame))) - (defun make-empty-face (name &optional doc-string temporary) "Like `make-face', but doesn't query the resource database." @@ -1365,8 +1362,9 @@ ) -;; These warnings are there for a reason. -;; Just specify your fonts correctly. Deal with it. +;; These warnings are there for a reason. Just specify your fonts +;; correctly. Deal with it. Additionally, one can use +;; `log-warning-minimum-level' instead of this. ;(defvar inhibit-font-complaints nil ; "Whether to suppress complaints about incomplete sets of fonts.") @@ -1395,6 +1393,15 @@ face )))) + +;; #### This is quite a mess. We should use the custom mechanism for +;; most of this stuff. Currently we don't do it, because Custom +;; doesn't use specifiers (yet.) FSF does it the Right Way. + +;; For instance, the definition of `bold' should be something like +;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should +;; make sure that everything works properly. + (defun init-other-random-faces (device) "Initializes the colors and fonts of the bold, italic, bold-italic, zmacs-region, list-mode-item-selected, highlight, primary-selection, @@ -1416,6 +1423,10 @@ ;; the time. For many languages, italic is an alien concept. ;; Basically, because italic is not a globally meaningful concept, ;; the use of the italic face should really be oboleted. + + ;; I disagree with above. In many languages, the concept of capital + ;; letters is just as alien, and yet we use them. Italic is here to + ;; stay. -hniksic ;; In a Solaris Japanese environment, there just aren't any italic ;; fonts - period. CDE recognizes this reality, and fonts @@ -1576,10 +1587,10 @@ (setq face (signal 'wrong-type-argument (list 'facep face)))) (while (cond ((stringp pixmap) (unless (file-readable-p pixmap) - (setq pixmap (vector 'xbm ':file pixmap))) + (setq pixmap `[xbm :file ,pixmap])) nil) ((and (consp pixmap) (= (length pixmap) 3)) - (setq pixmap (vector 'xbm ':data pixmap)) + (setq pixmap `[xbm :data ,pixmap]) nil) (t t)) (setq pixmap (signal 'wrong-type-argument @@ -1595,33 +1606,24 @@ ;; The default, modeline, left-margin, right-margin, text-cursor, ;; and pointer faces are created in C. -(make-face 'bold "bold text") -(make-face 'italic "italic text") -(make-face 'bold-italic "bold-italic text") -(make-face 'underline "underlined text") +(make-face 'bold "Bold text.") +(make-face 'italic "Italic text.") +(make-face 'bold-italic "Bold-italic text.") +(make-face 'underline "Underlined text.") (or (face-differs-from-default-p 'underline) (set-face-underline-p 'underline t 'global)) -(make-face 'zmacs-region "used on defined region between point and mark") -(make-face 'isearch "used on region matched by isearch") +(make-face 'zmacs-region "Used on highlightes region between point and mark.") +(make-face 'isearch "Used on region matched by isearch.") (make-face 'list-mode-item-selected "Face for the selected list item in list-mode.") -(make-face 'highlight "highlight face") -(make-face 'primary-selection) -(make-face 'secondary-selection) +(make-face 'highlight "Highlight face.") +(make-face 'primary-selection "Primary selection face.") +(make-face 'secondary-selection "Secondary selection face.") -;; The loop macro isn't defined until loaddefs.el is read -;;(loop for color in '("red" "green" "blue" "yellow") do -;; (make-face (intern color) (concat color " text")) -;; (set-face-foreground (intern color) color nil 'color)) -(make-face 'red "red text") -(set-face-foreground 'red "red" nil 'color) -(make-face 'green "green text") -(set-face-foreground 'green "green" nil 'color) -(make-face 'blue "blue text") -(set-face-foreground 'blue "blue" nil 'color) -(make-face 'yellow "yellow text") -(set-face-foreground 'yellow "yellow" nil 'color) - +;; Several useful color faces. +(dolist (color '(red green blue yellow)) + (make-face color (concat (symbol-name color) " text.")) + (set-face-foreground color (symbol-name color) nil 'color)) ;; Make some useful faces. This happens very early, before creating ;; the first non-stream device. We initialize the tty global values here.
--- a/lisp/prim/featurep.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -;;; featurep.el --- Support functions for reader conditionals - -;; Copyright 1997 Naggum Software - -;; Author: Erik Naggum <erik@naggum.no> -;; Keywords: internal - -;; This file is not (yet) part of GNU Emacs, but distributed under the -;; same conditions as GNU Emacs, and is useless without GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; The #+ and #- reader macros require support code to work properly until -;; `featurep' is enhanced in the C code. This support code is written in -;; Lisp to make it easier to experiment with the code. - -;; XEmacs: this code has been ported to C by Steve Baur. The -;; implementations should be equivalent. - - -;;; Code: - -(eval-when-compile (require 'cl)) - -(provide (if (string-match "XEmacs" emacs-version) 'xemacs 'emacs)) - -(defvar featurep-emacs-version nil - "The version number of this Emacs, as a floating-point number.") - -(defun featurep (fexp) - "Return non-nil if feature expression FEXP is true." - (typecase fexp - (symbol (and (memq fexp features) ;original definition - t)) - (number (>= (or featurep-emacs-version - (setq featurep-emacs-version - (+ emacs-major-version - (/ emacs-minor-version 100.0)))) - fexp)) - (list (case (pop fexp) - (not (let ((negate (pop fexp))) - (if fexp - (signal 'invalid-read-syntax (list fexp)) - (not (featurep negate))))) - (and (while (and fexp (featurep (car fexp))) - (pop fexp)) - (null fexp)) - (or (while (and fexp (not (featurep (car fexp)))) - (pop fexp)) - fexp) - (t (signal 'invalid-read-syntax (list fexp))))) - (t (signal 'invalid-read-syntax (list fexp))))) - -;;; featurep.el ends here -
--- a/lisp/prim/files.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/files.el Mon Aug 13 10:03:52 2007 +0200 @@ -144,7 +144,7 @@ If the file name matches one of these regular expressions, then `revert-buffer' reverts the file without querying if the file has changed on disk and you have not edited the buffer." - :type 'boolean + :type '(repeat (regexp "")) :group 'find-file) (defvar buffer-file-number nil @@ -644,8 +644,6 @@ (frame (make-frame (if name (list (cons 'name (symbol-name name))))))) (pop-to-buffer buffer t frame) - (unless focus-follows-mouse - (select-frame frame)) (make-frame-visible frame) buffer))
--- a/lisp/prim/fill.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/fill.el Mon Aug 13 10:03:52 2007 +0200 @@ -554,8 +554,10 @@ (setq prefixcol (current-column)))))) ;; Justify the line just ended, if desired. (if justify - (if (eobp) - (justify-current-line justify t t) + (if (save-excursion (skip-chars-forward " \t") (eobp)) + (progn + (delete-horizontal-space) + (justify-current-line justify t t)) (forward-line -1) (justify-current-line justify nil t) (forward-line 1))))))
--- a/lisp/prim/find-func.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/find-func.el Mon Aug 13 10:03:52 2007 +0200 @@ -8,7 +8,7 @@ ;; Created: 97/07/25 ;; URL: <http://www.kurims.kyoto-u.ac.jp/~petersen/emacs-lisp/> -;; $Id: find-func.el,v 1.1 1997/10/10 01:39:52 steve Exp $ +;; $Id: find-func.el,v 1.2 1997/10/31 14:53:07 steve Exp $ ;; This file is part of XEmacs. @@ -96,10 +96,10 @@ The library where FUNCTION is defined is searched for in `find-function-source-path', if non `nil', otherwise in `load-path'." + (if (not function) + (error "You didn't specify a function")) (and (subrp (symbol-function function)) (error "%s is a primitive function" function)) - (if (not function) - (error "You didn't specify a function")) (let ((def (symbol-function function)) library aliases) (while (symbolp def) @@ -118,7 +118,10 @@ (nth 1 def)) ((describe-function-find-file function)) ((compiled-function-p def) - (substring (compiled-function-annotation def) 0 -4)))) + (substring (compiled-function-annotation def) 0 -4)) + ((eq 'macro (car-safe def)) + (and (compiled-function-p (cdr def)) + (substring (compiled-function-annotation (cdr def)) 0 -4))))) (if (null library) (error (format "Don't know where `%s' is defined" function))) (if (string-match "\\.el\\(c\\)\\'" library) @@ -153,9 +156,8 @@ (defun find-function-read-function () "Read and return a function, defaulting to the one near point. -The function named by `find-function-function' is used to select the -default function." - (let ((fn (funcall find-function-function)) +`function-at-point' is used to select the default function." + (let ((fn (function-at-point)) (enable-recursive-minibuffers t) val) (setq val (completing-read @@ -184,7 +186,7 @@ "Find the definition of the function near point in the current window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -198,7 +200,7 @@ "Find the definition of the function near point in the other window. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers. @@ -212,7 +214,7 @@ "Find the definition of the function near point in the another frame. Finds the Emacs Lisp library containing the definition of the function -near point (selected by `find-function-function') in a buffer and +near point (selected by `function-at-point') in a buffer and places point before the definition. Point is saved in the buffer if it is one of the current buffers.
--- a/lisp/prim/frame.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/frame.el Mon Aug 13 10:03:52 2007 +0200 @@ -545,7 +545,8 @@ ; this is in C in FSFmacs (defun frame-list () "Return a list of all frames on all devices/consoles." - (apply 'append (mapcar 'device-frame-list (device-list)))) + ;; Lists are copies, so nconc is safe here. + (apply 'nconc (mapcar 'device-frame-list (device-list)))) (defun frame-type (&optional frame) "Return the type of the specified frame (e.g. `x' or `tty'). @@ -613,26 +614,25 @@ (list 'frame-configuration-p configuration))) (let ((config-plist (cdr configuration)) frames-to-delete) - (mapcar (function - (lambda (frame) - (let ((properties (assq frame config-plist))) - (if properties - (progn - (set-frame-properties - frame - ;; Since we can't set a frame's minibuffer status, - ;; we might as well omit the parameter altogether. - (lax-plist-remprop (nth 1 properties) 'minibuffer)) - (set-window-configuration (nth 2 properties))) - (setq frames-to-delete (cons frame frames-to-delete)))))) - (frame-list)) + (mapc (lambda (frame) + (let ((properties (assq frame config-plist))) + (if properties + (progn + (set-frame-properties + frame + ;; Since we can't set a frame's minibuffer status, + ;; we might as well omit the parameter altogether. + (lax-plist-remprop (nth 1 properties) 'minibuffer)) + (set-window-configuration (nth 2 properties))) + (setq frames-to-delete (cons frame frames-to-delete))))) + (frame-list)) (if nodelete ;; Note: making frames invisible here was tried ;; but led to some strange behavior--each time the frame ;; was made visible again, the window manager asked afresh ;; for where to put it. - (mapcar 'iconify-frame frames-to-delete) - (mapcar 'delete-frame frames-to-delete)))) + (mapc 'iconify-frame frames-to-delete) + (mapc 'delete-frame frames-to-delete)))) ; this function is in subr.el in FSFmacs. ; that's because they don't always include frame.el, while we do. @@ -1139,7 +1139,7 @@ (defun delete-other-frames (&optional frame) "Delete all but FRAME (or the selected frame)." (interactive) - (mapcar 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) + (mapc 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) ;; By adding primitives to directly access the window hierarchy, ;; we can move many functions into Lisp. We do it this way
--- a/lisp/prim/glyphs.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/glyphs.el Mon Aug 13 10:03:52 2007 +0200 @@ -602,12 +602,12 @@ ;; initialize default image types (if (featurep 'x) (set-console-type-image-conversion-list 'x - `(,@(if (featurep 'xpm) '(("\\.xpm$\\'" [xpm :file nil] 2))) + `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) ("\\.xbm\\'" [xbm :file nil] 2) ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2))) - ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2))) - ,@(if (featurep 'gif) '(("\\`GIF8[79]" [gif :data nil] 2))) + ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) + ("\\`GIF8[79]" [gif :data nil] 2))) ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) ;; all of the JFIF-format JPEG's that I've seen begin with ;; the following. I have no idea if this is standard. @@ -657,7 +657,10 @@ ;; has a built-in bitmap (if (featurep 'xpm) (set-glyph-image xemacs-logo - (concat "../etc/" "xemacs.xpm") + (concat "../etc/" + (if emacs-beta-version + "xemacs-beta.xpm" + "xemacs.xpm")) 'global 'x)) (cond ((featurep 'xpm) (set-glyph-image frame-icon-glyph
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/prim/help-nomule.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,99 @@ +;;; help-nomule.el --- Help functions when not in Mule + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Maintainer: XEmacs Development Team +;; Keywords: help, internal + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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: + +(defconst tutorial-supported-languages + '(("French" fr iso-8859-1) + ("German" de iso-8859-1) + ("Norwegian" no iso-8859-1) + ("Croatian" hr iso-8859-2)) + "Alist of supported languages in TUTORIAL files. +Add languages here, as more are translated.") + +;; TUTORIAL arg is XEmacs addition +(defun help-with-tutorial (&optional tutorial language) + "Select the XEmacs learn-by-doing tutorial. +Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\". +With a prefix argument, choose the language." + (interactive "i\nP") + (or tutorial + (setq tutorial "TUTORIAL")) + (when (and language (consp language)) + (let ((completion-ignore-case t)) + (setq language (assoc (completing-read "Language: " + tutorial-supported-languages + nil t) + tutorial-supported-languages)))) + (when language + (setq tutorial (format "%s.%s" tutorial (cadr language)))) + (let ((file (expand-file-name tutorial "~"))) + (delete-other-windows) + (let ((buffer (or (get-file-buffer file) + (create-file-buffer file))) + (window-configuration (current-window-configuration))) + (condition-case error-data + (progn + (switch-to-buffer buffer) + (setq buffer-file-name file) + (setq default-directory (expand-file-name "~/")) + (setq buffer-auto-save-file-name nil) + ;; Because of non-Mule users, TUTORIALs are not coded + ;; independently, so we must guess the coding according to + ;; the language. + (let ((coding-system-for-read (nth 2 language))) + (insert-file-contents (expand-file-name tutorial + data-directory))) + (goto-char (point-min)) + (search-forward "\n<<") + (delete-region (point-at-bol) (point-at-eol)) + (let ((n (- (window-height (selected-window)) + (count-lines (point-min) (point)) + 6))) + (if (< n 12) + (newline n) + ;; Some people get confused by the large gap. + (newline (/ n 2)) + (insert "[Middle of page left blank for didactic purposes. " + "Text continues below]") + (newline (- n (/ n 2))))) + (goto-char (point-min)) + (set-buffer-modified-p nil)) + ;; TUTORIAL was not found: kill the buffer and restore the + ;; window configuration. + (file-error (kill-buffer buffer) + (set-window-configuration window-configuration) + ;; Now, signal the error + (signal (car error-data) (cdr error-data))))))) + + +(provide 'help-nomule) + +;;; help-nomule.el ends here \ No newline at end of file
--- a/lisp/prim/help.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 10:03:52 2007 +0200 @@ -243,37 +243,38 @@ ;;(define-key global-map 'backspace 'deprecated-help-command) +;; This function has been moved to help-nomule.el and mule-help.el. ;; TUTORIAL arg is XEmacs addition -(defun help-with-tutorial (&optional tutorial) - "Select the XEmacs learn-by-doing tutorial. -Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"." - (interactive) - (if (null tutorial) - (setq tutorial "TUTORIAL")) - (let ((file (expand-file-name (concat "~/" tutorial)))) - (delete-other-windows) - (if (get-file-buffer file) - (switch-to-buffer (get-file-buffer file)) - (switch-to-buffer (create-file-buffer file)) - (setq buffer-file-name file) - (setq default-directory (expand-file-name "~/")) - (setq buffer-auto-save-file-name nil) - (insert-file-contents (expand-file-name tutorial data-directory)) - (goto-char (point-min)) - (search-forward "\n<<") - (delete-region (point-at-bol) (point-at-eol)) - (let ((n (- (window-height (selected-window)) - (count-lines (point-min) (point)) - 6))) - (if (< n 12) - (newline n) - ;; Some people get confused by the large gap. - (newline (/ n 2)) - (insert "[Middle of page left blank for didactic purposes. " - "Text continues below]") - (newline (- n (/ n 2))))) - (goto-char (point-min)) - (set-buffer-modified-p nil)))) +;(defun help-with-tutorial (&optional tutorial) +; "Select the XEmacs learn-by-doing tutorial. +;Optional arg TUTORIAL specifies the tutorial file; default is \"TUTORIAL\"." +; (interactive) +; (if (null tutorial) +; (setq tutorial "TUTORIAL")) +; (let ((file (expand-file-name (concat "~/" tutorial)))) +; (delete-other-windows) +; (if (get-file-buffer file) +; (switch-to-buffer (get-file-buffer file)) +; (switch-to-buffer (create-file-buffer file)) +; (setq buffer-file-name file) +; (setq default-directory (expand-file-name "~/")) +; (setq buffer-auto-save-file-name nil) +; (insert-file-contents (expand-file-name tutorial data-directory)) +; (goto-char (point-min)) +; (search-forward "\n<<") +; (delete-region (point-at-bol) (point-at-eol)) +; (let ((n (- (window-height (selected-window)) +; (count-lines (point-min) (point)) +; 6))) +; (if (< n 12) +; (newline n) +; ;; Some people get confused by the large gap. +; (newline (/ n 2)) +; (insert "[Middle of page left blank for didactic purposes. " +; "Text continues below]") +; (newline (- n (/ n 2))))) +; (goto-char (point-min)) +; (set-buffer-modified-p nil)))) ;; used by describe-key, describe-key-briefly, insert-key-binding, etc. @@ -798,31 +799,38 @@ (defun function-at-point () "Return the function whose name is around point. If that gives no function, return the function which is called by the -list containing point. If that doesn't give a function, return nil." - (or (condition-case () - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (or (not (zerop (skip-syntax-backward "_w"))) - (eq (char-syntax (char-after (point))) ?w) - (eq (char-syntax (char-after (point))) ?_) - (forward-sexp -1)) - (skip-chars-forward "`'") - (let ((obj (read (current-buffer)))) - (and (symbolp obj) (fboundp obj) obj))) - (set-syntax-table stab))) - (error nil)) - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) - (backward-up-list 1) - (forward-char 1) - (let (obj) - (setq obj (read (current-buffer))) - (and (symbolp obj) (fboundp obj) obj)))) - (error nil)))) +list containing point. If that doesn't give a function, return nil. + +If `function-at-point-function' is non nil, the function it names is +called instead." + (if (and (fboundp function-at-point-function) + (not (eq function-at-point-function 'function-at-point))) + (funcall function-at-point-function) + (or (condition-case () + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "`'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (fboundp obj) obj))) + (set-syntax-table stab))) + (error nil)) + (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (max (point-min) (- (point) 1000)) + (point-max)) + (backward-up-list 1) + (forward-char 1) + (let (obj) + (setq obj (read (current-buffer))) + (and (symbolp obj) (fboundp obj) obj)))) + (error nil))))) ;; Default to nil for the non-hackers? Not until we find a way to ;; distinguish hackers from non-hackers automatically! @@ -832,11 +840,11 @@ :type 'boolean :group 'help-appearance) -(defcustom find-function-function 'function-at-point - "*The function used by `describe-function', `where-is' and -`find-function' to select the function near point. +(defcustom function-at-point-function nil + "*Set this to name an alternative function to be used by +`function-at-point' instead of itself. -For example `function-at-point' or `function-called-at-point'." +For example `function-called-at-point'." :type 'function :group 'help) @@ -852,10 +860,10 @@ (defun describe-function (function) "Display the full documentation of FUNCTION (a symbol). -When run interactively, it defaults to any function found by the -value of `find-function-function'." +When run interactively, it defaults to any function found by +`function-at-point'." (interactive - (let* ((fn (funcall find-function-function)) + (let* ((fn (function-at-point)) (val (let ((enable-recursive-minibuffers t)) (completing-read (if fn @@ -1047,7 +1055,7 @@ ;;; ## this doesn't seem to be used for anything ;; (defun describe-function-arglist (function) -;; (interactive (list (or (function-called-at-point) +;; (interactive (list (or (function-at-point) ;; (error "no function call at point")))) ;; (let ((b nil)) ;; (unwind-protect @@ -1223,10 +1231,10 @@ (defun where-is (definition) "Print message listing key sequences that invoke specified command. Argument is a command definition, usually a symbol with a function definition. -When run interactively, it defaults to any function found by the -value of `find-function-function'." +When run interactively, it defaults to any function found by +`function-at-point'." (interactive - (let ((fn (funcall find-function-function)) + (let ((fn (function-at-point)) (enable-recursive-minibuffers t) val) (setq val (read-command
--- a/lisp/prim/keymap.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/keymap.el Mon Aug 13 10:03:52 2007 +0200 @@ -347,8 +347,41 @@ (signal 'wrong-type-argument (list 'eventp event)))) (setq i (1+ i))) new)))) + -;FSFmacs #### +(defun next-key-event () + "Return the next available keyboard event." + (let (event) + (while (not (key-press-event-p (setq event (next-event)))) + (dispatch-event event)) + event)) + +(defun key-sequence-list-description (keys) + "Convert a key sequence KEYS to the full [(modifiers... key)...] form. +Argument KEYS can be in any form accepted by `define-key' function." + (let ((vec + (cond ((vectorp keys) + keys) + ((stringp keys) + (vconcat keys)) + (t + (vector keys)))) + (event-to-list + #'(lambda (ev) + (append (event-modifiers ev) (list (event-key ev)))))) + (mapvector + #'(lambda (key) + (cond ((key-press-event-p key) + (funcall event-to-list key)) + ((characterp key) + (funcall event-to-list (character-to-event key))) + ((listp key) + key) + (t + (list key)))) + vec))) + + ;;; Support keyboard commands to turn on various modifiers. ;;; These functions -- which are not commands -- each add one modifier @@ -367,21 +400,41 @@ (defun event-apply-meta-modifier (ignore-prompt) (event-apply-modifier 'meta)) +;;; #### `key-translate-map' is ignored for now. (defun event-apply-modifier (symbol) "Return the next key event, with a modifier flag applied. -SYMBOL is the name of this modifier, as a symbol." - (let (event) - (while (not (key-press-event-p (setq event (next-command-event)))) - (dispatch-event event)) - (vconcat (list symbol) - (delq symbol (event-modifiers event)) - (list (event-key event))))) +SYMBOL is the name of this modifier, as a symbol. +`function-key-map' is scanned for prefix bindings." + (let (events binding) + ;; read keystrokes scanning `function-key-map' + (while (keymapp + (setq binding + (lookup-key + function-key-map + (vconcat + (setq events + (append events (list (next-key-event))))))))) + (if binding ; found a binding + (progn + ;; allow for several modifiers + (if (and (symbolp binding) (fboundp binding)) + (setq binding (funcall binding nil))) + (setq events (append binding nil)) + ;; put remaining keystrokes back into input queue + (setq unread-command-events + (mapcar 'character-to-event (cdr events)))) + (setq unread-command-events (cdr events))) + ;; add a modifier SYMBOL to the first keystroke or event + (vector + (append (list symbol) + (delq symbol + (aref (key-sequence-list-description (car events)) 0)))))) ;; This looks dirty. The following code should maybe go to another ;; file, and `create-console-hook' should maybe default to nil. (add-hook 'create-console-hook - (lambda (console) + #'(lambda (console) (letf (((selected-console) console)) (define-key function-key-map [?\C-x ?@ ?h] 'event-apply-hyper-modifier) (define-key function-key-map [?\C-x ?@ ?s] 'event-apply-super-modifier)
--- a/lisp/prim/minibuf.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/minibuf.el Mon Aug 13 10:03:52 2007 +0200 @@ -205,8 +205,15 @@ (interactive) (and minibuffer-electric-file-name-behavior (eq ?/ (char-before (point))) + (not (save-excursion + (goto-char (point-min)) + (and (looking-at "^/.+:~?") + (re-search-forward "^/.+:~?[^/]*" nil t) + (progn + (delete-region (point) (point-max)) + t)))) (not (eq (point) (1+ (point-min)))) ; permit `//hostname/path/to/file' - (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' + (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' (delete-region (point-min) (point))) (insert ?/))
--- a/lisp/prim/mouse.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/mouse.el Mon Aug 13 10:03:52 2007 +0200 @@ -184,8 +184,8 @@ Text drops follow the `mouse-yank-at-point' variable." ;; by Oliver Graf <ograf@fga.de> (interactive "e") - (let ((type (car (event-dnd-data event))) - (data (cadr (event-dnd-data event))) + (let ((type (car (event-drag-and-drop-data event))) + (data (cadr (event-drag-and-drop-data event))) (frame (event-channel event))) (cond ((= type 2) (let ((x pop-up-windows))
--- a/lisp/prim/obsolete.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/obsolete.el Mon Aug 13 10:03:52 2007 +0200 @@ -615,11 +615,6 @@ (color-instance-rgb-components (make-color-instance color))) (make-compatible 'x-color-values 'color-instance-rgb-components) -;; The name of char-int is unintuitive and silly, but in CLtL2. -(define-compatible-function-alias 'char-int 'char-to-int) -;; likewise with int-char. -(define-compatible-function-alias 'int-char 'int-to-char) - ;; Two loser functions which shouldn't be used. (make-obsolete 'following-char 'char-after) (make-obsolete 'preceding-char 'char-before) @@ -694,4 +689,6 @@ ;; Keywords already do The Right Thing in XEmacs (make-compatible 'define-widget-keywords "Just use them") +(make-obsolete 'function-called-at-point 'function-at-point) + ;;; obsolete.el ends here
--- a/lisp/prim/packages.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/packages.el Mon Aug 13 10:03:52 2007 +0200 @@ -100,13 +100,18 @@ (locate-file library (or path load-path) - (if nosuffix - "" - (if (or (rassq 'jka-compr-handler file-name-handler-alist) - (and (boundp 'find-file-hooks) - (member 'crypt-find-file-hook find-file-hooks))) - ".elc:.el:" - ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z")) + (cond ((or (rassq 'jka-compr-handler file-name-handler-alist) + (and (boundp 'find-file-hooks) + (member 'crypt-find-file-hook find-file-hooks))) + ;; Compression involved. + (if nosuffix + ":.gz:.Z" + ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z")) + (t + ;; No compression. + (if nosuffix + "" + ".elc:.el:"))) 4))) (and interactive-call (if result @@ -151,13 +156,15 @@ autolist)) ;; The following function is called from temacs -(defun packages-find-packages-1 (package path-only) +(defun packages-find-packages-1 (package path-only user-package) "Search the supplied directory for associated directories. The top level is assumed to look like: info/ Contain texinfo files for lisp installed in this hierarchy etc/ Contain data files for lisp installled in this hiearchy lisp/ Contain directories which either have straight lisp code - or are self-contained packages of their own." + or are self-contained packages of their own. + +This is an internal function. Do not call it after startup." ;; Info files (if (and (null path-only) (file-directory-p (concat package "/info"))) (let ((dir (concat package "/info/"))) @@ -170,16 +177,34 @@ ;; Lisp files (if (file-directory-p (concat package "/lisp")) (progn - ;; (print (concat "DIR: " package "/lisp/")) +; (print (concat "DIR: " +; (if user-package "[USER]" "") +; package +; "/lisp/")) (setq load-path (cons (concat package "/lisp/") load-path)) + (if user-package + (condition-case nil + (load (concat package "/lisp/" + (file-name-sans-extension autoload-file-name))) + (t nil))) (let ((dirs (directory-files (concat package "/lisp/") t "^[^-.]" nil 'dirs-only)) dir) (while dirs (setq dir (car dirs)) - ;; (print (concat "DIR: " dir "/")) +; (print (concat "DIR: " dir "/")) (setq load-path (cons (concat dir "/") load-path)) - (packages-find-packages-1 dir path-only) + (if user-package + (condition-case nil + (progn +; (print +; (concat dir "/" +; (file-name-sans-extension autoload-file-name))) + (load + (concat dir "/" + (file-name-sans-extension autoload-file-name)))) + (t nil))) + (packages-find-packages-1 dir path-only user-package) (setq dirs (cdr dirs))))))) ;; The following function is called from temacs @@ -197,11 +222,13 @@ (while path (setq dir (car path)) ;; (prin1 (concat "Find: " (expand-file-name dir) "\n")) - (if (null (and suppress-user + (if (null (and (or suppress-user inhibit-package-init) (string-match "^~" dir))) (progn ;; (print dir) - (packages-find-packages-1 (expand-file-name dir) path-only))) + (packages-find-packages-1 (expand-file-name dir) + path-only + (string-match "^~" dir)))) (setq path (cdr path))))) ;; Data-directory is really a list now. Provide something to search it for
--- a/lisp/prim/profile.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/profile.el Mon Aug 13 10:03:52 2007 +0200 @@ -26,7 +26,7 @@ ;;; Commentary: -;; In addition to Lisp-based `elp', XEmacs contains a set of +;; In addition to Lisp-based `elp', XEmacs provides a set of ;; primitives able to profile evaluation of Lisp functions, created by ;; the illustrious Ben Wing. The functions in this file can be used ;; to gain easy access to the internal profiling functions. @@ -36,16 +36,16 @@ ;; The output of this process is an alist with keys being the ;; functions, and values being the number of ticks per function. From ;; this, `profiling-results' easily extracts the total number of -;; ticks, and the percentage CPU time of each function. - -;; Unless stated otherwise, profiling info is being accumulated (the -;; current info is returned by `get-profiling-info'). Use +;; Unless stated otherwise, profiling info is being accumulated +;; incrementally through several profile runs (the current info is +;; always available by `get-profiling-info'). Use ;; `clear-profiling-info' to break the accumulation chain. ;; Caveats (ELP users should read this): ;; 1) The time reported is function time, rather than ;; function+descendants time; -;; 2) The Time/ms is CPU time (user+kernel), not the real time; +;; 2) Each tick is equivalent to 1ms (which can be changed), but this +;; is CPU time (user+kernel), not the real time; ;; 3) Only the actuall funcalls are profiled. If a subr Ffoo calls ;; Fbar using Fbar (), only Ffoo will appear in the profile. @@ -60,12 +60,6 @@ ;;; Code: -(defun profile-align (form width) - ;; Bletch! this is what (format "%-*s" width form) should do. - (let ((printed-form (format "%s" form))) - (concat printed-form - (make-string (max 0 (- width (length printed-form))) ?\ )))) - ;;;###autoload (defun profile-results (&optional info stream) "Print profiling info INFO to STREAM in a pretty format. @@ -88,26 +82,25 @@ ;; Calculate the longest function (maxfunlen (apply #'max (length "Function Name") - (mapcar (lambda (el) - ;; Functions longer than 40 - ;; characters don't qualify - (let ((l (length (format "%s" (car el))))) - (if (< l 40) - l 0))) - info)))) - (princ (format "%s Ticks %%/Total\n" - (profile-align "Function Name" maxfunlen))) + (mapcar + (lambda (el) + ;; Functions longer than 50 characters (usually + ;; anonymous functions) don't qualify + (let ((l (length (format "%s" (car el))))) + (if (< l 50) + l 0))) + info)))) + (princ (format "%-*s Ticks %%/Total\n" maxfunlen "Function Name")) (princ (make-string maxfunlen ?=)) (princ " ===== =======\n") (let ((sum (float (apply #'+ (mapcar #'cdr info))))) (dolist (entry (nreverse (sort info #'cdr-less-than-cdr))) - (princ (format "%s %-5d %-6.3f\n" - (profile-align (car entry) maxfunlen) - (cdr entry) (* 100 (/ (cdr entry) sum))))) + (princ (format "%-*s %-5d %-6.3f\n" + maxfunlen (car entry) (cdr entry) + (* 100 (/ (cdr entry) sum))))) (princ (make-string maxfunlen ?-)) (princ "--------------------\n") - (princ (format "%s %-5d %-6.2f\n" - (profile-align "Total" maxfunlen) sum 100.0)) + (princ (format "%-*s %-5d %-6.2f\n" maxfunlen "Total" sum 100.0)) (princ (format "\n\nOne tick = %g ms\n" (/ default-profiling-interval 1000.0))))) (when (and (not stream)
--- a/lisp/prim/simple.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 10:03:52 2007 +0200 @@ -2903,6 +2903,7 @@ (defun assoc-ignore-case (key alist) "Like `assoc', but assumes KEY is a string and ignores case when comparing." + (setq key (downcase key)) (let (element) (while (and alist (not element)) (if (equal key (downcase (car (car alist)))) @@ -3141,19 +3142,22 @@ (defun capitalize-region-or-word (arg) "Capitalize the selected region or the following word (or ARG words)." (interactive "p") - (if (region-active-p) (capitalize-region (region-beginning) (region-end)) + (if (region-active-p) + (capitalize-region (region-beginning) (region-end)) (capitalize-word arg))) (defun upcase-region-or-word (arg) "Upcase the selected region or the following word (or ARG words)." (interactive "p") - (if (region-active-p) (upcase-region (region-beginning) (region-end)) + (if (region-active-p) + (upcase-region (region-beginning) (region-end)) (upcase-word arg))) (defun downcase-region-or-word (arg) "Downcase the selected region or the following word (or ARG words)." (interactive "p") - (if (region-active-p) (downcase-region (region-beginning) (region-end)) + (if (region-active-p) + (downcase-region (region-beginning) (region-end)) (downcase-word arg))) ;;; @@ -3202,7 +3206,7 @@ (extent-object zmacs-region-extent))) buffer (marker-buffer (car region)))) (t - (signal 'error (list "invalid region" region)))) + (signal 'error (list "Invalid region" region)))) (if valid nil @@ -3210,7 +3214,7 @@ ;; otherwise incapacitated. (condition-case () (if (listp zmacs-region-extent) - (mapcar 'delete-extent zmacs-region-extent) + (mapc 'delete-extent zmacs-region-extent) (delete-extent zmacs-region-extent)) (error nil))) @@ -3289,7 +3293,7 @@ (if zmacs-region-extent (let ((inhibit-quit t)) (if (listp zmacs-region-extent) - (mapcar 'delete-extent zmacs-region-extent) + (mapc 'delete-extent zmacs-region-extent) (delete-extent zmacs-region-extent)) (setq zmacs-region-extent nil))) (run-hooks 'zmacs-deactivate-region-hook) @@ -3300,17 +3304,19 @@ You shouldn't need to call this; the command loop calls it when appropriate. Calling this function will call the hook `zmacs-update-region-hook', if the region is active." - (if zmacs-region-active-p - (progn - (if (marker-buffer (mark-marker t)) - (zmacs-make-extent-for-region (cons (point-marker t) - (mark-marker t)))) - (run-hooks 'zmacs-update-region-hook)))) + (when zmacs-region-active-p + (when (marker-buffer (mark-marker t)) + (zmacs-make-extent-for-region (cons (point-marker t) + (mark-marker t)))) + (run-hooks 'zmacs-update-region-hook))) ;;;;;; ;;;;;; echo area stuff ;;;;;; +;;; #### Should this be moved to a separate file, for clarity? +;;; -hniksic + ;;; The `message-stack' is an alist of labels with messages; the first ;;; message in this list is always in the echo area. A call to ;;; `display-message' inserts a label/message pair at the head of the @@ -3742,11 +3748,11 @@ (setq display-p nil)) (save-excursion (let ((buffer (get-buffer-create "*Warnings*"))) - (if display-p - ;; The C code looks at display-warning-tick to determine - ;; when it should call `display-warning-buffer'. Change it - ;; to get the C code's attention. - (setq display-warning-tick (1+ display-warning-tick))) + (when display-p + ;; The C code looks at display-warning-tick to determine + ;; when it should call `display-warning-buffer'. Change it + ;; to get the C code's attention. + (incf display-warning-tick)) (set-buffer buffer) (goto-char (point-max)) (setq warning-count (1+ warning-count)) @@ -3776,11 +3782,10 @@ "Make the buffer that contains the warnings be visible. The C code calls this periodically, right before redisplay." (let ((buffer (get-buffer-create "*Warnings*"))) - (if (or (not warning-marker) (not (eq (marker-buffer warning-marker) - buffer))) - (progn - (setq warning-marker (make-marker)) - (set-marker warning-marker 1 buffer))) + (when (or (not warning-marker) + (not (eq (marker-buffer warning-marker) buffer))) + (setq warning-marker (make-marker)) + (set-marker warning-marker 1 buffer)) (set-window-start (display-buffer buffer) warning-marker) (set-marker warning-marker (point-max buffer) buffer)))
--- a/lisp/prim/startup.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/startup.el Mon Aug 13 10:03:52 2007 +0200 @@ -39,7 +39,7 @@ (defvar command-line-processed nil "t once command line has been processed") -(defconst startup-message-timeout 1200) ; More or less disable the timeout +(defconst startup-message-timeout 12000) ; More or less disable the timeout (defconst inhibit-startup-message nil "*Non-nil inhibits the initial startup message. @@ -211,6 +211,8 @@ -unmapped Do not map the initial frame. -no-site-file Do not load the site-specific init file (site-start.el). -no-init-file Do not load the user-specific init file (~/.emacs). + -no-packages Do not process the package path. + -vanilla Equivalent to -q -no-site-file -no-packages. -q Same as -no-init-file. -user <user> Load user's init file instead of your own. -u <user> Same as -user.\n") @@ -461,6 +463,12 @@ (setq init-file-user nil)) ((string= arg "-no-site-file") (setq site-start-file nil)) + ((string= arg "-no-packages") + (setq inhibit-package-init t)) + ((string= arg "-vanilla") + (setq init-file-user nil + site-start-file nil + inhibit-package-init t)) ((or (string= arg "-u") (string= arg "-user")) (setq init-file-user (pop args))) @@ -654,47 +662,48 @@ (load filename)) (defun command-line-1 () - (if (null command-line-args-left) - (unless (or inhibit-startup-message - noninteractive - ;; Don't clobber a non-scratch buffer if init file - ;; has selected it. - (not (string= (buffer-name) "*scratch*")) - (input-pending-p)) - - ;; If there are no switches to process, run the term-setup-hook - ;; before displaying the copyright notice; there may be some need - ;; to do it before doing any output. If we're not going to - ;; display a copyright notice (because other options are present) - ;; then this is run after those options are processed. - (run-hooks 'term-setup-hook) - ;; Don't let the hook be run twice. - (setq term-setup-hook nil) + (cond + ((null command-line-args-left) + (unless noninteractive + ;; If there are no switches to process, run the term-setup-hook + ;; before displaying the copyright notice; there may be some need + ;; to do it before doing any output. If we're not going to + ;; display a copyright notice (because other options are present) + ;; then this is run after those options are processed. + (run-hooks 'term-setup-hook) + ;; Don't let the hook be run twice. + (setq term-setup-hook nil) - (let ((timeout nil)) - (unwind-protect - ;; Guts of with-timeout - (catch 'timeout - (setq timeout (add-timeout startup-message-timeout - (lambda (ignore) - (condition-case nil - (throw 'timeout t) - (error nil))) - nil)) - (startup-splash-frame) - (or nil;; (pos-visible-in-window-p (point-min)) - (goto-char (point-min))) - (sit-for 0) - (setq unread-command-event (next-command-event))) - (when timeout (disable-timeout timeout)) - (with-current-buffer (get-buffer "*scratch*") - (erase-buffer) - (when (stringp initial-scratch-message) - (insert initial-scratch-message)) - ;; In case the XEmacs server has already selected - ;; another buffer, erase the one our message is in. - (set-buffer-modified-p nil))))) - + ;; Don't clobber a non-scratch buffer if init file + ;; has selected it. + (when (string= (buffer-name) "*scratch*") + (unless (or inhibit-startup-message + (input-pending-p)) + (let ((timeout nil)) + (unwind-protect + ;; Guts of with-timeout + (catch 'timeout + (setq timeout (add-timeout startup-message-timeout + (lambda (ignore) + (condition-case nil + (throw 'timeout t) + (error nil))) + nil)) + (startup-splash-frame) + (or nil;; (pos-visible-in-window-p (point-min)) + (goto-char (point-min))) + (sit-for 0) + (setq unread-command-event (next-command-event))) + (when timeout (disable-timeout timeout))))) + (with-current-buffer (get-buffer "*scratch*") + ;; In case the XEmacs server has already selected + ;; another buffer, erase the one our message is in. + (erase-buffer) + (when (stringp initial-scratch-message) + (insert initial-scratch-message)) + (set-buffer-modified-p nil))))) + + (t ;; Command-line-options exist (let ((dir command-line-default-directory) (file-count 0) @@ -740,7 +749,7 @@ (> file-count 2) (not (get-buffer-window first-file-buffer))) (other-window 1) - (buffer-menu nil))))) + (buffer-menu nil)))))) (defvar startup-presentation-hack-keymap (let ((map (make-sparse-keymap)))
--- a/lisp/prim/subr.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/prim/subr.el Mon Aug 13 10:03:52 2007 +0200 @@ -396,6 +396,12 @@ (define-function 'string< 'string-lessp) (define-function 'int-to-string 'number-to-string) (define-function 'string-to-int 'string-to-number) + +;; These two names are a bit awkward, as they conflict with the normal +;; foo-to-bar naming scheme, but CLtL2 has them, so they stay. +(define-function 'char-int 'char-to-int) +(define-function 'int-char 'int-to-char) + ;; alist/plist functions (defun plist-to-alist (plist) @@ -572,7 +578,7 @@ abbrev-table-name-list))))))) (defun functionp (obj) - "Returns t if OBJ is a function, nil otherwise." + "Non-nil if OBJECT is a type of object that can be called as a function." (cond ((symbolp obj) (fboundp obj)) ((subrp obj))
--- a/lisp/psgml/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,974 +0,0 @@ -1997-10-10 Per Abrahamsen <abraham@dina.kvl.dk> - - * custom/wid-edit.el (variable-link): New widget. - (widget-variable-link-action): New function. - (function-link): New widget. - (widget-function-link-action): New function. - -1997-10-10 Karl M. Hegbloom <karlheg@inetarena.com> - - * prim/modeline.el (modeline-minor-mode-menu): menus are toggles - not strings now. - -1997-10-10 SL Baur <steve@altair.xemacs.org> - - * psgml-html.el (html-quote-region): Grow bounds when performing - substitutions. - From Adrian Aichner <aichner@ecf.teradyne.com> - -1997-09-26 SL Baur <steve@altair.xemacs.org> - - * iso-sgml.el: Correct email address. - - * psgml-parse.el (sgml-compile-dtd): no-conversion -> binary - coding system. - (sgml-bdtd-merge): Ditto. - (sgml-push-to-entity): Ditto. - -1997-06-15 Steven L Baur <steve@altair.xemacs.org> - - * psgml-parse.el (sgml-parse-chars): De-ebolify. - (sgml-read-peek): Use char-after not following-char. - -1997-06-14 Steven L Baur <steve@altair.xemacs.org> - - * psgml-parse.el (sgml-read-model): Ebola vaccine. - From Andrew J Cosgriff <Andrew.Cosgriff@cc.monash.edu.au> - -Wed Apr 23 11:28:10 1997 Steven L Baur <steve@altair.xemacs.org> - - * psgml-charent.el (sgml-display-char-list-filename): Move - iso88591.map to a proper location. - -Tue Apr 22 02:05:09 1997 Steven L Baur <steve@altair.xemacs.org> - - * psgml-xemacs.el (sgml-xemacs-get-popup-value): Allow for - interactive function. - -Sat Mar 22 19:58:27 1997 Steven L Baur <steve@altair.xemacs.org> - - * psgml-html.el (html-mode): Too many backslashes in DOCSTRING. - -Wed Mar 19 22:58:40 1997 Steven L Baur <steve@altair.xemacs.org> - - * psgml-html.el (html-helper-address-string): Use - user-mail-address function. - -Mon Jan 27 13:12:41 1997 Jin S. Choi <jsc@atype.com> - - * psgml.el: Fix location of CATALOG in `sgml-validate-command'. - -Thu Jan 16 18:23:51 1997 Steven L Baur <steve@miranova.com> - - * psgml.el: Use newer interface form of nsgmls. - -Wed Nov 20 19:40:05 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-modify-dtd): set sgml-current-tree to - sgml-top-tree. Needed by sgml-open-element. - -Mon Nov 11 01:50:40 1996 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0 released. - -Sun Sep 15 14:07:24 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (sgml-mode): modify mode-line-format with subst, don't - replicate the whole format in the code. - -Thu Sep 12 20:27:38 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-external-file): Try to find system - identifiers using the sgml-public-map - if sgml-system-identifiers-are-preferred; this way that flag will - have effect even if the sgml-public-map contains `%s'. - (sgml-final): moved to be defined before use. - - * psgml-dtd.el (sgml-parse-parameter-literal): Try to handle - character references to character number above 255 by leaving a - character reference in then parsed entity text. - -Thu Sep 5 14:11:00 1996 Dave Love <d.love@dl.ac.uk> - - * psgml-other.el (sgml-set-face-for): Nullify - {after,before}-change-functions as well as (obsolete) - {after,before}-change-function. - -Tue Sep 10 17:52:40 1996 Steven L Baur <steve@miranova.com> - - * Various files: Sync'ed with 1.0a12 - -Fri Jul 12 18:20:07 1996 Steven L Baur <steve@miranova.com> - - * Various files: Sync'ed up to Wingpsgml - - * iso-sgml.el: Added Appendix 2 Proposed entity additions to Latin-2 - -Fri Jul 12 03:38:10 1996 Adrian Aichner <aichner@ecf.teradyne.com> - - * psgml-edit.el: Allow user to control capitalization of auto-inserted - keywords. - - -Sun Sep 1 01:53:33 1996 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0a12 - - * psgml-maint.el: new file. Used to compile psgml. - -Tue Aug 20 23:11:30 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el: - (sgml-validate-error-regexps): Fixes from Dave Love <d.love@dl.ac.uk> - and David Megginson <dmeggins@uottawa.ca> for use with nsgmls. - (sgml-validate-command): changed default validate command to use - nsgmls. - -Sun Aug 11 19:21:56 1996 Lennart Staflin <lenst@lysator.liu.se> - - * iso88591.map: added code to character mappings. - -Thu Jun 13 20:43:53 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-get-and-move): use sgml-final, not - sgml-state-final-p. In this case the substate can be an AND-state. - -Tue May 21 07:39:34 1996 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0a11 released. - -Mon May 20 23:14:02 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (psgml-version): bump version. - (sgml-build-custom-menus): fix button3 after easy-menu redefines - it. (this was actually done at an earlier date). - -Fri May 3 18:16:18 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-push-to-entity): remove binding - before/after change functions. This probably made them nil in the - main buffer. - -Fri Apr 5 14:37:47 1996 Karl Eichwalder <ke@ke.Central.DE> - - * psgml.texi, psgml-api.texi: Add INFO-DIR-ENTRY. - - * aclocal.m4, configure.in, Makefile.in: New. - * INSTALL, install-sh, mkinstalldirs: Add from autoconf-2.9 - package. - -Fri Apr 5 09:47:01 1996 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0a10 released. - -Thu Mar 21 22:14:43 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-cache-catalog): use file-truename on file - to be cached. - -Wed Mar 20 20:59:35 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-info.el (sgml-eltype-refrenced-elements): allow for - exceptions. - -Tue Mar 19 21:59:27 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-api.el (sgml-map-content): use max from main buffer when - setting parser goal. (fix bug 75). - -Sun Mar 17 15:06:26 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-list-valid-tags): Show current - shortreference map name. - - * psgml-parse.el (sgml-lookup-shortref-name): new func. - - * psgml-edit.el (sgml-what-element): display 'shortref' if cursor - over beginning of a shortref - - * psgml-parse.el (sgml-is-goal-after-start): handle stag in entity - differently from stag in buffer. - -Tue Mar 12 21:22:52 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el: removed use of & in functions and variable - names. - - * psgml-dtd.el (sgml-remove-redundant-states-1): remove unused - variable res. - - * psgml.el (sgml-parse-colon-path): remove unused variable cd-prefix - -Sun Feb 18 16:33:43 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-push-to-entity): set mc-flag to nil so that - MULE does not mangle binary data. (reported by Jeffrey Friedl - <jfriedl@nff.ncl.omron.co.jp>) - -Mon Jan 22 22:57:54 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-down-element): make sure sgml-last-element - has a reasonable value even if there is an error - -Sat Jan 6 22:07:44 1996 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-parse-nametoken): change buffer-substring - to buffer-substring-no-properties - -Sun Nov 5 13:41:36 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-parse-attribute-definition): remove - unnecessary call to sgml-general-case. - (sgml-check-nametoken-group): added a revers to get name tokens in - same order as declared. - -Sat Nov 4 12:58:56 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (sgml-validate-error-regexps): added new regexp for - nsgmls (from David M). - - * psgml-edit.el (sgml-insert-attributes): call auto-fill-function - after. - - * psgml.el (sgml-default-validate-command): add %v for - sgml-declaration variable - -Sat Aug 26 13:57:07 1995 Lennart Staflin <lenst@lysator.liu.se> - - * fs.el (fs-para): fix typo (bug 61). - - * psgml-edit.el (sgml-custom-dtd): new arglist to - sgml-doctype-insert. - - * psgml-api.el (sgml-map-content): don't take hook-variables as - parameters. Move data parsing to separate function. (bug 59) - -Wed Aug 23 20:53:50 1995 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0 a8 released. - - * psgml-edit.el (sgml-expand-shortref-to-text): use - sgml-rs-ignore-pos. - (sgml-expand-shortref-to-entity): dito. - - * psgml-other.el (sgml-build-custom-menus): make menu entry call - sgml-insert-markup. - - * psgml.el (sgml-doctype): typo. - - * psgml-parse.el (sgml-rs-ignore-pos): Replaces - sgml-last-start-pos, now buffer local. (bug 49) - (sgml-push-to-entity): set sgml-rs-ignore-pos to start of entity - reference. (bug 49) - - * psgml-edit.el (sgml-doctype-insert): Remove &rest (bug 56). - - * psgml-lucid.el (sgml-build-custom-menus): Fix (bug 56). - - * psgml-other.el (sgml-build-custom-menus): Fix (bug 56). - - * psgml-edit.el (sgml-edit-attrib-specification-list): Use the - attlist for attribute names, not the name parsed from the - buffer. This fixes problems with attached text properties. - (fixes bug 53). - -Tue Aug 22 20:56:06 1995 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0a7 released - - * psgml.el (psgml-version): bump version - -Mon Aug 21 23:38:49 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-extid-sysid): handle old style extids. - (sgml-check-entities): log message on missmatch - -Wed Aug 16 22:54:42 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el - (sgml-make-extid): optional argument dir added. New representation - for external identifiers. - (sgml-extid-dir): New attr of extid - (sgml-extid-expand): new fun. - (sgml-path-lookup): use sgml-extid-expand - (sgml-lookup-sysid-as-file): take extid as argument instead of sysid, - use sgml-extid-expand - (sgml-parse-external): don't expand sysid - - -Thu Aug 10 22:33:50 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (sgml-default-validate-command): new function. - (sgml-validate): use new func. - (sgml-validate-command): new possible value: a list of templates - to try. - -Mon Jul 31 22:34:10 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-entity-insert-text): mark entities not - found. - (sgml-entity-marked-undefined-p): new func. - (sgml-push-to-entity): set default-directory to that of external - entities file. - (sgml-parse-external): expand sysid as file name - - * psgml-info.el (sgml-display-table): add nosort option. - (sgml-general-dtd-info): more info. including undef entities. - -Sun Jul 30 22:23:15 1995 Lennart Staflin <lenst@lysator.liu.se> - - * test/son2.sgml: check that inclusions are inherited from the doc - element. - - * test/doc.dtd: adding ix element as inclusion in doc. - -Wed Jul 26 22:07:16 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-parse-catalog-buffer): recoded. Now all - entries are on the format (type name file) and name might be nil - for "noname" entries. - (sgml-catalog-lookup): changed to handle new internal catalog - format. - -Mon Jul 24 00:07:02 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-parse-catalog-buffer): Handle full catalog - format. - (sgml-catalog-lookup): Handle new catalog format including - parameter entities. - (sgml-search-catalog): new function, can be used to look up - SGMLDECL etc.. - - * psgml.el (sgml-system-identifiers-are-preferred): new option. - -Sun Jul 23 20:56:00 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-other.el (sgml-popup-multi-menu): kludge to force - x-popup-menu to be two level. - - * psgml-parse.el (sgml-do-data): move start after data consumed. - -Mon May 1 20:57:29 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-normalize-content): fixing arithmetic error - - * psgml-parse.el (sgml-make-shortmap): add missing = to skip strings - -Sun Apr 23 23:01:35 1995 Lennart Staflin <lenst@lysator.liu.se> - - * Id 46: turns on autofill, fixed. - - * psgml-parse.el (sgml-auto-fill-inhibit-function): new variable - (do-auto-fill): advise do-auto-fill to honour above variable - (sgml-need-dtd): set sgml-auto-fill-inhibit-function, and don't - set auto-fill-function. - (sgml-safe-context-of): new fun - (sgml-safe-element-at): new fun - (sgml-in-prolog-p): new fun - -Mon Apr 10 21:26:30 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-write-dtd): set file-type for oemacs. - -Tue Mar 28 19:01:53 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-try-merge-compiled-dtd): entd should be - ents. - - -Mon Mar 27 18:31:26 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-bdtd-load): var. renamed. - (sgml-eltypes-in-state): fix som inconsitencies with - token/eltype/symbol. - (sgml-list-implications): fix bug handling empty elements. - - * psgml.el (sgml-recompile-out-of-date-cdtd): renamed from - sgml-ignore-out-of-date-cdtd. - -Sun Mar 26 16:25:10 1995 Lennart Staflin <lenst@lysator.liu.se> - - * Id 34: CATALOG searching priorities, fixed. - - * psgml-parse.el (sgml-catalog-lookup): - Giv PUBLIC entries priority over ENTITY and DOCTYPE - - * Id 35: Entity manager handling of system id, fixed. - - * psgml-parse.el (sgml-lookup-sysid-as-file): new func. - (sgml-external-file): call new func. - - * Id 41: selecting from a popup menu should not be an error - Installing patch from Tim Bradshaw <tfb@edinburgh.ac.uk>, - Also fixing consequences. - Also making new menu function sgml-popup-multi-menu, - which uses call-back style. Nicer attributes menu. - - * psgml-other.el (sgml-set-face-for): Use sgml-type instead of - type for overlay property. - - * psgml-edit.el (sgml-attrib-menu): Make all attributes into one - list with submenues for every attribute. - -Thu Mar 23 20:23:26 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (sgml-mode): append to post-command-hook, this makes - psgml work better with auto-show. - - * psgml-parse.el (sgml-throw-on-error): new var. - (sgml-error): Throw if sgml-throw-on-error is set. - (sgml-push-to-entity): remove fifth arg to insert-file-contents - - * psgml-edit.el: (sgml-indent-line) - Make sgml-indent-line better behaved. - 1. Don't tab outside document element. - 2. Ignore parse errors. - - -Sun Mar 19 16:46:45 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-bdtd-load): if sgml-ignore-out-of-date-cdtd - is ask, ask before recompiling. - -Thu Mar 2 19:08:59 1995 Lennart Staflin <lenst@lysator.liu.se> - - * Id 38: auto-fill breaks pubid, fixed - - * psgml-parse.el (sgml-do-auto-fill): new function, won't - auto-fill outside document element - (sgml-need-dtd): set auto-fill-function. - -Wed Feb 22 22:51:30 1995 Lennart Staflin <lenst@lysator.liu.se> - - * Id 37: sgml-kill-element with cursor inside tag - fixed. - - * psgml-edit.el (sgml-kill-element): signal error if point is - inside markup - -Sat Jan 28 14:35:01 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-insert-element): Leave point at the end of - the element. - - * psgml.texi: Patch from Kevin R - -Mon Jan 23 19:29:33 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-tag-regexp): make it handle unclosed tags - and net tags. - - * psgml-parse.el (struct sgml-tree): new field asl, constuctor - changed. - (sgml-open-element): pass asl to sgml-make-tree - (sgml-element-attribute-specification-list): use sgml-tree-asl. - -Sat Jan 14 16:27:46 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (sgml-mode-abbrev-table): new var. From patch by Karl - Eichwalder. - (sgml-validate-command): fixed doc. (Kevin Rodgers) - -Thu Jan 12 16:57:05 1995 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-other.el (sgml-set-face-for): installed patch from Kevin - - * psgml-parse.el (sgml-do-end-tag): move call to sgml-set-markup-type - -Sun Dec 11 16:38:29 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-do-set-option): take care of - read-from-string. - - * psgml.el (psgml-version): bump - (sgml-ignore-out-of-date-cdtd): new option - - * psgml-parse.el (sgml-bdtd-load): make up to date test optional. - -Fri Dec 9 22:02:13 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-other.el: Add ranges to multipart menus. - - * psgml-edit.el (sgml-normalize-start-tag): Don't recreate - NET-start tags. - -Sun Dec 4 01:23:46 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-expand-shortref-to-text): update sgml-goal - (sgml-expand-shortref-to-entity): dito - -Tue Nov 29 13:13:13 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-before-eltype-modification): obsolete? - - * psgml-parse.el: Major changes to handling of compiled dtds - -Fri Nov 25 23:01:46 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-entities-menu): sort entities menu - -Thu Nov 17 20:45:02 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-path-lookup): set cand not res. - -Sat Nov 12 08:09:13 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-code-dtd): map over all eltypes, not only - defined, when outputing the names - -Thu Nov 3 06:47:17 1994 Lennart Staflin <lenst@lysator.liu.se> - - * Patch from Norman Walsh - - * psgml-parse.el (sgml-do-entity-ref): check - sgml-warn-about-undefined-entities. - - * psgml.el (sgml-warn-about-undefined-entities): new var. - -Mon Oct 31 20:10:58 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-try-merge-compiled-dtd): Immediately exit - entity check loop if discrepancy found. - -Sun Oct 30 17:02:09 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-copy-eltypes): remove - - * psgml.el ((fboundp 'run-hook-with-args)): conditionally define - - * psgml-edit.el (sgml-list-valid-tags): don't show shortmap. - - * psgml-dtd.el (sgml-before-eltype-modification): use - sgml-merge-eltypes instead of sgml-copy-eltypes. - (sgml-do-usemap-element): call sgml-before-eltype-modification. - - * psgml-parse.el (sgml-merge-eltypes): don't overwrite values in - old eltypes. - -Sat Oct 29 00:15:41 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-setup-doctype): new func. - - -Thu Oct 27 01:51:37 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-show-warnings): instead of suppress - warnings, defualt nil. Set to t by next trouble spot. Warnings - also shown when parsing dtd. - (sgml-parse-external): moved - (sgml-do-doctype): include the code that sgml-check-doctype-body - did have - (sgml-make-primitive-content-token): moved - -Wed Oct 26 23:23:26 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml.el (psgml-version): bump version - (sgml-ignore-undefined-elements): new option - - * psgml-parse.el (sgml-eltype-all-miscdata): replace the function - sgml-eltype-all-appdata. - (sgml-eltype-set-all-miscdata): new func. - -Tue Oct 25 01:26:03 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-declare-entity): handle #DEFAULT - - * psgml-parse.el (sgml-lookup-entity): support default entity - (sgml-entity-declare): dito - (sgml-merge-entity-tables): dito - -Sat Oct 22 01:24:50 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-read-dtd): Decode current buffer. - -Fri Oct 14 00:41:19 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-code-dtd): take dtd as argument - (sgml-save-dtd): take optional dtd - - * Id 27: insert-element looping - Test if inside markup when producing menus and completion tables. - -Wed Sep 28 08:10:19 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-set-parse-state): Use smgl-goto-epos - (sgml-push-to-entity): reuse buffers always - (sgml-close-element): don't promote position of tag - - * psgml-dtd.el (sgml-parse-external): remove use of sgml-gname-symbol - (sgml-check-declared-value): "- - (sgml-check-default-value): "- - -Tue Sep 27 20:11:57 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-open-element): take attribute specification - list as argument. Call hook sgml-open-element-hook. - (sgml-data-function): new var - (sgml-pi-function): new var - remove sgml-{g,e}name-symbol - (sgml-skip-cdata): rename to sgml-do-data - -Mon Sep 26 09:44:35 1994 Lennart Staflin <lenst@lysator.liu.se> - - * Version 1.0 a3 - -Sun Sep 25 16:12:06 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el: move sgml-set-markup-type - - * psgml-edit.el (sgml-do-set-option): add event argument - - * Id 1: C-c C-d may hang - psgml-edit.el (sgml-next-data-field): check if at end of buffer - - * psgml-edit.el (sgml-normalize-start-tag): can`t use - sgml-change-start-tag becuse trimming may have moved cursor to - some other place if the tag is implied. - - -Sun Sep 25 14:54:19 1994 Lennart Staflin (lenst@lysita) - - * psgml-lucid.el: Implement changes in psgml-other. - * Id 24: Lucid menubar problems, see above. - -Sun Sep 25 10:17:25 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-other.el (sgml-popup-menu): new func. - (sgml-max-menu-size): move here - - * psgml.el: split sgml-user-options into sgml-file-options and - sgml-user-options. Fix some properties and buffer local status. - (sgml-valid-option): new func. - (sgml-save-options): save all file options that are valid. - - * psgml-edit.el: options menu split into file and user options, - sgml-split-menu move to emacs specific files (psgml-other, - psgml-lucid). The emacs specific provides a sgml-popup-menu. - - * psgml.el (sgml-live-element-indicator): remove buffer localness - - * psgml-parse.el (sgml-parse-catalog-buffer): use sgml-parse-name - for doctype. - -Fri Sep 23 00:19:18 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-reduce-|): inline sgml-make-alt - - * psgml-parse.el (sgml-add-move-to-set): make into macro - (sgml-state-final-p): make into macro - - * psgml-dtd.el (sgml-make-primitive-content-token): make defsubst - - * psgml-parse.el (sgml-parse-name): remove defsubst - (sgml-parse-name): add compiler macro - - * psgml-dtd.el (sgml-remove-redundant-states-1): new optimizer - (sgml-make-*): use it - (sgml-make-+): use it - (sgml-make-conc): use it - - * psgml-parse.el (sgml-parse-ds): make defsubst - (sgml-parse-parameter-entity-ref): make defsubst - (sgml-do-parameter-entity-ref): new sub for above - (sgml-eltype-token): def compiler macro - (sgml-token-eltype): def compiler macro - - * psgml-dtd.el (sgml-parse-connector): make defsubst - (sgml-make-opt): nconc instead of append - - * psgml-parse.el (sgml-parser-loop): check for end tag before - skipping cdata - (sgml-skip-ps): make defsubst - - * psgml-dtd.el (sgml-parse-prolog): add cleanup entities - - * psgml-parse.el (sgml-parser-loop): move parsing of end-tag to - after shortref - - * psgml.el (sgml-debug): use sgml-log-message - - * psgml-parse.el (sgml-deref-shortmap): respect the nobol argument - (sgml-last-start-pos): New variable - (sgml-push-to-entity): set sgml-last-start-pos to buffer start if - entering an internal entity - (sgml-pop-entity): set sgml-last-start-pos - (sgml-parse-to): set sgml-last-start-pos - (sgml-parser-loop): call deref map with disabling of &#RS if point - is equal to sgml-last-start-pos - -Thu Sep 22 01:03:56 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-cleanup-entities): clean up buffers used by - sgml-push-to-entity if some looping code has left a lot of buffers. - (sgml-need-dtd): call sgml-cleanup-entities - (sgml-push-to-entity): check that the sgml-cleanup-entities works, - cludge to make sure shortref maps don't find record-start in the - beginning of internal entities. This cludge breaks the epos - promotion code. - (sgml-set-parse-state): when setting parse state to start of a - element goto epos-end (not start+len). - -Sun Sep 18 05:49:17 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el - (sgml-parse-parameter-entity-ref): call sgml-push-to-entity with - optional argument 'param. - (sgml-push-to-entity): take new optional argument and pass it to - sgml-entity-insert-text. - (sgml-entity-insert-text): take extra type argument. - ci 2.8 - (sgml-eltype-mixed): add comp.macro - (sgml-parse-name): make defsubst - -Thu Sep 15 02:06:22 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-current-entity-map): add default-directory - (sgml-set-global): set default-directory in - sgml-current-entity-map - (sgml-check-name): fix bug in compiler-macro - (sgml-insert-external-entity): don't accepty directories as result - (sgml-push-to-entity): copy default-directory to new buffer - - * psgml.el (sgml-catalog-files): new default value - -Wed Sep 14 04:36:29 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-dtd): make type an untyped vector - -Tue Sep 13 06:35:43 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-check-name): add comp-mac - (sgml-final): make defsubst - (sgml-final&): sub for above - (sgml-parse-pcdata): make defsubst - (sgml-eltype-name): add comp-mac - -Mon Sep 12 05:11:38 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-parse-processing-instruction): make defsubst - (sgml-do-processing-instruction): broken out from above - -Mon Sep 12 01:36:46 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-parse-general-entity-ref): make defsubst - (sgml-do-general-entity-ref): broken out from above - (sgml-set-markup-type): make defsubst - -Sun Sep 11 21:49:14 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-is-enabled-net): make defsubst - (sgml-parse-s): make defsubst - (sgml-element-mixed): add a compiler macro - -Sun Sep 11 00:00:45 1994 Lennart Staflin (lenst@lysita) - - * psgml-lucid.el: Install patch - From: Tim Bradshaw <tfb@edinburgh.ac.uk> - in 4.0b2 with lemacs 19.10 and up I don't think you want to add - the SGML menus before the "Help" menu since then they come out at - the right hand of the menubar. Attached patch to psgml-lucid does - the trick. - - -Thu Sep 8 23:38:20 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-dtd.el (sgml-check-content): ANY also mixed - - -Thu Sep 8 22:35:19 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-make-shortmap): Only warning for strange - short ref delimiter - - * psgml-dtd.el (sgml-dtd-shortmaps): New variable - (sgml-declare-shortref): add mapping to variable - (sgml-check-doctype-body): add shortref maps from variable to dtd - struct - - * psgml-edit.el (sgml-custom-dtd): new command - (sgml-custom-markup): new command - -Thu Sep 8 01:17:59 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-normalize): expand short references also - -Wed Sep 7 20:56:41 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-reparse-buffer): New function. - - * nefarious.el (sgml-map-element-types): Update for 1.0 - - -Sun Sep 4 17:09:27 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-untag-element): require tags to be in the - buffer - - * psgml-parse.el (sgml-update-display): parse to point-max after - parse to window-end - - * psgml.el (sgml-validate-command): change to use format string - (sgml-validate): use format - - * psgml-edit.el (sgml-operate-on-tags): give tags uniq numbers as - invisible property - -Sun Sep 4 10:21:54 1994 Lennart Staflin (lenst@lysita) - - * psgml-dtd.el (sgml-check-element-type): Fix problem with ranked - groups - - -Sun Sep 4 00:10:50 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-indent-line): use sgml-find-context-of at - end of buffer. - -Sun Sep 3 23:00:00 1994 Lennart Staflin <lenst@lysator.liu.se> - - * Version 0.4b2 - -Fri Sep 2 19:48:41 1994 Lennart Staflin (lenst@lysita) - - * psgml.el (sgml-local-catalogs): new variable - - * psgml-parse.el: Implement local serach maps for entities - - -Tue Aug 30 17:28:42 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el: Introduce sgml-current-omittag and - sgml-current-shorttag that holds golbal copies of sgml-omittag and - sgml-shorttag. Change variable references where apropriate - - * psgml-edit.el (sgml-next-trouble-spot): ignore warnings before - point - (sgml-expand-entity-reference): New command - -Mon Aug 29 07:44:48 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-parse.el (sgml-parser-loop): Take argument: a function - that should return t if the loop should be prematurely exited - (sgml-parse-to): take optional argument to pass to sgml-parser-loop - - * psgml.el (sgml-command-post): function called from - post-command-hook. Activates DTD is `sgml-auto-activate-dtd' is - set and call `sgml-update-display' in psgml-parse if there is an - active DTD. - (sgml-auto-activate-dtd): New variable. - - * psgml-parse.el (sgml-update-display): instead of - sgml-set-live-indicator - - * psgml-dtd.el (sgml-parse-character-reference): only parse - function character refrences if optional argument is true - -Sat Aug 27 10:53:54 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el: Implement short references - -Fri Aug 26 02:47:35 1994 Lennart Staflin <lenst@lysator.liu.se> - - * psgml-edit.el (sgml-operate-on-tags): only set inivisible - property (and rear-nonsticky) - - * psgml-parse.el (sgml-parse-to): remove sgml-hide manipulation - -Fri Aug 26 00:02:30 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-set-live-element-indicator): don't let - point be inside an invisible region. - -Thu Aug 25 04:35:33 1994 Lennart Staflin (lenst@konrad) - - * psgml-edit.el (sgml-operate-on-tags): use category sgml-hide - instead of invisible+read-only. - - * psgml-parse.el (sgml-parse-to): temporary set sgml-hide's - property intangible to nil when parsing. - - * psgml.el (sgml-max-menu-size): set as 2/3 of frame-height - (psgml-version): bump version - - * psgml-parse.el (sgml-do-pcdata): set markup type nil, to delete - any overlays left from previous parse. - - * psgml-other.el (sgml-mode-map): change Fold to View - (sgml-set-face-after-change): disable - - * Version 1a1 - -Wed Aug 24 20:29:37 1994 Lennart Staflin (lenst@dell) - - * psgml-edit.el: changing append to nconc - - * psgml-parse.el: changing append to nconc - -Wed Aug 24 07:06:39 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-set-live-element-indicator): parse to - window-end after sit-for to set faces. - - * psgml.el (sgml-exposed-tags): new variable. - - * psgml-edit.el (sgml-operate-on-tags): install patch - From: kevinr@airedale (Kevin Rodgers) - (sgml-operate-on-tags): installed another patch from above. Added - variable sgml-exposed-tags. - -Tue Aug 23 02:32:45 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-load-dtd): install patch - date: 1994/08/19 18:30:03; author: kevinr; state: Exp; - lines: +3 -3 sgml-load-dtd, sgml-external-file: Use - `expand-file-name' instead of `concat'. - - * psgml-dtd.el (sgml-make-pcdata): change sgml-make-opt to - sgml-make-* - -Mon Aug 22 21:30:04 1994 Lennart Staflin (lenst@lysita) - - * psgml-edit.el: split psgml-parse into psgml-parse and psgml-edit - -Sat Aug 20 02:10:32 1994 Lennart Staflin (lenst@lysita) - - * psgml.texi (Attributes): add C-c C-d in attribute edit mode. - -Sat Aug 13 00:59:17 1994 Lennart Staflin (lenst@lysita) - - * psgml.el (sgml-mode): add some documentation. - -Mon Jul 19 1994 00:33:28 Kevin Rodgers <kevinr@ihs.com> - - * psgml-parse.el (sgml-close-element-hook): Define. - (sgml-close-element): Invoke `sgml-close-element-hook' after - `(sgml-tree-end sgml-current-tree)' and `(sgml-tree-etag-len - sgml-current-tree)' have been set. - -Fri Aug 12 21:19:52 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-pub-expand-char): remove test -- expand any - character. - - * experiment.el (sgml-pub-expand-char): remove test -- expand any - character. - -Thu Aug 11 20:13:44 1994 Lennart Staflin (lenst@lysita) - - * psgml-parse.el (sgml-push-to-param): move call to - sgml-external-file to before set-buffer. Simplify testing. - -Tue Jul 12 1994 21:39:20 Kevin Rodgers <kevinr@ihs.com> - - * psgml-parse.el (sgml-map-public): Accept an additional - optional argument, NAME, and map `n' to it if it's not nil. - (sgml-external-file): Pass the optional argument NAME to - `sgml-map-public'. - (sgml-pub-expand-char): Recognize `n' as well as `c', `o', and - `d' (and their upper-case variants). - -Wed Jul 6 21:17:41 1994 Lennart Staflin (lenst@konrad) - - * psgml-parse.el (sgml-next-data-field): stop any where but avoid - current element (previously only stopped at the beginning of an - element)
--- a/lisp/psgml/README.psgml Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,317 +0,0 @@ -This is the READ ME file for psgml.el version 1.0 -*- text -*- - - PSGML is a major mode for editing SGML documents. It works with -GNU Emacs 19.19 and later or with XEmacs 19.13. - -This distribution should contain the following source files: - psgml.el - psgml.texi - psgml-other.el - psgml-lucid.el - psgml-edit.el - psgml-parse.el - psgml-dtd.el - psgml-info.el - psgml-charent.el - psgml-api.texi -- internals documentation - psgml-api.el -- Extra functions for the API - iso88591.map - Makefile.in - -In addition the distribution contains the formatted versions of the -documentation files (psgml.info, ...). But the compiled elisp code is -no longer supplied. You will have to byte compile the files before -PSGML will achieve usable speed. - -PSGML now comes with autoconf support. See INSTALL for generic -instructions. Run - - sh configure - make - -and possibly - - make install - -If you are using xemacs, you can run give the argument `--with-xemacs' -to configure, or use `make xemacs'. - -Instead of using configure you can load the psgml-main.el file and run -the command psgml-compile-files. Then you have to set load-path or -move the .elc files. - -Send bug reports, comments and suggestions to lenst@lysator.liu.se. - -New in version 1.0 - -* Main changes - -** Support for general entities - -** Support for short reference - -** Support for catalog files - -** New mechanism for caching parsed DTD - -** Includes commands to list various aspects of the DTD - -* Entity support - -PSGML will recognize entity references (except in attribute values). If -the entity is a general text entity, PSGML will also parse the content -of the entity. To support this PSGML has a new entity manager with a -new mechanism for looking up entities (see belove). - -Short references are also supported, for the short reference delimiters -from the concrete reference syntax. - -There are some new and changed commands to complete the entity support: - -** Command: `sgml-expand-entity-reference' - -Insert the text of the entity referenced at point. - -** Command: `sgml-expand-all-shortrefs' - -Expand all short references in the buffer. Short references to text -entities are expanded to the replacement text of the entity, other -short references are expanded into general entity references. If -argument, `to-entity', is non-nil, or if called interactive with -numeric prefix argument, all short references are replaced by generally -entity references. - -** Command: `sgml-normalize' - -Changed to expand short references also. Normalize buffer by filling in -omitted tags and expanding empty tags. Argument `to-entity' controls -how short references are expanded as with `sgml-expand-all-shortrefs'. - -* Fontification - -If `sgml-set-face' is true and the DTD has been activated, PSGML will -automatically set the face of markup in the buffer. - -First the current line is parsed and fontified. If this would mean -parsing more than 500 chars, wait 1 second first. - -The rest of the buffer is fontified after 6 seconds idle time. - -Fontification can be interrupted by any input event. - -The buffer can be fontified initially if `sgml-auto-activate-dtd' is -true. - -* New entity manager - -The new entity manager will handle an entity reference thus: - -** If the entity has a system identifier, the entity manager will first -try and call the functions on `sgml-sysid-resolve-functions' with the -system identifier as argument, and if any function returns non-nil -assume that the function has handled the entity. - -** If the entity has a system identifier and -`sgml-system-identifiers-are-preferred' is non-nil, the system -identifier will be used as a file name relative to the file containing -the entity declaration. - -** Next the entity manager will try the catalog, and - -** if not found there use the `sgml-public-map'. - -** Finally if the entity has not been found and it has a system -identifier, this will be used as a file name. - -Note: `sgml-system-path' is no longer used for entity lookup. - -The catalog files searched is given by the variable -`sgml-local-catalogs' and `sgml-catalog-files'. The -`sgml-catalog-files' variable is initialized from the environment -variable `SGML_CATALOG_FILES' (should be a colon separated list of -files). The `sgml-local-catalogs' variable is assumed to be set in a -files local variables. - -File names for external entities (e.g system identifiers) are relative -to the directory containing the file declaring the entity. - -The `sgml-public-map' is initialized from the environment variable -`SGML_PATH'. - -`sgml-system-path' defaults to nil. - -Supports most of sgmls substitutions for sgml-public-map. Supported: -%%, %N, %P, %S, %Y, %C, %L, %O, %T, %V. Unsupported: %D, %X, %A, %E, -%I, %R, %U. Note: that %D is and alias for %C in PSGML (historical -accident). - -* New and changed options - -** `sgml-recompile-out-of-date-cdtd' - -** New options for insert-element: -`sgml-insert-missing-element-comment' and -`sgml-insert-end-tag-on-new-line'. - -** `sgml-validate-files' and slight change of `sgml-validate-command' - -The variable `sgml-validate-command' can now be a list of strings. The -strings can contain %-sequences that will be expanded: %b to buffer -file name, %s to SGML Declaration file, either the value of -sgml-declaration variable or SGML Declaration file for parent document -or DOCTYPE file or SGMLDECL from catalog. %d value of `sgml-doctype'. - -** `sgml-set-face' - -Now automatically sets faces for all visible text, with a delay of 1s. - -** `sgml-exposed-tags' - -The list of tag names that remain visible, despite `M-x -sgml-hide-tags'. Each name is a lowercase string, and start-tags and -end-tags must be listed individually. - -** `sgml-auto-activate-dtd' - -PSGML was behaving inconsistent when a new file was loaded. If the -variable `sgml-set-face' was true the DTD would automatically be -activated (loaded or parsed), but only if psgml-parse already loaded. - -Rather than let `sgml-set-face' decide if the DTD is activated, there -is now a distinct option for this. This option works even the first -time. - -If non-nil, loading a sgml-file will automatically try to activate its -DTD. Activation means either to parse the document type declaration or -to load a previously saved parsed DTD. The name of the activated DTD -will be shown in the mode line. - -* Various - -** Tracing catalog lookup - -To help debug entity lookup there is a new option -`sgml-trace-entity-lookup'. If this option is t messages will be logged -in *SGML LOG* buffer when external entities are looked up. These -messages shows entity, catalogs searched, and entry type in catalog -where entity was found. - -** Translating between characters and entity references - -Set the variable `sgml-display-char-list-filename' to a file that -contains mappings between all characters present in the presentation -character set, and their "standard replacement text" names, e.g. "å" -> -"[aring ]", e.t.c. The default value for this variable is -`iso88591.map'. - -Use the functions (also in the Modify menu) -`sgml-charent-to-display-char' and `sgml-display-char-to-charent' to -translate between entities and characters. - -** Handling of missing DOCTYPE - -If the document prolog does not contain a document type declaration, -PSGML will try to supply one on the form `<!DOCTYPE DocTypeName -SYSTEM>' If the variable `sgml-default-doctype-name' is defined this -will be used for the document type name, otherwise the GI of the first -start tag will be used. I.e., if the document starts with `<book>', a -document type declaration `<!DOCTYPE book SYSTEM>' will be assumed. - -** Handling of tags for undefined elements - -*** Start-tags for undefined elements will either be ignored, if -`sgml-ignore-undefined-elements' is `t', or assumed to be acceptable in -the current element and defined with `O O ANY'. - -*** An end-tag for an element that is not currently open will be -ignored. - -** Cleaned up Markup menu - -The removed entries can be added with sgml-custom-markup: - -(setq sgml-custom-markup - '(("<!entity ... >" "<!entity \r>\n") - ("<!attlist ... >" "<!attlist \r>\n") - ("<!element ... >" "<!element \r>\n") - ("<!doctype ...>" "<!doctype \r -- public or system --\n[\n]>\n") - ("Local variables comment" "<!--\nLocal variables:\n\rEnd:\n-->\n") - ("Comment" "<!-- \r -->\n") )) - -** New commands - -Thanks to David Megginson the custom menus are now reachable from the -keyboard: - -`C-c C-u C-d' (`sgml-custom-dtd') - -`C-c C-u C-m' (`sgml-custom-markup') - -* Changes to API - -** New hooks - -*** `sgml-close-element-hook' - -The hook run by `sgml-close-element'. These functions are invoked with -`sgml-current-tree' bound to the element just parsed. - -*** `sgml-new-attribute-list-function' - -This hook is run when a new element is inserted to construct the -attribute specification list. The default function prompts for the -required attributes. - -*** `sgml-doctype-parsed-hook' - -This hook is called after the doctype has been parsed. It can be used -to load any additional information into the DTD structure. - -Example: add description to element types - -(defun set-help-info () - (let ((help '(("para" "A Paragraph") - ("q" "A Quotation") - ("date" "A Date"))) - (dtd (sgml-pstate-dtd sgml-buffer-parse-state))) - (loop for h in help do - (setf (sgml-eltype-appdata (sgml-lookup-eltype (first h) dtd) - 'help-string) - (second h))))) -(add-hook 'sgml-doctype-parsed-hook 'set-help-info) -(defun sgml-help-for-element () - (interactive) - (let* ((el (sgml-find-element-of (point))) - (help (sgml-element-appdata el 'help-string))) - (and help - (message "%s" help)))) - -*** sgml-sysid-resolve-functions - -This variable should contain a list of functions. Each function should -take one argument, the system identifier of an entity. If the function -can handle that identifier, it should insert the text of the entity -into the current buffer at point and return t. If the system identifier -is not handled the function should return nil. - -Example use: Support URLs as system identifiers - -(defun sgml-url-sysid (sysid) - (cond ((string-match "^\\([a-z]+\\):" sysid) ; looks like url - (require 'url) - (set-buffer (prog1 (current-buffer) - (url-retrieve sysid))) - (insert-buffer url-working-buffer) - t))) -(add-hook 'sgml-sysid-resolve-functions 'sgml-url-sysid) - -** New file psgml-api.el - -This file contain API-functions that are not used by other parts of -psgml. Use `(require 'psgml-api)' to use the API functions (psgml-api -includes the rest of the psgml files). - -Local variables: -mode: text -mode: outline -end:
--- a/lisp/psgml/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,95 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'psgml-autoloads) (error "Already loaded")) - -;;;### (autoloads (style-format) "psgml-fs" "psgml/psgml-fs.el") - -(autoload 'style-format "psgml-fs" nil t nil) - -;;;*** - -;;;### (autoloads nil "psgml-html" "psgml/psgml-html.el") - -(autoload 'html-mode "psgml-html" "\ -HTML mode." t) - -(autoload 'html3-mode "psgml-html" "\ -HTML3 mode." t) - -;;;*** - -;;;### (autoloads (sgml-mode) "psgml" "psgml/psgml.el") - -(autoload 'sgml-mode "psgml" "\ -Major mode for editing SGML.\\<sgml-mode-map> -Makes > display the matching <. Makes / display matching /. -Use \\[sgml-validate] to validate your document with an SGML parser. - -You can find information with: -\\[sgml-show-context] Show the nesting of elements at cursor position. -\\[sgml-list-valid-tags] Show the tags valid at cursor position. - -Insert tags with completion of contextually valid tags with \\[sgml-insert-tag]. -End the current element with \\[sgml-insert-end-tag]. Insert an element (i.e. -both start and end tag) with \\[sgml-insert-element]. Or tag a region with -\\[sgml-tag-region]. - -To tag a region with the mouse, use transient mark mode or secondary selection. - -Structure editing: -\\[sgml-backward-element] Moves backwards over the previous element. -\\[sgml-forward-element] Moves forward over the next element. -\\[sgml-down-element] Move forward and down one level in the element structure. -\\[sgml-backward-up-element] Move backward out of this element level. -\\[sgml-beginning-of-element] Move to after the start tag of the current element. -\\[sgml-end-of-element] Move to before the end tag of the current element. -\\[sgml-kill-element] Kill the element following the cursor. - -Finding interesting positions -\\[sgml-next-data-field] Move forward to next point where data is allowed. -\\[sgml-next-trouble-spot] Move forward to next point where something is - amiss with the structure. - -Folding and unfolding -\\[sgml-fold-element] Fold the lines comprising the current element, leaving - the first line visible. -\\[sgml-fold-subelement] Fold the elements in the content of the current element. - Leaving the first line of every element visible. -\\[sgml-unfold-line] Show hidden lines in current line. - -User options: - -sgml-omittag Set this to reflect OMITTAG in the SGML declaration. -sgml-shortag Set this to reflect SHORTTAG in the SGML declaration. -sgml-auto-insert-required-elements If non-nil, automatically insert required - elements in the content of an inserted element. -sgml-balanced-tag-edit If non-nil, always insert start-end tag pairs. -sgml-omittag-transparent If non-nil, will show legal tags inside elements - with omitable start tags and legal tags beyond omitable end tags. -sgml-leave-point-after-insert If non-nil, the point will remain after - inserted tag(s). -sgml-warn-about-undefined-elements If non-nil, print a warning when a tag - for a undefined element is found. -sgml-max-menu-size Max number of entries in Tags and Entities menus before - they are split into several panes. -sgml-always-quote-attributes If non-nil, quote all attribute values - inserted after finishing edit attributes. -sgml-minimize-attributes Determines minimization of attributes inserted by - edit-attributes. -sgml-normalize-trims If non-nil, sgml-normalize will trim off white space - from end of element when adding end tag. -sgml-indent-step How much to increament indent for every element level. -sgml-indent-data If non-nil, indent in data/mixed context also. -sgml-set-face If non-nil, psgml will set the face of parsed markup. -sgml-markup-faces The faces used when the above variable is non-nil. -sgml-system-path List of directories used to look for system identifiers. -sgml-public-map Mapping from public identifiers to file names. -sgml-offer-save If non-nil, ask about saving modified buffers before - \\[sgml-validate] is run. - -All bindings: -\\{sgml-mode-map} -" t nil) - -;;;*** - -(provide 'psgml-autoloads)
--- a/lisp/psgml/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Thu Oct 9 20:52:27 1997 - -;;; Code: - -(custom-put 'extensions 'custom-loads '("tempo")) -(custom-put 'psgml-dtd 'custom-loads '("psgml")) -(custom-put 'html 'custom-loads '("psgml-html")) -(custom-put 'psgml 'custom-loads '("psgml-html" "psgml")) -(custom-put 'psgml-html 'custom-loads '("psgml-html")) -(custom-put 'sgml 'custom-loads '("psgml-html" "psgml")) -(custom-put 'tempo 'custom-loads '("tempo")) -(custom-put 'languages 'custom-loads '("psgml")) -(custom-put 'psgml-insert 'custom-loads '("psgml")) - -;;; custom-load.el ends here
--- a/lisp/psgml/iso-sgml.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,264 +0,0 @@ -;; iso-sgml.el --- display SGML entity references as ISO 8859-1 characters - -;; Copyright (C) 1994 Frederic Lepied - -;; Author: Frederic Lepied <lepied@cenaath.cena.dgac.fr> -;; Maintainer: lepied@cenaath.cena.dgac.fr -;; Keywords: SGML, HTML, ISO, Latin, i18n -;; Status: Works with emacs 19.24 -;; Created: 1994-06-21 -;; Last Modified By: Frederic Lepied [STERIA SIT] 69577103 -;; Last Modified On: Wed Dec 7 10:14:41 1994 -;; Update Count: 5 - -;; LCD Archive Entry: -;; iso-sgml|Frederic Lepied|lepied@cenaath.cena.dgac.fr| -;; Edit SGML or HTML buffers with ISO 8859-1 (Latin-1) display| -;; 10-May-1995|1.4|~/misc/iso-sgml.el.Z| - -;; $Id: iso-sgml.el,v 1.2 1997/09/27 16:57:46 steve Exp $ - -;; This program 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. -;; -;; This program 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 this program; if not, you can either send email to this -;; program's maintainer or write to: The Free Software Foundation, -;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA. - -;; Commentary: -;; Based on iso-cvt.el from Michael Gschwind <mike@vlsivie.tuwien.ac.at>, -;; iso-sgml.el transparently displays entity references in SGML or HTML -;; buffers as ISO 8859-1 (aka Latin-1) characters. -;; Modified for XEmacs 19.15 to include the proposed extensions to Latin-1 -;; by Steve Baur <steve@altair.xemacs.org> - -;; SEE ALSO: -;; iso-cvt.el -;; If you are interested in questions related to using the ISO 8859-1 -;; characters set (configuring emacs, Unix, etc. to use ISO), then you -;; can get the ISO 8859-1 FAQ via anonymous ftp from -;; ftp.vlsivie.tuwien.ac.at in /pub/bit/FAQ-ISO-8859-1 - -;; INSTALLATION: -;; add the following line to your .emacs : -;; (load "iso-sgml") -;; If you want it to work with other modes change the value of the -;; the variable isosgml-modes-list like this : -;; (setq isosgml-modes-list '(my-mode)) - -;; Code: - -(defconst isosgml-version "$Id: iso-sgml.el,v 1.2 1997/09/27 16:57:46 steve Exp $" - "iso-sgml RCS version number") - -(defvar isosgml-modes-list '(html-mode html-helper-mode sgml-mode) - "*List of modes to translate between SGML or HTML entity references - and the ISO 8859-1 character set.") - - -(defun isosgml-translate-conventions (trans-tab) - "Use the translation table argument to translate the current buffer." - (save-excursion - (let ((beg (point-min-marker)) ; see the `(elisp)Narrowing' Info node - (end (point-max-marker))) - (unwind-protect - (progn - (widen) - (goto-char (point-min)) - (let ((buffer-read-only nil) ; (inhibit-read-only t)? - (case-fold-search nil)) - (while trans-tab - (save-excursion - (let ((trans-this (car trans-tab))) - (while (search-forward (car trans-this) nil t) - (replace-match (car (cdr trans-this)) t t))) - (setq trans-tab (cdr trans-tab)))))) - (narrow-to-region beg end))))) - -(defvar sgml2iso-trans-tab - '( - ("Æ\;" "Æ") - ("Á\;" "Á") - ("Â\;" "Â") - ("À\;" "À") - ("Ã\;" "Ã") - ("Ç\;" "Ç") - ("É\;" "É") - ("È\;" "È") - ("Ë\;" "Ë") - ("Í\;" "Í") - ("Î\;" "Î") - ("Ì\;" "Ì") - ("Ï\;" "Ï") - ("Ñ\;" "Ñ") - ("Ó\;" "Ó") - ("Ô\;" "Ô") - ("Ò\;" "Ò") - ("Ø\;" "Ø") - ("Ú\;" "Ú") - ("Ù\;" "Ù") - ("Ý\;" "Ý") - ("á\;" "á") - ("â\;" "â") - ("´\;" "´") - ("æ\;" "æ") - ("à\;" "à") - ("å\;" "å") - ("ã\;" "ã") - ("¦\;" "¦") - ("ç\;" "ç") - ("¸\;" "¸") - ("¢\;" "¢") - ("©\;" "©") - ("¤\;" "¤") - ("°\;" "°") - ("é\;" "é") - ("ê\;" "ê") - ("è\;" "è") - ("ë\;" "ë") - ("½\;" "½") - ("¼\;" "¼") - ("¾\;" "¾") - ("í\;" "í") - ("î\;" "î") - ("ì\;" "ì") - ("¡\;" "¡") - ("¿\;" "¿") - ("ï\;" "ï") - ("«\;" "«") - ("¯\;" "¯") - ("µ\;" "µ") - ("·\;" "·") - (" \;" " ") - ("¬\;" "¬") - ("ñ\;" "ñ") - ("ó\;" "ó") - ("ô\;" "ô") - ("ò\;" "ò") - ("ª\;" "ª") - ("º\;" "º") - ("ø\;" "ø") - ("õ\;" "õ") - ("¶\;" "¶") - ("£\;" "£") - ("±\;" "±") - ("«\;" "»") - ("®\;" "®") - ("§\;" "§") - ("­\;" "") - ("¹\;" "¹") - ("²\;" "²") - ("²\;" "³") - ("ú\;" "ú") - ("û\;" "û") - ("ù\;" "ù") - ("¨\;" "¨") - ("ý\;" "ý") - ("¥\;" "¥") - ("Ä\;" "Ä") - ("ä\;" "ä") - ("Ö\;" "Ö") - ("ö\;" "ö") - ("Ü\;" "Ü") - ("ü\;" "ü") - ("ß\;" "ß") - ("§\;" "§") - ("¶\;" "¶") - ("©\;" "©") - ("¡\;" "¡") - ("¿\;" "¿") - ("¢\;" "¢") - ("£\;" "£") - ("×\;" "×") - ("±\;" "±") - ("÷\;" "÷") - ("¬\;" "¬") - ("&mu\;" "µ") - ("&Ae\;" "Ä") - ("&ae\;" "ä") - ("&Oe\;" "Ö") - ("&oe\;" "ö") - ("&Ue\;" "Ü") - ("&ue\;" "ü") - ("&sz\;" "ß") - ) - "Translation table from SGML entity references to ISO 8859-1 characters.") - -(defun fix-sgml2iso () - "Replace SGML entity references with ISO 8859-1 (aka Latin-1) characters." - (interactive) - (if (member major-mode isosgml-modes-list) - (let ((buffer-modified-p (buffer-modified-p))) - (unwind-protect - (isosgml-translate-conventions sgml2iso-trans-tab) - (set-buffer-modified-p buffer-modified-p))))) - -(defvar iso2sgml-trans-tab - (mapcar (function (lambda (entity-char) ; (ENTITY CHAR) - ;; Return (CHAR ENTITY) - (list (car (cdr entity-char)) - (car entity-char)))) - sgml2iso-trans-tab) - "Translation table from ISO 8859-1 characters to SGML entity references.") - -(defun fix-iso2sgml () - "Replace ISO 8859-1 (aka Latin-1) characters with SGML entity references." - (interactive) - (if (member major-mode isosgml-modes-list) - (let ((buffer-modified-p (buffer-modified-p))) - (unwind-protect - (isosgml-translate-conventions iso2sgml-trans-tab) - (set-buffer-modified-p buffer-modified-p))))) - - -(add-hook 'find-file-hooks 'fix-sgml2iso) -(add-hook 'write-file-hooks 'fix-iso2sgml) -(add-hook 'after-save-hook 'fix-sgml2iso) - -(provide 'iso-sgml) - -;; iso-sgml.el ends here - -; $Log: iso-sgml.el,v $ -; Revision 1.2 1997/09/27 16:57:46 steve -; Patches to beta24 -; -; Revision 1.4 1995/05/10 06:19:41 lepied -; * protect code with unwind-protect to prevent errors -; -; Revision 1.3 1994/12/07 09:08:07 lepied -; Thanks to kevinr@ihs.com (Kevin Rodgers) -; * replace regular expression search with normal one -; * cleanup interactive use -; -; Revision 1.2 1994/11/24 06:49:08 lepied -; Integrated patch from kevinr@ihs.com (Kevin Rodgers) : -; -; * iso-sgml.el (sgml2iso-trans-tab): Delete backslash (`\') from -; "±" entity reference. -; -; * iso-sgml.el (file header, library header (Keywords), LCD -; Archive Entry (description) [comment blocks]): Properly refer to -; SGML entity references; uppercase acronyms (ISO, SGML, HTML); -; capitalize Latin. -; (Commentary [comment block]): Rewrite as a complete sentence. -; (sgml2iso-trans-tab, fix-sgml2iso [doc strings]): Properly refer -; to SGML entity references. -; (iso2sgml-trans-tab, fix-iso2sgml [doc strings]): Properly refer -; to SGML entity references. -; -; * iso-sgml.el (iso2sgml-trans-tab): Initialize by -; programmatically reversing elements of sgml2iso-trans-tab, -; instead of hand-coding each element. -; -; Revision 1.1 1994/06/22 15:15:13 lepied -; Initial revision -;
--- a/lisp/psgml/psgml-api.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,107 +0,0 @@ -;;; psgml-api.el --- Extra API functions for PSGML -;; $Id: psgml-api.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> - -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; Commentary: - -;; Provides some extra functions for the API to PSGML. - - -;;; Code: - -(provide 'psgml-api) -(require 'psgml) -(require 'psgml-parse) - - -;;;; Mapping: map and modify - -(defun sgml-map-element-modify (el-fun element) - "Apply EL-FUN to ELEMENT and the elements in its content. -The EL-FUN may change the buffer. But if it changes the buffer and -leaves the element with no start-tag some elements may be ignored." - (let ((level ; level in the element tree - 0) - next - (tick ; change counter - (buffer-modified-tick))) - (while element - (funcall el-fun element) - ;; If the function has modified the buffer, a fresh parse is needed - (when (/= tick (buffer-modified-tick)) - (setq element (sgml-find-element-of (sgml-element-start element))) - (setq tick (buffer-modified-tick))) - (cond - ;; Map content if any - ((setq next (sgml-element-content element)) - (incf level)) - ;; If in a sub-tree, move to next element - (t - (while (and (> level 0) - (null (setq next (sgml-element-next element)))) - (setq element (sgml-element-parent element)) - (decf level)))) - (setq element next)))) - -;;;; Map content - -(defun sgml-map-content (element element-fun - &optional data-fun pi-fun entity-fun) - "Map content of ELEMENT, calling ELEMENT-FUN for every element. -Also calling DATA-FUN, if non-nil, with data in content." - (sgml-pop-all-entities) - (sgml-need-dtd) - (sgml-element-end element) ; Make sure all content is parsed - (let ((main-buffer-max (point-max))) - (save-excursion - (sgml-set-parse-state element 'start) - (when (eobp) (sgml-pop-entity)) - (when (eolp) (forward-char 1)) - (sgml-parse-data main-buffer-max data-fun pi-fun entity-fun) - (let ((c (sgml-tree-content element))) - (while c - (sgml-pop-all-entities) - (funcall element-fun c) - (sgml-set-parse-state c 'after) - (sgml-parse-data main-buffer-max data-fun pi-fun entity-fun) - (setq c (sgml-tree-next c))))) - ) - (sgml-pop-all-entities)) - -(defun sgml-parse-data (sgml-goal sgml-data-function sgml-pi-function - sgml-entity-function) - (let ((sgml-throw-on-element-change 'el-done)) - (catch sgml-throw-on-element-change - (sgml-with-parser-syntax - (sgml-parser-loop nil))))) - -;;;; Entity management - -(defun sgml-push-to-string (string) - "Create an entity from STRING and push it on the top of the entity stack. -After this the current buffer will be a scratch buffer containing the text -of the new entity with point at the first character. - Use `sgml-pop-entity' to exit from this buffer." - (sgml-push-to-entity (sgml-make-entity "#STRING" 'text string))) - - - -;;; psgml-api.el ends here
--- a/lisp/psgml/psgml-charent.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,118 +0,0 @@ -;;;; psgml-charent.el -;;; Last edited: Mon Nov 28 22:18:09 1994 by lenst@lysistrate (Lennart Staflin) -;;; $Id: psgml-charent.el,v 1.2 1997/04/24 04:00:12 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Steinar Bang, Falch Hurtigtrykk as., Oslo, 940711 -;; Lennart Staflin <lenst@lysator.liu.se> -;; -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Functions to convert character entities into displayable characters -;; and displayable characters back into character entities. - - -;;;; Code: - -(provide 'psgml-charent) -(require 'psgml-parse) - - -;;;; Variable declarations - -(defvar sgml-display-char-list-filename - (expand-file-name "sgml/iso88591.map" data-directory) - "*Name of file holding relations between character codes and character -names of displayable characters") - -(defvar sgml-display-char-alist-cache nil) - - -;;;; Function declarations - -(defun sgml-display-char-alist () - "Return the current display character alist. -Alist with entity name as key and display character as content." - (unless (file-exists-p sgml-display-char-list-filename) - (error "No display char file: %s" - sgml-display-char-list-filename)) - (sgml-cache-catalog sgml-display-char-list-filename - 'sgml-display-char-alist-cache - (function sgml-read-display-char-alist))) - -(defun sgml-read-display-char-alist () - (let (key disp-char alist) - (while (re-search-forward "^\\([0-9]+\\)[ \t]+\\(.+\\)$" nil t) - (setq key (buffer-substring (match-beginning 2) (match-end 2))) - (setq disp-char - (char-to-string - (string-to-number - (buffer-substring (match-beginning 1) (match-end 1))))) - (push (cons key disp-char) - alist)) - alist)) - -(defun sgml-charent-to-dispchar-alist () - "Association list to hold relations of the type - (CHARACTER-NAME . CHARACTER) - where - CHARACTER-NAME is a string holding a character name - CHARACTER is a string holding a single displayable character" - (sgml-need-dtd) - (let ((display-chars (sgml-display-char-alist)) - (alist nil)) - (sgml-map-entities - (function - (lambda (entity) - (let ((char (cdr (assoc (sgml-entity-text entity) - display-chars)))) - (when char - (push (cons (sgml-entity-name entity) char) alist))))) - (sgml-dtd-entities sgml-dtd-info)) - - alist)) - - -(defun sgml-charent-to-display-char () - "Replace character entities with their display character equivalents" - (interactive) - (let ((charent-to-char - (sgml-charent-to-dispchar-alist)) - charent replacement) - (save-excursion - (goto-char (point-min)) - (sgml-with-parser-syntax - (while (re-search-forward "&\\(\\w\\(\\w\\|\\s_\\)+\\);?" nil t) - (setq charent (buffer-substring (match-beginning 1) (match-end 1))) - (if (setq replacement (cdr (assoc charent charent-to-char))) - (replace-match replacement t t))))))) - -(defun sgml-display-char-to-charent () - "Replace displayable characters with their character entity equivalents" - (interactive) - (let ((case-fold-search nil)) - (save-excursion - (loop for pair in (sgml-charent-to-dispchar-alist) - do (goto-char (point-min)) - (while (search-forward (cdr pair) nil t) - (replace-match (concat "&" (car pair) ";") t t)))))) - - - -;;; psgml-charent.el ends here
--- a/lisp/psgml/psgml-debug.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,370 +0,0 @@ -;;;;\filename dump.el -;;;\Last edited: Sun Mar 24 19:17:42 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin) -;;;\RCS $Id: psgml-debug.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ -;;;\author {Lennart Staflin} -;;;\maketitle - -;;\begin{codeseg} -(provide 'psgml-debug) -(require 'psgml) -(require 'psgml-parse) -(require 'psgml-edit) -(require 'psgml-dtd) -(autoload 'sgml-translate-model "psgml-dtd" "" nil) - -;;;; Debugging - -(define-key sgml-mode-map "\C-c," 'sgml-goto-cache) -(define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree) -(define-key sgml-mode-map "\C-c." 'sgml-shortref-identify) - -(defun sgml-this-element () - (interactive) - (let ((tree (sgml-find-element-of (point)))) - (sgml-dump-rec tree))) - -(defun sgml-goto-cache () - (interactive) - (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state) - sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state)) - (sgml-find-start-point (point)) - (message "%s" (sgml-dump-node sgml-current-tree))) - -(defun sgml-dump-tree (arg) - (interactive "P") - (when arg - (sgml-parse-to-here)) - (with-output-to-temp-buffer "*Dump*" - (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state)))) - -(defun sgml-auto-dump () - (let ((standard-output (get-buffer-create "*Dump*")) - (cb (current-buffer))) - - (when sgml-buffer-parse-state - (unwind-protect - (progn (set-buffer standard-output) - (erase-buffer)) - (set-buffer cb)) - - (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state)) - - )) - ) - -(defun sgml-start-auto-dump () - (interactive) - (add-hook 'post-command-hook - (function sgml-auto-dump) - 'append)) - -(defun sgml-comepos (epos) - (if (sgml-strict-epos-p epos) - (format "%s:%s" - (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos))) - (sgml-epos-pos epos)) - (format "%s" epos))) - -(defun sgml-dump-node (u) - (format - "%s%s start:%s(%s) end:%s(%s) epos:%s/%s net:%s\n" - (make-string (sgml-tree-level u) ?. ) - (sgml-element-gi u) - (sgml-element-start u) (sgml-tree-stag-len u) - (if (sgml-tree-etag-epos u) (sgml-tree-end u)) (sgml-tree-etag-len u) - (sgml-comepos (sgml-tree-stag-epos u)) - (sgml-comepos (sgml-tree-etag-epos u)) - (sgml-tree-net-enabled u))) - -(defun sgml-dump-rec (u) - (while u - (princ (sgml-dump-node u)) - (sgml-dump-rec (sgml-tree-content u)) - (setq u (sgml-tree-next u)))) - -(defun sgml-shortref-identify () - (interactive) - (sgml-find-context-of (point)) - (let* ((nobol (eq (point) sgml-rs-ignore-pos)) - (tem (sgml-deref-shortmap sgml-current-shortmap nobol))) - (message "%s (%s)" tem nobol))) - -(defun sgml-lookup-shortref-name (table map) - (car (rassq map (cdr table)))) - -(defun sgml-show-current-map () - (interactive) - (sgml-find-context-of (point)) - (let ((name (sgml-lookup-shortref-name - (sgml-dtd-shortmaps sgml-dtd-info) - sgml-current-shortmap))) - (message "Current map: %s" - (or name "#EMPTY")))) - -;;;; For edebug - -;;(put 'when 'edebug-form-hook t) -;;(put 'unless 'edebug-form-hook t) -;;(put 'push 'edebug-form-hook '(form sexp)) -;;(put 'setf 'edebug-form-hook '(sexp form)) - -(setq edebug-print-level 3 - edebug-print-length 5 - edebug-print-circle nil -) - -(eval-when (load) - (unless sgml-running-xemacs - (def-edebug-spec sgml-with-parser-syntax (&rest form)) - (def-edebug-spec sgml-skip-upto (sexp)) - (def-edebug-spec sgml-check-delim (sexp &optional sexp)) - (def-edebug-spec sgml-parse-delim (sexp &optional sexp)) - (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp)))) - -;;;; dump - -(defun sgml-dump-dtd (&optional dtd) - (interactive ) - (unless dtd - (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state))) - (with-output-to-temp-buffer "*DTD dump*" - (princ (format "Dependencies: %S\n" - (sgml-dtd-dependencies dtd))) - (loop for et being the symbols of (sgml-dtd-eltypes dtd) - do (sgml-dp-element et)))) - -(defun sgml-dump-element (el-name) - (interactive - (list (completing-read "Element: " - (sgml-dtd-eltypes - (sgml-pstate-dtd sgml-buffer-parse-state)) - nil t))) - (with-output-to-temp-buffer "*Element dump*" - (sgml-dp-element (sgml-lookup-eltype el-name)))) - -(defun sgml-dp-element (el) - (cond - ((sgml-eltype-defined el) - (princ (format "Element %s %s %s%s:\n" - (sgml-eltype-name el) - (if (sgml-eltype-stag-optional el) "O" "-") - (if (sgml-eltype-etag-optional el) "O" "-") - (if (sgml-eltype-mixed el) " mixed" ""))) - (cond - ((sgml-model-group-p (sgml-eltype-model el)) - (sgml-dp-model (sgml-eltype-model el))) - (t - (prin1 (sgml-eltype-model el)) - (terpri))) - (princ (format "Exeptions: +%S -%S\n" - (sgml-eltype-includes el) - (sgml-eltype-excludes el))) - (princ (format "Attlist: %S\n" (sgml-eltype-attlist el))) - (princ (format "Plist: %S\n" (symbol-plist el)))) - (t - (princ (format "Undefined element %s\n" (sgml-eltype-name el))))) - (terpri)) - - -(defun sgml-dp-model (model &optional indent) - (or indent (setq indent 0)) - (let ((sgml-code-xlate (sgml-translate-model model))) - (loop - for i from 0 - for x in sgml-code-xlate do - (cond ((sgml-normal-state-p (car x)) - (princ (format "%s%d: opts=%s reqs=%s\n" - (make-string indent ? ) i - (sgml-untangel-moves (sgml-state-opts (car x))) - (sgml-untangel-moves (sgml-state-reqs (car x)))))) - (t ; and-node - (princ (format "%s%d: and-node next=%d\n" - (make-string indent ? ) i - (sgml-code-xlate (sgml-and-node-next (car x))))) - (loop for m in (sgml-and-node-dfas (car x)) - do (sgml-dp-model m (+ indent 2)))))))) - -(defun sgml-untangel-moves (moves) - (loop for m in moves - collect (list (sgml-move-token m) - (sgml-code-xlate (sgml-move-dest m))))) - - -;;;; Dump state - -(defun sgml-dump-state () - (interactive) - (with-output-to-temp-buffer "*State dump*" - (sgml-dp-state sgml-current-state))) - -(defun sgml-dp-state (state &optional indent) - (or indent (setq indent 0)) - (cond - ((sgml-normal-state-p state) - (sgml-dp-model state indent)) - (t - (princ (format "%sand-state\n" (make-string indent ? ))) - (sgml-dp-state (sgml-and-state-substate state) (+ 2 indent)) - (princ (format "%s--next\n" (make-string indent ? ))) - (sgml-dp-state (sgml-and-state-next state) (+ 2 indent)) - (princ (format "%s--dfas\n" (make-string indent ? ))) - (loop for m in (sgml-and-state-dfas state) - do (sgml-dp-model m (+ indent 2)) - (princ (format "%s--\n" (make-string indent ? ))))))) - - -;;;; Build autoloads for all interactive functions in psgml-parse - -(defun sgml-build-autoloads () - (interactive) - (with-output-to-temp-buffer "*autoload*" - (loop - for file in '("psgml-parse" "psgml-edit" "psgml-dtd" - "psgml-info" "psgml-charent") - do - (set-buffer (find-file-noselect (concat file ".el"))) - (goto-char (point-min)) - (while (and - (not (eobp)) - (re-search-forward "^(defun +\\([^ ]+\\)" nil t)) - (let ((name (buffer-substring (match-beginning 1) - (match-end 1))) - doc) - (forward-sexp 1) ; skip argument list - (skip-chars-forward " \n\t") - (when (eq ?\" (following-char)) ; doc string - (setq doc (buffer-substring (point) - (progn (forward-sexp 1) - (point))))) - (skip-chars-forward " \n\t") - (when (looking-at "(interactive") - (if (null doc) - (message "No doc for %s" name)) - (princ (format - "(autoload '%s \"%s\" %s t)\n" - name file doc)))))))) - -;;;; Test psgml with sgmls test cases - -(defun test-sgml (start) - (interactive "p") - (let (file - (sgml-show-warnings t)) - (with-output-to-temp-buffer "*Testing psgml*" - (while - (progn - (setq file (format "/usr/local/src/sgmls-1.1/test/test%03d.sgm" - start)) - (file-exists-p file)) - (princ (format "*** File test%03d ***\n" start)) - (find-file file) - (condition-case errcode - (progn - (sgml-parse-prolog) - ;;(sgml-next-trouble-spot) - (sgml-parse-until-end-of nil) - ) - (error - (princ errcode) - (terpri))) - (if (get-buffer sgml-log-buffer-name) - (princ (save-excursion - (set-buffer sgml-log-buffer-name) - (buffer-string)))) - (terpri) - (terpri) - (sit-for 0) - (kill-buffer (current-buffer)) - (setq start (1+ start)))))) - - -;;;; Profiling - -(defun profile-sgml (&optional file) - (interactive) - (or file (setq file (expand-file-name "~/src/psgml/0/test/shortref.sgml"))) - (find-file file) - (sgml-need-dtd) - (sgml-instrument-parser) - (elp-reset-all) - (dotimes (i 20) - (garbage-collect) - (sgml-reparse-buffer (function sgml-handle-shortref))) - (elp-results)) - -(defun sgml-instrument-parser () - (interactive) - (require 'elp) - (setq elp-function-list nil) - (elp-restore-all) - (setq elp-function-list - '( - sgml-parse-to - sgml-parser-loop - sgml-parse-markup-declaration - sgml-do-processing-instruction - sgml-pop-entity - sgml-tree-net-enabled - sgml-do-end-tag - sgml-do-data - sgml-deref-shortmap - sgml-handle-shortref - sgml-do-start-tag - sgml-do-general-entity-ref - sgml-set-face-for - sgml-pcdata-move - sgml-shortmap-skipstring - ;; - )) - (elp-instrument-list)) - - -(defun sgml-instrument-dtd-parser () - (interactive) - (require 'elp) - (setq elp-function-list nil) - (elp-restore-all) - (setq elp-function-list - '( - sgml-parse-prolog - sgml-skip-ds - sgml-parse-markup-declaration - sgml-check-doctype-body - ;; - sgml-check-dtd-subset - sgml-parse-ds - sgml-declare-attlist - sgml-declare-entity - sgml-declare-element - sgml-declare-shortref - ;; - sgml-parse-parameter-literal - sgml-check-element-type - sgml-check-primitive-content-token - sgml-check-model-group - ;; In sgml-check-model-group - sgml-parse-modifier - sgml-make-pcdata - sgml-skip-ts - sgml-make-opt - sgml-make-* - sgml-make-+ - sgml-reduce-, - sgml-reduce-| - sgml-make-& - sgml-make-conc - sgml-copy-moves - ;; is ps* - sgml-do-parameter-entity-ref - ;; - sgml-make-primitive-content-token - sgml-push-to-entity - sgml-lookup-entity - sgml-lookup-eltype - sgml-one-final-state - sgml-remove-redundant-states-1 - )) - (elp-instrument-list)) - - -;¤¤\end{codeseg}
--- a/lisp/psgml/psgml-dtd.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,925 +0,0 @@ -;;;; psgml-dtd.el --- DTD parser for SGML-editing mode with parsing support -;; $Id: psgml-dtd.el,v 1.2 1997/01/03 03:10:27 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> - -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Part of major mode for editing the SGML document-markup language. - - -;;;; Code: - -(provide 'psgml-dtd) -(require 'psgml) -(require 'psgml-parse) - - -;;;; Variables - -;; Variables used during doctype parsing and loading -(defvar sgml-used-pcdata nil - "True if model group built is mixed") - - -;;;; Constructing basic - -(defun sgml-copy-moves (s1 s2) - "Copy all moves from S1 to S2, keeping their status." - (let ((l (sgml-state-opts s1))) - (while l - (sgml-add-opt-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))) - (setq l (sgml-state-reqs s1)) - (while l - (sgml-add-req-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))))) - -(defun sgml-copy-moves-to-opt (s1 s2) - "Copy all moves from S1 to S2 as optional moves." - (let ((l (sgml-state-opts s1))) - (while l - (sgml-add-opt-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))) - (setq l (sgml-state-reqs s1)) - (while l - (sgml-add-opt-move s2 - (sgml-move-token (car l)) - (sgml-move-dest (car l))) - (setq l (cdr l))))) - - -(defun sgml-some-states-of (state) - ;; List of some states reachable from STATE, includes all final states - (let* ((states (list state)) - (l states) - s ms m) - (while l - (setq s (car l) - ms (append (sgml-state-opts s) (sgml-state-reqs s))) - (while ms - (setq m (sgml-move-dest (car ms)) - ms (cdr ms)) - (unless (sgml-normal-state-p m) - (setq m (sgml-and-node-next m))) - (unless (memq m states) - (nconc states (list m)))) - (setq l (cdr l))) - states)) - -(defmacro sgml-for-all-final-states (s dfa &rest forms) - "For all final states S in DFA do FORMS. -Syntax: var dfa-expr &body forms" - (` (let ((L-states (sgml-some-states-of (, dfa))) - (, s)) - (while L-states - (when (sgml-state-final-p (setq (, s) (car L-states))) - (,@ forms)) - (setq L-states (cdr L-states)))))) - -(put 'sgml-for-all-final-states 'lisp-indent-hook 2) -(put 'sgml-for-all-final-states 'edebug-form-hook '(symbolp &rest form)) - - -;;;; Optimization for the dfa building - -(defsubst sgml-empty-state-p (s) - ;; True if S hase no outgoing moves - (and (sgml-normal-state-p s) - (null (sgml-state-reqs s)) - (null (sgml-state-opts s))) ) - -(defun sgml-one-final-state (s) - ;; Collaps all states that have no moves - ;; This is a safe optimization, useful for (..|..|..) - (sgml-debug "OPT one final: reqs %d opts %d" - (length (sgml-state-reqs s)) - (length (sgml-state-opts s))) - (let ((final nil) - dest) - (loop for m in (append (sgml-state-reqs s) - (sgml-state-opts s)) - do - (setq dest (sgml-move-dest m)) - (when (sgml-empty-state-p dest) - (cond ((null final) - (setq final dest)) - (t - (setf (sgml-move-dest m) final))))))) - -(defun sgml-states-equal (s1 s2) - (and (= (length (sgml-state-opts s1)) - (length (sgml-state-opts s2))) - (= (length (sgml-state-reqs s1)) - (length (sgml-state-reqs s2))) - (loop for m in (sgml-state-opts s1) - always - (eq (sgml-move-dest m) - (sgml-move-dest (sgml-moves-lookup (sgml-move-token m) - (sgml-state-opts s2))))) - (loop for m in (sgml-state-reqs s1) - always - (eq (sgml-move-dest m) - (sgml-move-dest (sgml-moves-lookup (sgml-move-token m) - (sgml-state-reqs s2))))))) - -(defun sgml-remove-redundant-states-1 (s) - ;; Remove states accessible from s with one move and equivalent to s, - ;; by changing the moves from s. - (sgml-debug "OPT redundant-1: reqs %d opts %d" - (length (sgml-state-reqs s)) - (length (sgml-state-opts s))) - (let ((yes nil) - (no (list s)) - (l (sgml-state-reqs s)) - (nl (sgml-state-opts s)) - dest) - (while (or l (setq l (prog1 nl (setq nl nil)))) - (cond - ((not (sgml-normal-state-p (setq dest (sgml-move-dest (car l)))))) - ((memq dest no)) - ((memq dest yes)) - ((sgml-states-equal s dest) - (progn (push dest yes)))) - (setq l (cdr l))) - (setq l (sgml-state-opts s) - nl (sgml-state-reqs s)) - (when yes - (sgml-debug "OPT redundant-1: sucess %s" (length yes)) - (while (or l (setq l (prog1 nl (setq nl nil)))) - (cond ((memq (sgml-move-dest (car l)) yes) - (setf (sgml-move-dest (car l)) s))) - (setq l (cdr l)))))) - - - -;;;; Constructing - -(defun sgml-make-opt (s1) - (when (sgml-state-reqs s1) - (setf (sgml-state-opts s1) - (nconc (sgml-state-opts s1) - (sgml-state-reqs s1))) - (setf (sgml-state-reqs s1) nil)) - s1) - -(defun sgml-make-* (s1) - (setq s1 (sgml-make-+ s1)) - (when (sgml-state-reqs s1) - (sgml-make-opt s1)) - (sgml-remove-redundant-states-1 s1) - s1) - -(defun sgml-make-+ (s1) - (sgml-for-all-final-states s s1 - (sgml-copy-moves-to-opt s1 s)) - (sgml-remove-redundant-states-1 s1) ; optimize - s1) - -(defun sgml-make-conc (s1 s2) - (let ((moves (append (sgml-state-reqs s1) (sgml-state-opts s1)))) - (cond - (;; optimize the case where all moves from s1 goes to empty states - (loop for m in moves - always (sgml-empty-state-p (sgml-move-dest m))) - (loop for m in moves do (setf (sgml-move-dest m) s2)) - (when (sgml-state-final-p s1) - (sgml-copy-moves s2 s1))) - (t ; general case - (sgml-for-all-final-states s s1 - (sgml-copy-moves s2 s) - (sgml-remove-redundant-states-1 s))))) - s1) - -(defun sgml-make-pcdata () - (sgml-make-* (sgml-make-primitive-content-token sgml-pcdata-token))) - -(defun sgml-reduce-, (l) - (while (cdr l) - (setcar (cdr l) - (sgml-make-conc (car l) (cadr l))) - (setq l (cdr l))) - (car l)) - -(defun sgml-reduce-| (l) - (while (cdr l) ; apply the binary make-alt - (cond ((or (sgml-state-final-p (car l)) ; is result optional - (sgml-state-final-p (cadr l))) - (sgml-make-opt (car l)) - (sgml-copy-moves-to-opt (cadr l) (car l))) - (t - (sgml-copy-moves (cadr l) (car l)))) - (setcdr l (cddr l))) - (sgml-one-final-state (car l)) ; optimization - (car l)) - -(defun sgml-make-& (dfas) - (let ((&n (sgml-make-and-node dfas (sgml-make-state))) - (s (sgml-make-state)) - (l dfas)) - (while l ; For each si: - ;; For m in opts(si): add optional move from s to &n on token(m). - (loop for m in (sgml-state-opts (car l)) - do (sgml-add-opt-move s (sgml-move-token m) &n)) - ;; For m in reqs(si): add required move from s to &n on token(m). - (loop for m in (sgml-state-reqs (car l)) - do (sgml-add-req-move s (sgml-move-token m) &n)) - (setq l (cdr l))) - ;; Return s. - s)) - - - -;(sgml-make-conc (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list)) -;(sgml-make-conc (sgml-make-& (list (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list))) (sgml-make-primitive-content-token 'foo)) - -;(setq x (sgml-some-states-of (sgml-make-primitive-content-token 'para))) -;(sgml-state-final-p (car x) ) -;(sgml-state-final-p (cadr x)) - - -;;;; Parse doctype: General - -(defun sgml-skip-ts () - ;; Skip over ts* - ;;70 ts = 5 s | EE | 60+ parameter entity reference - ;;For simplicity I use ps* - ;;65 ps = 5 s | EE | 60+ parameter entity reference | 92 comment - ;;*** some comments are accepted that shouldn't - (sgml-skip-ps)) - -(defun sgml-parse-character-reference (&optional dofunchar) - ;; *** Actually only numerical character references - ;; I don't know how to handel the function character references. - ;; For the shortrefs let's give them numeric values. - (if (if dofunchar - (sgml-parse-delim "CRO" (digit nmstart)) - (sgml-parse-delim "CRO" (digit))) - (prog1 (if (sgml-is-delim "NULL" digit) - (string-to-int (sgml-check-nametoken)) - (let ((spec (sgml-check-name))) - (or (cdr (assoc spec '(("re" . 10) - ("rs" . 1) - ("tab" . 9) - ("space" . 32)))) - ;; *** What to do with other names? - 127))) - (or (sgml-parse-delim "REFC") - (sgml-parse-RE))))) - -(defun sgml-parse-parameter-literal (&optional dofunchar) - (let* (lita ; flag if lita - (value ; accumulates literals value - "") - (original-buffer ; Buffer (entity) where lit started - (current-buffer)) - temp - ) - (cond - ((or (sgml-parse-delim "LIT") - (setq lita (sgml-parse-delim "LITA"))) - (while (not (and (eq (current-buffer) original-buffer) - (if lita - (sgml-parse-delim "LITA") - (sgml-parse-delim "LIT")))) - (cond ((eobp) - (or (sgml-pop-entity) - (sgml-error "Parameter literal unterminated"))) - ((sgml-parse-parameter-entity-ref)) - ((setq temp (sgml-parse-character-reference dofunchar)) - (setq value (concat value (if (< temp 256) - (format "%c" temp) - (format "&#%d;" temp))))) - (t - (setq value - (concat value - (buffer-substring - (point) - (progn (forward-char 1) - (if lita - (sgml-skip-upto ("LITA" "PERO" "CRO")) - (sgml-skip-upto ("LIT" "PERO" "CRO"))) - (point))))))) - ) - value)))) - -(defun sgml-check-parameter-literal () - (or (sgml-parse-parameter-literal) - (sgml-parse-error "Parameter literal expected"))) - -(defsubst sgml-parse-connector () - (sgml-skip-ps) - (cond ((sgml-parse-delim "SEQ") - (function sgml-reduce-,)) - ((sgml-parse-delim "OR") - (function sgml-reduce-|)) - ((sgml-parse-delim "AND") - (function sgml-make-&)))) - -(defun sgml-parse-name-group () - "Parse a single name or a name group (general name case) . -Returns a list of strings or nil." - (let (names) - (cond - ((sgml-parse-delim "GRPO") - (sgml-skip-ps) - (setq names (sgml-parse-name-group)) ; *** Allows more than it should - (while (sgml-parse-connector) - (sgml-skip-ps) - (nconc names (sgml-parse-name-group))) - (sgml-check-delim "GRPC") - names) - ((setq names (sgml-parse-name)) - (list names))))) - -(defun sgml-check-name-group () - (or (sgml-parse-name-group) - (sgml-parse-error "Expecting a name or a name group"))) - -(defun sgml-check-nametoken-group () - "Parse a name token group, return a list of strings. -Case transformed for general names." - (sgml-skip-ps) - (let ((names nil)) - (cond - ((sgml-parse-delim GRPO) - (while (progn - (sgml-skip-ps) - (push (sgml-general-case (sgml-check-nametoken)) names) - (sgml-parse-connector))) - (sgml-check-delim GRPC) - (nreverse names)) ; store in same order as declared - (t - (list (sgml-general-case (sgml-check-nametoken))))))) - -(defun sgml-check-element-type () - "Parse and check an element type, returns list of strings." -;;; 117 element type = [[30 generic identifier]] -;;; | [[69 name group]] -;;; | [[118 ranked element]] -;;; | [[119 ranked group]] - (cond - ((sgml-parse-delim GRPO) - (sgml-skip-ts) - (let ((names (list (sgml-check-name)))) - (while (progn (sgml-skip-ts) - (sgml-parse-connector)) - (sgml-skip-ts) - (nconc names (list (sgml-check-name)))) - (sgml-check-delim GRPC) - ;; A ranked group will have a rank suffix here - (sgml-skip-ps) - (if (sgml-is-delim "NULL" digit) - (let ((suffix (sgml-parse-nametoken))) - (loop for n in names - collect (concat n suffix))) - names))) - (t ; gi/ranked element - (let ((name (sgml-check-name))) - (sgml-skip-ps) - (list (if (sgml-is-delim "NULL" digit) - (concat name (sgml-check-nametoken)) - name)))))) - - -(defun sgml-check-external () - (or (sgml-parse-external) - (sgml-parse-error "Expecting a PUBLIC or SYSTEM"))) - -;;;; Parse doctype: notation - -(defun sgml-declare-notation () - ;;148 notation declaration = MDO, "NOTATION", - ;; 65 ps+, 41 notation name, - ;; 65 ps+, 149 notation identifier, - ;; 65 ps*, MDC - ;;41 notation name = 55 name - ;;149 notation identifier = 73 external identifier - (sgml-skip-ps) - (sgml-check-name) - (sgml-skip-ps) - (sgml-check-external)) - - -;;;; Parse doctype: Element - -(defun sgml-parse-opt () - (sgml-skip-ps) - (cond ((or (sgml-parse-char ?o) - (sgml-parse-char ?O)) - t) - ((sgml-parse-char ?-) - nil))) - -(defun sgml-parse-modifier () - (cond ((sgml-parse-delim PLUS) - (function sgml-make-+)) - ((sgml-parse-delim REP) - (function sgml-make-*)) - ((sgml-parse-delim OPT) - (function sgml-make-opt)))) - -(defun sgml-check-primitive-content-token () - (sgml-make-primitive-content-token - (sgml-eltype-token - (sgml-lookup-eltype - (sgml-check-name))))) - -(defun sgml-check-model-group () - (sgml-skip-ps) - (let (el mod) - (cond - ((sgml-parse-delim "GRPO") - (let ((subs (list (sgml-check-model-group))) - (con1 nil) - (con2 nil)) - (while (setq con2 (sgml-parse-connector)) - (cond ((and con1 - (not (eq con1 con2))) - (sgml-parse-error "Mixed connectors"))) - (setq con1 con2) - (setq subs (nconc subs (list (sgml-check-model-group))))) - (sgml-check-delim "GRPC") - (setq el (if con1 - (funcall con1 subs) - (car subs))))) - ((sgml-parse-rni "pcdata") ; #PCDATA - (setq sgml-used-pcdata t) - (setq el (sgml-make-pcdata))) - ((sgml-parse-delim "DTGO") ; data tag group - (sgml-skip-ts) - (let ((tok (sgml-check-primitive-content-token))) - (sgml-skip-ts) (sgml-check-delim "SEQ") - (sgml-skip-ts) (sgml-check-data-tag-pattern) - (sgml-skip-ts) (sgml-check-delim "DTGC") - (setq el (sgml-make-conc tok (sgml-make-pcdata))) - (setq sgml-used-pcdata t))) - (t - (setq el (sgml-check-primitive-content-token)))) - (setq mod (sgml-parse-modifier)) - (if mod - (funcall mod el) - el))) - -(defun sgml-check-data-tag-pattern () - ;; 134 data tag pattern - ;; template | template group - (cond ((sgml-parse-delim GRPO) - (sgml-skip-ts) - (sgml-check-parameter-literal) ; data tag template, - (while (progn (sgml-skip-ts) - (sgml-parse-delim OR)) - (sgml-skip-ts) - (sgml-check-parameter-literal)) ; data tag template - (sgml-skip-ts) - (sgml-check-delim GRPC)) - (t - (sgml-check-parameter-literal))) ; data tag template - (sgml-skip-ts) - (when (sgml-parse-delim SEQ) - (sgml-check-parameter-literal))) ; data tag padding template - -(defun sgml-check-content-model () - (sgml-check-model-group)) - -(defun sgml-check-content () - (sgml-skip-ps) - (cond ((sgml-is-delim GRPO) - (sgml-check-content-model)) - (t - ;; ANY, CDATA, RCDATA or EMPTY - (let ((dc (intern (upcase (sgml-check-name))))) - (when (eq dc 'ANY) - (setq sgml-used-pcdata t)) - dc)))) - -(defun sgml-parse-exeption (type) - (sgml-skip-ps) - (if (sgml-parse-char type) - (mapcar (function sgml-lookup-eltype) - (sgml-check-name-group)))) - -(defun sgml-before-eltype-modification () -;;; (let ((merged (sgml-dtd-merged sgml-dtd-info))) -;;; (when (and merged -;;; (eq (sgml-dtd-eltypes sgml-dtd-info) -;;; (sgml-dtd-eltypes (cdr merged)))) -;;; (setf (sgml-dtd-eltypes sgml-dtd-info) -;;; (sgml-merge-eltypes (sgml-make-eltypes-table) -;;; (sgml-dtd-eltypes sgml-dtd-info))))) - ) - -(defun sgml-declare-element () - (let* ((names (sgml-check-element-type)) - (stag-opt (sgml-parse-opt)) - (etag-opt (sgml-parse-opt)) - (sgml-used-pcdata nil) - (model (sgml-check-content)) - (exclusions (sgml-parse-exeption ?-)) - (inclusions (sgml-parse-exeption ?+))) - (sgml-before-eltype-modification) - (while names - (sgml-debug "Defining element %s" (car names)) - (let ((et (sgml-lookup-eltype (car names)))) - (setf (sgml-eltype-stag-optional et) stag-opt - (sgml-eltype-etag-optional et) etag-opt - (sgml-eltype-model et) model - (sgml-eltype-mixed et) sgml-used-pcdata - (sgml-eltype-excludes et) exclusions - (sgml-eltype-includes et) inclusions)) - (setq names (cdr names))) - (sgml-lazy-message "Parsing doctype (%s elements)..." - (incf sgml-no-elements)))) - -;;;; Parse doctype: Entity - -(defun sgml-declare-entity () - (let (name ; Name of entity - dest ; Entity table - (type 'text) ; Type of entity - text ; Text of entity - extid ; External id - ) - (cond - ((sgml-parse-delim "PERO") ; parameter entity declaration - (sgml-skip-ps) - (setq name (sgml-check-name t)) - (setq dest (sgml-dtd-parameters sgml-dtd-info))) - (t ; normal entity declaration - (or (sgml-parse-rni "default") - (setq name (sgml-check-name t))) - (setq dest (sgml-dtd-entities sgml-dtd-info)))) - (sgml-skip-ps) - ;;105 entity text = 66 parameter literal - ;; | 106 data text - ;; | 107 bracketed text - ;; | 108 external entity specification - (setq extid (sgml-parse-external)) - (setq text - (cond - (extid ; external entity specification = - ; 73 external identifier, - ; (65 ps+, 109+ entity type)? - (sgml-skip-ps) - (setq type (or (sgml-parse-entity-type) 'text)) - extid) - ((sgml-startnm-char-next) - (let ((token (intern (sgml-check-name)))) - (sgml-skip-ps) - (cond - ((memq token '(cdata sdata)) ; data text *** - (setq type token) - (sgml-check-parameter-literal)) - ((eq token 'pi) - (concat "<?" (sgml-check-parameter-literal) ">")) - ((eq token 'starttag) - (sgml-start-tag-of (sgml-check-parameter-literal))) - ((eq token 'endtag) - (sgml-end-tag-of (sgml-check-parameter-literal))) - ((eq token 'ms) ; marked section - (concat "<![" (sgml-check-parameter-literal) "]]>")) - ((eq token 'md) ; Markup declaration - (concat "<!" (sgml-check-parameter-literal) ">"))))) - ((sgml-check-parameter-literal)))) - (when dest - (sgml-entity-declare name dest type text)))) - - -(defun sgml-parse-entity-type () - ;;109+ entity type = "SUBDOC" - ;; | (("CDATA" | "NDATA" | "SDATA"), - ;; 65 ps+, - ;; 41 notation name, - ;; 149.2+ data attribute specification?) - (let ((type (sgml-parse-name))) - (when type - (setq type (intern (downcase type))) - (cond ((eq type 'subdoc)) - ((memq type '(cdata ndata sdata)) - (sgml-skip-ps) - (sgml-check-name) - ;;149.2+ data attribute specification - ;; = 65 ps+, DSO, - ;; 31 attribute specification list, - ;; 5 s*, DSC - (sgml-skip-ps) - (when (sgml-parse-delim DSO) - (sgml-parse-attribute-specification-list) - (sgml-parse-s) - (sgml-check-delim DSC))) - (t (sgml-error "Illegal entity type: %s" type)))) - type)) - - -;;;; Parse doctype: Attlist - -(defun sgml-declare-attlist () - (let* ((assnot (cond ((sgml-parse-rni "notation") - (sgml-skip-ps) - t))) - (assel (sgml-check-name-group)) - (attlist nil) ; the list - (attdef nil)) - (while (setq attdef (sgml-parse-attribute-definition)) - (push attdef attlist)) - (setq attlist (nreverse attlist)) - (unless assnot - (sgml-before-eltype-modification) - (loop for elname in assel do - (setf (sgml-eltype-attlist (sgml-lookup-eltype elname)) - attlist))))) - -(defun sgml-parse-attribute-definition () - (sgml-skip-ps) - (if (sgml-is-delim MDC) ; End of attlist? - nil - (sgml-make-attdecl (sgml-check-name) - (sgml-check-declared-value) - (sgml-check-default-value)))) - -(defun sgml-check-declared-value () - (sgml-skip-ps) - (let ((type 'name-token-group) - (names nil)) - (unless (eq (following-char) ?\() - (setq type (intern (sgml-check-name))) - (sgml-skip-ps)) - (when (memq type '(name-token-group notation)) - (setq names (sgml-check-nametoken-group))) - (sgml-make-declared-value type names))) - -(defun sgml-check-default-value () - (sgml-skip-ps) - (let* ((rni (sgml-parse-rni)) - (key (if rni (intern (sgml-check-name))))) - (sgml-skip-ps) - (sgml-make-default-value - key - (if (or (not rni) (eq key 'fixed)) - (sgml-check-attribute-value-specification))))) - - -;;;; Parse doctype: Shortref - -;;;150 short reference mapping declaration = MDO, "SHORTREF", -;;; [[65 ps]]+, [[151 map name]], -;;; ([[65 ps]]+, [[66 parameter literal]], -;;; [[65 ps]]+, [[55 name]])+, -;;; [[65 ps]]*, MDC - -(defun sgml-declare-shortref () - (let ((mapname (sgml-check-name)) - mappings literal name) - (while (progn - (sgml-skip-ps) - (setq literal (sgml-parse-parameter-literal 'dofunchar))) - (sgml-skip-ps) - (setq name (sgml-check-name t)) - (push (cons literal name) mappings)) - (sgml-add-shortref-map - (sgml-dtd-shortmaps sgml-dtd-info) - mapname - (sgml-make-shortmap mappings)))) - -;;;152 short reference use declaration = MDO, "USEMAP", -;;; [[65 ps]]+, [[153 map specification]], -;;; ([[65 ps]]+, [[72 associated element type]])?, -;;; [[65 ps]]*, MDC - -(defun sgml-do-usemap-element (mapname) - ;; This is called from sgml-do-usemap with the mapname - (sgml-before-eltype-modification) - (loop for e in (sgml-parse-name-group) do - (setf (sgml-eltype-shortmap (sgml-lookup-eltype e sgml-dtd-info)) - (if (null mapname) - 'empty - mapname)))) - - -;;;; Parse doctype - -(defun sgml-check-dtd-subset () - (let ((sgml-parsing-dtd t) - (eref sgml-current-eref)) - (while - (progn - (setq sgml-markup-start (point)) - (cond - ((and (eobp) (eq sgml-current-eref eref)) - nil) - ((sgml-parse-ds)) - ((sgml-parse-markup-declaration 'dtd)) - ((sgml-parse-delim "MS-END"))))))) - - -;;;; Save DTD: compute translation - -(defvar sgml-translate-table nil) - -(defun sgml-translate-node (node) - (assert (not (numberp node))) - (let ((tp (assq node sgml-translate-table))) - (unless tp - (setq tp (cons node (length sgml-translate-table))) - (nconc sgml-translate-table (list tp))) - (cdr tp))) - -(defun sgml-translate-moves (moves) - (while moves - (sgml-translate-node (sgml-move-dest (car moves))) - (setq moves (cdr moves)))) - -(defun sgml-translate-model (model) - (let* ((sgml-translate-table (list (cons model 0))) - (p sgml-translate-table)) - (while p - (cond ((sgml-normal-state-p (caar p)) - (sgml-translate-moves (sgml-state-opts (caar p))) - (sgml-translate-moves (sgml-state-reqs (caar p)))) - (t - (sgml-translate-node (sgml-and-node-next (caar p))))) - (setq p (cdr p))) - sgml-translate-table)) - -;;;; Save DTD: binary coding - -(defvar sgml-code-token-numbers nil) -(defvar sgml-code-xlate nil) - -(defsubst sgml-code-xlate (node) - ;;(let ((x (cdr (assq node sgml-code-xlate)))) (assert x) x) - (cdr (assq node sgml-code-xlate))) - -(defun sgml-code-number (num) - (if (> num sgml-max-single-octet-number) - (insert (+ (lsh (- num sgml-max-single-octet-number) -8) - sgml-max-single-octet-number 1) - (logand (- num sgml-max-single-octet-number) 255)) - (insert num))) - -(defun sgml-code-token-number (token) - (let ((bp (assq token sgml-code-token-numbers))) - (unless bp - (setq sgml-code-token-numbers - (nconc sgml-code-token-numbers - (list (setq bp (cons token - (length sgml-code-token-numbers))))))) - (cdr bp))) - -(defun sgml-code-token (token) - (sgml-code-number (sgml-code-token-number token))) - -(defmacro sgml-code-sequence (loop-c &rest body) - "Produce the binary coding of a counted sequence from a list. -Syntax: (var seq) &body forms -FORMS should produce the binary coding of element in VAR." - (let ((var (car loop-c)) - (seq (cadr loop-c))) - (` (let ((seq (, seq))) - (sgml-code-number (length seq)) - (loop for (, var) in seq - do (,@ body)))))) - -(put 'sgml-code-sequence 'lisp-indent-hook 1) -(put 'sgml-code-sequence 'edbug-forms-hook '(sexp &rest form)) - -(defun sgml-code-sexp (sexp) - (let ((standard-output (current-buffer))) - (prin1 sexp) - (terpri))) - -(defun sgml-code-tokens (l) - (sgml-code-sequence (x l) - (sgml-code-token x))) - -(defsubst sgml-code-move (m) - (sgml-code-token (sgml-move-token m)) - (insert (sgml-code-xlate (sgml-move-dest m)))) - -(defun sgml-code-model (m) - (let ((sgml-code-xlate (sgml-translate-model m))) - (sgml-code-sequence (s sgml-code-xlate) ; s is (node . number) - (setq s (car s)) ; s is node - (cond - ((sgml-normal-state-p s) - (assert (and (< (length (sgml-state-opts s)) 255) - (< (length (sgml-state-reqs s)) 256))) - (sgml-code-sequence (x (sgml-state-opts s)) - (sgml-code-move x)) - (sgml-code-sequence (x (sgml-state-reqs s)) - (sgml-code-move x))) - (t ; s is a &-node - (insert 255) ; Tag &-node - (insert (sgml-code-xlate (sgml-and-node-next s))) - (sgml-code-sequence (m (sgml-and-node-dfas s)) - (sgml-code-model m))))))) - -(defun sgml-code-element (et) - (sgml-code-sexp (sgml-eltype-all-miscdata et)) - (cond - ((not (sgml-eltype-defined et)) - (insert 128)) - (t - (insert (sgml-eltype-flags et)) - (let ((c (sgml-eltype-model et))) - (cond ((eq c sgml-cdata) (insert 0)) - ((eq c sgml-rcdata) (insert 1)) - ((eq c sgml-empty) (insert 2)) - ((eq c sgml-any) (insert 3)) - ((null c) (insert 4)) - (t - (assert (sgml-model-group-p c)) - (insert 128) - (sgml-code-model c)))) - (sgml-code-tokens (sgml-eltype-includes et)) - (sgml-code-tokens (sgml-eltype-excludes et))))) - - -(defun sgml-code-dtd (dtd) - "Produce the binary coding of the current DTD into the current buffer." - (sgml-code-sexp (sgml-dtd-dependencies dtd)) - (sgml-code-sexp (sgml-dtd-parameters dtd)) - (sgml-code-sexp (sgml-dtd-doctype dtd)) - (let ((done 0) ; count written elements - tot) - (setq sgml-code-token-numbers nil) - (sgml-code-token-number sgml-pcdata-token) ; Make #PCDATA token 0 - (sgml-map-eltypes ; Assign numbers to all tokens - (function (lambda (et) - (sgml-code-token-number (sgml-eltype-token et)))) - dtd nil t) - (setq tot (length sgml-code-token-numbers)) - ;; Produce the counted sequence of element type names - (sgml-code-sequence (pair (cdr sgml-code-token-numbers)) - (sgml-code-sexp (sgml-eltype-name (car pair)))) - ;; Produce the counted sequence of element types - (sgml-code-sequence (pair (cdr sgml-code-token-numbers)) - (setq done (1+ done)) - (sgml-code-element (car pair)) - (sgml-lazy-message "Saving DTD %d%% done" (/ (* 100 done) tot))) - (sgml-code-sexp (sgml-dtd-entities dtd)) - (sgml-code-sexp (sgml-dtd-shortmaps dtd)) - (sgml-code-sexp (sgml-dtd-notations dtd)))) - - -;;;; Save DTD - -(defun sgml-save-dtd (file) - "Save the parsed dtd on FILE." - (interactive - (let* ((tem (expand-file-name - (or sgml-default-dtd-file - (sgml-default-dtd-file)))) - (dir (file-name-directory tem)) - (nam (file-name-nondirectory tem))) - (list - (read-file-name "Save DTD in: " dir tem nil nam)))) - (setq file (expand-file-name file)) - (when (equal file (buffer-file-name)) - (error "Would clobber current file")) - (sgml-need-dtd) - (sgml-push-to-entity (sgml-make-entity "#SAVE" nil "")) - (sgml-write-dtd sgml-dtd-info file) - (sgml-pop-entity) - (setq sgml-default-dtd-file - (if (equal (expand-file-name default-directory) - (file-name-directory file)) - (file-name-nondirectory file) - file)) - (setq sgml-loaded-dtd file)) - -(defun sgml-write-dtd (dtd file) - "Save the parsed dtd on FILE. -Construct the binary coded DTD (bdtd) in the current buffer." - (insert - ";;; This file was created by psgml on " (current-time-string) "\n" - "(sgml-saved-dtd-version 6)\n") - (sgml-code-dtd dtd) - (setq file-type 1) - (write-region (point-min) (point-max) file)) - - -;;; psgml-dtd.el ends here
--- a/lisp/psgml/psgml-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1717 +0,0 @@ -;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support -;;-*-byte-compile-warnings:(free-vars unused-vars unresolved callargs redefine)-*- -;; $Id: psgml-edit.el,v 1.2 1997/03/08 23:26:53 steve Exp $ - -;; Copyright (C) 1994, 1995, 1996 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> - -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Part of major mode for editing the SGML document-markup language. - - -;;;; Code: - -(provide 'psgml-edit) -(require 'psgml) -(require 'psgml-parse) -(require 'tempo) - - -;;;; Variables - -(defvar sgml-split-level nil - "Used by sgml-split-element") - - -;;;; SGML mode: structure editing - -(defun sgml-last-element () - "Return the element where last command left point. -This either uses the save value in `sgml-last-element' or parses the buffer -to find current open element." - (setq sgml-markup-type nil) - (if (and (memq last-command sgml-users-of-last-element) - sgml-last-element) ; Don't return nil - sgml-last-element - (setq sgml-last-element (sgml-find-context-of (point)))) ) - -(defun sgml-set-last-element (&optional el) - (if el (setq sgml-last-element el)) - (sgml-show-context sgml-last-element)) - -(defun sgml-beginning-of-element () - "Move to after the start-tag of the current element. -If the start-tag is implied, move to the start of the element." - (interactive) - (goto-char (sgml-element-stag-end (sgml-last-element))) - (sgml-set-last-element (if (sgml-element-empty sgml-last-element) - (sgml-element-parent sgml-last-element)))) - -(defun sgml-end-of-element () - "Move to before the end-tag of the current element." - (interactive) - (goto-char (sgml-element-etag-start (sgml-last-element))) - (sgml-set-last-element (if (sgml-element-empty sgml-last-element) - (sgml-element-parent sgml-last-element)))) - -(defun sgml-backward-up-element () - "Move backward out of this element level. -That is move to before the start-tag or where a start-tag is implied." - (interactive) - (goto-char (sgml-element-start (sgml-last-element))) - (sgml-set-last-element (sgml-element-parent sgml-last-element))) - -(defun sgml-up-element () - "Move forward out of this element level. -That is move to after the end-tag or where an end-tag is implied." - (interactive) - (goto-char (sgml-element-end (sgml-last-element))) - (sgml-set-last-element (sgml-element-parent sgml-last-element))) - -(defun sgml-forward-element () - "Move forward over next element." - (interactive) - (let ((next - (sgml-find-element-after (point) (sgml-last-element)))) - (goto-char (sgml-element-end next)) - (sgml-set-last-element (sgml-element-parent next)))) - -(defun sgml-backward-element () - "Move backward over previous element at this level. -With implied tags this is ambigous." - (interactive) - (let ((prev ; previous element - (sgml-find-previous-element (point) (sgml-last-element)))) - (goto-char (sgml-element-start prev)) - (sgml-set-last-element (sgml-element-parent prev)))) - -(defun sgml-down-element () - "Move forward and down one level in the element structure." - (interactive) - (let ((to - (sgml-find-element-after (point) (sgml-last-element)))) - (when (sgml-strict-epos-p (sgml-element-stag-epos to)) - (error "Sub-element in other entity")) - (goto-char (sgml-element-stag-end to)) - (sgml-set-last-element (if (sgml-element-empty to) - (sgml-element-parent to) - to)))) - - -(defun sgml-kill-element () - "Kill the element following the cursor." - (interactive "*") - (sgml-parse-to-here) - (when sgml-markup-type - (error "Point is inside markup")) - (kill-region (point) - (sgml-element-end (sgml-find-element-after (point))))) - -(defun sgml-transpose-element () - "Interchange element before point with element after point, leave point after." - (interactive "*") - (let ((pre (sgml-find-previous-element (point))) - (next (sgml-find-element-after (point))) - s1 s2 m2) - (goto-char (sgml-element-start next)) - (setq m2 (point-marker)) - (setq s2 (buffer-substring (point) - (sgml-element-end next))) - (delete-region (point) (sgml-element-end next)) - (goto-char (sgml-element-start pre)) - (setq s1 (buffer-substring (point) (sgml-element-end pre))) - (delete-region (point) (sgml-element-end pre)) - (insert-before-markers s2) - (goto-char m2) - (insert s1) - (sgml-message ""))) - -(defun sgml-mark-element () - "Set mark after next element." - (interactive) - (push-mark (sgml-element-end (sgml-find-element-after (point))) nil t)) - -(defun sgml-mark-current-element () - "Set mark at end of current element, and leave point before current element." - (interactive) - (let ((el (sgml-find-element-of (point)))) - (goto-char (sgml-element-start el)) - (push-mark (sgml-element-end el) nil t))) - - -(defun sgml-change-element-name (gi) - "Replace the name of the current element with a new name. -Eventual attributes of the current element will be translated if -possible." - (interactive - (list (let ((el (sgml-find-element-of (point)))) - (goto-char (sgml-element-start el)) - (sgml-read-element-name - (format "Change %s to: " (sgml-element-name el)))))) - (when (or (null gi) (equal gi "")) - (error "Illegal name")) - (let* ((element (sgml-find-element-of (point))) - (attspec (sgml-element-attribute-specification-list element)) - (oldattlist (sgml-element-attlist element))) - (unless (sgml-element-empty element) - (goto-char (sgml-element-end element)) - (delete-char (- (sgml-element-etag-len element))) - (tempo-process-and-insert-string (sgml-end-tag-of gi))) - (goto-char (sgml-element-start element)) - (delete-char (sgml-element-stag-len element)) - (tempo-process-and-insert-string (sgml-start-tag-of gi)) - (forward-char -1) - (let* ((newel (sgml-find-element-of (point))) - (newattlist (sgml-element-attlist newel)) - (newasl (sgml-translate-attribute-specification-list - attspec oldattlist newattlist))) - (sgml-insert-attributes newasl newattlist)))) - -(defun sgml-translate-attribute-specification-list (values from to) - "Translate attribute specification from one element type to another. -Input attribute values in VALUES using attlist FROM is translated into -a list using attlist TO." - (let ((new-values nil) - (sgml-show-warnings t) - tem) - (loop for attspec in values - as from-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) from) - as to-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) to) - do - (cond - ;; Special case ID attribute - ((and (eq 'id (sgml-attdecl-declared-value from-decl)) - (setq tem (sgml-attribute-with-declared-value to 'id))) - (push - (sgml-make-attspec (sgml-attdecl-name tem) - (sgml-attspec-attval attspec)) - new-values)) - ;; Use attribute with same name if compatible type - ((equal (sgml-attdecl-declared-value from-decl) - (sgml-attdecl-declared-value to-decl)) - (push attspec new-values)) - (to-decl - (sgml-log-warning - "Attribute %s has new declared-value" - (sgml-attspec-name attspec)) - (push attspec new-values)) - (t - (sgml-log-warning "Can't translate attribute %s = %s" - (sgml-attspec-name attspec) - (sgml-attspec-attval attspec))))) - new-values)) - -(defun sgml-untag-element () - "Remove tags from current element." - (interactive "*") - (let ((el (sgml-find-element-of (point)))) - (when (or (sgml-strict-epos-p (sgml-element-stag-epos el)) - (sgml-strict-epos-p (sgml-element-etag-epos el))) - (error "Current element has some tag inside an entity reference")) - (goto-char (sgml-element-etag-start el)) - (delete-char (sgml-element-etag-len el)) - (goto-char (sgml-element-start el)) - (delete-char (sgml-element-stag-len el)))) - -(defun sgml-kill-markup () - "Kill next tag, markup declaration or process instruction." - (interactive "*") - (let ((start (point))) - (sgml-with-parser-syntax - (sgml-parse-s) - (setq sgml-markup-start (point)) - (cond ((sgml-parse-markup-declaration 'ignore)) - ((sgml-parse-processing-instruction)) - ((sgml-skip-tag))) - (kill-region start (point))))) - - -;;;; SGML mode: folding - -(defun sgml-fold-region (beg end &optional unhide) - "Hide (or if prefixarg unhide) region. -If called from a program first two arguments are start and end of -region. And optional third argument true unhides." - (interactive "r\nP") - (let ((mp (buffer-modified-p)) - (inhibit-read-only t) ; - (buffer-read-only nil) ; should not need this, but - ; perhaps some old version of - ; emacs does not understand - ; inhibit-read-only - (before-change-function nil) - (after-change-function nil)) - (setq selective-display t) - (unwind-protect - (subst-char-in-region beg end - (if unhide ?\r ?\n) - (if unhide ?\n ?\r) - 'noundo) - (when sgml-buggy-subst-char-in-region - (set-buffer-modified-p mp))))) - -(defun sgml-fold-element () - "Fold the lines comprising the current element, leaving the first line visible. -This uses the selective display feature." - (interactive) - (sgml-parse-to-here) - (cond ((and (eq sgml-current-tree sgml-top-tree) ; outside document element - sgml-markup-type) - (sgml-fold-region sgml-markup-start - (save-excursion - (sgml-parse-to (point)) - (point)))) - ((and (eq sgml-current-tree sgml-top-tree) ; outside document element - (looking-at " *<!")) - (sgml-fold-region (point) - (save-excursion - (skip-chars-forward " \t") - (sgml-parse-to (1+ (point))) - (point)))) - - (t - (let ((el (sgml-find-element-of (point)))) - (when (eq el sgml-top-tree) - (error "No element here")) - (save-excursion - (goto-char (sgml-element-end el)) - (when (zerop (sgml-element-etag-len el)) - (skip-chars-backward " \t\n")) - (sgml-fold-region (sgml-element-start el) - (point))))))) - -(defun sgml-fold-subelement () - "Fold all elements current elements content, leaving the first lines visible. -This uses the selective display feature." - (interactive) - (let* ((el (sgml-find-element-of (point))) - (c (sgml-element-content el))) - (while c - (sgml-fold-region (sgml-element-start c) - (sgml-element-end c)) - (setq c (sgml-element-next c))))) - -(defun sgml-unfold-line () - "Show hidden lines in current line." - (interactive) - (let ((op (point))) - (beginning-of-line) - (push-mark) - (end-of-line) - (exchange-point-and-mark) - (sgml-fold-region (point) (mark) 'unhide) - (goto-char op))) - -(defun sgml-unfold-element () - "Show all hidden lines in current element." - (interactive) - (let* ((element (sgml-find-element-of (point)))) - (sgml-fold-region (sgml-element-start element) - (sgml-element-end element) - 'unfold))) - -(defun sgml-expand-element () - "As sgml-fold-subelement, but unfold first." - (interactive) - (sgml-unfold-element) - (sgml-fold-subelement)) - -(defun sgml-unfold-all () - "Show all hidden lines in buffer." - (interactive) - (sgml-fold-region (point-min) - (point-max) - 'unfold)) - -;;;; SGML mode: indentation and movement - -(defun sgml-indent-line (&optional col element) - "Indent line, calling parser to determine level unless COL or ELEMENT -is given. If COL is given it should be the column to indent to. If -ELEMENT is given it should be a parse tree node, from which the level -is determined." - (when sgml-indent-step - (let ((here (point-marker))) - (back-to-indentation) - (unless (or col element) - ;; Determine element - (setq element - (let ((sgml-throw-on-error 'parse-error)) - (catch sgml-throw-on-error - (if (eobp) - (sgml-find-context-of (point)) - (sgml-find-element-of (point))))))) - (when (eq element sgml-top-tree) ; not in a element at all - (setq element nil) ; forget element - (goto-char here)) ; insert normal tab insted) - (when element - (sgml-with-parser-syntax - (let ((stag (sgml-is-start-tag)) - (etag (sgml-is-end-tag))) - ;; Wing change - (when (and - (not (member* (sgml-element-gi - (if (or stag etag) - (sgml-element-parent element) - element)) - sgml-inhibit-indent-tags - :test #'equalp)) - (or sgml-indent-data - (not (sgml-element-data-p - (if stag - (sgml-element-parent element) - element))))) - (setq col - (* sgml-indent-step - (+ (if (or stag etag) -1 0) - (sgml-element-level element)))))))) - (when (and col (/= col (current-column))) - (beginning-of-line 1) - (delete-horizontal-space) - (indent-to col)) - (when (< (point) here) - (goto-char here)) - col))) - -(defun sgml-next-data-field () - "Move forward to next point where data is allowed." - (interactive) - (when (eobp) - (error "End of buffer")) - (let ((sgml-throw-on-warning 'next-data) - (avoid-el (sgml-last-element))) - ;; Avoid stopping in current element, unless point is in the start - ;; tag of the element - (when (< (point) (sgml-element-stag-end avoid-el)) - (setq avoid-el nil)) - (catch sgml-throw-on-warning - (while (progn - (sgml-parse-to (1+ (point))) - (setq sgml-last-element - (if (not (eq ?< (following-char))) - (sgml-find-element-of (point)) - sgml-current-tree)) - (or (eq sgml-last-element avoid-el) - (not (sgml-element-data-p sgml-last-element))))) - (sgml-set-last-element)))) - -(defun sgml-next-trouble-spot () - "Move forward to next point where something is amiss with the structure." - (interactive) - (push-mark) - (sgml-note-change-at (point)) ; Prune the parse tree - (sgml-parse-to (point)) - (let ((sgml-throw-on-warning 'trouble)) - (or (catch sgml-throw-on-warning - (sgml-parse-until-end-of nil t)) - (message "Ok")))) - - - -;;;; SGML mode: information display - -(defun sgml-list-valid-tags () - "Display a list of the contextually valid tags." - (interactive) - (sgml-parse-to-here) - (let ((model (sgml-element-model sgml-current-tree)) - (smap-name (sgml-lookup-shortref-name - (sgml-dtd-shortmaps sgml-dtd-info) - sgml-current-shortmap))) - (with-output-to-temp-buffer "*Tags*" - (princ (format "Current element: %s %s\n" - (sgml-element-name sgml-current-tree) - (if (sgml-eltype-defined - (sgml-element-eltype sgml-current-tree)) - "" - "[UNDEFINED]"))) - (princ (format "Element content: %s %s\n" - (cond ((or (sgml-current-mixed-p) (eq model sgml-any)) - "mixed") - ((sgml-model-group-p model) - "element") - (t - model)) - (if (eq model sgml-any) - "[ANY]" ""))) - - (when smap-name - (princ (format "Current short reference map: %s\n" smap-name))) - - (cond ((sgml-final-p sgml-current-state) - (princ "Valid end-tags : ") - (loop for e in (sgml-current-list-of-endable-eltypes) - do (princ (sgml-end-tag-of e)) (princ " ")) - (terpri)) - (t - (princ "Current element can not end here\n"))) -;;; (let ((s (sgml-tree-shortmap sgml-current-tree))) -;;; (when s -;;; (princ (format "Current shortref map: %s\n" s)))) - (princ "Valid start-tags\n") - (sgml-print-valid-tags "In current element:" - sgml-current-tree sgml-current-state)))) - -(defun sgml-print-valid-tags (prompt tree state &optional exclude omitted-stag) - (if (not (sgml-model-group-p state)) - (princ (format "%s (in %s)\n" prompt state)) - (let* ((req (sgml-required-tokens state)) - (elems (nconc req - (delq sgml-pcdata-token - (sgml-optional-tokens state)))) - (in (sgml-tree-includes tree)) - (ex (append exclude (sgml-tree-excludes tree)))) - ;; Modify for exceptions - (while in - (unless (memq (car in) elems) - (setq elems (nconc elems (list (car in))))) - (setq in (cdr in))) - (while ex - (setq elems (delq (car ex) elems)) - (setq ex (cdr ex))) - ;; - (setq elems (sort elems (function string-lessp))) - (sgml-print-list-of-tags prompt elems) - ;; Check for omissable start-tags - (when (and req (null (cdr req))) - ;; *** Assumes tokens are eltypes - (let ((el (sgml-fake-open-element tree (car req)))) - (when (sgml-element-stag-optional el) - (sgml-print-valid-tags - (format "If omitting %s:" (sgml-start-tag-of el)) - el - (sgml-element-model el) - (append exclude elems) - 'omitted-stag)))) - ;; Check for omissable end-tag - (when (and (not omitted-stag) - (sgml-final-p state) - (sgml-element-etag-optional tree)) - (sgml-print-valid-tags - (format "If omitting %s:" (sgml-end-tag-of tree)) - (sgml-element-parent tree) - (sgml-element-pstate tree) - (append exclude elems)))))) - -(defun sgml-print-list-of-tags (prompt list) - (when list - (princ prompt) - (let ((col (length prompt)) - (w (1- (frame-width)))) - (loop for e in list - as str = (sgml-start-tag-of e) - do - (setq col (+ col (length str) 2)) - (cond ((>= col w) - (setq col (+ (length str) 2)) - (terpri))) - (princ " ") - (princ str)) - (terpri)))) - -(defun sgml-show-context (&optional element) - "Display where the cursor is in the element hierarchy." - (interactive) - (let* ((el (or element (sgml-last-element))) - (model (sgml-element-model el))) - (sgml-message "%s %s" - (cond - ((and (null element) ; Don't trust sgml-markup-type if - ; explicit element is given as argument - sgml-markup-type)) - ((sgml-element-mixed el) - "#PCDATA") - ((not (sgml-model-group-p model)) - model) - (t "")) - (if (eq el sgml-top-tree) - "in empty context" - (sgml-element-context-string el))))) - -(defun sgml-what-element () - "Display what element is under the cursor." - (interactive) - (let* ((pos (point)) - (nobol (eq (point) sgml-rs-ignore-pos)) - (sref (sgml-deref-shortmap sgml-current-shortmap nobol)) - (el nil)) - (goto-char pos) - (setq el (sgml-find-element-of pos)) - (assert (not (null el))) - (message "%s %s" - (cond ((eq el sgml-top-tree) - "outside document element") - ((< (point) (sgml-element-stag-end el)) - "start-tag") - ((>= (point) (sgml-element-etag-start el)) - "end-tag") - (sref - "shortref") - (t - "content")) - (sgml-element-context-string el)))) - -;;;; SGML mode: keyboard inserting - -(defun sgml-insert-tag (tag &optional silent no-nl-after) - "Insert a tag, reading tag name in minibuffer with completion. -If the variable sgml-balanced-tag-edit is t, also inserts the -corresponding end tag. If sgml-leave-point-after-insert is t, the point -is left after the inserted tag(s), unless the element has som required -content. If sgml-leave-point-after-insert is nil the point is left -after the first tag inserted." - (interactive - (list - (completing-read "Tag: " (sgml-completion-table) nil t "<" ))) - (sgml-find-context-of (point)) - (assert (null sgml-markup-type)) - ;; Fix white-space before tag - (unless (sgml-element-data-p (sgml-parse-to-here)) - (skip-chars-backward " \t") - (cond ((bolp) - (if (looking-at "^\\s-*$") - (fixup-whitespace))) - (t - (insert "\n")))) - (tempo-process-and-insert-string tag) - (sgml-indent-line) - (unless no-nl-after - (save-excursion - (unless (sgml-element-data-p (sgml-parse-to-here)) - (unless (eolp) - (save-excursion (insert "\n")))))) - (or silent (sgml-show-context))) - -(defvar sgml-new-attribute-list-function - (function sgml-default-asl)) - -(defun sgml-insert-element (name &optional after silent) - "Reads element name from minibuffer and inserts start and end tags." - (interactive (list (sgml-read-element-name "Element: ") - sgml-leave-point-after-insert)) - (let (newpos ; position to leave cursor at - element ; inserted element - (sgml-show-warnings nil)) - (when (and name (not (equal name ""))) - (sgml-insert-tag (sgml-start-tag-of name) 'silent) - (forward-char -1) - (setq element (sgml-find-element-of (point))) - (sgml-insert-attributes (funcall sgml-new-attribute-list-function - element) - (sgml-element-attlist element)) - (forward-char 1) - (when (not (sgml-element-empty element)) - (when (and sgml-auto-insert-required-elements - (sgml-model-group-p sgml-current-state)) - (let (tem) - (while (and (setq tem (sgml-required-tokens sgml-current-state)) - (null (cdr tem))) - (setq tem (sgml-insert-element (car tem) t t)) - (setq newpos (or newpos tem)) - (sgml-parse-to-here)) - (when tem ; more than one req elem - (insert "\n") - (when sgml-insert-missing-element-comment - (insert (format "<!-- one of %s -->" tem)) - (sgml-indent-line nil element))))) - (setq newpos (or newpos (point))) - (when sgml-insert-end-tag-on-new-line - (insert "\n")) - (sgml-insert-tag (sgml-end-tag-of name) 'silent) - (unless after - (goto-char newpos)) - (unless silent (sgml-show-context))) - newpos))) - -(defun sgml-default-asl (element) - (loop for attdecl in (sgml-element-attlist element) - when (sgml-default-value-type-p (sgml-attdecl-default-value attdecl) - 'required) - collect - (sgml-make-attspec - (sgml-attdecl-name attdecl) - (sgml-read-attribute-value attdecl nil)))) - -(defun sgml-tag-region (element start end) - "Reads element name from minibuffer and inserts start and end tags." - (interactive - (list - (save-excursion (goto-char (region-beginning)) - (sgml-read-element-name "Tag region with element: ")) - (region-beginning) - (region-end))) - (save-excursion - (when (and element (not (equal element ""))) - (goto-char end) - (tempo-process-and-insert-string (sgml-end-tag-of element)) - (goto-char start) - (sgml-insert-tag (sgml-start-tag-of element))))) - -(defun sgml-insert-attributes (avl attlist) - "Insert the attributes with values AVL and declarations ATTLIST. -AVL should be a assoc list mapping symbols to strings." - (let (name val dcl def) - (loop for attspec in attlist do - (setq name (sgml-attspec-name attspec) - val (cdr-safe (sgml-lookup-attspec name avl)) - dcl (sgml-attdecl-declared-value attspec) - def (sgml-attdecl-default-value attspec)) - (unless val ; no value given - ;; Supply the default value if a value is needed - (cond ((sgml-default-value-type-p 'required def) - (setq val "")) - ((and (not (or sgml-omittag sgml-shorttag)) - (consp def)) - (setq val (sgml-default-value-attval def))))) - (cond - ((null val)) ; Ignore - ;; Ignore attributes with default value - ((and (consp def) - (eq sgml-minimize-attributes 'max) - (or sgml-omittag sgml-shorttag) - (equal val (sgml-default-value-attval def)))) - ;; No attribute name for token groups - ((and sgml-minimize-attributes sgml-shorttag - (member (sgml-general-case val) - (sgml-declared-value-token-group dcl))) - (tempo-process-and-insert-string (concat " " val))) - (t - (tempo-process-and-insert-string (concat " " name "=")) - (insert (sgml-quote-attribute-value val))))) - (when auto-fill-function - (funcall auto-fill-function)))) - - -(defun sgml-quote-attribute-value (value) - "Add quotes to the string VALUE unless minimization is on." - (let ((quote "")) - (cond ((and (not sgml-always-quote-attributes) - sgml-shorttag - (string-match "\\`[.A-Za-z0-9---]+\\'" value)) - ) ; no need to quote - ((not (string-match "\"" value)) ; can use "" quotes - (setq quote "\"")) - (t ; use '' quotes - (setq quote "'"))) - (concat quote value quote))) - -(defun sgml-completion-table (&optional avoid-tags-in-cdata) - (sgml-parse-to-here) - (when sgml-markup-type - (error "No tags allowed")) - (cond ((or (sgml-model-group-p sgml-current-state) - (eq sgml-current-state sgml-any)) - (append - (mapcar (function (lambda (x) (cons (sgml-end-tag-of x) x))) - (sgml-current-list-of-endable-eltypes)) - (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x))) - (sgml-current-list-of-valid-eltypes)))) - (t - (sgml-message "%s" sgml-current-state) - nil))) - -(defun sgml-element-endable-p () - (sgml-parse-to-here) - (and (not (eq sgml-current-tree sgml-top-tree)) - (sgml-final-p sgml-current-state))) - -(defun sgml-insert-end-tag () - "Insert end-tag for the current open element." - (interactive "*") - (sgml-parse-to-here) - (cond - ((eq sgml-current-tree sgml-top-tree) - (sgml-error "No open element")) - ((not (sgml-final-p sgml-current-state)) - (sgml-error "Can`t end element here")) - (t - (when (and sgml-indent-step - (not (sgml-element-data-p sgml-current-tree))) - (delete-horizontal-space) - (unless (bolp) - (insert "\n"))) - (when (prog1 (bolp) - (tempo-process-and-insert-string - (if (eq t (sgml-element-net-enabled sgml-current-tree)) - "/" - ;; wing change: If there is more than one endable - ;; tag, we probably want the outermost one rather - ;; than the innermost one. Thus, we end a </ul> - ;; even when a </li> is possible. - (sgml-end-tag-of - (car (last (sgml-current-list-of-endable-eltypes))))))) - (sgml-indent-line))))) - -(defun sgml-insert-start-tag (name asl attlist &optional net) - (tempo-process-and-insert-string (concat "<" name)) - (sgml-insert-attributes asl attlist) - (insert (if net "/" ">"))) - -(defun sgml-change-start-tag (element asl) - (let ((name (sgml-element-gi element)) - (attlist (sgml-element-attlist element))) - (assert (sgml-bpos-p (sgml-element-stag-epos element))) - (goto-char (sgml-element-start element)) - (delete-char (sgml-element-stag-len element)) - (sgml-insert-start-tag name asl attlist - (eq t (sgml-element-net-enabled element))))) - -(defun sgml-read-attribute-value (attdecl curvalue) - "Return the attribute value read from user. -ATTDECL is the attribute declaration for the attribute to read. -CURVALUE is nil or a string that will be used as default value." - (assert attdecl) - (let* ((name (sgml-attdecl-name attdecl)) - (dv (sgml-attdecl-declared-value attdecl)) - (tokens (sgml-declared-value-token-group dv)) - (notations (sgml-declared-value-notation dv)) - (type (cond (tokens "token") - (notations "notation") - (t (symbol-name dv)))) - (prompt - (format "Value for %s (%s%s): " - name type - (if curvalue - (format " Default: %s" curvalue) - ""))) - value) - (setq value - (if (or tokens notations) - (completing-read prompt - (mapcar 'list (or tokens notations)) - nil t) - (read-string prompt))) - (if (and curvalue (equal value "")) - curvalue value))) - -(defun sgml-non-fixed-attributes (attlist) - (loop for attdecl in attlist - unless (sgml-default-value-type-p 'fixed - (sgml-attdecl-default-value attdecl)) - collect attdecl)) - -(defun sgml-insert-attribute (name value) - "Read attribute name and value from minibuffer and insert attribute spec." - (interactive - (let* ((el (sgml-find-attribute-element)) - (name - (completing-read - "Attribute name: " - (mapcar (function (lambda (a) (list (sgml-attdecl-name a)))) - (sgml-non-fixed-attributes (sgml-element-attlist el))) - nil t))) - (list name - (sgml-read-attribute-value - (sgml-lookup-attdecl name (sgml-element-attlist el)) - (sgml-element-attval el name))))) - ;; Body - (assert (stringp name)) - (assert (or (null value) (stringp value))) - (let* ((el (sgml-find-attribute-element)) - (asl (cons (sgml-make-attspec name value) - (sgml-element-attribute-specification-list el))) - (in-tag (< (point) (sgml-element-stag-end el)))) - (sgml-change-start-tag el asl) - (when in-tag (forward-char -1)))) - -(defun sgml-split-element () - "Split the current element at point. -If repeated, the containing element will be split before the beginning -of then current element." - (interactive "*") - (setq sgml-split-level - (if (eq this-command last-command) - (1+ sgml-split-level) - 0)) - (let ((u (sgml-find-context-of (point))) - (start (point-marker))) - (loop repeat sgml-split-level do - (goto-char (sgml-element-start u)) - (setq u (sgml-element-parent u))) - ;; Verify that a new element can be started - (unless (and (sgml-element-pstate u) ; in case of top element - (sgml-get-move (sgml-element-pstate u) - (sgml-element-name u))) - - (sgml-error "The %s element can't be split" - (sgml-element-name u))) - ;; Do the split - (sgml-insert-end-tag) - (sgml-insert-tag (sgml-start-tag-of u) 'silent) - (skip-chars-forward " \t\n") - (sgml-indent-line) - (when (> sgml-split-level 0) - (goto-char start)) - (or (eq sgml-top-tree - (setq u (sgml-element-parent u))) - (sgml-message - "Repeat the command to split the containing %s element" - (sgml-element-name u))))) - -;;; David Megginson's custom menus for keys - -(defun sgml-custom-dtd (doctype) - "Insert a DTD declaration from the sgml-custom-dtd alist." - (interactive - (list (completing-read "Insert DTD: " sgml-custom-dtd nil t))) - (let ((entry (assoc doctype sgml-custom-dtd))) - (sgml-doctype-insert (second entry) (cddr entry)))) - -(defun sgml-custom-markup (markup) - "Insert markup from the sgml-custom-markup alist." - (interactive - (list (completing-read "Insert Markup: " sgml-custom-markup nil t))) - (sgml-insert-markup (cadr (assoc markup sgml-custom-markup)))) - - -;;;; SGML mode: Menu inserting - -(defun sgml-tags-menu (event) - "Pop up a menu with valid tags and insert the choosen tag. -If the variable sgml-balanced-tag-edit is t, also inserts the -corresponding end tag. If sgml-leave-point-after-insert is t, the point -is left after the inserted tag(s), unless the element has som required -content. If sgml-leave-point-after-insert is nil the point is left -after the first tag inserted." - (interactive "*e") - (let ((end (sgml-mouse-region))) - (sgml-parse-to-here) - (cond - ((eq sgml-markup-type 'start-tag) - (sgml-attrib-menu event)) - (t - (let ((what - (sgml-menu-ask event (if (or end sgml-balanced-tag-edit) - 'element 'tags)))) - (cond - ((null what)) - (end - (sgml-tag-region what (point) end)) - (sgml-balanced-tag-edit - (sgml-insert-element what)) - (t - (sgml-insert-tag what)))))))) - -(defun sgml-element-menu (event) - "Pop up a menu with valid elements and insert choice. -If sgml-leave-point-after-insert is nil the point is left after the first -tag inserted." - (interactive "*e") - (let ((what (sgml-menu-ask event 'element))) - (and what (sgml-insert-element what)))) - -(defun sgml-start-tag-menu (event) - "Pop up a menu with valid start-tags and insert choice." - (interactive "*e") - (let ((what (sgml-menu-ask event 'start-tag))) - (and what (sgml-insert-tag what)))) - -(defun sgml-end-tag-menu (event) - "Pop up a menu with valid end-tags and insert choice." - (interactive "*e") - (let ((what (sgml-menu-ask event 'end-tag))) - (and what (sgml-insert-tag what)))) - -(defun sgml-tag-region-menu (event) - "Pop up a menu with valid elements and tag current region with the choice." - (interactive "*e") - (let ((what (sgml-menu-ask event 'element))) - (and what (sgml-tag-region what - (region-beginning) - (region-end))))) - -(defun sgml-menu-ask (event type) - (sgml-parse-to-here) - (let (tab - (title (capitalize (symbol-name type)))) - (cond - (sgml-markup-type) - ((eq type 'element) - (setq tab - (mapcar (function symbol-name) - (sgml-current-list-of-valid-eltypes)))) - (t - (unless (eq type 'start-tag) - (setq tab - (mapcar (function sgml-end-tag-of) - (sgml-current-list-of-endable-eltypes)))) - (unless (eq type 'end-tag) - (setq tab - (nconc tab - (mapcar (function sgml-start-tag-of) - (sgml-current-list-of-valid-eltypes))))))) - (or tab - (error "No valid %s at this point" type)) - (or - (sgml-popup-menu event - title - (mapcar (function (lambda (x) (cons x x))) - tab)) - (message nil)))) - -(defun sgml-entities-menu (event) - (interactive "*e") - (sgml-need-dtd) - (let ((menu - (mapcar (function (lambda (x) (cons x x))) - (sort (sgml-map-entities (function sgml-entity-name) - (sgml-dtd-entities sgml-dtd-info) - t) - (function string-lessp)))) - choice) - (unless menu - (error "No entities defined")) - (setq choice (sgml-popup-menu event "Entities" menu)) - (when choice - (insert "&" choice ";")))) - -(defun sgml-doctype-insert (doctype vars) - "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS. -VARS should be a list of variables and values. -For backward compatibility a single string instead of a variable is -assigned to sgml-default-dtd-file. -All variables are made buffer local and are also added to the -buffers local variables list." - (when doctype - (unless (bolp) - (insert "\n")) - (unless (eolp) - (insert "\n") - (forward-char -1)) - (sgml-insert-markup doctype)) - (while vars - (cond ((stringp (car vars)) - (sgml-set-local-variable 'sgml-default-dtd-file (car vars)) - (setq vars (cdr vars))) - ((car vars) ; Avoid nil - (sgml-set-local-variable (car vars) (cadr vars)) - (setq vars (cddr vars))))) - (setq sgml-top-tree nil)) - -(defun sgml-attrib-menu (event) - "Pop up a menu of the attributes of the current element -\(or the element whith start-tag before point)." - (interactive "e") - (let ((menu (sgml-make-attrib-menu (sgml-find-attribute-element)))) - (sgml-popup-multi-menu event "Attributes" menu))) - -(defun sgml-make-attrib-menu (el) - (let ((attlist (sgml-non-fixed-attributes (sgml-element-attlist el)))) - (or attlist - (error "No non-fixed attributes for element")) - (loop for attdecl in attlist - for name = (sgml-attdecl-name attdecl) - for defval = (sgml-attdecl-default-value attdecl) - for tokens = (or (sgml-declared-value-token-group - (sgml-attdecl-declared-value attdecl)) - (sgml-declared-value-notation - (sgml-attdecl-declared-value attdecl))) - collect - (cons - (sgml-attdecl-name attdecl) - (nconc - (if tokens - (loop for val in tokens collect - (list val - (list 'sgml-insert-attribute name val))) - (list - (list "Set attribute value" - (list 'sgml-insert-attribute - (sgml-attdecl-name attdecl) - (list 'sgml-read-attribute-value - (list 'quote attdecl) - (sgml-element-attval el name)))))) - (if (sgml-default-value-type-p 'required defval) - nil - (list "--" - (list (if (sgml-default-value-type-p nil defval) - (format "Default: %s" - (sgml-default-value-attval defval)) - "#IMPLIED") - (list 'sgml-insert-attribute name nil)))))))) - ) - -;;;; SGML mode: Fill - -(defun sgml-fill-element (element) - "Fill bigest enclosing element with mixed content. -If current element has pure element content, recursively fill the -subelements." - (interactive (list (sgml-find-element-of (point)))) - ;; - (message "Filling...") - (when (sgml-element-mixed element) - ;; Find bigest enclosing element with mixed content - (while (sgml-element-mixed (sgml-element-parent element)) - (setq element (sgml-element-parent element)))) - ;; - (sgml-do-fill element) - (sgml-message "Done")) - -(defun sgml-do-fill (element) - (when sgml-debug - (goto-char (sgml-element-start element)) - (sit-for 0)) - (save-excursion - (cond - ((sgml-element-mixed element) - (let (last-pos - (c (sgml-element-content element)) - (agenda nil)) ; regions to fill later - (goto-char (sgml-element-stag-end element)) - (when (eolp) (forward-char 1)) - (setq last-pos (point)) - (while c - (cond - ((sgml-element-mixed c)) - (t - ;; Put region before element on agenda. Can't fill it now - ;; that would mangel the parse tree that is being traversed. - (push (cons last-pos (sgml-element-start c)) - agenda) - (goto-char (sgml-element-start c)) - (sgml-do-fill c) - ;; Fill may change parse tree, get a fresh - (setq c (sgml-find-element-of (point))) - (setq last-pos (sgml-element-end c)))) - (setq c (sgml-element-next c))) - ;; Fill the last region in content of element, - ;; but get a fresh parse tree, if it has change due to other fills. - (sgml-fill-region last-pos - (sgml-element-etag-start - (sgml-find-element-of - (sgml-element-start element)))) - (while agenda - (sgml-fill-region (caar agenda) (cdar agenda)) - (setq agenda (cdr agenda))))) - (t - ;; If element is not mixed, fill subelements recursively - (let ((c (sgml-element-content element))) - (while c - (goto-char (sgml-element-start c)) - (sgml-do-fill c) - (setq c (sgml-element-next (sgml-find-element-of (point)))))))))) - -(defun sgml-fill-region (start end) - (sgml-message "Filling...") - (save-excursion - (goto-char end) - (skip-chars-backward " \t\n") - (while (progn (beginning-of-line 1) - (< start (point))) - (delete-horizontal-space) - (delete-char -1) - (insert " ")) - (end-of-line 1) - (let (give-up prev-column opoint) - (while (and (not give-up) (> (current-column) fill-column)) - (setq prev-column (current-column)) - (setq opoint (point)) - (move-to-column (1+ fill-column)) - (skip-chars-backward "^ \t\n") - (if (bolp) - (re-search-forward "[ \t]" opoint t)) - (setq opoint (point)) - (skip-chars-backward " \t") - (if (bolp) - (setq give-up t) - (delete-region (point) opoint) - (newline) - (sgml-indent-line) - (end-of-line 1) - (setq give-up (>= (current-column) prev-column))))))) - -;;;; SGML mode: Attribute editing - -(defvar sgml-start-attributes nil) -(defvar sgml-main-buffer nil) -(defvar sgml-attlist nil) - -(defun sgml-edit-attributes () - "Edit attributes of current element. -Editing is done in a separate window." - (interactive) - (let ((element (sgml-find-attribute-element))) - (unless (sgml-bpos-p (sgml-element-stag-epos element)) - (error "Element's start-tag is not in the buffer")) - (push-mark) - (goto-char (sgml-element-start element)) - (let* ((start (point-marker)) - (asl (sgml-element-attribute-specification-list element)) - (cb (current-buffer)) - (quote sgml-always-quote-attributes)) - (switch-to-buffer-other-window - (sgml-attribute-buffer element asl)) - (sgml-edit-attrib-mode) - (make-local-variable 'sgml-attlist) - (setq sgml-attlist (sgml-element-attlist element)) - (make-local-variable 'sgml-start-attributes) - (setq sgml-start-attributes start) - (make-local-variable 'sgml-always-quote-attributes) - (setq sgml-always-quote-attributes quote) - (make-local-variable 'sgml-main-buffer) - (setq sgml-main-buffer cb)))) - -(defun sgml-attribute-buffer (element asl) - (let ((bname "*Edit attributes*") - (buf nil) - (inhibit-read-only t)) - (save-excursion - (when (setq buf (get-buffer bname)) - (kill-buffer buf)) - (setq buf (get-buffer-create bname)) - (set-buffer buf) - (erase-buffer) - (sgml-insert '(read-only t rear-nonsticky (read-only)) - "<%s -- Edit values and finish with C-c C-c --\n" - (sgml-element-name element)) - (loop - for attr in (sgml-element-attlist element) do - ;; Produce text like - ;; name = value - ;; -- declaration : default -- - (let* ((aname (sgml-attdecl-name attr)) - (dcl-value (sgml-attdecl-declared-value attr)) - (def-value (sgml-attdecl-default-value attr)) - (cur-value (sgml-lookup-attspec aname asl))) - (sgml-insert ; atribute name - '(read-only t rear-nonsticky (read-only)) - " %s = " aname) - (cond ; attribute value - ((sgml-default-value-type-p 'fixed def-value) - (sgml-insert '(read-only t category sgml-fixed - rear-nonsticky (category)) - "#FIXED %s" - (sgml-default-value-attval def-value))) - ((and (null cur-value) - (or (memq def-value '(implied conref current)) - (sgml-default-value-attval def-value))) - (sgml-insert '(category sgml-default rear-nonsticky (category)) - "#DEFAULT")) - ((not (null cur-value)) - (sgml-insert nil "%s" (sgml-attspec-attval cur-value)))) - (sgml-insert - '(read-only 1) - "\n\t-- %s: %s --\n" - (cond ((sgml-declared-value-token-group dcl-value)) - ((sgml-declared-value-notation dcl-value) - (format "NOTATION %s" - (sgml-declared-value-notation dcl-value))) - (t - dcl-value)) - (cond ((sgml-default-value-attval def-value)) - (t - (concat "#" (upcase (symbol-name def-value)))))))) - (sgml-insert '(read-only t) ">") - (goto-char (point-min)) - (sgml-edit-attrib-next)) - buf)) - -(defvar sgml-edit-attrib-mode-map (make-sparse-keymap)) -(define-key sgml-edit-attrib-mode-map "\C-c\C-c" 'sgml-edit-attrib-finish) -(define-key sgml-edit-attrib-mode-map "\C-c\C-d" 'sgml-edit-attrib-default) -(define-key sgml-edit-attrib-mode-map "\C-c\C-k" 'sgml-edit-attrib-clear) - -(define-key sgml-edit-attrib-mode-map "\C-a" 'sgml-edit-attrib-field-start) -(define-key sgml-edit-attrib-mode-map "\C-e" 'sgml-edit-attrib-field-end) -(define-key sgml-edit-attrib-mode-map "\t" 'sgml-edit-attrib-next) - -(defun sgml-edit-attrib-mode () - "Major mode to edit attribute specification list.\\<sgml-edit-attrib-mode-map> -Use \\[sgml-edit-attrib-next] to move between input fields. Use -\\[sgml-edit-attrib-default] to make an attribute have its default -value. To abort edit kill buffer (\\[kill-buffer]) and remove window -(\\[delete-window]). To finsh edit use \\[sgml-edit-attrib-finish]. - -\\{sgml-edit-attrib-mode-map}" - (kill-all-local-variables) - (setq mode-name "SGML edit attributes" - major-mode 'sgml-edit-attrib-mode) - (use-local-map sgml-edit-attrib-mode-map) - (run-hooks 'text-mode-hook 'sgml-edit-attrib-mode-hook)) - -(defun sgml-edit-attrib-finish () - "Finish editing and insert attribute values in original buffer." - (interactive) - (let ((cb (current-buffer)) - (asl (sgml-edit-attrib-specification-list)) - ;; save buffer local variables - (start sgml-start-attributes)) - (when (markerp start) - (delete-windows-on cb) - (switch-to-buffer (marker-buffer start)) - (kill-buffer cb) - (goto-char start) - (let ((element (sgml-find-element-of start))) - ;; *** Should the it be verified that this element - ;; is the one edited? - (sgml-change-start-tag element asl))))) - - -(defun sgml-edit-attrib-specification-list () - (goto-char (point-min)) - (forward-line 1) - (sgml-with-parser-syntax - (let ((asl nil) - (al sgml-attlist)) - (while (not (eq ?> (following-char))) - (sgml-parse-s) - (sgml-check-nametoken) ; attribute name, should match head of al - (forward-char 3) - (unless (memq (get-text-property (point) 'category) - '(sgml-default sgml-fixed)) - (push - (sgml-make-attspec (sgml-attdecl-name (car al)) - (sgml-extract-attribute-value - (sgml-attdecl-declared-value (car al)))) - asl)) - (while (progn (beginning-of-line 2) - (or (eolp) - (not (get-text-property (point) 'read-only))))) - - (forward-line 1) - (setq al (cdr al))) - asl))) - - -(defun sgml-extract-attribute-value (type) - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (sgml-edit-attrib-field-end) - (point))) - (unless (eq type 'cdata) - (subst-char-in-region (point-min) (point-max) ?\n ? ) - (goto-char (point-min)) - (delete-horizontal-space)) - (goto-char (point-min)) - (when (search-forward "\"" nil t) ; don't allow both " and ' - (goto-char (point-min)) - (while (search-forward "'" nil t) ; replace ' with char ref - (replace-match "'"))) - (buffer-string)))) - -(defun sgml-edit-attrib-default () - "Set current attribute value to default." - (interactive) - (sgml-edit-attrib-clear) - (save-excursion - (sgml-insert '(category sgml-default) - "#DEFAULT"))) - -(defun sgml-edit-attrib-clear () - "Kill the value of current attribute." - (interactive) - (kill-region - (progn (sgml-edit-attrib-field-start) (point)) - (progn (sgml-edit-attrib-field-end) (point)))) - -(defun sgml-edit-attrib-field-start () - "Go to the start of the attribute value field." - (interactive) - (let (start) - (beginning-of-line 1) - (while (not (eq t (get-text-property (point) 'read-only))) - (beginning-of-line 0)) - (setq start (next-single-property-change (point) 'read-only)) - (unless start (error "No attribute value here")) - (assert (number-or-marker-p start)) - (goto-char start))) - -(defun sgml-edit-attrib-field-end () - "Go to the end of the attribute value field." - (interactive) - (sgml-edit-attrib-field-start) - (let ((end (if (and (eolp) - (get-text-property (1+ (point)) 'read-only)) - (point) - (next-single-property-change (point) 'read-only)))) - (assert (number-or-marker-p end)) - (goto-char end))) - -(defun sgml-edit-attrib-next () - "Move to next attribute value." - (interactive) - (or (search-forward-regexp "^ *[.A-Za-z0-9---]+ *= ?" nil t) - (goto-char (point-min)))) - - -;;;; SGML mode: Hiding tags/attributes - -(defconst sgml-tag-regexp - "\\(</?>\\|</?[A-Za-z][---A-Za-z0-9.]*\\(\\([^'\"></]\\|'[^']*'\\|\"[^\"]*\"\\)*\\)>?\\)") - -(defun sgml-operate-on-tags (action &optional attr-p) - (let ((buffer-modified-p (buffer-modified-p)) - (inhibit-read-only t) - (buffer-read-only nil) - (before-change-function nil) - (markup-index ; match-data index in tag regexp - (if attr-p 2 1)) - (tagcount ; number tags to give them uniq - ; invisible properties - 1)) - (unwind-protect - (save-excursion - (goto-char (point-min)) - (while (re-search-forward sgml-tag-regexp nil t) - (cond - ((eq action 'hide) - (let ((tag (downcase - (buffer-substring-no-properties - (1+ (match-beginning 0)) - (match-beginning 2))))) - (if (or attr-p (not (member tag sgml-exposed-tags))) - (add-text-properties - (match-beginning markup-index) (match-end markup-index) - (list 'invisible tagcount - 'rear-nonsticky '(invisible face)))))) - ((eq action 'show) ; ignore markup-index - (remove-text-properties (match-beginning 0) (match-end 0) - '(invisible nil))) - (t (error "Invalid action: %s" action))) - (incf tagcount))) - (set-buffer-modified-p buffer-modified-p)))) - -(defun sgml-hide-tags () - "Hide all tags in buffer." - (interactive) - (sgml-operate-on-tags 'hide)) - -(defun sgml-show-tags () - "Show hidden tags in buffer." - (interactive) - (sgml-operate-on-tags 'show)) - -(defun sgml-hide-attributes () - "Hide all attribute specifications in the buffer." - (interactive) - (sgml-operate-on-tags 'hide 'attributes)) - -(defun sgml-show-attributes () - "Show all attribute specifications in the buffer." - (interactive) - (sgml-operate-on-tags 'show 'attributes)) - - -;;;; SGML mode: Normalize (and misc manipulations) - -(defun sgml-expand-shortref-to-text (name) - (let (before-change-function - (entity (sgml-lookup-entity name (sgml-dtd-entities sgml-dtd-info)))) - (cond - ((null entity) (sgml-error "Undefined entity %s" name)) - ((sgml-entity-data-p entity) - (sgml-expand-shortref-to-entity name)) - (t - (delete-region sgml-markup-start (point)) - (sgml-entity-insert-text entity) - (setq sgml-goal (point-max)) ; May have changed size of buffer - ;; now parse the entity text - (setq sgml-rs-ignore-pos sgml-markup-start) - (goto-char sgml-markup-start))))) - -(defun sgml-expand-shortref-to-entity (name) - (let ((end (point)) - (re-found nil) - before-change-function) - (goto-char sgml-markup-start) - (setq re-found (search-forward "\n" end t)) - (delete-region sgml-markup-start end) - (insert "&" name (if re-found "\n" ";")) - (setq sgml-goal (point-max)) ; May have changed size of buffer - (goto-char (setq sgml-rs-ignore-pos sgml-markup-start)))) - -(defun sgml-expand-all-shortrefs (to-entity) - "Expand all short references in the buffer. -Short references to text entities are expanded to the replacement text -of the entity other short references are expanded into general entity -references. If argument, TO-ENTITY, is non-nil, or if called -interactive with numeric prefix argument, all short references are -replaced by generaly entity references." - (interactive "*P") - (sgml-reparse-buffer - (if to-entity - (function sgml-expand-shortref-to-entity) - (function sgml-expand-shortref-to-text)))) - -(defun sgml-normalize (to-entity &optional element) - "Normalize buffer by filling in omitted tags and expanding empty tags. -Argument TO-ENTITY controls how short references are expanded as with -`sgml-expand-all-shortrefs'. An optional argument ELEMENT can be the -element to normalize insted of the whole buffer, if used no short -references will be expanded." - (interactive "*P") - (unless element - (sgml-expand-all-shortrefs to-entity)) - (let ((only-one (not (null element)))) - (setq element (or element (sgml-top-element))) - (goto-char (sgml-element-end element)) - (let ((before-change-function nil)) - (sgml-normalize-content element only-one))) - (sgml-note-change-at (sgml-element-start element)) - (sgml-message "Done")) - -(defun sgml-normalize-element () - (interactive "*") - (sgml-normalize nil (sgml-find-element-of (point)))) - -(defun sgml-normalize-content (element only-first) - "Normalize all elements in a content where ELEMENT is first element. -If sgml-normalize-trims is non-nil, trim off white space from ends of -elements with omitted end-tags." - (let ((content nil)) - (while element ; Build list of content elements - (push element content) - (setq element (if only-first - nil - (sgml-element-next element)))) - (while content - (setq element (car content)) - ;; Progress report - (sgml-lazy-message "Normalizing %d%% left" - (/ (point) (/ (+ (point-max) 100) 100))) - ;; Fix the end-tag - (sgml-normalize-end-tag element) - ;; Fix tags of content - (sgml-normalize-content (sgml-tree-content element) nil) - ;; Fix the start-tag - (sgml-normalize-start-tag element) - ;; Next content element - (setq content (cdr content))))) - -(defun sgml-normalize-start-tag (element) - (when (sgml-bpos-p (sgml-element-stag-epos element)) - (goto-char (min (point) (sgml-element-start element))) - (let ((name (sgml-element-gi element)) - (attlist (sgml-element-attlist element)) - (asl (sgml-element-attribute-specification-list element))) - (save-excursion - (assert (or (zerop (sgml-element-stag-len element)) - (= (point) (sgml-element-start element)))) - (delete-char (sgml-element-stag-len element)) - (sgml-insert-start-tag name asl attlist nil))))) - -(defun sgml-normalize-end-tag (element) - (unless (sgml-element-empty element) - (when (sgml-bpos-p (sgml-element-etag-epos element)) - (goto-char (min (point) (sgml-element-etag-start element))) - (if (and (zerop (sgml-element-etag-len element)) - sgml-normalize-trims) - (skip-chars-backward " \t\n\r")) - (delete-char (sgml-tree-etag-len element)) - (save-excursion (tempo-process-and-insert-string (sgml-end-tag-of element)))))) - - -(defun sgml-make-character-reference (&optional invert) - "Convert character after point into a character reference. -If called with a numeric argument, convert a character reference back -to a normal character. If called from a program, set optional -argument INVERT to non-nil." - (interactive "*P") - (cond - (invert - (or (looking-at "&#\\([0-9]+\\)[;\n]?") - (error "No character reference after point")) - (let ((c (string-to-int (buffer-substring (match-beginning 1) - (match-end 1))))) - (delete-region (match-beginning 0) - (match-end 0)) - (insert c))) - ;; Convert character to &#nn; - (t - (let ((c (following-char))) - (delete-char 1) - (insert (format "&#%d;" c)))))) - -(defun sgml-expand-entity-reference () - "Insert the text of the entity referenced at point." - (interactive) - (sgml-with-parser-syntax - (setq sgml-markup-start (point)) - (sgml-check-delim "ERO") - (let* ((ename (sgml-check-name t)) - (entity (sgml-lookup-entity ename - (sgml-dtd-entities - (sgml-pstate-dtd - sgml-buffer-parse-state))))) - (unless entity - (error "Undefined entity %s" ename)) - (or (sgml-parse-delim "REFC") - (sgml-parse-RE)) - (delete-region sgml-markup-start (point)) - (sgml-entity-insert-text entity)))) - - -;;;; SGML mode: TAB completion - -(defun sgml-complete () - "Complete the word/tag/entity before point. -If it is a tag (starts with < or </) complete with valid tags. -If it is an entity (starts with &) complete with declared entities. -If it is a markup declaration (starts with <!) complete with markup -declaration names. -If it is something else complete with ispell-complete-word." - (interactive "*") - (let ((tab ; The completion table - nil) - (pattern nil) - (c nil) - (here (point))) - (skip-chars-backward "^ \n\t</!&%") - (setq pattern (buffer-substring (point) here)) - (setq c (char-after (1- (point)))) - (cond - ;; entitiy - ((eq c ?&) - (sgml-need-dtd) - (setq tab - (sgml-entity-completion-table - (sgml-dtd-entities (sgml-pstate-dtd sgml-buffer-parse-state))))) - ;; start-tag - ((eq c ?<) - (save-excursion - (backward-char 1) - (sgml-parse-to-here) - (setq tab (sgml-eltype-completion-table - (sgml-current-list-of-valid-eltypes))))) - ;; end-tag - ((eq c ?/) - (save-excursion - (backward-char 2) - (sgml-parse-to-here) - (setq tab (sgml-eltype-completion-table - (sgml-current-list-of-endable-eltypes))))) - ;; markup declaration - ((eq c ?!) - (setq tab sgml-markup-declaration-table)) - (t - (goto-char here) - (ispell-complete-word))) - (when tab - (let ((completion (try-completion pattern tab))) - (cond ((null completion) - (goto-char here) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((eq completion t) - (goto-char here) - (message "[Complete]")) - ((not (string= pattern completion)) - (delete-char (length pattern)) - (insert completion)) - (t - (goto-char here) - (message "Making completion list...") - (let ((list (all-completions pattern tab))) - (with-output-to-temp-buffer " *Completions*" - (display-completion-list list))) - (message "Making completion list...%s" "done"))))))) - - -;;;; SGML mode: Options menu - -(defun sgml-file-options-menu (&optional event) - (interactive "e") - (sgml-options-menu event sgml-file-options)) - -(defun sgml-user-options-menu (&optional event) - (interactive "e") - (sgml-options-menu event sgml-user-options)) - -(defun sgml-options-menu (event vars) - (let ((var - (let ((maxlen - (loop for var in vars - maximize (length (sgml-variable-description var))))) - (sgml-popup-menu - event "Options" - (loop for var in vars - for desc = (sgml-variable-description var) - collect - (cons - (format "%s%s [%s]" - desc - (make-string (- maxlen (length desc)) ? ) - (sgml-option-value-indicator var)) - var)))))) - (when var - (sgml-do-set-option var event)))) - -(defun sgml-do-set-option (var &optional event) - (let ((type (sgml-variable-type var)) - (val (symbol-value var))) - (cond - ((eq 'toggle type) - (message "%s set to %s" var (not val)) - (set var (not val))) - ((eq 'string type) - (describe-variable var) - (setq val (read-string (concat (sgml-variable-description var) ": "))) - (when (stringp val) - (set var val))) - ((consp type) - (let ((val - (sgml-popup-menu event - (sgml-variable-description var) - (loop for c in type collect - (cons - (if (consp c) (car c) (format "%s" c)) - (if (consp c) (cdr c) c)))))) - (set var val) - (message "%s set to %s" var val))) - (t - (describe-variable var) - (setq val (read-string (concat (sgml-variable-description var) - " (sexp): "))) - (when (stringp val) - (set var (car (read-from-string val))))))) - (force-mode-line-update)) - -(defun sgml-option-value-indicator (var) - (let ((type (sgml-variable-type var)) - (val (symbol-value var))) - (cond - ((eq type 'toggle) - (if val "Yes" "No")) - ((eq type 'string) - (if (stringp val) - (substring val 0 4) - "-")) - ((and (atom type) val) - "...") - ((consp type) - (or (car (rassq val type)) - val)) - (t - "-")))) - -;;;; NEW - -(defun sgml-trim-and-leave-element () - (interactive) - (goto-char (sgml-element-etag-start (sgml-last-element))) - (while (progn (forward-char -1) - (looking-at "\\s-")) - (delete-char 1)) - (sgml-up-element)) - - -;;; psgml-edit.el ends here
--- a/lisp/psgml/psgml-fs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,241 +0,0 @@ -;;; psgml-fs.el --- Format a SGML-file according to a style file -;; Copyright (C) 1995 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> -;; Version: $Id: psgml-fs.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ -;; Keywords: -;; Last edited: Thu Mar 21 22:32:27 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin) - -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to lenst@lysator.liu.se) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. -;;; -;;; Commentary: - -;; The function `style-format' formats the SGML-file in the current -;; buffer according to the style defined in the file `psgml-style.fs' -;; (or the file given by the variable `fs-style'). - -;; To try it load this file and open the test file example.sgml. Then -;; run the emacs command `M-x style-format'. - -;; The style file should contain a single Lisp list. The elements of -;; this list, are them self lists, describe the style for an element type. -;; The sublists begin with the generic identifier for the element types and -;; the rest of the list are characteristic/value pairs. - -;; E.g. ("p" block t left 4 top 2) - -;; Defines the style for p-elements to be blocks with left margin 4 and -;; at least to blank lines before the block. - - -;;; Code: -(require 'psgml-api) - -;;;; Formatting parameters - -(defvar fs-char - '((left . 0) - (first . nil) - (default-top . 0) - (default-bottom . 0) - (ignore-empty-para . nil) - (literal . nil))) - -(defvar fs-special-styles - '(top bottom before after hang-from text) - "Style attribues that should not be entered in the characteristics table.") - - -;;;; Formatting engine - -(defun fs-char (p) - (cdr (assq p fs-char))) - -(defvar fs-para-acc "" - "Accumulate text of paragraph") - -(defvar fs-hang-from nil - "Hanging indent of current pargraph") - -(defvar fs-first-indent nil) -(defvar fs-left-indent nil) - -(defvar fs-vspace 0 - "Vertical space after last paragraph") - -(defun fs-addvspace (n) - (when (> n fs-vspace) - (princ (make-string (- n fs-vspace) ?\n)) - (setq fs-vspace n))) - - -(defun fs-para () - (when (if (fs-char 'ignore-epmty-para) - (string-match "[^\t\n ]" fs-para-acc) - fs-left-indent) - (assert fs-left-indent) - (fs-output-para fs-para-acc fs-first-indent fs-left-indent - fs-hang-from - (fs-char 'literal)) - (setq fs-vspace 0 - fs-hang-from nil)) - (setq fs-para-acc "" - fs-first-indent nil - fs-left-indent nil)) - -(defun fs-paraform-data (data) - (unless fs-left-indent - (setq fs-left-indent (fs-char 'left) - fs-first-indent (fs-char 'first))) - (setq fs-para-acc (concat fs-para-acc data))) - -(defun fs-output-para (text first-indent indent hang-from literal) - (sgml-push-to-string text) - (let ((indent-tabs-mode nil) - (fill-prefix (make-string indent ? ))) - (cond - (literal - (goto-char (point-max)) - (unless (bolp) - (insert ?\n)) - (goto-char (point-min)) - (while (not (eobp)) - (insert fill-prefix) - (beginning-of-line 2))) - (t - (while (re-search-forward "[ \t\n\r]+" nil t) - (replace-match " ")) - (goto-char (point-min)) - (delete-horizontal-space) - (insert - (if hang-from - hang-from - (make-string (or first-indent indent) ? ))) - (fill-region-as-paragraph (point-min) (point-max)) - )) - (princ (buffer-string))) - (sgml-pop-entity)) - -(defun fs-element-content (e) - (let ((fs-para-acc "")) - (sgml-map-content e - (function fs-paraform-phrase) - (function fs-paraform-data) - nil - (function fs-paraform-entity)) - fs-para-acc)) - -(defun fs-paraform-phrase (e) - (sgml-map-content e - (function fs-paraform-phrase) - (function fs-paraform-data) - nil - (function fs-paraform-entity))) - -(defun fs-paraform-entity (entity) - (let ((entity-map (fs-char 'entity-map)) - (text nil)) - (when entity-map - (setq text - (loop for (name val) on entity-map by 'cddr - thereis (if (equal name (sgml-entity-name entity)) - val)))) - (unless text - (setq text (sgml-entity-text entity))) - (fs-paraform-data text))) - -;;;; Style driven engine - -(defvar fs-style "psgml-style.fs" - "*Style sheet to use for `style-format'. -The value can be the style-sheet list, or it can be a file name -\(string) of a file containing the style sheet or it can be the name -\(symbol) of a variable containing the style sheet." ) - -(defvar fs-cached-styles nil) - -(defun fs-get-style (style) - (cond ((stringp style) - (sgml-cache-catalog style - 'fs-cached-styles - (function (lambda () - (read (current-buffer)))))) - ((symbolp style) - (fs-get-style (symbol-value style))) - ((listp style) - style) - (t - (error "Illegal style value: %s" style)))) - -(defun fs-engine (e) - (fs-do-style e - (cdr (or (assoc (sgml-element-gi e) fs-style) - (assq t fs-style))))) - -(defun fs-do-style (e style) - (let ((hang-from (getf style 'hang-from))) - (when hang-from - (setq fs-hang-from - (format "%s%s " - (make-string (fs-char 'left) ? ) - (eval hang-from))))) - (let ((fs-char (nconc - (loop for st on style by 'cddr - unless (memq (car st) fs-special-styles) - collect (cons (car st) - (eval (cadr st)))) - fs-char))) - (when (getf style 'block) - (fs-para) - (fs-addvspace (or (getf style 'top) - (fs-char 'default-top)))) - (let ((before (getf style 'before))) - (when before - (fs-do-style e before))) - (cond ((getf style 'text) - (fs-paraform-data (eval (getf style 'text)))) - (t - (sgml-map-content e - (function fs-engine) - (function fs-paraform-data) - nil - (function fs-paraform-entity)))) - (let ((after (getf style 'after))) - (when after - (fs-do-style e after))) - (when (getf style 'block) - (fs-para) - (fs-addvspace (or (getf style 'bottom) - (fs-char 'default-bottom)))))) - -;;;###autoload -(defun style-format () - (interactive) - (setq fs-para-acc "") - (let ((fs-style (fs-get-style fs-style))) - (with-output-to-temp-buffer "*Formatted*" - (fs-engine (sgml-top-element)) - (fs-para)))) - - - -;;;; Helper functions for use in style sheet - -(defun fs-attval (name) - (sgml-element-attval e name)) - - -;;; psgml-fs.el ends here
--- a/lisp/psgml/psgml-html.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,798 +0,0 @@ -;;; psgml-html.el --- HTML mode in conjunction with PSGML - -;; Copyright (C) 1994 Nelson Minar. -;; Copyright (C) 1995 Nelson Minar and Ulrik Dickow. -;; Copyright (C) 1996 Ben Wing. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Synched up with: FSF 19.30. - -;;; Author: Ben Wing. - -;;; Commentary: - -; Parts were taken from html-helper-mode and from code by Alastair Burt. - -; If you'd like to use the hm--html-minor-mode together with this -; mode, you have to put the following line to your ~/.emacs: -; (add-hook 'html-mode-hook 'hm--html-minor-mode) - -;;; Code: - -(defvar html-auto-sgml-entity-conversion nil - "*Control automatic sgml entity to ISO-8859-1 conversion") - -(require 'psgml) -(require 'derived) -(when html-auto-sgml-entity-conversion - (require 'iso-sgml)) -(require 'tempo) ;essential part of html-helper-mode - -;;{{{ user variables - -(defgroup html nil - "HyperText Markup Language" - :group 'sgml) - -(defgroup psgml-html nil - "HTML mode in conjunction with PSGML" - :tag "Psgml Html" - :prefix "html-helper-" - :group 'html - :group 'psgml) - -;; Set this to be whatever signature you want on the bottom of your pages. -(defcustom html-helper-address-string - (concat "<a href=\"mailto:" (user-mail-address) "\">" - (user-full-name) "</a>") - "*The default author string of each file." - :type 'string - :group 'psgml-html) - -(defcustom html-helper-htmldtd-version "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">\n" - "*Version of HTML DTD you're using." - :type 'string - :group 'psgml-html) - -(defcustom html-helper-do-write-file-hooks t - "*If not nil, then modify `local-write-file-hooks' to do timestamps." - :type 'boolean - :group 'psgml-html) - -(defcustom html-helper-build-new-buffer t - "*If not nil, then insert `html-helper-new-buffer-strings' for new buffers." - :type 'boolean - :group 'psgml-html) - -(defcustom html-helper-timestamp-hook 'html-helper-default-insert-timestamp - "*Hook called for timestamp insertion. -Override this for your own timestamp styles." - :type 'boolean - :group 'psgml-html) - -;; strings you might want to change - -(defcustom html-helper-new-buffer-template - '(html-helper-htmldtd-version - "<html>\n" - " <head>\n" - " <title>" (p "Document Title: " title) "</title>\n" - " </head>\n" - "\n" - " <body>\n" - " <h1>" (s title) "</h1>\n\n" - p - "\n\n <hr>\n" - " <address>" html-helper-address-string "</address>\n" - (html-helper-return-created-string) - html-helper-timestamp-start - html-helper-timestamp-end - "\n </body>\n</html>\n") - "*Template for new buffers. -Inserted by `html-helper-insert-new-buffer-strings' if -`html-helper-build-new-buffer' is set to t" - :type 'sexp - :group 'psgml-html) - -(defcustom html-helper-timestamp-start "<!-- hhmts start -->\n" - "*Start delimiter for timestamps. -Everything between `html-helper-timestamp-start' and -`html-helper-timestamp-end' will be deleted and replaced with the output -of the functions `html-helper-timestamp-hook' if -`html-helper-do-write-file-hooks' is t" - :type 'string - :group 'psgml-html) - -(defcustom html-helper-timestamp-end "<!-- hhmts end -->" - "*End delimiter for timestamps. -Everything between `html-helper-timestamp-start' and -`html-helper-timestamp-end' will be deleted and replaced with the output -of the function `html-helper-insert-timestamp' if -`html-helper-do-write-file-hooks' is t" - :type 'string - :group 'psgml-html) - -;; control over what types of tags to load. By default, we load all the -;; ones we know of. - -(defcustom html-helper-types-to-install - '(anchor header logical phys list textel entity image head form) - "*List of tag types to install when html-helper-mode is first loaded. -If you want to not install some type of tag, override this variable. -Order is significant: menus go in this order." - :type '(repeat symbol) - :group 'psgml-html) - -;;}}} end of user variables -;;{{{ type based keymap and menu variable and function setup - -;; html-helper-mode has a concept of "type" of tags. Each type is a -;; list of tags that all go together in one keymap and one menu. -;; Types can be added to the system after html-helper has been loaded, -;; briefly by doing html-helper-add-type-to-alist, then -;; html-helper-install-type, then html-helper-add-tag (for each tag) -;; then html-helper-rebuild-menu. See the mode documentation for more detail. - -(defconst html-helper-type-alist nil - "Alist: type of tag -> keymap, keybinding, menu, menu string. -Add to this with `html-helper-add-type-to-alist'.") - -;;{{{ accessor functions for html-helper-type-alist - -(defun html-helper-keymap-for (type) - "Accessor function for alist: for type, return keymap or nil" - (nth 0 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-key-for (type) - "Accessor function for alist: for type, return keybinding or nil" - (nth 1 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-menu-for (type) - "Accessor function for alist: for type, return menu or nil" - (nth 2 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-menu-string-for (type) - "Accessor function for alist: for type, return menustring or nil" - (nth 3 (cdr-safe (assq type html-helper-type-alist)))) - -(defun html-helper-normalized-menu-for (type) - "Helper function for building menus from submenus: add on string to menu." - (cons (html-helper-menu-string-for type) - (eval (html-helper-menu-for type)))) - -;;}}} - -(define-derived-mode html-mode sgml-mode "HTML" - "Major mode for editing HTML documents. -This is based on PSGML mode, and has a sophisticated SGML parser in it. -It knows how to properly indent HTML/SGML documents, and it can do - a form of document validation (use \\[sgml-next-trouble-spot] to find - the next error in your document). -Commands beginning with C-z insert various types of HTML tags - (prompting for the required information); to iconify or suspend, - use C-z C-z. -To literally insert special characters such as < and &, use C-c followed - by the character. -Use \\[sgml-insert-end-tag] to insert the proper closing tag. -Use \\[sgml-edit-attributes] to edit the attributes for a tag. -Use \\[sgml-show-context] to show the current HTML context. - -More specifically: -\\{html-mode-map} -" - (make-local-variable 'sgml-declaration) - (make-local-variable 'sgml-default-doctype-name) - (setq sgml-declaration (expand-file-name "html.decl" - sgml-data-directory) - sgml-default-doctype-name "html" - sgml-always-quote-attributes t - sgml-indent-step 2 - sgml-indent-data t - sgml-inhibit-indent-tags '("pre") - sgml-minimize-attributes nil - sgml-omittag t - sgml-shortag t) - - ;; font-lock setup for various emacsen: XEmacs, Emacs 19.29+, Emacs <19.29. - ;; By Ulrik Dickow <dickow@nbi.dk>. (Last update: 05-Sep-1995). - (cond ((string-match "XEmacs\\|Lucid" (emacs-version)) ; XEmacs/Lucid - (put major-mode 'font-lock-keywords-case-fold-search t)) - ;; XEmacs (19.13, at least) guesses the rest correctly. - ;; If any older XEmacsen don't, then tell me. - ;; - ((string-lessp "19.28.89" emacs-version) ; Emacs 19.29 and later - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(html-font-lock-keywords t t))) - ;; - (t ; Emacs 19.28 and older - (make-local-variable 'font-lock-keywords-case-fold-search) - (make-local-variable 'font-lock-keywords) - (make-local-variable 'font-lock-no-comments) - (setq font-lock-keywords-case-fold-search t) - (setq font-lock-keywords html-font-lock-keywords) - (setq font-lock-no-comments t))) - - (if html-helper-do-write-file-hooks - (add-hook 'local-write-file-hooks 'html-helper-update-timestamp)) - - (if (and html-helper-build-new-buffer (zerop (buffer-size))) - (html-helper-insert-new-buffer-strings)) - - (set (make-local-variable 'sgml-custom-markup) - '(("<A>" "<A HREF=\"\">\r</a>"))) - - ;; Set up the syntax table. - (modify-syntax-entry ?< "(>" html-mode-syntax-table) - (modify-syntax-entry ?> ")<" html-mode-syntax-table) - (modify-syntax-entry ?\" ". " html-mode-syntax-table) - (modify-syntax-entry ?\\ ". " html-mode-syntax-table) - (modify-syntax-entry ?' "w " html-mode-syntax-table) - - ; sigh ... need to call this now to get things working. - (sgml-build-custom-menus) - (add-submenu nil sgml-html-menu "SGML") - (delete-menu-item '("SGML"))) - -(defun html-helper-add-type-to-alist (type) - "Add a type specification to the alist. -The spec goes (type . (keymap-symbol keyprefix menu-symbol menu-string)). -See code for an example." - (setq html-helper-type-alist (cons type html-helper-type-alist))) - -;; Here are the types provided by html-helper-mode. -(mapcar 'html-helper-add-type-to-alist - '((entity . (nil nil html-helper-entity-menu "Insert Character Entities")) - (textel . (nil nil html-helper-textel-menu "Insert Text Elements")) - (head . (html-helper-head-map "\C-zb" html-helper-head-menu "Insert Structural Elements")) - (header . (html-helper-base-map "\C-z" html-helper-header-menu "Insert Headers")) - (anchor . (html-helper-base-map "\C-z" html-helper-anchor-menu "Insert Hyperlinks")) - (logical . (html-helper-base-map "\C-z" html-helper-logical-menu "Insert Logical Styles")) - (phys . (html-helper-base-map "\C-z" html-helper-phys-menu "Insert Physical Styles")) - (list . (html-helper-list-map "\C-zl" html-helper-list-menu "Insert List Elements")) - (form . (html-helper-form-map "\C-zf" html-helper-form-menu "Insert Form Elements")) - (image . (html-helper-image-map "\C-zm" html-helper-image-menu "Insert Inlined Images")))) - -;; Once html-helper-mode is aware of a type, it can then install the -;; type: arrange for keybindings, menus, etc. - -(defconst html-helper-installed-types nil - "The types that have been installed (used when building menus). -There is no support for removing a type once it has been installed.") - -(defun html-helper-install-type (type) - "Install a new tag type: add it to the keymap, menu structures, etc. -For this to work, the type must first have been added to the list of types -with html-helper-add-type-to-alist." - (setq html-helper-installed-types (cons type html-helper-installed-types)) - (let ((keymap (html-helper-keymap-for type)) - (key (html-helper-key-for type)) - (menu (html-helper-menu-for type)) - (menu-string (html-helper-menu-string-for type))) - (and key - (progn - (set keymap nil) - (define-prefix-command keymap) - (define-key html-mode-map key keymap))) - (and menu - (progn - (set menu nil))))) - -;; install the default types. -(mapcar 'html-helper-install-type html-helper-types-to-install) - -;;}}} - -;;{{{ html-helper-add-tag function for building basic tags - -(defvar html-helper-tempo-tags nil - "List of tags used in completion.") - -;; this while loop is awfully Cish -;; isn't there an emacs lisp function to do this? -(defun html-helper-string-to-symbol (input-string) - "Given a string, downcase it and replace spaces with -. -We use this to turn menu entries into good symbols for functions. -It's not entirely successful, but fortunately emacs lisp is forgiving." - (let* ((s (copy-sequence input-string)) - (l (1- (length s)))) - (while (> l 0) - (if (char-equal (aref s l) ?\ ) - (aset s l ?\-)) - (setq l (1- l))) - (concat "html-" (downcase s)))) - - -(defun html-helper-add-tag (l) - "Add a new tag to html-helper-mode. -Builds a tempo-template for the tag and puts it into the -appropriate keymap if a key is requested. Format: -`(html-helper-add-tag '(type keybinding completion-tag menu-name template doc)'" - (let* ((type (car l)) - (keymap (html-helper-keymap-for type)) - (menu (html-helper-menu-for type)) - (key (nth 1 l)) - (completer (nth 2 l)) - (name (nth 3 l)) - (tag (nth 4 l)) - (doc (nth 5 l)) - (command (tempo-define-template (html-helper-string-to-symbol name) - tag completer doc - 'html-helper-tempo-tags))) - - (if (null (memq type html-helper-installed-types)) ;type loaded? - t ;no, do nothing. - (if (stringp key) ;bind key somewhere? - (if keymap ;special keymap? - (define-key (eval keymap) key command) ;t: bind to prefix - (define-key html-mode-map key command)) ;nil: bind to global - t) - (if menu ;is there a menu? - (set menu ;good, cons it in - (cons (vector name command t) (eval menu)))) - ))) - -;;}}} - -;;{{{ most of the HTML tags - -;; These tags are an attempt to be HTML/2.0 compliant, with the exception -;; of container <p>, <li>, <dd>, <dt> (we adopt 3.0 behaviour). -;; For reference see <URL:http://www.w3.org/hypertext/WWW/MarkUp/MarkUp.html> - -;; order here is significant: within a tag type, menus and mode help -;; go in the reverse order of what you see here. Sorry about that, it's -;; not easy to fix. - -(mapcar - 'html-helper-add-tag - '( - ;;entities - (entity "\C-c#" "&#" "Ascii Code" ("&#" (r "Ascii: ") ";")) - (entity "\C-c\"" """ "Quotation mark" (""")) - (entity "\C-c$" "®" "Registered" ("®")) - (entity "\C-c@" "©" "Copyright" ("©")) - (entity "\C-c-" "­" "Soft Hyphen" ("­")) - (entity "\C-c " " " "Nonbreaking Space" (" ")) - (entity "\C-c&" "&" "Ampersand" ("&")) - (entity "\C-c>" ">" "Greater Than" (">")) - (entity "\C-c<" "<" "Less Than" ("<")) - - ;; logical styles - (logical "q" "<blockquote>" "Blockquote" ("<blockquote>" (r "Quote: ") "</blockquote>")) - (logical "c" "<code>" "Code" ("<code>" (r "Code: ") "</code>")) - (logical "x" "<samp>" "Sample" ("<samp>" (r "Sample code") "</samp>")) - (logical "r" "<cite>" "Citation" ("<cite>" (r "Citation: ") "</cite>")) - (logical "k" "<kbd>" "Keyboard Input" ("<kbd>" (r "Keyboard: ") "</kbd>")) - (logical "v" "<var>" "Variable" ("<var>" (r "Variable: ") "</var>")) - (logical "d" "<dfn>" "Definition" ("<dfn>" (r "Definition: ") "</dfn>")) - (logical "a" "<address>" "Address" ("<address>" r "</address>")) - (logical "e" "<em>" "Emphasized" ("<em>" (r "Text: ") "</em>")) - (logical "s" "<strong>" "Strong" ("<strong>" (r "Text: ") "</strong>")) - (logical "p" "<pre>" "Preformatted" ("<pre>" (r "Text: ") "</pre>")) - - ;;physical styles - (phys "-" "<strike>" "Strikethru" ("<strike>" (r "Text: ") "</strike>")) - (phys "u" "<u>" "Underline" ("<u>" (r "Text: ") "</u>")) - (phys "o" "<i>" "Italic" ("<i>" (r "Text: ") "</i>")) - (phys "b" "<b>" "Bold" ("<b>" (r "Text: ") "</b>")) - (phys "t" "<tt>" "Fixed" ("<tt>" (r "Text: ") "</tt>")) - - ;;headers - (header "6" "<h6>" "Header 6" ("<h6>" (r "Header: ") "</h6>")) - (header "5" "<h5>" "Header 5" ("<h5>" (r "Header: ") "</h5>")) - (header "4" "<h4>" "Header 4" ("<h4>" (r "Header: ") "</h4>")) - (header "3" "<h3>" "Header 3" ("<h3>" (r "Header: ") "</h3>")) - (header "2" "<h2>" "Header 2" ("<h2>" (r "Header: ") "</h2>")) - (header "1" "<h1>" "Header 1" ("<h1>" (r "Header: ") "</h1>")) - - ;; forms - (form "o" "<option>" "Option" (& "<option>" > )) - (form "v" "<option value" "Option with Value" (& "<option value=\"" (r "Value: ") "\">" >)) - (form "s" "<select" "Selections" ("<select name=\"" (p "Name: ") "\">\n<option>" > "\n</select>")"<select") - (form "z" "<input" "Reset Form" ("<input type=\"RESET\" value=\"" (p "Reset button text: ") "\">")) - (form "b" "<input" "Submit Form" ("<input type=\"SUBMIT\" value=\"" (p "Submit button text: ") "\">")) - (form "i" "<input" "Image Field" ("<input type=\"IMAGE\" name=\"" (p "Name: ") "\" src=\"" (p "Image URL: ") "\">")) - (form "h" "<input" "Hidden Field" ("<input type=\"HIDDEN\" name=\"" (p "Name: ") "\" value=\"" (p "Value: ") "\">")) - (form "p" "<textarea" "Text Area" ("<textarea name=\"" (p "Name: ") "\" rows=\"" (p "Rows: ") "\" cols=\"" (p "Columns: ") "\">" r "</textarea>")) - (form "c" "<input" "Checkbox" ("<input type=\"CHECKBOX\" name=\"" (p "Name: ") "\">")) - (form "r" "<input" "Radiobutton" ("<input type=\"RADIO\" name=\"" (p "Name: ") "\">")) - (form "t" "<input" "Text Field" ("<input type=\"TEXT\" name=\"" (p "Name: ") "\" size=\"" (p "Size: ") "\">")) - (form "f" "<form" "Form" ("<form action=\"" (p "Action: ") "\" method=\"" (p "Method: ") "\">\n</form>\n")) - - ;;lists - (list "t" "<dt>" "Definition Item" (& "<dt>" > (p "Term: ") "\n<dd>" > (r "Definition: "))) - (list "l" "<li>" "List Item" (& "<li>" > (r "Item: "))) - (list "r" "<dir>" "DirectoryList" (& "<dir>" > "\n<li>" > (r "Item: ") "\n</dir>" >)) - (list "m" "<menu>" "Menu List" (& "<menu>" > "\n<li>" > (r "Item: ") "\n</menu>" >)) - (list "o" "<ol>" "Ordered List" (& "<ol>" > "\n<li>" > (r "Item: ") "\n</ol>" >)) - (list "d" "<dl>" "Definition List" (& "<dl>" > "\n<dt>" > (p "Term: ") "\n<dd>" > (r "Definition: ") "\n</dl>" >)) - (list "u" "<ul>" "Unordered List" (& "<ul>" > "\n<li>" > (r "Item: ") "\n</ul>" >)) - - ;;anchors - (anchor "n" "<a name=" "Link Target" ("<a name=\"" (p "Anchor name: ") "\">" (r "Anchor text: ") "</a>")) - (anchor "h" "<a href=" "Hyperlink" ("<a href=\"" (p "URL: ") "\">" (r "Anchor text: ") "</a>")) - - ;;graphics - (image "a" nil "Aligned Image" ("<img align=\"" (r "Alignment: ") "\" src=\"" (r "Image URL: ") "\">")) - (image "i" "<img src=" "Image" ("<img src=\"" (r "Image URL: ") "\">")) - (image "e" "<img align=" "Aligned Image With Alt. Text" ("<img align=\"" (r "Alignment: ") "\" src=\"" (r "Image URL: ") "\" alt=\"" (r "Text URL: ") "\">")) - (image "t" "<img alt=" "Image With Alternate Text" ("<img alt=\"" (r "Text URL: ") "\" src=\"" (r "Image URL: ") "\">")) - - ;;text elements - (textel "\C-c=" nil "Horizontal Line" (& "<hr>\n")) - (textel "\C-c\C-m" nil "Line Break" ("<br>\n")) - (textel "\e\C-m" nil "Paragraph" ("<p>" (progn (sgml-indent-line) nil) "\n")) - - ;;head elements - (head "H" "<head>" "Head" ("<head>\n" "</head>\n")) - (head "B" "<body>" "Body" ("<body>\n" "</body>\n")) - (head "i" "<isindex>" "Isindex" ("<isindex>\n")) - (head "n" "<nextid>" "Nextid" ("<nextid>\n")) - (head "h" "<meta http-equiv=" "HTTP Equivalent" ("<meta http-equiv=\"" (p "Equivalent: ") "\" content=\"" (r "Content: ") "\">\n")) - (head "m" "<meta name=" "Meta Name" ("<meta name=\"" (p "Name: ") "\" content=\"" (r "Content: ") "\">\n")) - (head "l" "<link" "Link" ("<link href=\"" p "\">")) - (head "b" "<base" "Base" ("<base href=\"" r "\">")) - (head "t" "<title>" "Title" ("<title>" (r "Document title: ") "</title>")) - )) - -;;}}} -;;{{{ html-helper-smart-insert-item - -;; there are two different kinds of items in HTML - those in regular -;; lists <li> and those in dictionaries <dt>..<dd> -;; This command will insert the appropriate one depending on context. - -(defun html-helper-smart-insert-item (&optional arg) - "Insert a new item, either in a regular list or a dictionary." - (interactive "*P") - (let ((case-fold-search t)) - (if - (save-excursion - (re-search-backward "<li>\\|<dt>\\|<ul>\\|<ol>\\|<dd>\\|<menu>\\|<dir>\\|<dl>" nil t) - (looking-at "<dt>\\|<dl>\\|<dd>")) - (tempo-template-html-definition-item arg) - (tempo-template-html-list-item arg)))) - -;; special keybindings in the prefix maps (not in the list of tags) -(and (boundp 'html-helper-base-map) - (define-key html-helper-base-map "i" 'html-helper-smart-insert-item)) - -(define-key html-mode-map "\C-z\C-z" 'suspend-or-iconify-emacs) -(define-key html-mode-map "\C-zg" 'html-insert-mailto-reference-from-click) - -;; and, special menu bindings -(and (boundp 'html-helper-list-menu) - (setq html-helper-list-menu - (cons '["List Item" html-helper-smart-insert-item t] html-helper-list-menu))) - -;;}}} -;;{{{ patterns for font-lock - -; Old patterns from html-mode.el -;(defvar html-font-lock-keywords -; (list -; '("\\(<[^>]*>\\)+" . font-lock-comment-face) -; '("[Hh][Rr][Ee][Ff]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t) -; '("[Ss][Rr][Cc]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t)) -; "Patterns to highlight in HTML buffers.") - -;; By Ulrik Dickow <dickow@nbi.dk>. -;; -;; Originally aimed at Emacs 19.29. Later on disabled syntactic fontification -;; and reordered regexps completely, to be compatible with XEmacs (it doesn't -;; understand OVERRIDE=`keep'). -;; -;; We make an effort on handling nested tags intelligently. - -;; font-lock compatibility with XEmacs/Lucid and older Emacsen (<19.29). -;; -(if (string-match "XEmacs\\|Lucid" (emacs-version)) - ;; XEmacs/Lucid - ;; Make needed faces if the user hasn't already done so. - ;; Respect X resources (`make-face' uses them when they exist). - (let ((change-it - (function (lambda (face) - (or (if (fboundp 'facep) - (facep face) - (memq face (face-list))) - (make-face face)) - (not (face-differs-from-default-p face)))))) - (if (funcall change-it 'html-helper-bold-face) - (copy-face 'bold 'html-helper-bold-face)) - (if (funcall change-it 'html-helper-italic-face) - (copy-face 'italic 'html-helper-italic-face)) - (if (funcall change-it 'html-helper-underline-face) - (set-face-underline-p 'html-helper-underline-face t)) - (if (funcall change-it 'font-lock-variable-name-face) - (set-face-foreground 'font-lock-variable-name-face "salmon")) - (if (funcall change-it 'font-lock-reference-face) - (set-face-foreground 'font-lock-reference-face "violet"))) - ;; Emacs (any version) - ;; - ;; Note that Emacs evaluates the face entries in `font-lock-keywords', - ;; while XEmacs doesn't. So XEmacs doesn't use the following *variables*, - ;; but instead the faces with the same names as the variables. - (defvar html-helper-bold-face 'bold - "Face used as bold. Typically `bold'.") - (defvar html-helper-italic-face 'italic - "Face used as italic. Typically `italic'.") - (defvar html-helper-underline-face 'underline - "Face used as underline. Typically `underline'.") - ;; - (if (string-lessp "19.28.89" emacs-version) - () ; Emacs 19.29 and later - ;; Emacs 19.28 and older - ;; Define face variables that don't exist until Emacs 19.29. - (defvar font-lock-variable-name-face 'font-lock-doc-string-face - "Face to use for variable names -- and some HTML keywords.") - (defvar font-lock-reference-face 'underline ; Ugly at line breaks - "Face to use for references -- including HTML hyperlink texts."))) - -(defvar html-font-lock-keywords - (let (;; Titles and H1's, like function defs. - ;; We allow for HTML 3.0 attributes, like `<h1 align=center>'. - (tword "\\(h1\\|title\\)\\([ \t\n]+[^>]+\\)?") - ;; Names of tags to boldify. - (bword "\\(b\\|h[2-4]\\|strong\\)\\([ \t\n]+[^>]+\\)?") - ;; Names of tags to italify. - (iword "\\(address\\|cite\\|em\\|i\\|var\\)\\([ \t\n]+[^>]+\\)?") - ;; Regexp to match shortest sequence that surely isn't a bold end. - ;; We simplify a bit by extending "</strong>" to "</str.*". - ;; Do similarly for non-italic and non-title ends. - (not-bend (concat "\\([^<]\\|<\\([^/]\\|/\\([^bhs]\\|" - "b[^>]\\|" - "h\\([^2-4]\\|[2-4][^>]\\)\\|" - "s\\([^t]\\|t[^r]\\)\\)\\)\\)")) - (not-iend (concat "\\([^<]\\|<\\([^/]\\|/\\([^aceiv]\\|" - "a\\([^d]\\|d[^d]\\)\\|" - "c\\([^i]\\|i[^t]\\)\\|" - "e\\([^m]\\|m[^>]\\)\\|" - "i[^>]\\|" - "v\\([^a]\\|a[^r]\\)\\)\\)\\)")) - (not-tend (concat "\\([^<]\\|<\\([^/]\\|/\\([^ht]\\|" - "h[^1]\\|t\\([^i]\\|i[^t]\\)\\)\\)\\)"))) - (list ; Avoid use of `keep', since XEmacs will treat it the same as `t'. - ;; First fontify the text of a HREF anchor. It may be overridden later. - ;; Anchors in headings will be made bold, for instance. - '("<a\\s-+href[^>]*>\\([^>]+\\)</a>" - 1 font-lock-reference-face t) - ;; Tag pairs like <b>...</b> etc. - ;; Cunning repeated fontification to handle common cases of overlap. - ;; Bold complex --- possibly with arbitrary other non-bold stuff inside. - (list (concat "<" bword ">\\(" not-bend "*\\)</\\1>") - 3 'html-helper-bold-face t) - ;; Italic complex --- possibly with arbitrary non-italic kept inside. - (list (concat "<" iword ">\\(" not-iend "*\\)</\\1>") - 3 'html-helper-italic-face t) - ;; Bold simple --- first fontify bold regions with no tags inside. - (list (concat "<" bword ">\\(" "[^<]" "*\\)</\\1>") - 3 'html-helper-bold-face t) - ;; Any tag, general rule, just after bold/italic stuff. - '("\\(<[^>]*>\\)" 1 font-lock-type-face t) - ;; Titles and level 1 headings (anchors do sometimes appear in h1's) - (list (concat "<" tword ">\\(" not-tend "*\\)</\\1>") - 3 'font-lock-function-name-face t) - ;; Underline is rarely used. Only handle it when no tags inside. - '("<u>\\([^<]*\\)</u>" 1 html-helper-underline-face t) - ;; Forms, anchors & images (also fontify strings inside) - '("\\(<\\(form\\|i\\(mg\\|nput\\)\\)\\>[^>]*>\\)" - 1 font-lock-variable-name-face t) - '("</a>" 0 font-lock-keyword-face t) - '("\\(<a\\b[^>]*>\\)" 1 font-lock-keyword-face t) - '("=[ \t\n]*\\(\"[^\"]+\"\\)" 1 font-lock-string-face t) - ;; Large-scale structure keywords (like "program" in Fortran). - ;; "<html>" "</html>" "<body>" "</body>" "<head>" "</head>" "</form>" - '("</?\\(body\\|form\\|h\\(ead\\|tml\\)\\)>" - 0 font-lock-variable-name-face t) - ;; HTML special characters - '("&[^;\n]*;" 0 font-lock-string-face t) - ;; SGML things like <!DOCTYPE ...> with possible <!ENTITY...> inside. - '("\\(<![a-z]+\\>[^<>]*\\(<[^>]*>[^<>]*\\)*>\\)" - 1 font-lock-comment-face t) - ;; Comments: <!-- ... -->. They traditionally override anything else. - ;; It's complicated 'cause we won't allow "-->" inside a comment, and - ;; font-lock colours the *longest* possible match of the regexp. - '("\\(<!--\\([^-]\\|-[^-]\\|--[^>]\\)*-->\\)" - 1 font-lock-comment-face t))) - "Additional expressions to highlight in HTML mode.") - -(put 'html-mode 'font-lock-defaults '(html-font-lock-keywords)) -(put 'html3-mode 'font-lock-defaults '(html-font-lock-keywords)) - -;;}}} - -;;{{{ patterns for hilit19 - -;; Define some useful highlighting patterns for the hilit19 package. -;; These will activate only if hilit19 has already been loaded. -;; Thanks to <dickow@nbi.dk> for some pattern suggestions - -(if (featurep 'hilit19) - (hilit-set-mode-patterns - 'html-helper-mode - '(("<!--" "-->" comment) - ("<![a-z]+\\>[^<>]*\\(<[^>]*>[^<>]*\\)*>" nil comment) ;<!DOCTYPE ...> - ("<title>" "</title>" defun) - ("<h[1-6]>" "</h[1-6]>" bold) ;only colour inside tag - ("<a\\b" ">" define) - ("</a>" nil define) - ("<img\\b" ">" include) - ("<option\\|</?select\\|<input\\|</?form\\|</?textarea" ">" include) - ;; First <i> highlighting just handles unnested tags, then do nesting - ("<i>[^<]*</i>" nil italic) - ("<b>" "</b>" bold) - ("<i>" "</i>" italic) - ("<u>" "</u>" underline) - ("&[^;\n]*;" nil string) - ("<" ">" keyword)) - nil 'case-insensitive) - nil) - -;;}}} - -;;{{{ timestamps - -(defun html-helper-update-timestamp () - "Basic function for updating timestamps. -It finds the timestamp in the buffer by looking for -`html-helper-timestamp-start', deletes all text up to -`html-helper-timestamp-end', and runs `html-helper-timestamp-hook' which -will should insert an appropriate timestamp in the buffer." - (save-excursion - (goto-char (point-max)) - (if (not (search-backward html-helper-timestamp-start nil t)) - (message "timestamp delimiter start was not found") - (let ((ts-start (+ (point) (length html-helper-timestamp-start))) - (ts-end (if (search-forward html-helper-timestamp-end nil t) - (- (point) (length html-helper-timestamp-end)) - nil))) - (if (not ts-end) - (message "timestamp delimiter end was not found. Type C-c C-t to insert one.") - (delete-region ts-start ts-end) - (goto-char ts-start) - (run-hooks 'html-helper-timestamp-hook))))) - nil) - -(defun html-helper-return-created-string () - "Return a \"Created:\" string." - (let ((time (current-time-string))) - (concat "<!-- Created: " - (substring time 0 20) - (nth 1 (current-time-zone)) - " " - (substring time -4) - " -->\n"))) - -(defun html-helper-default-insert-timestamp () - "Default timestamp insertion function." - (let ((time (current-time-string))) - (insert "Last modified: " - (substring time 0 20) - (nth 1 (current-time-zone)) - " " - (substring time -4) - "\n"))) - -(defun html-helper-insert-timestamp-delimiter-at-point () - "Simple function that inserts timestamp delimiters at point. -Useful for adding timestamps to existing buffers." - (interactive) - (insert html-helper-timestamp-start) - (insert html-helper-timestamp-end)) - -;;}}} - -(defun mail-address-at-point (pos &optional buffer) - "Return a list (NAME ADDRESS) of the address at POS in BUFFER." - (or buffer (setq buffer (current-buffer))) - (let (beg end) - (save-excursion - (set-buffer buffer) - (save-excursion - (goto-char pos) - (or (re-search-forward "[\n,]" nil t) - (error "Can't find address at position")) - (backward-char) - (setq end (point)) - (or (re-search-backward "[\n,:]" nil t) - (error "Can't find address at position")) - (forward-char) - (re-search-forward "[ \t]*" nil t) - (setq beg (point)) - (mail-extract-address-components (buffer-substring beg end)))))) - -(defun html-insert-mailto-reference-from-click () - "Insert a mailto: reference for the clicked-on e-mail address." - (interactive) - (let (event) - (message "Click on a mail address:") - (save-excursion - (setq event (next-command-event)) - (or (mouse-event-p event) - (error "Aborted."))) - (let ((lis (mail-address-at-point (event-closest-point event) - (event-buffer event)))) - (insert "<a href=\"mailto:" (car (cdr lis)) "\">" - (or (car lis) (car (cdr lis))) "</a>")))) - -(defun html-quote-region (begin end) - "\"Quote\" any characters in the region that have special HTML meanings. -This converts <'s, >'s, and &'s into the HTML commands necessary to -get those characters to appear literally in the output." - (interactive "r") - (save-excursion - (goto-char begin) - (while (search-forward "&" end t) - (forward-char -1) - (delete-char 1) - (insert "&") - (setq end (+ 4 end))) - (goto-char begin) - (while (search-forward "<" end t) - (forward-char -1) - (delete-char 1) - (insert "<") - (setq end (+ 3 end))) - (goto-char begin) - (while (search-forward ">" end t) - (forward-char -1) - (delete-char 1) - (insert ">") - (setq end (+ 3 end))))) - -;;{{{ html-helper-insert-new-buffer-strings - -(tempo-define-template "html-skeleton" html-helper-new-buffer-template - nil - "Insert a skeleton for a HTML document") - -(defun html-helper-insert-new-buffer-strings () - "Insert `html-helper-new-buffer-strings'." - (tempo-template-html-skeleton)) - -;;}}} - -;;;###autoload -(autoload 'html-mode "psgml-html" "HTML mode." t) - -;;;###autoload -(autoload 'html3-mode "psgml-html" "HTML3 mode." t) - -(defvar sgml-html-menu - (cons "HTML" - (append '(["View in Netscape" sgml-html-netscape-file - (buffer-file-name - (current-buffer))] - ["View in W3" w3-preview-this-buffer t] - "---" - ["HTML-Quote Region" html-quote-region t] - "---") - (cdr sgml-main-menu)))) - -(defun sgml-html-netscape-file () - "Preview the file for the current buffer in Netscape." - (interactive) - (highlight-headers-follow-url-netscape - (concat "file:" (buffer-file-name (current-buffer))))) - -(define-derived-mode html3-mode html-mode "HTML3" - (setq sgml-declaration (expand-file-name "html3.decl" - sgml-data-directory) - sgml-default-doctype-name "html-3" - sgml-shortag nil )) -
--- a/lisp/psgml/psgml-info.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,413 +0,0 @@ -;;;; psgml-info.el -;;; Last edited: Wed Mar 20 21:24:16 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin) -;;; $Id: psgml-info.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $ - -;; Copyright (C) 1994, 1995 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> - -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; This file is an addon to the PSGML package. - -;; This file contains some commands to print out information about the -;; current DTD. - -;; sgml-list-elements -;; Will list all elements and the attributes declared for the element. - -;; sgml-list-attributes -;; Will list all attributes declared and the elements that use them. - -;; sgml-list-terminals -;; Will list all elements that can contain data. - -;; sgml-list-occur-in-elements -;; Will list all element types and where it can occur. - -;; sgml-list-content-elements -;; Will list all element types and the element types that can occur -;; in its content. - -;;;; Code: - -(require 'psgml) -(require 'psgml-parse) - -(defconst sgml-attr-col 18) - - -;;;; Utility functions - -(defsubst sgml-add-to-table (row-index elem table) - (let ((p (assoc row-index table))) - (cond ((null p) - (cons (list row-index elem) table)) - (t - (nconc p (list elem)) - table)))) - -(defsubst sgml-add-last-unique (x l) - (unless (memq x l) - (nconc l (list x)))) - -(defun sgml-map-element-types (func) - (sgml-need-dtd) - (sgml-map-eltypes func - (sgml-pstate-dtd sgml-buffer-parse-state) - t)) - -(defun sgml-eltype-refrenced-elements (eltype) - "List of element types referenced in the model of ELTYPE." - ;; Now with cache. Uses appdata prop re-cache. - (or - (sgml-eltype-appdata eltype 're-cache) - (let* ((res ; result list (eltypes) - nil) - (states ; list of states - (list (sgml-eltype-model eltype))) - (agenda ; point into states - states)) - (cond - ((not (sgml-model-group-p (car states))) - nil) - (t - (while agenda - (cond - ((sgml-normal-state-p (car agenda)) - (loop for m in (append (sgml-state-opts (car agenda)) - (sgml-state-reqs (car agenda))) - do - (pushnew (sgml-move-token m) res) - (sgml-add-last-unique (sgml-move-dest m) states))) - - (t ; &-node - (sgml-add-last-unique (sgml-and-node-next (car agenda)) states) - (loop for dfa in (sgml-and-node-dfas (car agenda)) do - (sgml-add-last-unique dfa states)))) - (setq agenda (cdr agenda))) - (setq res (sort (set-difference - (union res (sgml-eltype-includes eltype)) - (sgml-eltype-excludes eltype)) - (function string-lessp))) - (setf (sgml-eltype-appdata eltype 're-cache) res) - res))))) - - -;;;; List elements - -(defun sgml-list-elements () - "List the elements and their attributes in the current DTD." - (interactive) - (message "Creating table...") - (sgml-display-table - (sgml-map-element-types - (function - (lambda (eltype) - (cons (sgml-eltype-name eltype) - (mapcar (function sgml-attdecl-name) - (sgml-eltype-attlist eltype)))))) - "Elements" "Element" "Attribute")) - - -;;;; List attributes - -(defun sgml-list-attributes () - "List the attributes and in which elements they occur." - (interactive) - (let ((attributes nil)) - (message "Creating table...") - (sgml-map-element-types - (function - (lambda (eltype) - (loop for a in (sgml-eltype-attlist eltype) do - (setq attributes - (sgml-add-to-table (sgml-attdecl-name a) - (sgml-eltype-name eltype) - attributes)))))) - (sgml-display-table attributes - "Attributes" "Attribute" "Element"))) - - - - -;;;; List terminals - -(defun sgml-list-terminals () - "List the elements that can have data in their content." - (interactive) - (message "Creating table...") - (let ((data-models (list sgml-cdata sgml-rcdata sgml-any))) - (sgml-display-table - (delq nil - (sgml-map-element-types - (function - (lambda (eltype) - (if (or (sgml-eltype-mixed eltype) - (memq (sgml-eltype-model eltype) data-models)) - (list (sgml-eltype-name eltype) - (symbol-name - (if (sgml-model-group-p (sgml-eltype-model eltype)) - 'mixed - (sgml-eltype-model eltype))))))))) - "Terminals" "Element" "Content"))) - - -;;;; Element cross reference list - -(defun sgml-list-content-elements () - "List all element types and the element types that can occur in its content." - (interactive) - (message "Creating table...") - (sgml-display-table - (sgml-map-element-types - (function - (lambda (eltype) - (cons (sgml-eltype-name eltype) - (mapcar (function sgml-eltype-name) - (sgml-eltype-refrenced-elements eltype)))))) - "Elements refrenced by elements" - "Element" "Content")) - -(defun sgml-list-occur-in-elements () - "List all element types and where it can occur." - (interactive) - (message "Creating table...") - (let ((cross nil)) - (sgml-map-element-types - (function - (lambda (eltype) - (loop for ref in (sgml-eltype-refrenced-elements eltype) - do (setq cross (sgml-add-to-table ref - (sgml-eltype-name eltype) - cross)))))) - (sgml-display-table - cross - "Cross referenced element types" "Element" "Can occur in"))) - - -;;;; Display table - -(defun sgml-display-table (table title col-title1 col-title2 - &optional width nosort) - (or width - (setq width sgml-attr-col)) - (let ((buf (get-buffer-create (format "*%s*" title)))) - (message "Preparing display...") - (set-buffer buf) - (erase-buffer) - (insert col-title1) - (indent-to width) - (insert col-title2 "\n") - (insert-char ?= (length col-title1)) - (indent-to width) - (insert-char ?= (length col-title2)) - (insert "\n") - (unless nosort - (setq table (sort table (function (lambda (a b) - (string< (car a) (car b))))))) - (loop for e in table do - (insert (format "%s" (car e))) - (loop for name in (if nosort - (cdr e) - (sort (cdr e) (function string-lessp))) - do - (when (> (+ (length name) (current-column)) - fill-column) - (insert "\n")) - (when (< (current-column) sgml-attr-col) - (indent-to width)) - (insert name " ")) - (insert "\n")) - (goto-char (point-min)) - (display-buffer buf) - (message nil))) - - -;;;; Describe entity - -(defun sgml-describe-entity (name) - "Describe the properties of an entity as declared in the current DTD." - (interactive - (let (default input) - (sgml-need-dtd) - (save-excursion - (sgml-with-parser-syntax - (unless (sgml-parse-delim "ERO") - (skip-chars-backward "^&\"'= \t\n")) - (setq default (or (sgml-parse-name t) "")))) - (setq input (completing-read - (format "Entity name (%s): " default) - (sgml-entity-completion-table - (sgml-dtd-entities - (sgml-pstate-dtd sgml-buffer-parse-state))))) - (list - (if (equal "" input) default input)))) - - (with-output-to-temp-buffer "*Help*" - (let ((entity (sgml-lookup-entity name - (sgml-dtd-entities - (sgml-pstate-dtd - sgml-buffer-parse-state))))) - (or entity (error "Undefined entity")) - (princ (format "Entity %s is %s\n" - name - (cond ((null entity) - "undefined") - (t - (format "a %s entity" - (sgml-entity-type entity)))))) - (when entity - (let ((text (sgml-entity-text entity))) - (cond ((stringp text) - (princ "Defined to be:\n") - (princ text)) - (t - (princ "With external identifier ") - (princ (if (car text) "PUBLIC" "SYSTEM")) - (when (car text) - (princ (format " '%s'" (car text)))) - (when (cdr text) - (princ (format " '%s'" (cdr text))))))))))) - - - -;;;; Describe element type - -(defun sgml-describe-element-type (et-name) - "Describe the properties of an element type as declared in the current DTD." - (interactive - (let (default input) - (sgml-need-dtd) - (save-excursion - (sgml-with-parser-syntax - (unless (sgml-parse-delim "STAGO") - (skip-syntax-backward "w_")) - (setq default (sgml-parse-name)) - (unless (and default - (sgml-eltype-defined (sgml-lookup-eltype default))) - (setq default nil)))) - (setq input (sgml-read-element-type (if default - (format "Element type (%s): " - default) - "Element type: ") - sgml-dtd-info - default)) - - (list - (sgml-eltype-name input)))) - - (sgml-need-dtd) - (let ((et (sgml-lookup-eltype et-name))) - (with-output-to-temp-buffer "*Help*" - (princ (format "ELEMENT: %s\n\n" (sgml-eltype-name et))) - (princ (format " Start-tag is %s.\n End-tag is %s.\n" - (if (sgml-eltype-stag-optional et) - "optional" "required") - (if (sgml-eltype-etag-optional et) - "optional" "required"))) - (princ "\nATTRIBUTES:\n") - (loop for attdecl in (sgml-eltype-attlist et) do - (let ((name (sgml-attdecl-name attdecl)) - (dval (sgml-attdecl-declared-value attdecl)) - (defl (sgml-attdecl-default-value attdecl))) - (when (listp dval) - (setq dval (concat (if (eq (first dval) - 'notation) - "#NOTATION (" "(") - (mapconcat (function identity) - (second dval) - "|") - ")"))) - (cond ((sgml-default-value-type-p 'fixed defl) - (setq defl (format "#FIXED '%s'" - (sgml-default-value-attval defl)))) - ((symbolp defl) - (setq defl (upcase (format "#%s" defl)))) - (t - (setq defl (format "'%s'" - (sgml-default-value-attval defl))))) - (princ (format " %-9s %-30s %s\n" name dval defl)))) - ;; ---- - (let ((s (sgml-eltype-shortmap et))) - (when s - (princ (format "\nUSEMAP: %s\n" s)))) - ;; ---- - (princ "\nOCCURS IN:\n\n") - (let ((occurs-in ())) - (sgml-map-eltypes - (function (lambda (cand) - (when (memq et (sgml-eltype-refrenced-elements cand)) - (push cand occurs-in)))) - (sgml-pstate-dtd sgml-buffer-parse-state)) - - (loop with col = 0 - for occur-et in (sort occurs-in (function string-lessp)) - for name = (sgml-eltype-name occur-et) - do - (when (and (> col 0) (> (+ col (length name) 1) fill-column)) - (princ "\n") - (setq col 0)) - (princ " ") (princ name) - (incf col (length name)) - (incf col 1)))))) - - -;;;; Print general info about the DTD. - -(defun sgml-general-dtd-info () - "Display information about the current DTD." - (interactive) - (sgml-need-dtd) - (let ((elements 0) - (entities 0) - (parameters 0) - (fmt "%20s %s\n") - (hdr "") - ) - (sgml-map-eltypes (function (lambda (e) (incf elements))) - sgml-dtd-info) - (sgml-map-entities (function (lambda (e) (incf entities))) - (sgml-dtd-entities sgml-dtd-info)) - (sgml-map-entities (function (lambda (e) (incf parameters))) - (sgml-dtd-parameters sgml-dtd-info)) - - (with-output-to-temp-buffer "*Help*" - (princ (format fmt "Doctype:" (sgml-dtd-doctype sgml-dtd-info))) - (when (sgml-dtd-merged sgml-dtd-info) - (princ (format fmt "Compiled DTD:" - (car (sgml-dtd-merged sgml-dtd-info))))) - (princ (format fmt "Element types:" (format "%d" elements))) - (princ (format fmt "Entities:" (format "%d" entities))) - (princ (format fmt "Parameter entities:" (format "%d" parameters))) - - (setq hdr "Files used:") - (loop for x in (sgml-dtd-dependencies sgml-dtd-info) - if (stringp x) - do (princ (format fmt hdr x)) - (setq hdr "")) - - (setq hdr "Undef parameters:") - (sgml-map-entities - (function (lambda (entity) - (when (sgml-entity-marked-undefined-p entity) - (princ (format fmt hdr (sgml-entity-name entity))) - (setq hdr "")))) - (sgml-dtd-parameters sgml-dtd-info))))) - -;;; psgml-info.el ends here
--- a/lisp/psgml/psgml-other.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,183 +0,0 @@ -;;;; psgml-other.el --- Part of SGML-editing mode with parsing support -;; $Id: psgml-other.el,v 1.3 1997/03/08 23:26:53 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> - -;; -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;;; Part of psgml.el. Code not compatible with XEmacs. - - -;;;; Code: - -(require 'psgml) -(require 'easymenu) - -(defvar sgml-max-menu-size (/ (* (frame-height) 2) 3) - "*Max number of entries in Tags and Entities menus before they are split -into several panes.") - - -;;;; Key Commands - -;; Doesn't this work in Lucid? *** -(define-key sgml-mode-map [(meta control space)] 'sgml-mark-element) - -(define-key sgml-mode-map [(shift button-3)] 'sgml-tags-menu) - - -;;;; Pop Up Menus - -(defun sgml-popup-menu (event title entries) - "Display a popup menu. -ENTRIES is a list where every element has the form (STRING . VALUE) or -STRING." - (x-popup-menu - event - (let ((menus (list (cons title entries)))) - (cond - ((> (length entries) sgml-max-menu-size) - (setq menus - (loop for i from 1 while entries - collect - (let ((submenu - (subseq entries 0 (min (length entries) - sgml-max-menu-size)))) - (setq entries (nthcdr sgml-max-menu-size entries)) - (cons - (format "%s '%s'-'%s'" - title - (sgml-range-indicator (caar submenu)) - (sgml-range-indicator (caar (last submenu)))) - submenu)))))) - (cons title menus)))) - -(defun sgml-range-indicator (string) - (substring string - 0 - (min (length string) sgml-range-indicator-max-length))) - -(defun sgml-popup-multi-menu (event title menus) - "Display a popup menu. -MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...). -ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated -if the item is selected." - (nconc menus '(("---" "---"))) ; Force x-popup-menu to use two level - ; menu even if there is only one entry - ; on the first level - (eval (car (x-popup-menu event (cons title menus))))) - - -;;;; Insert with properties - -(defvar sgml-write-protect-intagible - (not (boundp 'emacs-minor-version))) - -(defun sgml-insert (props format &rest args) - (let ((start (point))) - (insert (apply (function format) - format - args)) - (when (and sgml-write-protect-intagible - (getf props 'intangible)) - (setf (getf props 'read-only) t)) - (add-text-properties start (point) props))) - - -;;;; Set face of markup - -(defvar sgml-use-text-properties nil) - -(defun sgml-set-face-for (start end type) - (let ((face (cdr (assq type sgml-markup-faces)))) - (cond - (sgml-use-text-properties - (let ((inhibit-read-only t) - (after-change-function nil) ; obsolete variable - (before-change-function nil) ; obsolete variable - (after-change-functions nil) - (before-change-functions nil)) - (put-text-property start end 'face face))) - (t - (let ((current (overlays-at start)) - (pos start) - old-overlay) - (while current - (cond ((and (null old-overlay) - (eq type (overlay-get (car current) 'sgml-type))) - (setq old-overlay (car current))) - ((overlay-get (car current) 'sgml-type) - (message "delov: %s" (overlay-get (car current) 'sgml-type)) - (delete-overlay (car current)))) - (setq current (cdr current))) - (while (< (setq pos (next-overlay-change pos)) - end) - (setq current (overlays-at pos)) - (while current - (when (overlay-get (car current) 'sgml-type) - (delete-overlay (car current))) - (setq current (cdr current)))) - (cond (old-overlay - (move-overlay old-overlay start end) - (if (null (overlay-get old-overlay 'face)) - (overlay-put old-overlay 'face face))) - (face - (setq old-overlay (make-overlay start end)) - (overlay-put old-overlay 'sgml-type type) - (overlay-put old-overlay 'face face)))))))) - -(defun sgml-set-face-after-change (start end &optional pre-len) - ;; If inserting in front of an markup overlay, move that overlay. - ;; this avoids the overlay being deleted and recreated by - ;; sgml-set-face-for. - (when (and sgml-set-face (not sgml-use-text-properties)) - (loop for o in (overlays-at start) - do (cond - ((not (overlay-get o 'sgml-type))) - ((= start (overlay-start o)) - (move-overlay o end (overlay-end o))))))) - -(defun sgml-fix-overlay-after-change (overlay flag start end &optional size) - (message "sfix(%s): %d-%d (%s)" flag start end size) - (overlay-put overlay 'front-nonsticky t) - (when nil - (move-overlay overlay end (overlay-end overlay)))) - -(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el - -(defun sgml-clear-faces () - (interactive) - (loop for o being the overlays - if (overlay-get o 'sgml-type) - do (delete-overlay o))) - - -;;;; Emacs before 19.29 - -(unless (fboundp 'buffer-substring-no-properties) - (defalias 'buffer-substring-no-properties 'buffer-substring)) - - -;;;; Provide - -(provide 'psgml-other) - -;;; psgml-other.el ends here
--- a/lisp/psgml/psgml-parse.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4273 +0,0 @@ -;;;; psgml-parse.el --- Parser for SGML-editing mode with parsing support -;; $Id: psgml-parse.el,v 1.8 1997/09/27 16:57:47 steve Exp $ - -;; Copyright (C) 1994, 1995 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> -;; Acknowledgment: -;; The catalog parsing code was contributed by -;; David Megginson <dmeggins@aix1.uottawa.CA> - -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;; Part of major mode for editing the SGML document-markup language. - - -;;;; Code: - -(require 'psgml) - -;;; Interface to psgml-dtd -(eval-and-compile - (autoload 'sgml-do-usemap-element "psgml-dtd") - (autoload 'sgml-write-dtd "psgml-dtd") - (autoload 'sgml-check-dtd-subset "psgml-dtd") - ) - - -;;;; Advise to do-auto-fill - -(defvar sgml-auto-fill-inhibit-function nil - "If non-nil, it should be a function of no arguments. -The functions is evaluated before the standard auto-fill function, -do-auto-fill, tries to fill a line. If the function returns a true -value the auto-fill is inhibited.") - -;;(defadvice do-auto-fill (around disable-auto-fill-hook activate) -;; (or (and sgml-auto-fill-inhibit-function -;; (funcall sgml-auto-fill-inhibit-function)) -;; ad-do-it)) - - -;;;; Variables - -;;; Hooks - -(defvar sgml-open-element-hook nil - "The hook run by `sgml-open-element'. -Theses functions are called with two arguments, the first argument is -the opened element and the second argument is the attribute specification -list. It is probably best not to refer to the content or the end-tag of -the element.") - -(defvar sgml-close-element-hook nil - "The hook run by `sgml-close-element'. -These functions are invoked with `sgml-current-tree' bound to the -element just parsed.") - -(defvar sgml-doctype-parsed-hook nil - "This hook is caled after the doctype has been parsed. -It can be used to load any additional information into the DTD structure.") - -(defvar sgml-sysid-resolve-functions nil - "This variable should contain a list of functions. -Each function should take one argument, the system identifier of an entity. -If the function can handle that identifier, it should insert the text -of the entity into the current buffer at point and return t. If the -system identifier is not handled the function should return nil.") - -;;; Internal variables - -(defconst sgml-pcdata-token (intern "#PCDATA")) - -(defvar sgml-computed-map nil - "Internal representation of entity search map.") - -(defvar sgml-used-entity-map nil - "The value of `sgml-current-entity-map' used to compute the map in -`sgml-compute-map'.") - -(defvar sgml-last-element nil - "Used to keep information about position in element structure between -commands.") - -(defconst sgml-users-of-last-element - '(sgml-beginning-of-element - sgml-end-of-element - sgml-up-element - sgml-backward-up-element - sgml-backward-element - sgml-forward-element - sgml-down-element - sgml-show-context - sgml-next-data-field - ) - "List of commands that set the sgml-last-element variable.") - -(defvar sgml-parser-syntax nil - "Syntax table used during parsing.") - -(defvar sgml-ecat-assoc nil - "Assoc list caching parsed ecats.") - -(defvar sgml-catalog-assoc nil - "Assoc list caching parsed catalogs.") - - -;;; Variables dynamically bound to affect parsing - -(defvar sgml-throw-on-warning nil - "Set to a symbol other than nil to make sgml-log-warning throw to that symbol.") - -(defvar sgml-throw-on-error nil - "Set to a symbol other than nil to make sgml-error throw to that symbol.") - -(defvar sgml-show-warnings nil - "Set to t to show warnings.") - -(defvar sgml-close-element-trap nil - "Can be nil for no trap, an element or t for any element. -Tested by sgml-close-element to see if the parse should be ended.") - -(defvar sgml-goal 0 - "Point in buffer to parse up to.") - -(defvar sgml-shortref-handler (function sgml-handle-shortref) - "Function called by parser to handle a short reference. -Called with the entity as argument. The start and end of the -short reference is `sgml-markup-start' and point.") - -(defvar sgml-data-function nil - "Function called with parsed data.") - -(defvar sgml-entity-function nil - "Function called with entity referenced at current point in parse.") - -(defvar sgml-pi-function nil - "Function called with parsed process instruction.") - -(defvar sgml-signal-data-function nil - "Called when some data characters are conceptually parsed, -e.g. a data entity reference.") - -(defvar sgml-throw-on-element-change nil - "Throw tag.") - -;;; Global variables active during parsing - -(defvar sgml-parsing-dtd nil - "This variable is bound to `t' while parsing a DTD (subset).") - -(defvar sgml-rs-ignore-pos nil - "Set to position of last parsing start in current buffer.") -(make-variable-buffer-local 'sgml-rs-ignore-pos) - -(defvar sgml-dtd-info nil - "Holds the `sgml-dtd' structure describing the current DTD.") - -(defvar sgml-current-omittag nil - "Value of `sgml-omittag' in main buffer. Valid during parsing.") - -(defvar sgml-current-shorttag nil - "Value of `sgml-shorttag' in main buffer. Valid during parsing.") - -(defvar sgml-current-localcat nil - "Value of `sgml-local-catalogs' in main buffer. Valid during parsing.") - -(defvar sgml-current-local-ecat nil - "Value of `sgml-local-ecat-files' in main buffer. Valid during parsing.") - -(defvar sgml-current-top-buffer nil - "The buffer of the document entity, the main buffer. -Valid during parsing. This is used to find current directory for -catalogs.") - -(defvar sgml-current-state nil - "Current state in content model or model type if CDATA, RCDATA or ANY.") - -(defvar sgml-current-shortmap nil - "The current active short reference map.") - -(defvar sgml-current-tree nil - "Current parse tree node, identifies open element.") - -(defvar sgml-previous-tree nil - "Previous tree node in current tree. -This is nil if no previous node.") - -(defvar sgml-markup-type nil -"Contains the type of markup parsed last. -The value is a symbol: -nil - pcdata or space -CDATA - CDATA or RCDATA -comment - comment declaration -doctype - doctype declaration -end-tag -ignored - ignored marked section -ms-end - marked section start, if not ignored -ms-start - marked section end, if not ignored -pi - processing instruction -sgml - SGML declaration -start-tag -entity - general entity reference -param - parameter reference -shortref- short reference -mdecl - markup declaration -") - -(defvar sgml-top-tree nil - "Root node of parse tree during parsing.") - -(defvar sgml-markup-tree nil - "Tree node of markup parsed. -In case markup closed element this is different from sgml-current-tree. -Only valid after `sgml-parse-to'.") - -(defvar sgml-markup-start nil - "Start point of markup being parsed.") - -(defvar sgml-conref-flag nil - "This variable is set by `sgml-parse-attribute-specification-list' -if a CONREF attribute is parsed.") - -(defvar sgml-no-elements nil - "Number of declared elements.") - -;;; Vars used in *param* buffers - -(defvar sgml-previous-buffer nil) - -(defvar sgml-current-eref nil - "This is the entity reference used to enter current entity. -If this is nil, then current entity is main buffer.") - -(defvar sgml-scratch-buffer nil - "The global value of this variable is the first scratch buffer for -entities. The entity buffers can have a buffer local value for this variable -to point to the next scratch buffer.") - -(defvar sgml-last-entity-buffer nil) - -;;; For loading DTD - -(eval-and-compile - (defconst sgml-max-single-octet-number 250 - "Octets greater than this is the first of a two octet coding.")) - -(defvar sgml-read-token-vector nil) ; Vector of symbols used to decode - ; token numbers. -(defvar sgml-read-nodes nil) ; Vector of nodes used when reading - ; a finite automaton. - -;; Buffer local variables - -(defvar sgml-loaded-dtd nil - "File name corresponding to current DTD.") -(make-variable-buffer-local 'sgml-loaded-dtd) - -(defvar sgml-current-element-name nil - "Name of current element for mode line display.") - - -;;;; Build parser syntax table - -(setq sgml-parser-syntax (make-syntax-table)) - -(let ((i 0)) - (while (< i 256) - (modify-syntax-entry i " " sgml-parser-syntax) - (setq i (1+ i)))) - -(mapconcat (function (lambda (c) - (modify-syntax-entry c "w" sgml-parser-syntax))) - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrtsuvwxyz" "") -(mapconcat (function (lambda (c) - (modify-syntax-entry c "_" sgml-parser-syntax))) - "-.0123456789" "") -(mapconcat (function (lambda (c) - (modify-syntax-entry c "." sgml-parser-syntax))) - "</>&%#[]" ".") - -;;(progn (set-syntax-table sgml-parser-syntax) (describe-syntax)) - - -(defmacro sgml-with-parser-syntax (&rest body) - (` (let ((normal-syntax-table (syntax-table))) - (set-syntax-table sgml-parser-syntax) - (unwind-protect - (progn (,@ body)) - (set-syntax-table normal-syntax-table))))) - - -;;;; State machine - -;; From the parsers POV a state is a mapping from tokens (in sgml it -;; is primitive state tokens) to states. The pairs of the mapping is -;; called moves. - -;; DFAs are always represented by the start state, which is a -;; normal state. Normal states contain moves of two types: -;; 1. moves for required tokens, 2. moves for optional tokens. -;; By design these are keept in two different sets. -;; [Alt: they could perhaps have been keept in one set but -;; marked in different ways.] - -;; The and-model groups creates too big state machines, therefor -;; there is a datastruture called and-node. - -;; A and-node is a specification for a dfa that has not been computed. -;; It contains a set of dfas that all have to be traversed befor going -;; to the next state. The and-nodes are only stored in moves and are -;; not seen by the parser. When a move is taken the and-node is converted -;; to a and-state. - -;; A and-state keeps track of which dfas still need to be -;; traversed and the state of the current dfa. - -;; move = <token, node> - -;; node = normal-state | and-node - -;; and-node = <dfas, next> -;; where: dfas is a set of normal-state -;; next is a normal-state - -;; State = normal-state | and-state -;; The parser only knows about the state type. - -;; normal-state = <opts, reqs> -;; where: opts is a set of moves for optional tokens -;; reqs is a set of moves for required tokens - -;; and-state = <substate, dfas, next> -;; where: substate is a normal-state -;; dfas is a set of states -;; next is the next state - -;; The and-state is only used during the parsing. -;; Primitiv functions to get data from parse state need -;; to know both normal-state and and-state. - - -;;; Representations: - -;;move: (token . node) - -(defmacro sgml-make-move (token node) - (` (cons (, token) (, node)))) - -(defmacro sgml-move-token (x) - (` (car (, x)))) - -(defmacro sgml-move-dest (x) - (` (cdr (, x)))) - -;; set of moves: list of moves - -(defmacro sgml-add-move-to-set (token node set) - (`(cons (cons (, token) (, node)) (, set)))) - -(defmacro sgml-moves-lookup (token set) - (` (assq (, token) (, set)))) - -;; normal-state: ('normal-state opts . reqs) - -(defsubst sgml-make-state () - (cons 'normal-state (cons nil nil))) - -(defmacro sgml-normal-state-p (s) - (` (eq (car (, s)) 'normal-state))) - -(defmacro sgml-state-opts (s) - (` (cadr (, s)))) - -(defmacro sgml-state-reqs (s) - (` (cddr (, s)))) - -(defmacro sgml-state-final-p (s) - (`(null (sgml-state-reqs (, s))))) - -;; adding moves -;; *** Should these functions check for ambiguity? -;; What if adding a optional move for a token that has a -;; required move? -;; What about the other way? - -(defsubst sgml-add-opt-move (s token dest) - (or (sgml-moves-lookup token (sgml-state-opts s)) - (setf (sgml-state-opts s) - (sgml-add-move-to-set token dest (sgml-state-opts s))))) - -(defsubst sgml-add-req-move (s token dest) - (or (sgml-moves-lookup token (sgml-state-reqs s)) - (setf (sgml-state-reqs s) - (sgml-add-move-to-set token dest (sgml-state-reqs s))))) - -(defsubst sgml-make-primitive-content-token (token) - (let ((s1 (sgml-make-state)) - (s2 (sgml-make-state))) - (sgml-add-req-move s1 token s2) - s1)) - -;;and-state: (state next . dfas) - -(defsubst sgml-make-and-state (state dfas next) - (cons state (cons next dfas))) - -(defsubst sgml-step-and-state (state and-state) - (cons state (cdr and-state))) - -(defsubst sgml-and-state-substate (s) - (car s)) - -(defsubst sgml-and-state-dfas (s) - (cddr s)) - -(defsubst sgml-and-state-next (s) - (cadr s)) - - -;;and-node: (next . dfas) - -(defsubst sgml-make-and-node (dfas next) - (cons next dfas)) - -(defmacro sgml-and-node-next (n) - (` (car (, n)))) - -(defmacro sgml-and-node-dfas (n) - (` (cdr (, n)))) - - -;;; Using states - -(defsubst sgml-final (state) - (if (sgml-normal-state-p state) - (sgml-state-final-p state) - (sgml-final-and state))) - -(defun sgml-final-and (state) - (and (sgml-final (sgml-and-state-substate state)) - (loop for s in (sgml-and-state-dfas state) - always (sgml-state-final-p s)) - (sgml-state-final-p (sgml-and-state-next state)))) - -;; get-move: State x Token --> State|nil - -(defsubst sgml-get-move (state token) - "Return a new state or nil, after traversing TOKEN from STATE." - (cond - ((sgml-normal-state-p state) - (let ((c (or (sgml-moves-lookup token (sgml-state-opts state)) - (sgml-moves-lookup token (sgml-state-reqs state))))) - (if c - (let ((dest (sgml-move-dest c))) - (if (sgml-normal-state-p dest) - dest - ;; dest is a and-node - (sgml-next-sub-and (sgml-and-node-dfas dest) - token - (sgml-and-node-next dest))))))) - (t ;state is a and-state - (sgml-get-and-move state token)))) - -(defun sgml-get-and-move (state token) - ;; state is a and-state - (let ((m (sgml-get-move (sgml-and-state-substate state) token))) - (cond (m (cons m (cdr state))) - ((sgml-final (sgml-and-state-substate state)) - (sgml-next-sub-and (sgml-and-state-dfas state) - token - (sgml-and-state-next state)))))) - -(defun sgml-next-sub-and (dfas token next) - "Compute the next state, choosing from DFAS and moving by TOKEN. -If this is not possible, but all DFAS are final, move by TOKEN in NEXT." - (let ((allfinal t) - (l dfas) - (res nil) - s1 s2) - (while (and l (not res)) - (setq s1 (car l) - allfinal (and allfinal (sgml-state-final-p s1)) - s2 (sgml-get-move s1 token) - res (and s2 (sgml-make-and-state s2 (remq s1 dfas) next)) - l (cdr l))) - (cond (res) - (allfinal (sgml-get-move next token))))) - -(defsubst sgml-tokens-of-moves (moves) - (mapcar (function (lambda (m) (sgml-move-token m))) - moves)) - -(defun sgml-required-tokens (state) - (if (sgml-normal-state-p state) - (sgml-tokens-of-moves (sgml-state-reqs state)) - (or (sgml-required-tokens (sgml-and-state-substate state)) - (loop for s in (sgml-and-state-dfas state) - nconc (sgml-tokens-of-moves (sgml-state-reqs s))) - (sgml-tokens-of-moves (sgml-state-reqs (sgml-and-state-next state)))))) - -(defun sgml-optional-tokens (state) - (if (sgml-normal-state-p state) - (sgml-tokens-of-moves (sgml-state-opts state)) - (nconc - (sgml-optional-tokens (sgml-and-state-substate state)) - (if (sgml-final (sgml-and-state-substate state)) - (loop for s in (sgml-and-state-dfas state) - nconc (sgml-tokens-of-moves (sgml-state-opts s)))) - (if (loop for s in (sgml-and-state-dfas state) - always (sgml-state-final-p s)) - (sgml-tokens-of-moves - (sgml-state-opts (sgml-and-state-next state))))))) - - -;;;; Attribute Types - -;;; Basic Types -;; name = string attribute names are lisp symbols -;; attval = string attribute values are lisp strings - -;;; Attribute Declaration Type -;; attdecl = <name, declared-value, default-value> - -;; This is the result of the ATTLIST declarations in the DTD. -;; All attribute declarations for an element is the elements -;; attlist. - -;;; Attribute Declaration Operations -;; sgml-make-attdecl: name declared-value default-value -> attdecl -;; sgml-attdecl-name: attdecl -> name -;; sgml-attdecl-declared-value: attdecl -> declared-value -;; sgml-attdecl-default-value: attdecl -> default-value - -;;; Attribute Declaration List Type -;; attlist = attdecl* - -;;; Attribute Declaration List Operations -;; sgml-lookup-attdecl: name x attlist -> attdecl - -;;; Declared Value Type -;; declared-value = (token-group | notation | simpel) -;; token-group = nametoken+ -;; notation = nametoken+ -;; simple = symbol lisp symbol corresponding to SGML type - -;;; Declared Value Operations -;; sgml-declared-value-token-group: declared-value -> list of symbols -;; sgml-declared-value-notation: declared-value -> list of symbols -;; (empty list if not token-group/notation) - -;;; Default Value Type -;; default-value = (required | implied | conref | specified ) -;; implied, conref = constant symbol -;; specified = (fixed | normal) -;; fixed, normal = attval - -;;; Default Value Operations -;; sgml-default-value-attval: default-value -> (attval | nil) -;; sgml-default-value-type-p: type x default-value -> cond - -;;; Attribute Specification Type -;; attspec = <name, attval> - -;; This is the result of parsing an attribute specification. - -;; sgml-make-attspec: name x attval -> attspec -;; sgml-attspec-name: attspec -> name -;; sgml-attspec-attval: attspec -> attval - - -;;; Attribute Specification List Type -;; asl = attspec* - -;; aka. attribute value list - - -;;; Code - -;;; attdecl representation = (name declared-value default-value) - -(defun sgml-make-attdecl (name dcl-value default-value) - (list name dcl-value default-value)) - -(defun sgml-attdecl-name (attdecl) - (car attdecl)) - -(defun sgml-attdecl-declared-value (attdecl) - "The declared value of ATTDECL. -It may be a symbol or (name-token-group (NAME1 ... NAMEn)) -or (notation (NOT1 ... NOTn))" - (cadr attdecl)) - -(defun sgml-attdecl-default-value (attdecl) - "The default value of ATTDECL. -The default value is either a symbol (required | implied | current | -conref) or a list with first element nil or symbol 'fixed' and second -element the value." - (caddr attdecl)) - - -;;; attlist representation = (attspec*) - -(defun sgml-lookup-attdecl (name attlist) - "Return the attribute declaration for NAME in ATTLIST." - (assoc name attlist)) - -(defun sgml-attribute-with-declared-value (attlist declared-value) - "Find the first attribute in ATTLIST that has DECLARED-VALUE." - (let ((found nil)) - (while (and attlist (not found)) - (when (equal declared-value - (sgml-attdecl-declared-value (car attlist))) - (setq found (car attlist))) - (setq attlist (cdr attlist))) - found)) - - -;;; declared-value representation -;; token-group = (name-token (symbol+)) -;; notation = (notation (symbol+)) -;; simple = symbol lisp symbol correspoinding to SGML type - -(defun sgml-make-declared-value (type &optional names) - "Make a declared-value of TYPE. -TYPE should be a symbol. If TYPE is name-token-group or notation -NAMES should be a list of symbols." - (if (consp names) - (list type names) - type)) - -(defun sgml-declared-value-token-group (declared-value) - "Return the name token group for the DECLARED-VALUE. -This applies to name token groups. For other declared values nil is -returned." - (and (consp declared-value) - (eq 'name-token-group (car declared-value)) - (cadr declared-value))) - -(defun sgml-declared-value-notation (declared-value) - "Return the list of notation names for the DECLARED-VALUE. -This applies to notation declared value. For other declared values -nil is returned." - (and (consp declared-value) - (eq 'notation (car declared-value)) - (cadr declared-value))) - -;;; default-value representation = symbol | ((nil | 'fixed) attval) - -(defun sgml-make-default-value (type &optional attval) - (if attval - (list type attval) - type)) - -(defun sgml-default-value-attval (default-value) - "Return the actual default value of the declared DEFAULT-VALUE. -The actual value is a string. Return nil if no actual value." - (and (consp default-value) - (cadr default-value))) - -(defun sgml-default-value-type-p (type default-value) - "Return true if DEFAULT-VALUE is of TYPE. -Where TYPE is a symbol, one of required, implied, conref, or fixed." - (or (eq type default-value) - (and (consp default-value) - (eq type (car default-value))))) - - -;;; attspec representation = (symbol . string) - -(defun sgml-make-attspec (name attval) - "Create an attspec from NAME and ATTVAL. -Special case, if ATTVAL is nil this is an implied attribute." - (cons name attval)) - -;; sgml-attspec-name: attspec -> name -(defun sgml-attspec-name (attspec) - (car attspec)) - -;; sgml-attspec-attval: attspec -> attval -(defun sgml-attspec-attval (attspec) - "Return the value of attribute specification ATTSPEC. -If ATTSPEC is nil, nil is returned." - (cdr attspec)) - -;;; asl representaion = (attspec*) - -(defun sgml-lookup-attspec (name asl) - (assoc name asl)) - - -;;;; Element content types - -;; The content of an element is defined as -;; (125 declared content | 126 content model), -;; 125 declared content = "CDATA" | "RCDATA" | "EMPTY" -;; 126 content model = (127 model group | "ANY"), -;; (65 ps+, 138 exceptions)? - -;; I represent a model group with the first state of a corresponding finite -;; automaton (this is a cons). Exceptions are handled separately. -;; The other content types are represented by symbols. - -(defsubst sgml-model-group-p (model) - (consp model)) - -(defconst sgml-cdata 'CDATA) -(defconst sgml-rcdata 'RCDATA) -(defconst sgml-empty 'EMPTY) -(defconst sgml-any 'ANY) - - -;;;; External identifier -;; extid = (pubid? sysid? dir) -;; Representation as (pubid sysid . dir) -;; where pubid = nil | string -;; sysid = nil | string -;; dir = string - -(defun sgml-make-extid (pubid sysid &optional dir) - (cons pubid (cons sysid (or dir default-directory)))) - -(defun sgml-extid-pubid (extid) - (car extid)) - -(defun sgml-extid-sysid (extid) - (if (consp (cdr extid)) - (cadr extid) - (cdr extid))) - -(defun sgml-extid-dir (extid) - "Directory where EXTID was declared" - (if (consp (cdr extid)) - (cddr extid) - nil)) - -(defun sgml-extid-expand (file extid) - "Expand file name FILE in the context of EXTID." - (expand-file-name file (sgml-extid-dir extid))) - -;;;; DTD - -;; DTD = (doctype, eltypes, parameters, entities, shortmaps, -;; notations, dependencies, merged) -;; DTDsubset ~=~ DTD, but doctype is unused -;; -;; doctype = name -;; eltypes = oblist -;; parameters = entity* -;; entities = entity* -;; shortmaps = (name, shortmap)* -;; dependencies = file* -;; merged = Compiled-DTD? where Compiled-DTD = (file, DTD) - -(defstruct (sgml-dtd - (:type vector) - (:constructor sgml-make-dtd (doctype))) - doctype ; STRING, name of doctype - (eltypes ; OBLIST, element types defined - (sgml-make-eltype-table)) - (parameters ; ALIST - (sgml-make-entity-table)) - (entities ; ALIST - (sgml-make-entity-table)) - (shortmaps ; ALIST - (sgml-make-shortref-table)) - (notations ; ?? - nil) - (dependencies ; LIST - nil) - (merged ; (file . DTD) - nil) - (undef-entities ; LIST of entity names - nil)) - - -;;;; Element type objects - -;; An element type object contains the information about an element type -;; obtained from parsing the DTD. - -;; An element type object is represented by a symbol in a special oblist. -;; A table of element type objects is represented by a oblist. - - -;;; Element type objects - -(defun sgml-eltype-name (et) - (symbol-name et)) - -(define-compiler-macro sgml-eltype-name (et) - (`(symbol-name (, et)))) - -(defun sgml-eltype-defined (et) - (fboundp et)) - -(defun sgml-eltype-token (et) - "Return a token for the element type" - et) - -(define-compiler-macro sgml-eltype-token (et) - et) - -(defun sgml-token-eltype (token) - "Return the element type corresponding to TOKEN." - token) - -(define-compiler-macro sgml-token-eltype (token) - token) - -(defmacro sgml-prop-fields (&rest names) - (cons - 'progn - (loop for n in names collect - (`(defmacro (, (intern (format "sgml-eltype-%s" n))) (et) - (list 'get et ''(, n))))))) - -(sgml-prop-fields - ;;flags ; optional tags and mixed - ; (perhaps in value field) - ;;model ; Content type - ; (perhaps in function field) - attlist ; List of defined attributes - includes ; List of included elements - excludes ; List of excluded elements - shortmap ; Associated shortref map - ; nil if none and 'empty if #empty - ) - -(defmacro sgml-eltype-flags (et) - (` (symbol-value (, et)))) - -(defun sgml-eltype-model (et) - (if (fboundp et) - (symbol-function et) - sgml-any)) - -(defsetf sgml-eltype-model fset) - - -(defun sgml-eltype-stag-optional (et) - (oddp (sgml-eltype-flags et))) - -(defun sgml-eltype-etag-optional (et) - (/= 0 (logand 2 (sgml-eltype-flags et)))) - -(defun sgml-eltype-mixed (et) - (< 3 (sgml-eltype-flags et))) -(define-compiler-macro sgml-eltype-mixed (et) - (`(< 3 (sgml-eltype-flags (, et))))) - -(defsetf sgml-eltype-stag-optional (et) (f) - (list 'sgml-set-eltype-flag et 1 f)) -(defsetf sgml-eltype-etag-optional (et) (f) - (list 'sgml-set-eltype-flag et 2 f)) -(defsetf sgml-eltype-mixed (et) (f) - (list 'sgml-set-eltype-flag et 4 f)) - -(defun sgml-set-eltype-flag (et mask f) - (setf (sgml-eltype-flags et) - (logior (logand (if (boundp et) - (sgml-eltype-flags et) - 0) - (lognot mask)) - (if f mask 0)))) - -(defun sgml-maybe-put (sym prop val) - (when val (put sym prop val))) - -(defsetf sgml-eltype-includes (et) (l) - (list 'sgml-maybe-put et ''includes l)) - -(defsetf sgml-eltype-excludes (et) (l) - (list 'sgml-maybe-put et ''excludes l)) - -(defmacro sgml-eltype-appdata (et prop) - "Get application data from element type ET with name PROP. -PROP should be a symbol, reserved names are: flags, model, attlist, -includes, excludes, conref-regexp, mixed, stag-optional, etag-optional." - (` (get (, et) (, prop)))) - -(defun sgml-eltype-all-miscdata (et) - (loop for p on (symbol-plist et) by (function cddr) - unless (memq (car p) '(model flags includes excludes)) - nconc (list (car p) (cadr p)))) - -(defun sgml-eltype-set-all-miscdata (et miscdata) - (setf (symbol-plist et) - (nconc (symbol-plist et) miscdata))) - -(defun sgml-make-eltype (name) - (let ((et (make-symbol name))) - (setf (sgml-eltype-flags et) 0) - et)) - - -;;; Element type tables - -(defun sgml-make-eltype-table () - "Make an empty table of element types." - (make-vector 73 0)) - -(defun sgml-eltype-table-empty (eltype-table) - (loop for x across eltype-table always (eq x 0))) - -(defun sgml-merge-eltypes (eltypes1 eltypes2) - "Return the merge of two element type tables ELTYPES1 and ELTYPES2. -This may change ELTYPES1, ELTYPES2 is unchanged. Returns the new table." - (if (sgml-eltype-table-empty eltypes1) - eltypes2 - (progn - (mapatoms - (function (lambda (sym) - (let ((et (intern (symbol-name sym) eltypes1))) - (unless (fboundp et) ; not yet defined by <!element - (when (fboundp sym) - (fset et (symbol-function sym))) - (when (boundp sym) - (set et (symbol-value sym)))) - (setf (symbol-plist et) - (nconc (symbol-plist et) - (copy-list (symbol-plist sym))))))) - eltypes2) - eltypes1))) - -(defun sgml-lookup-eltype (name &optional dtd) - "Lookup the element defintion for NAME (string)." - (intern name (sgml-dtd-eltypes (or dtd sgml-dtd-info)))) - -(defun sgml-eltype-completion-table (eltypes) - "Make a completion table from a list, ELTYPES, of element types." - (loop for et in eltypes as name = (sgml-eltype-name et) - if (boundp et) - collect (cons name name))) - -(defun sgml-read-element-type (prompt dtd &optional default) - "Read an element type name. -PROMPT is displayed as a prompt and DTD should be the dtd to get the -element types from. Optional argument DEFAULT (string) will be used as -a default for the element type name." - (let ((name - (completing-read prompt - (sgml-dtd-eltypes dtd) - (function fboundp) - t - nil - nil))) - (when (equal name "") - (setq name (or default (error "Aborted")))) - (sgml-lookup-eltype name dtd))) - -(defun sgml-map-eltypes (fn dtd &optional collect all) - (let ((*res* nil)) - (mapatoms - (cond ((and collect all) - (function (lambda (a) (push (funcall fn a) *res*)))) - (collect - (function (lambda (a) (when (boundp a) - (push (funcall fn a) *res*))))) - (all - (function (lambda (a) (funcall fn a)))) - (t - (function (lambda (a) (when (boundp a) (funcall fn a)))))) - (sgml-dtd-eltypes dtd)) - (nreverse *res*))) - -;;;; Load a saved dtd - -;;; Wing addition -(defmacro sgml-char-int (ch) - (if (fboundp 'char-int) - (` (char-int (, ch))) - ch)) - -(defsubst sgml-read-octet () - ;; Wing change - (prog1 (sgml-char-int (following-char)) - (forward-char))) - -(defsubst sgml-read-number () - "Read a number. -A number is 1: an octet [0--sgml-max-singel-octet-number] -or 2: two octets (n,m) interpreted as (n-t-1)*256+m+t." - (if (> (following-char) sgml-max-single-octet-number) - (+ (* (- (following-char) (eval-when-compile - (1+ sgml-max-single-octet-number))) - 256) - (prog1 (char-after (1+ (point))) - (forward-char 2)) - sgml-max-single-octet-number) - (sgml-read-octet))) - -(defsubst sgml-read-peek () - (char-after (point))) - -(defun sgml-read-sexp () - (prog1 - (let ((standard-input (current-buffer))) - (read)) - (skip-chars-forward " \t") - (forward-char 1))) - -(defsubst sgml-read-token () - (aref sgml-read-token-vector (sgml-read-number))) - -(defsubst sgml-read-node-ref () - (aref sgml-read-nodes (sgml-read-octet))) - -(defun sgml-read-model-seq () - (loop repeat (sgml-read-number) collect (sgml-read-model))) - -(defun sgml-read-token-seq () - (loop repeat (sgml-read-number) collect (sgml-read-token))) - -(defun sgml-read-moves () - (loop repeat (sgml-read-number) - collect (sgml-make-move (sgml-read-token) (sgml-read-node-ref)))) - -(defun sgml-read-model () - (let* ((n (sgml-read-number)) - (sgml-read-nodes (make-vector n nil))) - (loop for i below n do (aset sgml-read-nodes i (sgml-make-state))) - (loop for e across sgml-read-nodes do - (cond ((eq ?\377 (sgml-read-peek)) ; a and-node - (sgml-read-octet) ; skip - (setf (sgml-and-node-next e) (sgml-read-node-ref)) - (setf (sgml-and-node-dfas e) (sgml-read-model-seq))) - (t ; a normal-state - (setf (sgml-state-opts e) (sgml-read-moves)) - (setf (sgml-state-reqs e) (sgml-read-moves))))) - (aref sgml-read-nodes 0))) - -(defun sgml-read-content () - (let ((c (sgml-read-octet))) - (cond ((eq c 0) sgml-cdata) - ((eq c 1) sgml-rcdata) - ((eq c 2) sgml-empty) - ((eq c 3) sgml-any) - ((eq c 4) nil) - ((eq c 128) - (sgml-read-model))))) - -(defun sgml-read-decode-flag (flag mask) - (not (zerop (logand flag mask)))) - -(defun sgml-read-element (et) - (sgml-eltype-set-all-miscdata et (sgml-read-sexp)) - (let ((flags (sgml-read-octet))) - (unless (= flags 128) - (setf (sgml-eltype-flags et) flags - (sgml-eltype-model et) (sgml-read-content) - (sgml-eltype-includes et) (sgml-read-token-seq) - (sgml-eltype-excludes et) (sgml-read-token-seq))))) - -(defun sgml-read-dtd () - "Decode the saved DTD in current buffer, return the DTD." - (let ((gc-cons-threshold (max gc-cons-threshold 500000)) - temp dtd) - (setq temp (sgml-read-sexp)) ; file-version - (cond - ((equal temp '(sgml-saved-dtd-version 5)) - ;; Doctype -- create dtd structure - (setq dtd (sgml-make-dtd (sgml-read-sexp))) - ;; Element type names -- read and create token vector - (setq temp (sgml-read-number)) ; # eltypes - (setq sgml-read-token-vector (make-vector (1+ temp) nil)) - (aset sgml-read-token-vector 0 sgml-pcdata-token) - (loop for i from 1 to temp do - (aset sgml-read-token-vector i - (sgml-lookup-eltype (sgml-read-sexp) dtd))) - ;; Element type descriptions - (loop for i from 1 to (sgml-read-number) do - (sgml-read-element (aref sgml-read-token-vector i))) - (setf (sgml-dtd-parameters dtd) (sgml-read-sexp)) - (setf (sgml-dtd-entities dtd) (sgml-read-sexp)) - (setf (sgml-dtd-shortmaps dtd) (sgml-read-sexp)) - (setf (sgml-dtd-notations dtd) (sgml-read-sexp)) - (setf (sgml-dtd-dependencies dtd) (sgml-read-sexp))) - ;; New version - ((equal temp '(sgml-saved-dtd-version 6)) - (setq dtd (sgml-bdtd-read-dtd))) - ;; Something else - (t - (error "Unknown file format for saved DTD: %s" temp))) - dtd)) - -(defun sgml-load-dtd (file) - "Load a saved DTD from FILE." - (interactive - (let ((tem (expand-file-name - (or sgml-default-dtd-file - (sgml-default-dtd-file))))) - (list (read-file-name "Load DTD from: " - (file-name-directory tem) - tem - t - (file-name-nondirectory tem))))) - (setq sgml-loaded-dtd nil) ; Allow reloading of DTD - ;; Search for 'file' on the sgml-system-path [ndw] - (let ((real-file (car (mapcan (function - (lambda (dir) - (let ((f (expand-file-name file dir))) - (if (file-exists-p f) - (list f))))) - (cons "." - ;; wing change -- add sgml-data-directory - (append sgml-system-path - (list sgml-data-directory))))))) - (or real-file - (error "Saved DTD file %s not found" file)) - (let ((cb (current-buffer)) - (tem nil) - (dtd nil) - (l (buffer-list)) - (find-file-type ; Allways binary - (function (lambda (fname) 1)))) - ;; Search loaded buffer for a already loaded DTD - (while (and l (null tem)) - (set-buffer (car l)) - (if (equal sgml-loaded-dtd real-file) - (setq tem (current-buffer))) - (setq l (cdr l))) - (cond - (tem ; loaded DTD found - (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state))) - (t ; load DTD from file - (set-buffer cb) - (sgml-push-to-entity real-file) - (message "Loading DTD from %s..." real-file) - (setq dtd (sgml-read-dtd)) - (message "Loading DTD from %s...done" real-file) - (sgml-pop-entity))) - (set-buffer cb) - (sgml-set-initial-state dtd) - (setq sgml-default-dtd-file file) - (setq sgml-loaded-dtd real-file)))) - -;;;; Biniary coded DTD module -;;; Works on the binary coded compiled DTD (bdtd) - -;;; bdtd-load: cfile dtdfile ents -> bdtd -;;; bdtd-merge: bdtd dtd -> dtd? -;;; bdtd-read-dtd: bdtd -> dtd - -;;; Implement by letting bdtd be implicitly the current buffer and -;;; dtd implicit in sgml-dtd-info. - -(defun sgml-bdtd-load (cfile dtdfile ents) - "Load the compiled dtd from CFILE into the current buffer. -If this file does not exists, is of an old version or out of date, a -new compiled dtd will be creted from file DTDFILE and parameter entity -settings in ENTS." - ;;(Assume the current buffer is a scratch buffer and is empty) - (sgml-debug "Trying to load compiled DTD from %s..." cfile) - (or (and (file-readable-p cfile) - (let ((find-file-type ; Allways binary - (function (lambda (fname) 1)))) - ;; fifth arg to insert-file-contents is not available in early - ;; v19. - (insert-file-contents cfile nil nil nil)) - (equal '(sgml-saved-dtd-version 6) (sgml-read-sexp)) - (or (sgml-up-to-date-p cfile (sgml-read-sexp)) - (if (eq 'ask sgml-recompile-out-of-date-cdtd) - (not (y-or-n-p - "Compiled DTD is out of date, recompile? ")) - (not sgml-recompile-out-of-date-cdtd)))) - (sgml-compile-dtd dtdfile cfile ents))) - -(defun sgml-up-to-date-p (file dependencies) - "Check if FILE is newer than all files in the list DEPENDENCIES. -If DEPENDENCIES contains the symbol `t', FILE is not considered newer." - (if (memq t dependencies) - nil - (loop for f in dependencies - always (file-newer-than-file-p file f)))) - -(defun sgml-compile-dtd (dtd-file to-file ents) - "Construct a binary code compiled dtd from DTD-FILE and write it to TO-FILE. -The dtd will be constructed with the parameter entities set according -to ENTS. The bdtd will be left in the current buffer. The current -buffer is assumend to be empty to start with." - (sgml-log-message "Recompiling DTD file %s..." dtd-file) - (let* ((sgml-dtd-info (sgml-make-dtd nil)) - (parameters (sgml-dtd-parameters sgml-dtd-info)) - (sgml-parsing-dtd t)) - (push dtd-file - (sgml-dtd-dependencies sgml-dtd-info)) - (loop for (name . val) in ents - do (sgml-entity-declare name parameters 'text val)) - (sgml-push-to-entity dtd-file) - (sgml-check-dtd-subset) - (sgml-pop-entity) - (erase-buffer) - ;; For XEmacs-20.0/Mule - (setq buffer-file-coding-system 'binary) - (sgml-write-dtd sgml-dtd-info to-file) - t)) - -(defun sgml-check-entities (params1 params2) - "Check that PARAMS1 is compatible with PARAMS2." - (block check-entities - (sgml-map-entities - (function (lambda (entity) - (let ((other - (sgml-lookup-entity (sgml-entity-name entity) - params2))) - (unless (or (null other) - (equal entity other)) - (sgml-log-message - "Parameter %s in complied DTD has wrong value;\ - is '%s' should be '%s'" - (sgml-entity-name entity) - (sgml-entity-text other) - (sgml-entity-text entity)) - (return-from check-entities nil))))) - params1) - t)) - -(defun sgml-bdtd-merge () - "Merge the binary coded dtd in the current buffer with the current dtd. -The current dtd is the variable sgml-dtd-info. Return t if mereged -was successfull or nil if failed." - (setq buffer-file-coding-system 'binary) - (goto-char (point-min)) - (sgml-read-sexp) ; skip filev - (let ((dependencies (sgml-read-sexp)) - (parameters (sgml-read-sexp)) - (gc-cons-threshold (max gc-cons-threshold 500000)) - temp) - ;; Check comaptibility of parameters - (and (sgml-check-entities (sgml-dtd-parameters sgml-dtd-info) - parameters) - (progn - ;; Do the merger - (sgml-message "Reading compiled DTD...") - (sgml-merge-entity-tables (sgml-dtd-parameters sgml-dtd-info) - parameters) - (setf (sgml-dtd-dependencies sgml-dtd-info) - (nconc (sgml-dtd-dependencies sgml-dtd-info) - dependencies)) - ;; Doctype - (setq temp (sgml-read-sexp)) - (when (and temp (null (sgml-dtd-doctype sgml-dtd-info))) - (setf (sgml-dtd-doctype sgml-dtd-info) temp)) - - ;; Element type names -- read and create token vector - (setq temp (sgml-read-number)) ; # eltypes - (setq sgml-read-token-vector (make-vector (1+ temp) nil)) - (aset sgml-read-token-vector 0 sgml-pcdata-token) - (loop for i from 1 to temp do - (aset sgml-read-token-vector i - (sgml-lookup-eltype (sgml-read-sexp)))) - ;; Element type descriptions - (loop for i from 1 to (sgml-read-number) do - (sgml-read-element (aref sgml-read-token-vector i))) - (sgml-merge-entity-tables (sgml-dtd-entities sgml-dtd-info) - (sgml-read-sexp)) - (sgml-merge-shortmaps (sgml-dtd-shortmaps sgml-dtd-info) - (sgml-read-sexp)) - (setf (sgml-dtd-notations sgml-dtd-info) (sgml-read-sexp)) - t)))) - -(defun sgml-bdtd-read-dtd () - "Create and return a dtd from the binary coded dtd in the current buffer." - (let ((sgml-dtd-info (sgml-make-dtd nil))) - (sgml-bdtd-merge) - sgml-dtd-info)) - -;;;; Set markup type - -(defsubst sgml-set-markup-type (type) - "Set the type of the markup parsed to TYPE. -The markup starts at position given by variable sgml-markup-start and -ends at point." - (when (and sgml-set-face - (null sgml-current-eref)) - (sgml-set-face-for sgml-markup-start (point) type)) - (setq sgml-markup-type type)) - - -;;;; Parsing delimiters - -(eval-and-compile - (defconst sgml-delimiters - '("AND" "&" - "COM" "--" - "CRO" "&#" - "DSC" "]" - "DSO" "[" - "DTGC" "]" - "DTGO" "[" - "ERO" "&" - "ETAGO" "</" - "GRPC" ")" - "GRPO" "(" - "LIT" "\"" - "LITA" "'" - "MDC" ">" - "MDO" "<!" - "MINUS" "-" - "MSC" "]]" - "NET" "/" - "OPT" "?" - "OR" "|" - "PERO" "%" - "PIC" ">" - "PIO" "<?" - "PLUS" "+" - "REFC" ";" - "REP" "*" - "RNI" "#" - "SEQ" "," - "STAGO" "<" - "TAGC" ">" - "VI" "=" - ;; Some combinations - "MS-START" "<![" ; MDO DSO - "MS-END" "]]>" ; MSC MDC - ;; Pseudo - "NULL" "" - ))) - - -(defmacro sgml-is-delim (delim &optional context move offset) - "Macro for matching delimiters. -Syntax: DELIM &optional CONTEXT MOVE -where DELIM is the delimiter name (string or symbol), -CONTEXT the contextual constraint, and -MOVE is `nil', `move' or `check'. - -Test if the text following point in current buffer matches the SGML -delimiter DELIM. Also check the characters after the delimiter for -CONTEXT. Applicable values for CONTEXT is -`gi' -- name start or TAGC if SHORTTAG YES, -`com' -- if COM or MDC, -`nmstart' -- name start character, -`stagc' -- TAGC if SHORTTAG YES, -`digit' -- any Digit, -string -- delimiter with that name, -list -- any of the contextual constraints in the list." - - (or offset (setq offset 0)) - (let ((ds (member (upcase (format "%s" delim)) - sgml-delimiters))) - (assert ds) - (setq delim (car ds) - ds (cadr ds)) - (cond ((eq context 'gi) - (setq context '(nmstart stagc))) - ((eq context 'com) - (setq context '("COM" "MDC"))) - ((null context) - (setq context '(t))) - ((not (listp context)) - (setq context (list context)))) - (`(if (and ; This and checks that characters - ; of the delimiter - (,@(loop for i from 0 below (length ds) collect - (` (eq (, (aref ds i)) - (sgml-following-char (, (+ i offset))))))) - (or - (,@(loop - for c in context collect ; context check - (cond - ((eq c 'nmstart) ; name start character - (`(sgml-startnm-char - (or (sgml-following-char (, (length ds))) 0)))) - ((eq c 'stagc) - (`(and sgml-current-shorttag - (sgml-is-delim "TAGC" nil nil (, (length ds)))))) - ((eq c 'digit) - (`(memq (sgml-following-char (, (length ds))) - '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))) - ((stringp c) - (`(sgml-is-delim (, c) nil nil (, (length ds))))) - ((eq c t)) - (t (error "Context type: %s" c)))) - ))) - - (progn ; Do operations if delimiter found - (,@ (if move (`((forward-char (, (length ds))))))) - (,@ (if (not (eq move 'check)) - '(t)))) - (,@ (if (eq move 'check) - (`((sgml-delimiter-parse-error (, delim)))))))))) - -(defmacro sgml-following-char (n) - (cond ((zerop n) '(following-char)) - ((= n 1) '(char-after (1+ (point)))) - (t (` (char-after (+ (, n) (point))))))) - -(defun sgml-delimiter-parse-error (delim) - (sgml-parse-error "Delimiter %s (%s) expected" - delim (cadr (member delim sgml-delimiters)))) - -(defmacro sgml-parse-delim (delim &optional context) - (`(sgml-is-delim (, delim) (, context) move))) - -(defmacro sgml-check-delim (delim &optional context) - (`(sgml-is-delim (, delim) (, context) check))) - -(defmacro sgml-skip-upto (delim) - "Skip until the delimiter or first char of one of the delimiters. -If DELIM is a string/symbol this is should be a delimiter role. -Characters are skipped until the delimiter is recognized. -If DELIM is a list of delimiters, skip until a character that is first -in any of them." - (cond - ((consp delim) - (list 'skip-chars-forward - (concat "^" - (loop for d in delim - concat (let ((ds (member (upcase (format "%s" d)) - sgml-delimiters))) - (assert ds) - (let ((s (substring (cadr ds) 0 1))) - (if (member s '("-" "\\")) - (concat "\\" s) - s))))))) - (t - (let ((ds (member (upcase (format "%s" delim)) - sgml-delimiters))) - (assert ds) - (setq ds (cadr ds)) - (if (= 1 (length ds)) - (list 'skip-chars-forward (concat "^" ds)) - (`(and (search-forward (, ds) nil t) - (backward-char (, (length ds)))))))))) - - -;;(macroexpand '(sgml-is-delim mdo)) -;;(macroexpand '(sgml-parse-delim mdo)) -;;(macroexpand '(sgml-check-delim mdo)) - - -;;;; General lexical functions -;;; Naming conventions -;;; sgml-parse-xx try to parse xx, return nil if can't else return -;;; some propriate non-nil value. -;;; Except: for name/nametoken parsing, return 0 if can't. -;;; sgml-check-xx require xx, report error if can't parse. Return -;;; aproporiate value. - -(defmacro sgml-parse-char (char) - (` (cond ((eq (, char) (following-char)) - (forward-char 1) - t)))) - -(defmacro sgml-parse-chars (char1 char2 &optional char3) - "Parse two or three chars; return nil if can't" - (if (null char3) - (` (cond ((and (eq (, char1) (char-after (point))) - (eq (, char2) (char-after (1+ (point))))) - (forward-char 2) - t))) - (` (cond ((and (eq (, char1) (char-after (point))) - (eq (, char2) (char-after (1+ (point)))) - (eq (, char3) (char-after (1+ (1+ (point)))))) - (forward-char 3) - t))))) - -(defun sgml-check-char (char) - (cond ((not (sgml-parse-char char)) - (sgml-parse-error "Expecting %c" char)))) - -(defun sgml-parse-RE () - (or (sgml-parse-char ?\n) - (sgml-parse-char ?\r))) - -(defmacro sgml-startnm-char (c) - (` (eq ?w (char-syntax (, c))))) - -(defun sgml-startnm-char-next () - (and (not (eobp)) - (sgml-startnm-char (following-char)))) - -(defun sgml-name-char (c) - (and c - (or (sgml-startnm-char c) - (eq ?_ (char-syntax c))))) - -(defun sgml-is-end-tag () - (sgml-is-delim "ETAGO" gi)) - -(defsubst sgml-is-enabled-net () - (and (sgml-is-delim "NET") - sgml-current-shorttag - (sgml-tree-net-enabled sgml-current-tree))) - -(defun sgml-is-start-tag () - (sgml-is-delim "STAGO" gi)) - -(defsubst sgml-parse-s (&optional shortmap) - (if shortmap - (or (/= 0 (skip-chars-forward " ")) - (/= 0 (skip-chars-forward "\t")) - (sgml-parse-char ?\n) - (sgml-parse-char ?\r)) - (/= 0 (skip-chars-forward " \t\n\r")))) - -(defsubst sgml-parse-processing-instruction () - (if (sgml-parse-delim "PIO") - (sgml-do-processing-instruction))) - -(defun sgml-do-processing-instruction () - (let ((start (point))) - (sgml-skip-upto "PIC") - (when sgml-pi-function - (funcall sgml-pi-function - (buffer-substring-no-properties start (point))))) - (sgml-check-delim "PIC") - (sgml-set-markup-type 'pi) - t) - - -(defmacro sgml-general-case (string) (`(downcase (, string)))) -(defmacro sgml-entity-case (string) string) - -(defun sgml-parse-name (&optional entity-name) - (if (sgml-startnm-char-next) - (let ((name (buffer-substring-no-properties - (point) - (progn (skip-syntax-forward "w_") - (point))))) - (if entity-name - (sgml-entity-case name) - (sgml-general-case name))))) - -(define-compiler-macro sgml-parse-name (&whole form &optional entity-name) - (cond - ((memq entity-name '(nil t)) - (` (if (sgml-startnm-char-next) - ((, (if entity-name 'sgml-entity-case 'sgml-general-case)) - (buffer-substring-no-properties (point) - (progn (skip-syntax-forward "w_") - (point))))))) - (t - form))) - -(defun sgml-check-name (&optional entity-name) - (or (sgml-parse-name entity-name) - (sgml-parse-error "Name expected"))) - -(define-compiler-macro sgml-check-name (&optional entity-name) - (`(or (, (if entity-name - (`(sgml-parse-name (, entity-name))) - '(sgml-parse-name))) - (sgml-parse-error "Name expected")))) - - -(defun sgml-parse-nametoken (&optional entity-name) - "Parses a name token and returns a string or nil if no nametoken." - (if (sgml-name-char (following-char)) - (let ((name (buffer-substring-no-properties - (point) - (progn (skip-syntax-forward "w_") - (point))))) - (if entity-name - (sgml-entity-case name) - (sgml-general-case name))))) - -(defun sgml-check-nametoken () - (or (sgml-parse-nametoken) - (sgml-parse-error "Name token expected"))) - -;;(defun sgml-gname-symbol (string) -;; "Convert a string to a general name/nametoken/numbertoken." -;; (intern (sgml-general-case string))) - -;;(defun sgml-ename-symbol (string) -;; "Convert a string to an entity name." -;; (intern (sgml-entity-case string))) - -(defsubst sgml-parse-general-entity-ref () - (if (sgml-parse-delim "ERO" nmstart) - (sgml-do-general-entity-ref))) - -(defun sgml-do-general-entity-ref () - (sgml-do-entity-ref - (prog1 (sgml-parse-name t) - (or (sgml-parse-delim "REFC") - (sgml-parse-RE)) - (sgml-set-markup-type 'entity))) - t) - -(defun sgml-do-entity-ref (name) - (let ((entity - (sgml-lookup-entity name - (sgml-dtd-entities sgml-dtd-info)))) - (cond ((and (null entity) - sgml-warn-about-undefined-entities) - (sgml-log-warning - "Undefined entity %s" name)) - ((sgml-entity-data-p entity) - (when sgml-signal-data-function - (funcall sgml-signal-data-function)) - (cond - (sgml-entity-function - (funcall sgml-entity-function entity)) - (sgml-data-function - (sgml-push-to-entity entity sgml-markup-start) - (funcall sgml-data-function (buffer-string)) - (sgml-pop-entity)))) - (t - (sgml-push-to-entity entity sgml-markup-start))))) - -(defsubst sgml-parse-parameter-entity-ref () - "Parse and push to a parameter entity, return nil if no ref here." - ;;(setq sgml-markup-start (point)) - (if (sgml-parse-delim "PERO" nmstart) - (sgml-do-parameter-entity-ref))) - -(defun sgml-do-parameter-entity-ref () - (let* ((name (sgml-parse-name t)) - (ent (sgml-lookup-entity name - (sgml-dtd-parameters sgml-dtd-info)))) - (or (sgml-parse-delim "REFC") - (sgml-parse-char ?\n)) - ;;(sgml-set-markup-type 'param) - (cond (ent - (sgml-push-to-entity ent sgml-markup-start 'param)) - (t - (sgml-log-warning - "Undefined parameter entity %s" name))) - t)) - -(defun sgml-parse-comment () - (if (sgml-parse-delim "COM") - (progn (sgml-skip-upto "COM") - (sgml-check-delim "COM") - t))) - -(defun sgml-skip-cs () - "Skip over the separator used in the catalog. -Return true if not at the end of the buffer." - (while (or (sgml-parse-s) - (sgml-parse-comment))) - (not (eobp))) - -(defsubst sgml-skip-ps () - "Move point forward stopping before a char that isn't a parameter separator." - (while - (or (sgml-parse-s) - (if (eobp) (sgml-pop-entity)) - (sgml-parse-parameter-entity-ref) - (sgml-parse-comment)))) - -(defsubst sgml-parse-ds () -;71 ds = 5 s | EE | 60+ parameter entity reference -; | 91 comment declaration -; | 44 processing instruction -; | 93 marked section declaration *** - (or (and (eobp) (sgml-pop-entity)) ;EE - (sgml-parse-s) ;5 s - ;;(sgml-parse-comment-declaration) ;91 comment declaration - (sgml-parse-parameter-entity-ref) - (sgml-parse-processing-instruction))) - -(defun sgml-skip-ds () - (while (sgml-parse-ds))) - -(defmacro sgml-parse-rni (&optional name) - "Parse a RNI (#) return nil if none; with optional NAME, -a RNI must be followed by NAME." - (cond - (name - (` (if (sgml-parse-delim "RNI") - (sgml-check-token (, name))))) - (t '(sgml-parse-delim "RNI")))) - -(defun sgml-check-token (name) - (or (equal (sgml-check-name) name) - (sgml-parse-error "Reserved name not expected"))) - -(defun sgml-parse-literal () - "Parse a literal and return a string, if no literal return nil." - (let (lita start value) - (cond ((or (sgml-parse-delim "LIT") - (setq lita (sgml-parse-delim "LITA"))) - (setq start (point)) - (if lita - (sgml-skip-upto "LITA") - (sgml-skip-upto "LIT")) - (setq value (buffer-substring-no-properties start (point))) - (if lita - (sgml-check-delim "LITA") - (sgml-check-delim "LIT")) - value)))) - -(defun sgml-check-literal () - (or (sgml-parse-literal) - (sgml-parse-error "A litteral expected"))) - -(defun sgml-parse-minimum-literal () - "Parse a quoted SGML string and return it, if no string return nil." - (cond - ((memq (following-char) '(?\" ?\')) - (let* ((qchar (following-char)) - (blanks " \t\r\n") - (qskip (format "^%s%c" blanks qchar)) - (start (point)) - (value ; accumulates the literal value - "") - (spaced "")) - (forward-char 1) - (skip-chars-forward blanks) - (while (not (sgml-parse-char qchar)) - (cond ((eobp) - (goto-char start) - (sgml-parse-error "Unterminated literal")) - ((sgml-parse-s) - (setq spaced " ")) - (t - (setq value - (concat value spaced - (buffer-substring-no-properties - (point) - (progn (skip-chars-forward qskip) - (point)))) - spaced "")))) - value)))) - -(defun sgml-check-minimum-literal () - (or (sgml-parse-minimum-literal) - (sgml-parse-error "A minimum literal expected"))) - -(defun sgml-parse-external () - "Leaves nil if no external id, or (pubid . sysid)" - (sgml-skip-ps) - (let* ((p (point)) - (token (sgml-parse-nametoken))) - (cond - (token - (sgml-skip-ps) - (cond ((member token '("public" "system")) - (let* ((pubid ; the public id - (if (string-equal token "public") - (or (sgml-parse-minimum-literal) - (sgml-parse-error "Public identifier expected")))) - (sysid ; the system id - (progn (sgml-skip-ps) - (sgml-parse-literal)))) - (sgml-make-extid pubid sysid))) - (t - (goto-char p) - nil)))))) - -(defun sgml-skip-tag () - (when (sgml-parse-char ?<) - (sgml-parse-char ?/) - (unless (search-forward-regexp - "\\([^\"'<>/]\\|\"[^\"]*\"\\|'[^']*'\\)*" - nil t) - (sgml-error "Invalid tag")) - (or (sgml-parse-char ?>) - (sgml-parse-char ?/)))) - - -;;;; Entity Manager - -(defstruct (sgml-entity - (:type list) - (:constructor sgml-make-entity (name type text))) - name ; Name of entity (string) - type ; Type of entity CDATA NDATA PI SDATA - text ; string or external - ) - -(defun sgml-entity-data-p (entity) - "True if ENTITY is a data entity, that is not a text entity." - (not (eq (sgml-entity-type entity) 'text))) - -(defun sgml-entity-marked-undefined-p (entity) - (cdddr entity)) - - -;;; Entity tables -;; Represented by a cons-cell whose car is the default entity (or nil) -;; and whose cdr is as an association list. - -(defun sgml-make-entity-table () - (list nil)) - -(defun sgml-lookup-entity (name entity-table) - (or (assoc name (cdr entity-table)) - (car entity-table))) - -(defun sgml-entity-declare (name entity-table type text) - "Declare an entity with name NAME in table ENTITY-TABLE. -TYPE should be the type of the entity (text|cdata|ndata|sdata...). -TEXT is the text of the entity, a string or an external identifier. -If NAME is nil, this defines the default entity." - (cond - (name - (unless (sgml-lookup-entity name entity-table) - (sgml-debug "Declare entity %s %s as %S" name type text) - (nconc entity-table - (list (sgml-make-entity name type text))))) - (t - (unless (car entity-table) - (sgml-debug "Declare default entity %s as %S" type text) - (setcar entity-table (sgml-make-entity name type text)))))) - -(defun sgml-entity-completion-table (entity-table) - "Make a completion table from the ENTITY-TABLE." - (cdr entity-table)) - -(defun sgml-map-entities (fn entity-table &optional collect) - (if collect - (mapcar fn (cdr entity-table)) - (loop for e in (cdr entity-table) do (funcall fn e)))) - -(defun sgml-merge-entity-tables (tab1 tab2) - "Merge entity table TAB2 into TAB1. TAB1 is modified." - (nconc tab1 (cdr tab2)) - (setcar tab1 (or (car tab1) (car tab2)))) - - -(defun sgml-entity-insert-text (entity &optional ptype) - "Insert the text of ENTITY. -PTYPE can be 'param if this is a parameter entity." - (let ((text (sgml-entity-text entity))) - (cond - ((stringp text) - (insert text)) - (t - (sgml-insert-external-entity text - (or ptype - (sgml-entity-type entity)) - (sgml-entity-name entity)))))) - -;;;; External identifyer resolve - -(defun sgml-cache-catalog (file cache-var parser-fun - &optional default-dir) - "Return parsed catalog. -FILE is the file containing the catalog. Maintains a cache of parsed -catalog files in variable CACHE-VAR. The parsing is done by function -PARSER-FUN that should parse the current buffer and return the parsed -repreaentation of the catalog." - (setq file (file-truename (expand-file-name file default-dir))) - (and - (file-readable-p file) - (let ((c (assoc file (symbol-value cache-var))) - (modtime (elt (file-attributes file) 5))) - (if (and c (equal (second c) modtime)) - (cddr c) - (when c (set cache-var (delq c (symbol-value cache-var)))) - (let (new) - (message "Loading %s ..." file) - (sgml-push-to-entity file) - (setq default-directory (file-name-directory file)) - (setq new (funcall parser-fun)) - (sgml-pop-entity) - (push (cons file (cons modtime new)) (symbol-value cache-var)) - (message "Loading %s ... done" file) - new))))) - -(defun sgml-main-directory () - "Directory of the document entity." - (let ((cb (current-buffer))) - (set-buffer sgml-current-top-buffer) - (prog1 default-directory - (set-buffer cb)))) - -(defun sgml-trace-lookup (&rest args) - "Log a message like `sgml-log-message', but only if `sgml-trace-entity-lookup' is set." - (when sgml-trace-entity-lookup - (apply (function sgml-log-message) args))) - - -(defun sgml-catalog-lookup (files pubid type name) - "Look up the public identifier/entity name in catalogs. -FILES is a list of catalogs to use. PUBID is the public identifier -\(if any). TYPE is the entity type and NAME is the entity name." - (cond ((eq type 'param) - (setq name (format "%%%s" name) - type 'entity)) - ((eq type 'dtd) - (setq type 'doctype))) - ;;(sgml-trace-lookup " [pubid='%s' type=%s name='%s']" pubid type name) - (loop - for f in files thereis - (let ((cat (sgml-cache-catalog f 'sgml-catalog-assoc - (function sgml-parse-catalog-buffer) - (sgml-main-directory)))) - (sgml-trace-lookup " catalog: %s %s" - (expand-file-name f (sgml-main-directory)) - (if (null cat) "empty/non existent" "exists")) - (or - ;; Giv PUBLIC entries priority over ENTITY and DOCTYPE - (if pubid - (loop for (key cname file) in cat - thereis (if (and (eq 'public key) - (string= pubid cname)) - (if (file-readable-p file) - (progn - (sgml-trace-lookup " >> %s [by pubid]" file) - file) - (progn - (sgml-trace-lookup " !unreadable %s" file) - nil))))) - (loop for (key cname file) in cat - ;;do (sgml-trace-lookup " %s %s" key cname) - thereis (if (and (eq type key) - (or (null cname) - (string= name cname))) - (if (file-readable-p file) - (progn - (sgml-trace-lookup " >> %s [by %s %s]" - file key cname) - file) - (progn - (sgml-trace-lookup " !unreadable %s" file) - nil)))))))) - -(defun sgml-path-lookup (extid type name) - (let* ((pubid (sgml-extid-pubid extid)) - (sysid (sgml-extid-sysid extid)) - (subst (list '(?% ?%)))) - (when pubid - (nconc subst (list (cons ?p (sgml-transliterate-file pubid))) - (sgml-pubid-parts pubid)) - (setq pubid (sgml-canonize-pubid pubid))) - (when sysid (nconc subst (list (cons ?s sysid)))) - (when name (nconc subst (list (cons ?n name)))) - (when type (nconc subst (list (cons ?y (cond ((eq type 'dtd) "dtd") - ((eq type 'text) "text") - ((eq type 'param) "parm") - (t "sgml")))))) - (sgml-debug "Ext. file subst. = %S" subst) - (loop for cand in sgml-public-map - thereis - (and (setq cand (sgml-subst-expand cand subst)) - (file-readable-p - (setq cand - (sgml-extid-expand (substitute-in-file-name cand) - extid))) - (not (file-directory-p cand)) - cand)))) - -(defun sgml-external-file (extid &optional type name) - "Return file name for entity with external identifier EXTID. -Optional argument TYPE should be the type of entity and NAME should be -the entity name." - ;; extid is (pubid . sysid) - (let ((pubid (sgml-extid-pubid extid))) - (when pubid (setq pubid (sgml-canonize-pubid pubid))) - (sgml-trace-lookup "Start looking for %s entity %s public %s system %s" - (or type "-") - (or name "?") - pubid - (sgml-extid-sysid extid)) - (or (if (and sgml-system-identifiers-are-preferred - (sgml-extid-sysid extid)) - (or (sgml-lookup-sysid-as-file extid) - (sgml-path-lookup ;Try the path also, but only using sysid - (sgml-make-extid nil (sgml-extid-sysid extid)) - nil nil))) - (sgml-catalog-lookup sgml-current-localcat pubid type name) - (sgml-catalog-lookup sgml-catalog-files pubid type name) - (if (not sgml-system-identifiers-are-preferred) - (sgml-lookup-sysid-as-file extid)) - (sgml-path-lookup extid type name)))) - -(defun sgml-lookup-sysid-as-file (extid) - (let ((sysid (sgml-extid-sysid extid))) - (and sysid - (loop for pat in sgml-public-map - never (string-match "%[Ss]" pat)) - (file-readable-p (setq sysid (sgml-extid-expand sysid extid))) - sysid))) - -(defun sgml-insert-external-entity (extid &optional type name) - "Insert the contents of an external entity at point. -EXTID is the external identifier of the entity. Optional arguments TYPE -is the entity type and NAME is the entity name, used to find the entity. -Returns nil if entity is not found." - (let* ((pubid (sgml-extid-pubid extid)) - (sysid (sgml-extid-sysid extid))) - (or (if sysid - (loop for fn in sgml-sysid-resolve-functions - thereis (funcall fn sysid))) - (let ((file (sgml-external-file extid type name))) - (and file (insert-file-contents file))) - (progn - (sgml-log-warning "External entity %s not found" name) - (when pubid - (sgml-log-warning " Public identifier %s" pubid)) - (when sysid - (sgml-log-warning " System identfier %s" sysid)) - nil)))) - - -;; Parse a buffer full of catalogue entries. -(defun sgml-parse-catalog-buffer () - "Parse all entries in a catalogue." - (sgml-trace-lookup " (Parsing catalog)") - (loop - while (sgml-skip-cs) - for type = (downcase (sgml-check-cat-literal)) - for class = (cdr (assoc type '(("public" . public) ("dtddecl" . public) - ("entity" . name) ("linktype" . name) - ("doctype" . name) ("sgmldecl" . noname) - ("document" . noname)))) - when (not (null class)) - collect - (let* ((name - (cond ((eq class 'public) - (sgml-skip-cs) - (sgml-canonize-pubid (sgml-check-minimum-literal))) - ((string= type "doctype") - (sgml-general-case (sgml-check-cat-literal))) - ((eq class 'name) - (sgml-entity-case (sgml-check-cat-literal))))) - (file - (expand-file-name (sgml-check-cat-literal)))) - (list (intern type) name file)))) - - -(defun sgml-check-cat-literal () - "Read the next catalog token. -Skips any leading spaces/comments." - (sgml-skip-cs) - (or (sgml-parse-literal) - (buffer-substring-no-properties - (point) - (progn (skip-chars-forward "^ \r\n\t") - (point))))) - -(defconst sgml-formal-pubid-regexp - (concat - "^\\(+//\\|-//\\|\\)" ; Registered indicator [1] - "\\(\\([^/]\\|/[^/]\\)+\\)" ; Owner [2] - "//" - "\\([^ ]+\\)" ; Text class [4] - " " - "\\(\\([^/]\\|/[^/]\\)*\\)" ; Text description [5] - "//" - "\\(\\([^/]\\|/[^/]\\)*\\)" ; Language [7] - "\\(//" ; [9] - "\\(\\([^/]\\|/[^/]\\)*\\)" ; Version [10] - "\\)?")) - -(defun sgml-pubid-parts (pubid) - (nconc - (if (string-match sgml-formal-pubid-regexp pubid) - (nconc - (list - (cons ?o (sgml-transliterate-file (sgml-matched-string pubid 2))) - (cons ?c (downcase (sgml-matched-string pubid 4))) - (cons ?d (sgml-transliterate-file (sgml-matched-string pubid 5))) - ;; t alias for d (%T used by sgmls) - (cons ?t (sgml-transliterate-file (sgml-matched-string pubid 5))) - (cons ?l (downcase (sgml-matched-string pubid 7)))) - (if (match-beginning 9) - (list (cons ?v (sgml-transliterate-file - (sgml-matched-string pubid 10))))))))) - -(defun sgml-canonize-pubid (pubid) - (if (string-match sgml-formal-pubid-regexp pubid) - (concat - (sgml-matched-string pubid 1) ; registered indicator - (sgml-matched-string pubid 2) ; Owner - "//" - (upcase (sgml-matched-string pubid 4)) ; class - " " - (sgml-matched-string pubid 5) ; Text description - "//" - (upcase (sgml-matched-string pubid 7)) ; Language - "//" - (if (match-beginning 9) - (sgml-matched-string pubid 10) "")))) - -(defun sgml-transliterate-file (string) - (mapconcat (function (lambda (c) - (char-to-string - (or (cdr-safe (assq c sgml-public-transliterations)) - c)))) - string "")) - -(defun sgml-subst-expand-char (c parts) - (cdr-safe (assq (downcase c) parts))) - -(defun sgml-subst-expand (s parts) - (loop for i from 0 to (1- (length s)) - as c = (aref s i) - concat (if (eq c ?%) - (or (sgml-subst-expand-char (aref s (incf i)) parts) - (return nil)) - (char-to-string (aref s i))))) - -(defun sgml-matched-string (string n &optional regexp noerror) - (let ((res (if regexp - (or (string-match regexp string) - noerror - (error "String match fail"))))) - (if (or (null regexp) - (numberp res)) - (substring string (match-beginning n) - (match-end n))))) - -;;;; Files for SGML declaration and DOCTYPE declaration - -(defun sgml-declaration () - (or sgml-declaration - (if sgml-doctype - (sgml-in-file-eval sgml-doctype - '(sgml-declaration))) - (if sgml-parent-document - (sgml-in-file-eval (car sgml-parent-document) - '(sgml-declaration))) - ;; *** check for sgmldecl comment - (sgml-external-file nil 'sgmldecl) - ) - ) - -(defun sgml-in-file-eval (file expr) - (let ((cb (current-buffer))) - (set-buffer (find-file-noselect file)) - (prog1 (eval expr) - (set-buffer cb)))) - - -;;;; Entity references and positions - -(defstruct (sgml-eref - (:constructor sgml-make-eref (entity start end)) - (:type list)) - entity - start ; type: epos - end) - -(defun sgml-make-epos (eref pos) - (cons eref pos)) - -(defun sgml-epos-eref (epos) - (if (consp epos) - (car epos))) - -(defun sgml-epos-pos (epos) - "The buffer position of EPOS withing its entity." - (if (consp epos) - (cdr epos) - epos)) - -(defun sgml-bpos-p (epos) - "True if EPOS is a position in the main buffer." - (numberp epos)) - -(defun sgml-strict-epos-p (epos) - "True if EPOS is a position in an entity other then the main buffer." - (consp epos)) - -(defun sgml-epos (pos) - "Convert a buffer position POS into an epos." - (if sgml-current-eref - (sgml-make-epos sgml-current-eref pos) - pos)) - -(defun sgml-epos-before (epos) - "The last position in buffer not after EPOS. -If EPOS is a buffer position this is the same. If EPOS is in an entity -this is the buffer position before the entity reference." - (while (consp epos) - (setq epos (sgml-eref-start (sgml-epos-eref epos)))) - epos) - -(defun sgml-epos-after (epos) - "The first position in buffer after EPOS. -If EPOS is in an other entity, buffer position is after -entity reference leading to EPOS." - (while (consp epos) - (setq epos (sgml-eref-end (sgml-epos-eref epos)))) - epos) - -(defun sgml-epos-promote (epos) - "Convert position in entity structure EPOS to a buffer position. -If EPOS is in an entity, the buffer position will be the position -before the entity reference if EPOS is first character in entity -text. Otherwise buffer position will be after entity reference." - (while (and (consp epos) - (= (cdr epos) 1)) - (setq epos (sgml-eref-start (car epos)))) - (sgml-epos-after epos)) - - -;;;; DTD repository -;;compiled-dtd: extid -> Compiled-DTD? -;;extid-cdtd-name: extid -> file? -;;up-to-date-p: (file, dependencies) -> cond - -;; Emacs Catalogues: -;; Syntax: -;; ecat ::= (cs | ecat-entry)* -;; cs ::= (s | comment) -;; ecat-entry ::= (pub-entry | file-entry) -;; pub-entry ::= ("PUBLIC", minimal literal, ent-spec?, cat literal) -;; pub-entry ::= ("FILE", literal, ent-spec?, cat literal) -;; ent-spec ::= ("[", (name, literal)*, "]") - -;; Parsed ecat = (eent*) -;; eent = (type ...) -;; = ('public pubid cfile . ents) -;; = ('file file cfile . ents) - -(defun sgml-load-ecat (file) - "Return ecat for FILE." - (sgml-cache-catalog - file 'sgml-ecat-assoc - (function - (lambda () - (let (new type ents from to name val) - (while (progn (sgml-skip-cs) - (setq type (sgml-parse-name))) - (setq type (intern (downcase type))) - (setq ents nil from nil) - (sgml-skip-cs) - (cond - ((eq type 'public) - (setq from (sgml-canonize-pubid (sgml-check-minimum-literal)))) - ((eq type 'file) - (setq from (expand-file-name (sgml-check-cat-literal))))) - (cond - ((null from) - (error "Syntax error in ECAT: %s" file)) - (t - (sgml-skip-cs) - (when (sgml-parse-char ?\[) - (while (progn (sgml-skip-cs) - (setq name (sgml-parse-name t))) - (sgml-skip-cs) - (setq val (sgml-check-literal)) - (push (cons name val) ents)) - (sgml-check-char ?\]) - (sgml-skip-cs)) - (setq to (expand-file-name (sgml-check-cat-literal))) - (push (cons type (cons from (cons to ents))) - new)))) - (nreverse new)))))) - -(defun sgml-ecat-lookup (files pubid file) - "Return (file . ents) or nil." - (let ((params (sgml-dtd-parameters sgml-dtd-info))) - (loop - for f in files - do (sgml-debug "Search ECAT %s" f) - thereis - (loop - for (type name cfile . ents) in (sgml-load-ecat f) - thereis - (if (and (cond ((eq type 'public) (equal name pubid)) - ((eq type 'file) (equal name file))) - (loop for (name . val) in ents - for entity = (sgml-lookup-entity name params) - always (and entity - (equal val (sgml-entity-text entity))))) - (cons cfile ents)))))) - -;;(let ((sgml-dtd-info (sgml-make-dtd nil))) -;; (sgml-ecat-lookup sgml-ecat-files -;; "-//lenst//DTD My DTD//EN//" -;; "/home/u5/lenst/src/psgml/bar.dtd")) - - -;;;; Merge compiled dtd - -(defun sgml-try-merge-compiled-dtd (pubid file) - (when pubid (setq pubid (sgml-canonize-pubid pubid))) - (when file (setq file (expand-file-name file))) - (sgml-debug "Find compiled dtd for %s %s" pubid file) - (let ((ce (or (sgml-ecat-lookup sgml-current-local-ecat pubid file) - (sgml-ecat-lookup sgml-ecat-files pubid file)))) - (and ce - (let ((cfile (car ce)) - (ents (cdr ce))) - (sgml-debug "Found %s" cfile) - (if (sgml-use-special-case) - (sgml-try-merge-special-case pubid file cfile ents) - (and (sgml-bdtd-load cfile file ents) - (sgml-bdtd-merge))))))) - -(defun sgml-use-special-case () - (and (null (sgml-dtd-merged sgml-dtd-info)) - (sgml-eltype-table-empty (sgml-dtd-eltypes sgml-dtd-info)) - (eq 'dtd (sgml-entity-type (sgml-eref-entity sgml-current-eref))))) - -(defun sgml-try-merge-special-case (pubid file cfile ents) - (let (cdtd) - (sgml-debug "Merging special case") - ;; Look for a compiled dtd in som other buffer - (let ((cb (current-buffer))) - (loop for b in (buffer-list) - until - (progn (set-buffer b) - (and sgml-buffer-parse-state - (let ((m (sgml-dtd-merged - (sgml-pstate-dtd sgml-buffer-parse-state)))) - (and m - (string-equal cfile (car m)) - (setq cdtd (cdr m))))))) - (set-buffer cb)) - ;; Load a new compiled dtd - (unless cdtd - (and (sgml-bdtd-load cfile file ents) - (setq cdtd (sgml-bdtd-read-dtd)))) - ;; Do the merger - (cond - ((and cdtd - (sgml-check-entities (sgml-dtd-parameters sgml-dtd-info) - (sgml-dtd-parameters cdtd))) - (setf (sgml-dtd-eltypes sgml-dtd-info) - (sgml-dtd-eltypes cdtd)) - (sgml-merge-entity-tables (sgml-dtd-entities sgml-dtd-info) - (sgml-dtd-entities cdtd)) - (sgml-merge-entity-tables (sgml-dtd-parameters sgml-dtd-info) - (sgml-dtd-parameters cdtd)) - (sgml-merge-shortmaps (sgml-dtd-shortmaps sgml-dtd-info) - (sgml-dtd-shortmaps cdtd)) - (setf (sgml-dtd-dependencies sgml-dtd-info) - (nconc (sgml-dtd-dependencies sgml-dtd-info) - (sgml-dtd-dependencies cdtd))) - (setf (sgml-dtd-merged sgml-dtd-info) (cons cfile cdtd)))))) - - -;;;; Pushing and poping entities - -(defun sgml-push-to-entity (entity &optional ref-start type) - "Set current buffer to a buffer containing the entity ENTITY. -ENTITY can also be a file name. Optional argument REF-START should be -the start point of the entity reference. Optional argument TYPE, -overrides the entity type in entity look up." - (sgml-debug "Push to %s" - (cond ((stringp entity) - (format "string '%s'" entity)) - (t - (sgml-entity-name entity)))) - (when ref-start - ;; don't consider a RS shortref here again - (setq sgml-rs-ignore-pos ref-start)) - (unless (and sgml-scratch-buffer - (buffer-name sgml-scratch-buffer)) - (setq sgml-scratch-buffer (generate-new-buffer " *entity*"))) - (let ((cb (current-buffer)) - (dd default-directory) - ;;*** should eref be argument ? - (eref (sgml-make-eref (if (stringp entity) - (sgml-make-entity entity nil nil) - entity) - (sgml-epos (or ref-start (point))) - (sgml-epos (point))))) - (set-buffer sgml-scratch-buffer) - ;; For MULE to not misinterpret binary data set the mc-flag - ;; (reported by Jeffrey Friedl <jfriedl@nff.ncl.omron.co.jp>) - (setq mc-flag nil) - ;; For XEmacs 20.0/Mule - (setq buffer-file-coding-system 'binary) - (when (eq sgml-scratch-buffer (default-value 'sgml-scratch-buffer)) - (make-local-variable 'sgml-scratch-buffer) - (setq sgml-scratch-buffer nil)) - (when after-change-function ;*** - (message "OOPS: after-change-function not NIL in scratch buffer %s: %s" - (current-buffer) - after-change-function) - (setq before-change-function nil - after-change-function nil)) - (setq sgml-last-entity-buffer (current-buffer)) - (erase-buffer) - (setq default-directory dd) - (make-local-variable 'sgml-current-eref) - (setq sgml-current-eref eref) - (set-syntax-table sgml-parser-syntax) - (make-local-variable 'sgml-previous-buffer) - (setq sgml-previous-buffer cb) - (setq sgml-rs-ignore-pos ; don't interpret beginning of buffer - ; as #RS if internal entity. - (if (or (stringp entity) - (stringp (sgml-entity-text entity))) - (point) - 0)) - (when sgml-buffer-parse-state - (sgml-debug "-- pstate set in scratch buffer") - (setq sgml-buffer-parse-state nil)) - (cond - ((stringp entity) ; a file name - (save-excursion (insert-file-contents entity)) - (setq default-directory (file-name-directory entity))) - ((consp (sgml-entity-text entity)) ; external id? - (let* ((extid (sgml-entity-text entity)) - (file - (sgml-external-file extid - (or type (sgml-entity-type entity)) - (sgml-entity-name entity)))) - (when sgml-parsing-dtd - (push (or file t) - (sgml-dtd-dependencies sgml-dtd-info))) - (sgml-debug "Push to %s = %s" extid file) - (cond - ((and file sgml-parsing-dtd - (sgml-try-merge-compiled-dtd (sgml-extid-pubid extid) - file)) - (goto-char (point-max))) - (file - ;; fifth arg not available in early v19 - (erase-buffer) - (insert-file-contents file nil nil nil) - (setq default-directory (file-name-directory file)) - (goto-char (point-min))) - (t ;; No file for entity - (save-excursion - (let* ((pubid (sgml-extid-pubid extid)) - (sysid (sgml-extid-sysid extid))) - (or (if sysid ; try the sysid hooks - (loop for fn in sgml-sysid-resolve-functions - thereis (funcall fn sysid))) - (progn - ;; Mark entity as not found - (setcdr (cddr entity) t) ;*** - (sgml-log-warning "External entity %s not found" - (sgml-entity-name entity)) - (when pubid - (sgml-log-warning " Public identifier %s" pubid)) - (when sysid - (sgml-log-warning " System identfier %s" sysid)) - nil)))))))) - (t ;; internal entity - (save-excursion - (insert (sgml-entity-text entity))))))) - -(defun sgml-pop-entity () - (cond ((and (boundp 'sgml-previous-buffer) - (bufferp sgml-previous-buffer)) - (sgml-debug "Exit entity") - (setq sgml-last-entity-buffer sgml-previous-buffer) - (set-buffer sgml-previous-buffer) - t))) - -(defun sgml-goto-epos (epos) - "Goto a position in an entity given by EPOS." - (assert epos) - (cond ((sgml-bpos-p epos) - (goto-char epos)) - (t - (let ((eref (sgml-epos-eref epos))) - (sgml-cleanup-entities) - (sgml-goto-epos (sgml-eref-end eref)) - (sgml-push-to-entity (sgml-eref-entity eref) - (sgml-epos-pos (sgml-eref-start eref)))) - (goto-char (sgml-epos-pos epos))))) - -(defun sgml-pop-all-entities () - (while (sgml-pop-entity))) - -(defun sgml-cleanup-entities () - (let ((cb (current-buffer)) - (n 0)) - (while (and sgml-scratch-buffer (buffer-name sgml-scratch-buffer)) - (set-buffer sgml-scratch-buffer) - (assert (not (eq sgml-scratch-buffer - (default-value 'sgml-scratch-buffer)))) - (incf n)) - (while (> n 10) - (set-buffer (prog1 sgml-previous-buffer - (kill-buffer (current-buffer)))) - (decf n)) - (set-buffer cb))) - -(defun sgml-any-open-param/file () - "Return true if there currently is a parameter or file open." - (and (boundp 'sgml-previous-buffer) - sgml-previous-buffer)) - - -;;;; Parse tree - -(defstruct (sgml-tree - (:type vector) - (:constructor sgml-make-tree - (eltype stag-epos stag-len parent level - excludes includes pstate net-enabled - conref &optional shortmap pshortmap asl))) - eltype ; element object - ;;start ; start point in buffer - ;;end ; end point in buffer - stag-epos ; start-tag entity position - etag-epos ; end-tag entity position - stag-len ; length of start-tag - etag-len ; length of end-tag - parent ; parent tree - level ; depth of this node - excludes ; current excluded elements - includes ; current included elements - pstate ; state in parent - next ; next sibling tree - content ; child trees - net-enabled ; if NET enabled (t this element, - ; other non-nil, some parent) - conref ; if conref attribute used - shortmap ; shortmap at start of element - pshortmap ; parents shortmap - asl ; attribute specification list -) - - -(defun sgml-tree-end (tree) - "Buffer position after end of TREE." - (let ((epos (sgml-tree-etag-epos tree)) - (len (sgml-tree-etag-len tree))) - (cond ((sgml-bpos-p epos) - (+ epos len)) - ((zerop len) - (sgml-epos-promote epos)) - (t - (sgml-epos-after epos))))) - - -;;;; (text) Element view of parse tree - -(defmacro sgml-alias-fields (orig dest &rest fields) - (let ((macs nil)) - (while fields - (push - (` (defmacro (, (intern (format "%s-%s" dest (car fields)))) (element) - (, (format "Return %s field of ELEMENT." (car fields))) - (list - '(, (intern (format "%s-%s" orig (car fields)))) - element))) - macs) - (setq fields (cdr fields))) - (cons 'progn macs))) - -(sgml-alias-fields sgml-tree sgml-element - eltype ; element object - ;; start ; start point in buffer - stag-epos - etag-epos - stag-len ; length of start-tag - etag-len ; length of end-tag - parent ; parent tree - level ; depth of this node - excludes ; current excluded elements - includes ; current included elements - pstate ; state in parent - net-enabled ; if NET enabled - ) - -(defun sgml-element-model (element) - "Declared content or content model of ELEMENT." - (sgml-eltype-model (sgml-tree-eltype element))) - -(defun sgml-element-name (element) - "Return name (symbol) of ELEMENT." - (sgml-tree-eltype element)) - -(defun sgml-element-gi (element) - "Return general identifier (string) of ELEMENT." - (sgml-eltype-name (sgml-tree-eltype element))) - -(defun sgml-element-appdata (element prop) - "Return the application data named PROP associated with the type of ELEMENT." - (sgml-eltype-appdata (sgml-tree-eltype element) prop)) - -(defmacro sgml-element-stag-optional (element) - "True if start-tag of ELEMENT is omissible." - (`(sgml-eltype-stag-optional (sgml-tree-eltype (, element))))) - -(defun sgml-element-etag-optional (element) - "True if end-tag of ELEMENT is omissible." - (sgml-eltype-etag-optional (sgml-tree-eltype element))) - -(define-compiler-macro sgml-element-etag-optional (element) - "True if end-tag of ELEMENT is omissible." - (`(sgml-eltype-etag-optional (sgml-tree-eltype (, element))))) - -(defun sgml-element-attlist (element) - "Return the attribute specification list of ELEMENT." - (sgml-eltype-attlist (sgml-tree-eltype element))) - -(defun sgml-element-mixed (element) - "True if ELEMENT has mixed content." - (sgml-eltype-mixed (sgml-tree-eltype element))) - -(define-compiler-macro sgml-element-mixed (element) - (`(sgml-eltype-mixed (sgml-tree-eltype (, element))))) - -(defun sgml-element-start (element) - "Position before start of ELEMENT." - (sgml-epos-promote (sgml-tree-stag-epos element))) - -(defun sgml-element-stag-end (element) - "Position after start-tag of ELEMENT." - (let ((epos (sgml-tree-stag-epos element)) - (len (sgml-tree-stag-len element))) - (cond ((sgml-bpos-p epos) - (+ epos len)) - ((zerop len) - (sgml-epos-promote epos)) - (t - (sgml-epos-after epos))))) - -(defun sgml-element-empty (element) - "True if ELEMENT is empty." - (or (eq sgml-empty (sgml-element-model element)) - (sgml-tree-conref element))) - -(defun sgml-element-data-p (element) - "True if ELEMENT can have data characters in its content." - (or (sgml-element-mixed element) - (eq sgml-cdata (sgml-element-model element)) - (eq sgml-rcdata (sgml-element-model element)))) - -(defun sgml-element-context-string (element) - "Return string describing context of ELEMENT." - (if (eq element sgml-top-tree) - "" - (format "in %s %s" - (sgml-element-gi element) - (sgml-element-context-string (sgml-tree-parent element))))) - -;;;; Display and Mode-line - -(defun sgml-update-display () - (when (not (eq this-command 'keyboard-quit)) - ;; Don't let point be inside an invisible region - (when (and (get-text-property (point) 'invisible) - (eq (get-text-property (point) 'invisible) - (get-text-property (1- (point)) 'invisible))) - (setq sgml-last-element nil) ; May not be valid after point moved - (if (memq this-command '(backward-char previous-line backward-word)) - (goto-char (or (previous-single-property-change (point) 'invisible) - (point-min))) - (goto-char (or (next-single-property-change (point) 'invisible) - (point-max))))) - (when (and (not executing-macro) - (or sgml-live-element-indicator - sgml-set-face) - (not (null sgml-buffer-parse-state)) - (sit-for 0)) - (let ((deactivate-mark nil)) - (sgml-need-dtd) - (let ((start - (save-excursion (sgml-find-start-point (point)) - (sgml-pop-all-entities) - (point))) - (eol-pos - (save-excursion (end-of-line 1) (point)))) - (let ((quiet (< (- (point) start) 500))) - ;;(message "Should parse %s to %s => %s" start (point) quiet) - (when (if quiet - t - (setq sgml-current-element-name "?") - (sit-for 1)) - - ;; Find current element - (cond ((and (memq this-command sgml-users-of-last-element) - sgml-last-element) - (setq sgml-current-element-name - (sgml-element-gi sgml-last-element))) - (sgml-live-element-indicator - (save-excursion - (condition-case nil - (sgml-parse-to - (point) (function input-pending-p) quiet) - (error - (setq sgml-current-element-name "*error*"))) - (unless (input-pending-p) - (setq sgml-current-element-name - (sgml-element-gi sgml-current-tree)))))) - ;; Set face on current line - (when (and sgml-set-face (not (input-pending-p))) - (save-excursion - (condition-case nil - (sgml-parse-to - eol-pos (function input-pending-p) quiet) - (error nil))))))) - ;; Set face in rest of buffer - (sgml-fontify-buffer 6) ;*** make option for delay - )))) - -(defun sgml-fontify-buffer (delay) - (and - sgml-set-face - (null (sgml-tree-etag-epos - (sgml-pstate-top-tree sgml-buffer-parse-state))) - (sit-for delay) - (condition-case nil - (save-excursion - (message "Fontifying...") - (sgml-parse-until-end-of nil nil - (function input-pending-p) - t) - (message "Fontifying...done")) - (error nil)))) - -(defun sgml-set-active-dtd-indicator (name) - (set (make-local-variable 'sgml-active-dtd-indicator) - (list (format " [%s" name) - '(sgml-live-element-indicator ("/" sgml-current-element-name)) - "]")) - (force-mode-line-update)) - -;;;; Parser state - -(defstruct (sgml-pstate - (:constructor sgml-make-pstate (dtd top-tree))) - dtd - top-tree) - -;(defsubst sgml-excludes () -; (sgml-tree-excludes sgml-current-tree)) - -;(defsubst sgml-includes () -; (sgml-tree-includes sgml-current-tree)) - -(defsubst sgml-current-mixed-p () - (sgml-element-mixed sgml-current-tree)) - -(defun sgml-set-initial-state (dtd) - "Set initial state of parsing" - (make-local-variable 'before-change-function) - (setq before-change-function 'sgml-note-change-at) - (make-local-variable 'after-change-function) - (setq after-change-function 'sgml-set-face-after-change) - (sgml-set-active-dtd-indicator (sgml-dtd-doctype dtd)) - (let ((top-type ; Fake element type for the top - ; node of the parse tree - (sgml-make-eltype "#DOC") ; was "Document (no element)" - )) - (setf (sgml-eltype-model top-type) - (sgml-make-primitive-content-token - (sgml-eltype-token - (sgml-lookup-eltype (sgml-dtd-doctype dtd) dtd)))) - (setq sgml-buffer-parse-state - (sgml-make-pstate dtd - (sgml-make-tree top-type - 0 0 nil 0 nil nil nil nil nil))))) - -(defun sgml-set-parse-state (tree where) - "Set parse state from TREE, either from start of TREE if WHERE is start -or from after TREE if WHERE is after." - (setq sgml-current-tree tree - sgml-markup-tree tree - sgml-rs-ignore-pos 0 ) - (let ((empty - (sgml-element-empty tree))) - (cond ((and (eq where 'start) - (not empty)) - (setq sgml-current-state (sgml-element-model sgml-current-tree) - sgml-current-shortmap (sgml-tree-shortmap sgml-current-tree) - sgml-previous-tree nil) - (setq sgml-markup-type - (if (and (not (zerop (sgml-tree-stag-len tree))) - (sgml-bpos-p (sgml-tree-stag-epos tree))) - 'start-tag) - sgml-markup-start (sgml-element-start sgml-current-tree)) - (sgml-goto-epos (sgml-tree-stag-epos sgml-current-tree)) - (forward-char (sgml-tree-stag-len sgml-current-tree))) - (t - (setq sgml-current-state (sgml-tree-pstate sgml-current-tree) - sgml-current-shortmap (sgml-tree-pshortmap sgml-current-tree) - sgml-previous-tree sgml-current-tree) - (sgml-goto-epos (sgml-tree-etag-epos sgml-current-tree)) - (forward-char (sgml-tree-etag-len sgml-current-tree)) - (setq sgml-markup-type (if empty 'start-tag 'end-tag) - sgml-markup-start (- (point) - (sgml-tree-etag-len sgml-current-tree))) - (setq sgml-current-tree (sgml-tree-parent sgml-current-tree)))) - (assert sgml-current-state))) - -(defsubst sgml-final-p (state) - ;; Test if a state/model can be ended - (or (not (sgml-model-group-p state)) - (sgml-final state))) - -;(defun sgml-current-element-contains-data () -; "Retrun true if the current open element is either mixed or is (r)cdata." -; (or (eq sgml-cdata sgml-current-state) -; (eq sgml-rcdata sgml-current-state) -; (sgml-current-mixed-p))) - -;(defun sgml-current-element-content-class () -; "Return a string describing the type of content in the current element. -;The type can be CDATA, RCDATA, ANY, #PCDATA or none." -; (cond ((eq sgml-cdata sgml-current-state) -; "CDATA") -; ((eq sgml-rcdata sgml-current-state) -; "RCDATA") -; ((eq sgml-any sgml-current-state) -; "ANY") -; ((sgml-current-mixed-p) -; "#PCDATA") -; (t ""))) - -(defun sgml-promoted-epos (start end) - "Return an entity position for start of region START END. -If region is empty, choose return an epos as high in the -entity hierarchy as possible." -;; This does not work if the entity is entered by a shortref that -;; only is active in the current element. - (let ((epos (sgml-epos start))) - (when (= start end) - (while (and (sgml-strict-epos-p epos) - (= 1 (sgml-epos-pos epos))) - (setq epos (sgml-eref-start (sgml-epos-eref epos))))) - epos)) - -(defun sgml-open-element (eltype conref before-tag after-tag &optional asl) - (unless (sgml-eltype-defined eltype) - (setf (sgml-eltype-mixed eltype) t) - (setf (sgml-eltype-etag-optional eltype) t) - (when sgml-warn-about-undefined-elements - (sgml-log-warning - "Start-tag of undefined element %s; assume O O ANY" - (sgml-eltype-name eltype)))) - (let* ((emap (sgml-eltype-shortmap eltype)) - (newmap (if emap - (if (eq 'empty emap) - nil - (sgml-lookup-shortref-map - (sgml-dtd-shortmaps sgml-dtd-info) - emap)) - sgml-current-shortmap)) - (nt (sgml-make-tree - eltype - (sgml-promoted-epos before-tag after-tag) ; stag-epos - (- after-tag before-tag) ; stag-len - sgml-current-tree ; parent - (1+ (sgml-tree-level sgml-current-tree)) ; level - (append (sgml-eltype-excludes eltype) - (sgml-tree-excludes sgml-current-tree)) - (append (sgml-eltype-includes eltype) - (sgml-tree-includes sgml-current-tree)) - sgml-current-state - (if (sgml-tree-net-enabled sgml-current-tree) 1) - conref - newmap - sgml-current-shortmap - asl))) -;; (let ((u (sgml-tree-content sgml-current-tree))) -;; (cond ((and u (> before-tag (sgml-element-start u))) -;; (while (and (sgml-tree-next u) -;; (> before-tag -;; (sgml-element-start (sgml-tree-next u)))) -;; (setq u (sgml-tree-next u))) -;; (setf (sgml-tree-next u) nt)) -;; (t -;; (setf (sgml-tree-content sgml-current-tree) nt)))) - ;; Install new node in tree - (cond (sgml-previous-tree - (sgml-debug "Open element %s: after %s" - eltype (sgml-tree-eltype sgml-previous-tree)) - (setf (sgml-tree-next sgml-previous-tree) nt)) - (t - (sgml-debug "Open element %s: first in %s" - eltype (sgml-tree-eltype sgml-current-tree)) - (setf (sgml-tree-content sgml-current-tree) nt))) - ;; Prune tree - ;; *** all the way up? tree-end = nil? - (setf (sgml-tree-next sgml-current-tree) nil) - ;; Set new state - (setq sgml-current-state (sgml-eltype-model eltype) - sgml-current-shortmap newmap - sgml-current-tree nt - sgml-previous-tree nil) - (assert sgml-current-state) - (setq sgml-markup-tree sgml-current-tree) - (run-hook-with-args 'sgml-open-element-hook sgml-current-tree asl) - (when (sgml-element-empty sgml-current-tree) - (sgml-close-element after-tag after-tag)))) - -(defun sgml-fake-open-element (tree el &optional state) - (sgml-make-tree - el 0 0 - tree - 0 - (append (sgml-eltype-excludes el) (sgml-tree-excludes tree)) - (append (sgml-eltype-includes el) (sgml-tree-includes tree)) - state - nil - nil)) - -(defun sgml-close-element (before-tag after-tag) - (when (or (eq sgml-close-element-trap t) - (eq sgml-close-element-trap sgml-current-tree)) - (setq sgml-goal (point))) - (when sgml-throw-on-element-change - (throw sgml-throw-on-element-change 'end)) - (sgml-debug "Close element %s" (sgml-tree-eltype sgml-current-tree)) - (setf (sgml-tree-etag-epos sgml-current-tree) - ;;(sgml-promoted-epos before-tag after-tag) - (sgml-epos before-tag)) - (setf (sgml-tree-etag-len sgml-current-tree) (- after-tag before-tag)) - (run-hooks 'sgml-close-element-hook) - (setq sgml-markup-tree sgml-current-tree) - (cond ((eq sgml-current-tree sgml-top-tree) - (unless (eobp) - (sgml-error "Parse ended"))) - (t - (setq sgml-previous-tree sgml-current-tree - sgml-current-state (sgml-tree-pstate sgml-current-tree) - sgml-current-shortmap (sgml-tree-pshortmap sgml-current-tree) - sgml-current-tree (sgml-tree-parent sgml-current-tree)) - (assert sgml-current-state)))) - -(defun sgml-fake-close-element (tree) - (sgml-tree-parent tree)) - -(defun sgml-note-change-at (at &optional end) - ;; Inform the cache that there have been some changes after AT - (when sgml-buffer-parse-state - (sgml-debug "sgml-note-change-at %s" at) - (let ((u (sgml-pstate-top-tree sgml-buffer-parse-state))) - (when u - ;;(message "%d" at) - (while - (cond - ((and (sgml-tree-next u) ; Change clearly in next element - (> at (sgml-element-stag-end (sgml-tree-next u)))) - (setq u (sgml-tree-next u))) - (t ; - (setf (sgml-tree-next u) nil) ; Forget next element - (cond - ;; If change after this element and it is ended by an end - ;; tag no pruning is done. If the end of the element is - ;; implied changing the tag that implied it may change - ;; the extent of the element. - ((and (sgml-tree-etag-epos u) - (> at (sgml-tree-end u)) - (or (> (sgml-tree-etag-len u) 0) - (sgml-element-empty u))) - nil) - (t - (setf (sgml-tree-etag-epos u) nil) - (cond;; Enter into content if change is clearly in it - ((and (sgml-tree-content u) - (> at (sgml-element-stag-end (sgml-tree-content u)))) - (setq u (sgml-tree-content u))) - ;; Check if element has no start tag, - ;; then it must be pruned as a change could create - ;; a valid start tag for the element. - ((and (zerop (sgml-tree-stag-len u)) - (> at (sgml-element-start u))) - ;; restart from to with new position - ;; this can't loop forever as - ;; position allways gets smaller - (setq at (sgml-element-start u) - u sgml-top-tree)) - (t - (setf (sgml-tree-content u) nil)))))))))))) - -(defun sgml-list-implications (token type) - "Return a list of the tags implied by a token TOKEN. -TOKEN is a token, and the list elements are either tokens or `t'. -Where the latter represents end-tags." - (let ((state sgml-current-state) - (tree sgml-current-tree) - (temp nil) - (imps nil)) - (while ; Until token accepted - (cond - ;; Test if accepted in state - ((or (eq state sgml-any) - (and (sgml-model-group-p state) - (not (memq token (sgml-tree-excludes tree))) - (or (memq token (sgml-tree-includes tree)) - (sgml-get-move state token)))) - nil) - ;; Test if end tag implied - ((or (eq state sgml-empty) - (and (sgml-final-p state) - (not (eq tree sgml-top-tree)))) - (unless (eq state sgml-empty) ; not realy implied - (push t imps)) - (setq state (sgml-tree-pstate tree) - tree (sgml-fake-close-element tree)) - t) - ;; Test if start-tag can be implied - ((and (setq temp (sgml-required-tokens state)) - (null (cdr temp))) - (setq temp (car temp) - tree (sgml-fake-open-element tree temp - (sgml-get-move state temp)) - state (sgml-element-model tree)) - (push temp imps) - t) - ;; No implictions and not accepted - (t - (sgml-log-warning "Out of context %s" type) - (setq imps nil)))) - ;; Return the implications in correct order - (nreverse imps))) - - -(defun sgml-eltypes-in-state (tree state) - "Return list of element types (eltype) valid in STATE and TREE." - (let* ((req ; Required tokens - (if (sgml-model-group-p state) - (sgml-required-tokens state))) - (elems ; Normally valid tokens - (if (sgml-model-group-p state) - (nconc req - (delq sgml-pcdata-token (sgml-optional-tokens state)))))) - ;; Modify for exceptions - (loop for et in (sgml-tree-includes tree) ;*** Tokens or eltypes? - unless (memq et elems) do (push et elems)) - (loop for et in (sgml-tree-excludes tree) - do (setq elems (delq et elems))) - ;; Check for omitable start-tags - (when (and sgml-omittag-transparent - (not (sgml-final-p state)) - req - (null (cdr req))) - (let ((et (sgml-token-eltype (car req)))) - (when (sgml-eltype-stag-optional et) - (setq elems - (nconc elems ; *** possibility of duplicates - (sgml-eltypes-in-state - (sgml-fake-open-element tree et) - (sgml-eltype-model et))))))) - elems)) - -(defun sgml-current-list-of-valid-eltypes () - "Returns a list of contextually valid element types (eltype)." - (let ((elems (sgml-eltypes-in-state sgml-current-tree sgml-current-state)) - (tree sgml-current-tree) - (state sgml-current-state)) - (when sgml-omittag-transparent - (while (and tree - (sgml-final-p state) - (sgml-element-etag-optional tree)) - (setq state (sgml-tree-pstate tree) - tree (sgml-tree-parent tree)) - (loop for e in (sgml-eltypes-in-state tree state) do - (when (not (memq e elems)) - (setq elems (nconc elems (list e))))))) - ;; *** Filter out elements that are undefined? - (sort elems (function string-lessp)))) - -(defun sgml-current-list-of-endable-eltypes () - "Return a list of the element types endable in current state." - (let* ((elems nil) - (tree sgml-current-tree) - (state sgml-current-state)) - (while - (and (sgml-final-p state) - (not (eq tree sgml-top-tree)) - (progn - (setq elems - (nconc elems (list (sgml-tree-eltype tree)))) - sgml-omittag) - (sgml-eltype-etag-optional (sgml-tree-eltype tree))) - (setq state (sgml-tree-pstate tree) - tree (sgml-tree-parent tree))) - elems)) - -;;;; Logging of warnings - -(defconst sgml-log-buffer-name "*SGML LOG*") - -(defvar sgml-log-last-size 0) - -(defun sgml-display-log () - (let ((buf (get-buffer sgml-log-buffer-name))) - (when buf - (display-buffer buf) - (setq sgml-log-last-size (save-excursion (set-buffer buf) - (point-max)))))) - -(defun sgml-log-warning (format &rest things) - (when sgml-throw-on-warning - (apply 'message format things) - (throw sgml-throw-on-warning t)) - (when (or sgml-show-warnings sgml-parsing-dtd) - (apply 'sgml-message format things) - (apply 'sgml-log-message format things))) - -(defun sgml-log-message (format &rest things) - (let ((mess (apply 'format format things)) - (buf (get-buffer-create sgml-log-buffer-name)) - (cb (current-buffer))) - (set-buffer buf) - (goto-char (point-max)) - (insert mess "\n") - (when (get-buffer-window buf) - (setq sgml-log-last-size (point-max))) - (set-buffer cb))) - -(defun sgml-error (format &rest things) - (when sgml-throw-on-error - (throw sgml-throw-on-error nil)) - (while (and (boundp 'sgml-previous-buffer) sgml-previous-buffer) - (when sgml-current-eref - (sgml-log-message - "Line %s in %S " - (count-lines (point-min) (point)) - (sgml-entity-name (sgml-eref-entity sgml-current-eref)))) - (sgml-pop-entity)) - (apply 'sgml-log-warning format things) - (apply 'error format things)) - -(defun sgml-parse-error (format &rest things) - (apply 'sgml-error - (concat format "; at: %s") - (append things (list (buffer-substring-no-properties - (point) - (min (point-max) (+ (point) 12))))))) - -(defun sgml-message (format &rest things) - (let ((buf (get-buffer sgml-log-buffer-name))) - (when (and buf - (> (save-excursion (set-buffer buf) - (point-max)) - sgml-log-last-size)) - (sgml-display-log))) - (apply 'message format things)) - -(defun sgml-reset-log () - (let ((buf (get-buffer sgml-log-buffer-name))) - (when buf - (setq sgml-log-last-size - (save-excursion (set-buffer buf) - (point-max)))))) - -(defun sgml-clear-log () - (let ((b (get-buffer sgml-log-buffer-name))) - (when b - (delete-windows-on b) - (kill-buffer b) - (setq sgml-log-last-size 0)))) - -(defun sgml-show-or-clear-log () - "Show the *SGML LOG* buffer if it is not showing, or clear and -remove it if it is showing." - (interactive) - (cond ((and (get-buffer sgml-log-buffer-name) - (null (get-buffer-window sgml-log-buffer-name))) - (sgml-display-log)) - (t - (sgml-clear-log)))) - - - -;;; This has noting to do with warnings... - -(defvar sgml-lazy-time 0) - -(defun sgml-lazy-message (&rest args) - (unless (= sgml-lazy-time (second (current-time))) - (apply 'message args) - (setq sgml-lazy-time (second (current-time))))) - -;;;; Shortref maps - -(eval-and-compile - (defconst sgml-shortref-list - '( - "\t" ;&#TAB - "\n" ;&#RE; - "\001" ;&#RS; - "\001B" - "\001\n" - "\001B\n" - "B\n" - " " ;&#SPACE; - "BB" - "\"" ;" - "#" - "%" - "'" - "(" - ")" - "*" - "+" - "," - "-" - "--" - ":" - ";" - "=" - "@" - "[" - "]" - "^" - "_" - "{" - "|" - "}" - "~"))) - -(eval-and-compile - (defun sgml-shortref-index (string) - (let ((pos (member string sgml-shortref-list)) - (len (length sgml-shortref-list))) - (and pos (- len (length pos))) ))) - -(defun sgml-make-shortmap (pairs) - "Create a shortreference map from PAIRS. -Where PAIRS is a list of (delim . ename)." - (let ((map - (make-vector (1+ (length sgml-shortref-list)) - nil)) - index) - (loop for p in pairs - for delim = (car p) - for name = (cdr p) - do - (setq index (sgml-shortref-index delim)) - (cond ((null index) - (sgml-log-warning - "Illegal short reference delimiter '%s'" delim)) - (t - (aset map index name)))) - ;; Compute a suitable string for skip-chars-forward that - ;; can be used to skip over pcdata - (aset map - (eval-when-compile (length sgml-shortref-list)) - (if (some (function - (lambda (r) (aref map (sgml-shortref-index r)))) - '("\001B\n" "B\n" " " "BB")) - "^<]/& \n\t\"#%'()*+,\\-:;=@[]\\^_{|}~" - "^<]/&\n\t\"#%'()*+,\\-:;=@[]\\^_{|}~")) - map)) - -(defun sgml-shortmap-skipstring (map) - (if (bolp) - "" - (aref map (eval-when-compile (length sgml-shortref-list))))) - - -(defconst sgml-shortref-oneassq - (loop for d in sgml-shortref-list - for c = (aref d 0) - when (and (= 1 (length d)) - (/= 1 c) (/= 10 c)) - collect (cons c (sgml-shortref-index d)))) - -(defun sgml-parse-B () - (/= 0 (skip-chars-forward " \t"))) - -(defun sgml-deref-shortmap (map &optional nobol) - "Identify shortref delimiter at point and return entity name. -Also move point. Return nil, either if no shortref or undefined." - - (macrolet - ((delim (x) (` (aref map (, (sgml-shortref-index x)))))) - (let ((i (if nobol 1 0))) - (while (numberp i) - (setq i - (cond - ((and (bolp) (zerop i)) ; Either "\001" "\001B" - ; "\001\n" "\001B\n" - (cond ((sgml-parse-B) ; "\001B" - (if (eolp) - (delim "\001B\n") - (delim "\001B"))) - ((sgml-parse-RE) (delim "\001\n")) - ((delim "\001")) - (t 1))) - ((cond ((sgml-parse-char ?\t) (setq i (delim "\t")) t) - ((sgml-parse-char ? ) (setq i (delim " ")) t)) - (cond ((sgml-parse-B) (setq i (delim "BB")))) - (cond ((sgml-parse-char ?\n) - (delim "B\n")) - (t i))) - ((sgml-parse-RE) (delim "\n")) - ((sgml-parse-chars ?- ?-) (delim "--")) - ;; The other one character delimiters - ((setq i (assq (following-char) sgml-shortref-oneassq)) - (when i (forward-char 1)) - (aref map (cdr i)))))) - i))) - -;;; Table of shortref maps - -(defun sgml-make-shortref-table () - (list nil)) - -(defun sgml-add-shortref-map (table name map) - (nconc table (list (cons name map)))) - -(defun sgml-lookup-shortref-map (table name) - (cdr (assoc name (cdr table)))) - -(defun sgml-lookup-shortref-name (table map) - (car (rassq map (cdr table)))) - -(defun sgml-merge-shortmaps (tab1 tab2) - "Merge tables of short reference maps TAB2 into TAB1, modifying TAB1." - (nconc tab1 (cdr tab2))) - -;;;; Parse markup declarations - -(defun sgml-skip-until-dsc () - (while (progn - (sgml-skip-upto ("DSO" "DSC" "LITA" "LIT" "COM")) - (not (sgml-parse-delim "DSC"))) - (cond ((sgml-parse-literal)) - ((sgml-parse-delim "DSO") - (sgml-skip-until-dsc)) - ((sgml-parse-comment)) - (t (forward-char 1))))) - -(defun sgml-skip-upto-mdc () - "Move point forward until end of current markup declaration. -Assumes starts with point inside a markup declaration." - (while (progn - (sgml-skip-upto ("DSO" "MDC" "LIT" "LITA" "COM")) - (not (sgml-is-delim "MDC"))) - (cond ((sgml-parse-delim "DSO") - (sgml-skip-until-dsc)) - ((sgml-parse-literal)) - ((sgml-parse-comment)) - (t (forward-char 1))))) - -(defun sgml-do-sgml-declaration () - (sgml-skip-upto-mdc) - (setq sgml-markup-type 'sgml)) - -(defun sgml-do-doctype () - (cond - (sgml-dtd-info ; Has doctype already been defined - (sgml-skip-upto-mdc)) - (t - (let (sgml-markup-start) - (message "Parsing doctype...") - (sgml-setup-doctype (sgml-check-name) - (sgml-parse-external)) - (message "Parsing doctype...done")))) - (setq sgml-markup-type 'doctype)) - -(defun sgml-check-end-of-entity (type) - (unless (eobp) - (sgml-parse-error "Illegal character '%c' in %s" - (following-char) - type))) - -(defun sgml-setup-doctype (docname external) - (let ((sgml-parsing-dtd t)) - (setq sgml-no-elements 0) - (setq sgml-dtd-info (sgml-make-dtd docname)) - ;;(setq sgml-dtd-shortmaps nil) - (sgml-skip-ps) - (cond - ((sgml-parse-delim "DSO") - (let ((original-buffer (current-buffer))) - (sgml-check-dtd-subset) - (if (eq (current-buffer) original-buffer) - (sgml-check-delim "DSC") - (sgml-parse-error "Illegal character '%c' in doctype declaration" - (following-char)))))) - (cond (external - (sgml-push-to-entity (sgml-make-entity docname 'dtd external)) - (sgml-check-dtd-subset) - (sgml-check-end-of-entity "DTD subset") - (sgml-pop-entity))) -;;; (loop for map in sgml-dtd-shortmaps do -;;; (sgml-add-shortref-map -;;; (sgml-dtd-shortmaps sgml-dtd-info) -;;; (car map) -;;; (sgml-make-shortmap (cdr map)))) - (sgml-set-initial-state sgml-dtd-info) - (run-hooks 'sgml-doctype-parsed-hook))) - -(defun sgml-do-data (type &optional marked-section) - "Move point forward until there is an end-tag open after point." - (let ((start (point)) - (done nil) - (eref sgml-current-eref) - sgml-signal-data-function) - (while (not done) - (cond (marked-section - (skip-chars-forward (if (eq type sgml-cdata) "^]" "^&]")) - (when sgml-data-function - (funcall sgml-data-function (buffer-substring-no-properties - start (point)))) - (setq done (sgml-parse-delim "MS-END"))) - (t - (skip-chars-forward (if (eq type sgml-cdata) "^</" "^</&")) - (when sgml-data-function - (funcall sgml-data-function (buffer-substring-no-properties start (point)))) - (setq done (or (sgml-is-delim "ETAGO" gi) - (sgml-is-enabled-net))))) - (setq start (point)) - (cond - (done) - ((eobp) - (when (eq eref sgml-current-eref) - (sgml-error "Unterminated %s %s" - type (if marked-section "marked section"))) - (sgml-pop-entity) - (setq start (point))) - ((null sgml-data-function) - (forward-char 1)) - ((sgml-parse-general-entity-ref) - (setq start (point))) - (t - (forward-char 1)))))) - - -(defun sgml-do-marked-section () - (let ((status nil)) - (while (progn (sgml-skip-ps) - (not (sgml-parse-char ?\[))) - (push (sgml-check-name) - status)) - (cond - ((member "ignore" status) - (sgml-skip-marked-section) - (sgml-set-markup-type 'ignored)) - ((or (member "cdata" status) - (member "rcdata" status)) - (when sgml-signal-data-function - (funcall sgml-signal-data-function)) - (let ((type (if (member "cdata" status) sgml-cdata sgml-rcdata))) - (sgml-do-data type t) - (sgml-set-markup-type type))) - (t - (sgml-set-markup-type 'ms-start))))) - -(defun sgml-skip-marked-section () - (while (progn - (sgml-skip-upto ("MS-START" "MS-END")) - (when (eobp) (sgml-error "Marked section unterminated")) - (not (sgml-parse-delim "MS-END"))) - (cond ((sgml-parse-delim "MS-START") - ;;(search-forward "[") - (sgml-skip-marked-section)) - (t (forward-char 1))))) - -(defun sgml-do-usemap () - (let (mapname) - ;;(setq sgml-markup-type 'usemap) - (unless (sgml-parse-rni "empty") - (setq mapname (sgml-check-name))) - (sgml-skip-ps) - (cond - ((sgml-is-delim "MDC") - (sgml-debug "USEMAP %s" (if mapname mapname "#EMPTY")) - (cond (sgml-dtd-info - (setq sgml-current-shortmap - (if mapname - (or (sgml-lookup-shortref-map - (sgml-dtd-shortmaps sgml-dtd-info) - mapname) - (sgml-error "Undefined shortref map %s" mapname))))) - ;; If in prolog - (t - (sgml-log-warning - "USEMAP without associated element type in prolog")))) - (t - ;; Should be handled by psgml-dtd - (sgml-do-usemap-element mapname))))) - -(defconst sgml-markup-declaration-table - '(("sgml" . sgml-do-sgml-declaration) - ("doctype" . sgml-do-doctype) - ("element" . sgml-declare-element) - ("entity" . sgml-declare-entity) - ("usemap" . sgml-do-usemap) - ("shortref" . sgml-declare-shortref) - ("notation" . sgml-declare-notation) - ("attlist" . sgml-declare-attlist) - ("uselink" . sgml-skip-upto-mdc) - ("linktype" . sgml-skip-upto-mdc) - ("link" . sgml-skip-upto-mdc) - ("idlink" . sgml-skip-upto-mdc) - )) - -(defun sgml-parse-markup-declaration (option) - "Parse a markup declartion. -OPTION can be `prolog' if parsing the prolog or `dtd' if parsing the -dtd or `ignore' if the declaration is to be ignored." - (cond - ((sgml-parse-delim "MDO" (nmstart "COM" "MDC")) - (cond - ((sgml-startnm-char-next) - (setq sgml-markup-type nil) - (let* ((tok (sgml-parse-nametoken)) - (rut (assoc tok sgml-markup-declaration-table))) - (when (and (not (memq option '(prolog ignore))) - (member tok '("sgml" "doctype"))) - (sgml-error "%s declaration is only valid in prolog" tok)) - (when (and (not (memq option '(dtd ignore))) - (member tok '("element" "entity" "attlist" "notation" - "shortref"))) - (sgml-error "%s declaration is only valid in doctype" tok)) - (cond ((eq option 'ignore) - (sgml-skip-upto-mdc)) - (rut (sgml-skip-ps) - (funcall (cdr rut))) - (t (sgml-parse-error - "Illegal markup declaration %s" tok))))) - (t - (setq sgml-markup-type 'comment))) - (sgml-skip-ps) - (sgml-check-delim "MDC") - (unless (eq option 'ignore) ; Set the markup type given - (when sgml-markup-type - (sgml-set-markup-type sgml-markup-type))) - t) - ((sgml-parse-delim "MS-START") - (sgml-do-marked-section)))) - - -;;;; Parsing attribute values - -(defun sgml-parse-attribute-specification-list (&optional eltype) - "Parse an attribute specification list. -Optional argument ELTYPE, is used to resolve omitted name=. -Returns a list of attspec (attribute specification)." - (setq sgml-conref-flag nil) - (let ((attlist (if eltype (sgml-eltype-attlist eltype))) - name val asl attdecl) - (while (setq name (progn (sgml-parse-s) - (sgml-parse-nametoken))) - (sgml-parse-s) - (cond ((sgml-parse-delim "VI") - (sgml-parse-s) - (setq val (sgml-check-attribute-value-specification)) - (when eltype - (or (setq attdecl (sgml-lookup-attdecl name attlist)) - (sgml-log-warning - "Attribute %s not declared for element %s" - name (sgml-eltype-name eltype))))) - ((null eltype) - (sgml-parse-error "Expecting a =")) - ((progn - (unless sgml-current-shorttag - (sgml-log-warning - "Must have attribute name when SHORTTAG NO")) - (setq attdecl - (sgml-find-attdecl-for-value (setq val name) - eltype)))) - (t - (sgml-log-warning - "%s is not in any name group for element %s." - val - (sgml-eltype-name eltype)))) - ;; *** What happens when eltype is nil ?? - (when attdecl - (push (sgml-make-attspec (sgml-attdecl-name attdecl) val) - asl) - (when (sgml-default-value-type-p 'conref - (sgml-attdecl-default-value attdecl)) - (setq sgml-conref-flag t)))) - asl)) - -(defun sgml-check-attribute-value-specification () - (or (sgml-parse-literal) - (sgml-parse-nametoken t) ; Not really a nametoken, but an - ; undelimited literal - (sgml-parse-error "Expecting an attribute value: literal or token"))) - -(defun sgml-find-attdecl-for-value (value eltype) - "Find the attribute declaration of ELTYPE that has VALUE in its name group. -VALUE is a string. Returns nil or an attdecl." - (let ((al (sgml-eltype-attlist eltype)) - dv) - (while (and al - (or (atom (setq dv (sgml-attdecl-declared-value (car al)))) - (not (member value - (sgml-declared-value-token-group dv))))) - (setq al (cdr al))) - (if al (car al)))) - - -;;;; Parser driver - -;; The parser maintains a partial parse tree during the parse. This tree -;; can be inspected to find information, and also be used to restart the -;; parse. The parser also has a postition in the current content model. -;; (Called a state.) The parser is used for several things: -;; 1) To find the state the parser would be in at a point in the buffer. -;; (Point in emacs sense, I.e. between chararacters). -;; 2) Identify the element containing a character. -;; 3) Find end of an element. -;; 4) Find the next element. -;; 5) To find the previous element. - -;; These tasks are done by a combination of parsing and traversing -;; the partial parse tree. The primitive parse operation is to parse -;; until a goal point in the buffer has been passed. In addition to -;; this it is possible to "trap" closing of elements. Either for a -;; specific element or for any element. When the trap is sprung the -;; parse is ended. This is used to extend the parse tree. When the -;; trap is used the parser is usually called with the end of the -;; buffer as the goal point. - -(defun sgml-need-dtd () - "Make sure that an eventual DTD is parsed or loaded." - (sgml-pop-all-entities) - (sgml-cleanup-entities) - (when (null sgml-buffer-parse-state) ; first parse in this buffer - ;;(sgml-set-initial-state) ; fall back DTD - (add-hook 'pre-command-hook 'sgml-reset-log) - (make-local-variable 'sgml-auto-fill-inhibit-function) - (setq sgml-auto-fill-inhibit-function (function sgml-in-prolog-p)) - (if sgml-default-dtd-file - (sgml-load-dtd sgml-default-dtd-file) - (sgml-load-doctype))) - (sgml-debug "Need dtd getting state from %s" (buffer-name)) - (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state) - sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state)) - (sgml-set-global)) - - -(defun sgml-load-doctype () - (cond - ;; Case of doctype in another file - ((or sgml-parent-document sgml-doctype) - (let ((dtd - (save-excursion ; get DTD from parent document - (set-buffer (find-file-noselect - (if (consp sgml-parent-document) - (car sgml-parent-document) - (or sgml-doctype sgml-parent-document)))) - (sgml-need-dtd) - (sgml-pstate-dtd sgml-buffer-parse-state)))) - (sgml-set-initial-state dtd) - (when (consp sgml-parent-document) ; modify DTD for child documents - (sgml-modify-dtd (cdr sgml-parent-document))))) - - ;; The doctype declaration should be in the current buffer - (t - (save-excursion (sgml-parse-prolog))))) - - -(defun sgml-modify-dtd (modifier) - (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state) - sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state)) - (sgml-set-global) - (setq sgml-current-tree sgml-top-tree) - (while (stringp (cadr modifier)) ; Loop thru the context elements - (let ((et (sgml-lookup-eltype (car modifier)))) - (sgml-open-element et nil (point-min) (point-min)) - (setq modifier (cdr modifier)))) - - (unless (stringp (car modifier)) - (error "wrong format of sgml-parent-document")) - - (let* ((doctypename (car modifier)) - (et (sgml-lookup-eltype - (sgml-general-case (if (symbolp doctypename) - (symbol-name doctypename) - doctypename))))) - - (setq sgml-current-state - (sgml-make-primitive-content-token et)) - - (when (consp (cadr modifier)) ; There are "seen" elements - (sgml-open-element et nil (point-min) (point-min)) - (loop for seenel in (cadr modifier) - do (setq sgml-current-state - (sgml-get-move sgml-current-state - (sgml-lookup-eltype seenel)))))) - - (let ((top (sgml-pstate-top-tree sgml-buffer-parse-state))) - (setf (sgml-tree-includes top) (sgml-tree-includes sgml-current-tree)) - (setf (sgml-tree-excludes top) (sgml-tree-excludes sgml-current-tree)) - (setf (sgml-tree-shortmap top) sgml-current-shortmap) - (setf (sgml-eltype-model (sgml-tree-eltype top)) - sgml-current-state))) - - -(defun sgml-set-global () - (setq sgml-current-omittag sgml-omittag - sgml-current-shorttag sgml-shorttag - sgml-current-localcat sgml-local-catalogs - sgml-current-local-ecat sgml-local-ecat-files - sgml-current-top-buffer (current-buffer))) - -(defun sgml-parse-prolog () - "Parse the document prolog to learn the DTD." - (interactive) - (sgml-debug "Parse prolog in buffer %s" (buffer-name)) - (unless sgml-debug - (sgml-clear-log)) - (message "Parsing prolog...") - (sgml-cleanup-entities) - (sgml-set-global) - (setq sgml-dtd-info nil) - (goto-char (point-min)) - (sgml-with-parser-syntax - (while (progn (sgml-skip-ds) - (setq sgml-markup-start (point)) - (and (sgml-parse-markup-declaration 'prolog) - (null sgml-dtd-info)))) - (unless sgml-dtd-info ; Set up a default doctype - (let ((docname (or sgml-default-doctype-name - (if (sgml-parse-delim "STAGO" gi) - (sgml-parse-name))))) - (when docname - (sgml-setup-doctype docname '(nil)))))) - (unless sgml-dtd-info - (error "No document type defined by prolog")) - (sgml-message "Parsing prolog...done")) - - -(defun sgml-parse-until-end-of (sgml-close-element-trap &optional - cont extra-cond quiet) - "Parse until the SGML-CLOSE-ELEMENT-TRAP has ended, -or if it is t, any additional element has ended, -or if nil, until end of buffer." - (cond - (cont (sgml-parse-continue (point-max))) - (t (sgml-parse-to (point-max) extra-cond quiet))) - (when (eobp) ; End of buffer, can imply - ; end of any open element. - (while (prog1 (not - (or (eq sgml-close-element-trap t) - (eq sgml-close-element-trap sgml-current-tree) - (eq sgml-current-tree sgml-top-tree))) - (sgml-implied-end-tag "buffer end" (point) (point)))))) - -(defun sgml-parse-to (sgml-goal &optional extra-cond quiet) - "Parse until (at least) SGML-GOAL. -Optional argument EXTRA-COND should be a function. This function is -called in the parser loop, and the loop is exited if the function returns t. -If third argument QUIT is non-nil, no \"Parsing...\" message will be displayed." - (sgml-need-dtd) - - (unless before-change-function - (message "WARN: before-change-function has been lost, restoring (%s)" - (current-buffer)) - (setq before-change-function 'sgml-note-change-at) - (setq after-change-function 'sgml-set-face-after-change) - ) - - (sgml-find-start-point (min sgml-goal (point-max))) - (assert sgml-current-tree) - (let ((bigparse (and (not quiet) (> (- sgml-goal (point)) 10000)))) - (when bigparse - (sgml-message "Parsing...")) - (sgml-with-parser-syntax - (sgml-parser-loop extra-cond)) - (when bigparse - (sgml-message "")))) - -(defun sgml-parse-continue (sgml-goal &optional extra-cond quiet) - "Parse until (at least) SGML-GOAL." - (assert sgml-current-tree) - (unless quiet - (sgml-message "Parsing...")) - (sgml-with-parser-syntax - (sgml-parser-loop extra-cond)) - (unless quiet - (sgml-message ""))) - -(defun sgml-reparse-buffer (shortref-fun) - "Reparse the buffer and let SHORTREF-FUN take care of short references. -SHORTREF-FUN is called with the entity as argument and `sgml-markup-start' -pointing to start of short ref and point pointing to the end." - (sgml-note-change-at (point-min)) - (let ((sgml-shortref-handler shortref-fun)) - (sgml-parse-until-end-of nil))) - -(defun sgml-move-current-state (token) - (setq sgml-current-state - (or (sgml-get-move sgml-current-state token) - sgml-current-state))) - -(defun sgml-execute-implied (imps type) - (loop for token in imps do - (if (eq t token) - (sgml-implied-end-tag type sgml-markup-start sgml-markup-start) - (sgml-move-current-state token) - (when sgml-throw-on-element-change - (throw sgml-throw-on-element-change 'start)) - (sgml-open-element (sgml-token-eltype token) - nil sgml-markup-start sgml-markup-start) - (unless (and sgml-current-omittag - (sgml-element-stag-optional sgml-current-tree)) - (sgml-log-warning - "%s start-tag implied by %s; not minimizable" - (sgml-eltype-name (sgml-token-eltype token)) - type))))) - -(defun sgml-do-move (token type) - (sgml-execute-implied (sgml-list-implications token type) type) - (unless (eq sgml-any sgml-current-state) - (sgml-move-current-state token))) - -(defun sgml-pcdata-move () - "Moify parser state to reflect parsed data." - (sgml-do-move sgml-pcdata-token "data character")) - -(defsubst sgml-parse-pcdata () - (/= 0 - (if sgml-current-shortmap - (skip-chars-forward (sgml-shortmap-skipstring sgml-current-shortmap)) - (skip-chars-forward "^<]/&")))) - -(defsubst sgml-do-pcdata () - ;; Parse pcdata - (sgml-pcdata-move) - ;;*** assume sgml-markup-start = point - ;;*** should perhaps handle &#nn;? - (forward-char 1) - (sgml-parse-pcdata) - (when sgml-data-function - (funcall sgml-data-function (buffer-substring-no-properties - sgml-markup-start - (point)))) - (sgml-set-markup-type nil)) - -(defun sgml-parser-loop (extra-cond) - (let (tem - (sgml-signal-data-function (function sgml-pcdata-move))) - (while (and (eq sgml-current-tree sgml-top-tree) - (or (< (point) sgml-goal) sgml-current-eref) - (progn (setq sgml-markup-start (point) - sgml-markup-type nil) - (or (sgml-parse-s) - (sgml-parse-markup-declaration 'prolog) - (sgml-parse-processing-instruction))))) - (while (and (or (< (point) sgml-goal) sgml-current-eref) - (not (if extra-cond (funcall extra-cond)))) - (assert sgml-current-tree) - (setq sgml-markup-start (point) - sgml-markup-type nil) - (cond - ((eobp) (sgml-pop-entity)) - ((and (or (eq sgml-current-state sgml-cdata) - (eq sgml-current-state sgml-rcdata))) - (if (or (sgml-parse-delim "ETAGO" gi) - (sgml-is-enabled-net)) - (sgml-do-end-tag) - (sgml-do-data sgml-current-state))) - ((and sgml-current-shortmap - (or (setq tem (sgml-deref-shortmap sgml-current-shortmap - (eq (point) - sgml-rs-ignore-pos))) - ;; Restore position, to consider the delim for S+ or data - (progn (goto-char sgml-markup-start) - nil))) - (setq sgml-rs-ignore-pos sgml-markup-start) ; don't reconsider RS - (funcall sgml-shortref-handler tem)) - ((and (not (sgml-current-mixed-p)) - (sgml-parse-s sgml-current-shortmap))) - ((or (sgml-parse-delim "ETAGO" gi) - (sgml-is-enabled-net)) - (sgml-do-end-tag)) - ((sgml-parse-delim "STAGO" gi) - (sgml-do-start-tag)) - ((sgml-parse-general-entity-ref)) - ((sgml-parse-markup-declaration nil)) - ((sgml-parse-delim "MS-END") ; end of marked section - (sgml-set-markup-type 'ms-end)) - ((sgml-parse-processing-instruction)) - (t - (sgml-do-pcdata)))))) - -(defun sgml-handle-shortref (name) - (sgml-set-markup-type 'shortref) - (sgml-do-entity-ref name)) - -(defun sgml-do-start-tag () - ;; Assume point after STAGO - (when sgml-throw-on-element-change - (throw sgml-throw-on-element-change 'start)) - (setq sgml-conref-flag nil) - (let (net-enabled et asl) - (setq et (if (sgml-is-delim "TAGC") ; empty start-tag - (sgml-do-empty-start-tag) - (sgml-lookup-eltype (sgml-check-name)))) - (unless (sgml-parse-delim "TAGC") ; optimize common case - (setq asl (sgml-parse-attribute-specification-list et)) - (or - (if (sgml-parse-delim "NET") - (prog1 (setq net-enabled t) - (or sgml-current-shorttag - (sgml-log-warning - "NET enabling start-tag is not allowed with SHORTTAG NO")))) - (sgml-check-tag-close))) - (sgml-set-markup-type 'start-tag) - (cond ((and sgml-ignore-undefined-elements - (not (sgml-eltype-defined et))) - (when sgml-warn-about-undefined-elements - (sgml-log-warning - "Start-tag of undefined element %s; ignored" - (sgml-eltype-name et)))) - (t - (sgml-do-move (sgml-eltype-token et) - (format "%s start-tag" (sgml-eltype-name et))) - (sgml-open-element et sgml-conref-flag - sgml-markup-start (point) asl) - (when net-enabled - (setf (sgml-tree-net-enabled sgml-current-tree) t)))))) - - -(defun sgml-do-empty-start-tag () - "Return eltype to use if empty start tag" - (cond - ;; Document element if no element is open - ((eq sgml-current-tree sgml-top-tree) - (sgml-lookup-eltype - (sgml-dtd-doctype sgml-dtd-info))) - ;; If omittag use current open element - (sgml-current-omittag - (sgml-tree-eltype sgml-current-tree)) - ;; Find the eltype of the last closed element. - ;; If element has a left sibling then use that - (sgml-previous-tree - (sgml-tree-eltype sgml-previous-tree)) - ;; No sibling, last closed must be found in enclosing element - (t - (loop named outer - for current = sgml-current-tree then (sgml-tree-parent current) - for parent = (sgml-tree-parent current) - do;; Search for a parent with a child before current - (when (eq parent sgml-top-tree) - (sgml-error "No previously closed element")) - (unless (eq current (sgml-tree-content parent)) - ;; Search content of u for element before current - (loop for c = (sgml-tree-content parent) then (sgml-tree-next c) - do (when (eq current (sgml-tree-next c)) - (return-from outer (sgml-tree-eltype c))))))))) - - -(defun sgml-do-end-tag () - "Assume point after </ or at / in a NET" - (let ((gi "Null") ; Name of element to end or "NET" - et ; Element type of end tag - (found ; Set to true when found element to end - t)) - (cond ((sgml-parse-delim "TAGC") ; empty end-tag - (setq et (sgml-tree-eltype sgml-current-tree))) - ((sgml-parse-delim "NET")) - (t - (setq et (sgml-lookup-eltype (sgml-check-name))) - (sgml-parse-s) - (sgml-check-tag-close))) - (sgml-set-markup-type 'end-tag) ; This will create the overlay for - ; the end-tag before the element - ; is closed - (when et - (setq gi (sgml-eltype-name et)) - (setq found ; check if there is an open element - ; with the right eltype - (loop for u = sgml-current-tree then (sgml-tree-parent u) - while u - thereis (eq et (sgml-tree-eltype u)))) - (unless found - (sgml-log-warning - "End-tag %s does not end any open element; ignored" - gi))) - (when found - (setq found nil) - (while (not found) ; Loop until correct element to - ; end is found - (unless (sgml-final-p sgml-current-state) - (sgml-log-warning - "%s element can't end here, need one of %s; %s end-tag out of context" - (sgml-element-gi sgml-current-tree) - (sgml-required-tokens sgml-current-state) - gi)) - (when (eq sgml-current-tree sgml-top-tree) - (sgml-error "%s end-tag ended document and parse" gi)) - (setq found - (or (eq et (sgml-tree-eltype sgml-current-tree)) - (and (null et) ; Null end-tag - (eq t (sgml-tree-net-enabled sgml-current-tree))))) - (unless found - (sgml-implied-end-tag (format "%s end-tag" gi) - sgml-markup-start sgml-markup-start))) - (sgml-close-element sgml-markup-start (point))))) - -(defun sgml-is-goal-after-start (goal tree) - (and tree - (if (sgml-bpos-p (sgml-tree-stag-epos tree)) - (> goal (sgml-tree-stag-epos tree)) - (>= goal (sgml-epos-after (sgml-tree-stag-epos tree)))))) - -(defun sgml-find-start-point (goal) - (let ((u sgml-top-tree)) - (while - (cond - ((sgml-is-goal-after-start goal (sgml-tree-next u)) - (setq u (sgml-tree-next u))) - ((and (sgml-tree-etag-epos u) - (if (> (sgml-tree-etag-len u) 0) ; if threre is an end-tag - (>= goal (sgml-tree-end u)) ; precisely after is after - (> goal (sgml-tree-end u)))) ; else it could possibly - ; become part of the element - (sgml-set-parse-state u 'after) - nil) - ((sgml-is-goal-after-start goal (sgml-tree-content u)) - (setq u (sgml-tree-content u))) - (t - (sgml-set-parse-state u 'start) - nil))) - ) - ) - - -(defun sgml-check-tag-close () - (or - (sgml-parse-delim "TAGC") - (if (or (sgml-is-delim "STAGO" gi) - (sgml-is-delim "ETAGO" gi)) - (or sgml-current-shorttag - (sgml-log-warning - "Unclosed tag is not allowed with SHORTTAG NO") - t)) - (sgml-error "Invalid character in markup %c" - (following-char)))) - -(defun sgml-implied-end-tag (type start end) - (cond ((eq sgml-current-tree sgml-top-tree) - (unless (= start (point-max)) - (sgml-error - "document ended by %s" type))) - ((not - (and sgml-current-omittag - (sgml-element-etag-optional sgml-current-tree))) - (sgml-log-warning - "%s end-tag implied by %s; not minimizable" - (sgml-element-gi sgml-current-tree) - type))) - (sgml-close-element start end)) - - -;;;; Parsing tasks and extending the element view of the parse tree - -(defun sgml-find-context-of (pos) - "Find the parser context for POS, returns the parse tree. -Also sets sgml-current-tree and sgml-current-state. If POS is in -markup, sgml-markup-type will be a symbol identifying the markup -type. It will be nil otherwise." - (save-excursion - (sgml-parse-to pos) - (cond ((and (> (point) pos) - sgml-markup-type) - ;;(setq sgml-current-state sgml-markup-type) - (cond ((memq sgml-markup-type '(start-tag end-tag)) - (setq sgml-current-tree sgml-markup-tree)))) - (t - (setq sgml-markup-type nil))) - sgml-current-tree)) - -(defun sgml-parse-to-here () - "Find context of point. -See documentation of sgml-find-context-of." - (sgml-find-context-of (point))) - -(defun sgml-find-element-of (pos) - "Find the element containing character at POS." - (when (eq pos (point-max)) - (error "End of buffer")) - (save-excursion - (sgml-parse-to (1+ pos)) ; Ensures that the element is - ; in the tree. - ;; Find p in u: - ;; assert p >= start(u) - ;; if next(u) and p >= start(next(u)): find p in next(u) - ;; else if end(u) and p >= end(u): in parent(u) unless u is top - ;; else if content: - ;; if p < start(content(u)): in u - ;; else find p in content(u) - ;; else: in u - (let ((u sgml-top-tree)) - (while ; pos >= start(u) - (cond ((and (sgml-tree-next u) - (>= pos (sgml-element-start (sgml-tree-next u)))) - (setq u (sgml-tree-next u))) ; continue searching next node - ((and (sgml-tree-etag-epos u) - (>= pos (sgml-tree-end u))) - (setq u (sgml-tree-parent u)) ; must be parent node - nil) - ((and (sgml-tree-content u) - (>= pos (sgml-element-start (sgml-tree-content u)))) - (setq u (sgml-tree-content u))))) ; search content - u))) - -(defun sgml-find-previous-element (pos &optional in-element) - "Find the element before POS and return it, error if non found. -If in IN-ELEMENT is given look for previous element in IN-ELEMENT else -look in current element. If this element has no content elements but -end at POS, it will be returned as previous element." - (save-excursion - ;; Parse to point; now the previous element is in the parse tree - (sgml-parse-to pos) - ;; containing element may be given or obtained from parser - (or in-element (setq in-element sgml-current-tree)) - ;; in-element is the containing element - (let* ((c ; this is the content of the - ; containing element - (sgml-tree-content in-element))) - (while - (cond - ((null c) ; If c = Nil: no previous element. - ;; But maybe the containing element ends at pos too. - (cond ((= pos (sgml-element-end in-element)) - (setq c in-element))) ; Previous is parent! - nil) - ((<= pos (sgml-element-start c)) ; Pos before first content el - (setq c nil)) ; No, previous element. - ((null (sgml-tree-next c)) nil) ; No next, c must be the prev el - ((>= (sgml-element-start (sgml-tree-next c)) pos) - nil) - (t - (setq c (sgml-tree-next c))))) - (or c - (error "No previous element in %s element" - (sgml-element-gi in-element)))))) - -(defun sgml-find-element-after (pos &optional in-element) - "Find the first element starting after POS. -Returns parse tree; error if no element after POS." - (setq in-element (or in-element - (save-excursion (sgml-find-context-of pos)))) - (or - ;; First try to find element after POS in IN-ELEMENT/current element - (let ((c ; content of in-element - (sgml-element-content in-element))) - (while (and c - (> pos (sgml-element-start c))) - (setq c (sgml-element-next c))) - c) - ;; If there is no more elements IN-ELEMENT/current element try - ;; to identify the element containing the character after POS. - ;; If this element starts at POS, use it for element after POS. - (let ((el (sgml-find-element-of pos))) - (if (and el (= pos (sgml-element-start el))) - el)) - (progn - (sgml-message "") ; force display of log buffer - (error "No more elements in %s element" - (sgml-element-gi in-element))))) - -(defun sgml-element-content (element) - "First element in content of ELEMENT, or nil." - (when (null (or (sgml-tree-content element) - (sgml-tree-etag-epos element))) - (save-excursion (sgml-parse-until-end-of t))) - (sgml-tree-content element)) - -(defun sgml-element-next (element) - "Next sibling of ELEMENT." - (unless (sgml-tree-etag-epos element) - (save-excursion (sgml-parse-until-end-of element))) - (unless (or (sgml-tree-next element) - (sgml-tree-etag-epos (sgml-tree-parent element))) - (save-excursion (sgml-parse-until-end-of t))) - (sgml-tree-next element)) - -(defun sgml-element-etag-start (element) - "Last position in content of ELEMENT and start of end-tag, if any." - (unless (sgml-tree-etag-epos element) - (save-excursion - (sgml-parse-until-end-of element))) - (assert (sgml-tree-etag-epos element)) - (sgml-epos-promote (sgml-tree-etag-epos element))) - -(defun sgml-element-end (element) - "First position after ELEMENT." - (sgml-element-etag-start element) ; make end be defined - (sgml-tree-end element)) - -(defun sgml-read-element-name (prompt) - (sgml-parse-to-here) - (cond (sgml-markup-type - (error "No elements allowed in markup")) - ((and ;;sgml-buffer-eltype-map - (not (eq sgml-current-state sgml-any))) - (let ((tab - (mapcar (function (lambda (x) (cons (symbol-name x) nil))) - (sgml-current-list-of-valid-eltypes)))) - (cond ((null tab) - (error "No element valid at this point")) - (t - (completing-read prompt tab nil t - (and (null (cdr tab)) (caar tab))))))) - (t - (read-from-minibuffer prompt)))) - -(defun sgml-element-attribute-specification-list (element) - "Return the attribute specification list for ELEMENT. -This is a list of (attname value) lists." -;;; (if (> (sgml-element-stag-len element) 2) -;;; (save-excursion -;;; (sgml-with-parser-syntax -;;; (sgml-goto-epos (sgml-element-stag-epos element)) -;;; (sgml-check-delim "STAGO") -;;; (sgml-check-name) -;;; (prog1 (sgml-parse-attribute-specification-list -;;; (sgml-element-eltype element)) -;;; (sgml-pop-all-entities))))) - (sgml-tree-asl element)) - -(defun sgml-find-attribute-element () - "Return the element to which an attribute editing command should be applied." - (let ((el (sgml-find-element-of (point)))) - (save-excursion - (sgml-parse-to (point)) - ;; If after a start-tag of an empty element return that element - ;; instead of current element - (if (eq sgml-markup-type 'start-tag) - sgml-markup-tree ; the element of the start-tag - el)))) - - -(defun sgml-element-attval (element attribute) - "Return the value of the ATTRIBUTE in ELEMENT, string or nil." - (let ((asl (sgml-element-attribute-specification-list element)) - (def (sgml-attdecl-default-value - (sgml-lookup-attdecl attribute (sgml-element-attlist element))))) - (or (sgml-attspec-attval (sgml-lookup-attspec attribute asl)) - (sgml-default-value-attval def)))) - - -(defun sgml-cohere-name (x) - "Convert X into a string where X can be a string, a symbol or an element." - (cond ((stringp x) x) - ((symbolp x) (symbol-name x)) - (t (sgml-element-gi x)))) - -(defun sgml-start-tag-of (element) - "Return the start-tag for ELEMENT." - (format "<%s>" (sgml-cohere-name element))) - -(defun sgml-end-tag-of (element) - "Return the end-tag for ELEMENT (token or element)." - (format "</%s>" (sgml-cohere-name element))) - -(defun sgml-top-element () - "Return the document element." - (sgml-element-content (sgml-find-context-of (point-min)))) - -(defun sgml-off-top-p (element) - "True if ELEMENT is the pseudo element above the document element." - (null (sgml-tree-parent element))) - -(defun sgml-safe-context-of (pos) - (let ((sgml-throw-on-error 'parse-error)) - (catch sgml-throw-on-error - (sgml-find-context-of pos)))) - -(defun sgml-safe-element-at (pos) - (let ((sgml-throw-on-error 'parse-error)) - (catch sgml-throw-on-error - (if (= pos (point-max)) - (sgml-find-context-of pos) - (sgml-find-element-of pos))))) - -(defun sgml-in-prolog-p () - (let ((el (sgml-safe-context-of (point)))) - (or (null el) - (sgml-off-top-p el)))) - - -;;;; Provide - -(provide 'psgml-parse) - -;; Local variables: -;; byte-compile-warnings:(free-vars unresolved callargs redefine) -;; End: -;;; psgml-parse.el ends here
--- a/lisp/psgml/psgml-style.fs Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -;;; style.fs --- example style file for fs.el and catalog.sgml -*- lisp -*- - -( - ("example" - default-top 1 - default-bottom 1) - ("front") - ("body") - ("pubfront" text "") - ("abstract" - block t - before (block t text "ABSTRACT") - left 4) - ("p" block t) - ("title" block t) - ("titlegrp" block t bottom 2 default-bottom 0 default-top 0) - ("subtitle" before (text " // ")) - ("list" block t) - ("head" block t) - ("item" - left (+ (fs-char 'left) 3) - hang-from " * ") - ("keyword" - before (text "|") - after (text "|")) - ("chapter" block t top 2 before (text "CHAPTER")) - ("lit" block t literal t) - (t - before (text (format "<%s>" (sgml-element-gi e))) - after (text " ") - ) -)
--- a/lisp/psgml/psgml-xemacs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,255 +0,0 @@ -;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support -;; $Id: psgml-xemacs.el,v 1.2 1997/04/24 04:00:12 steve Exp $ - -;; Copyright (C) 1994 Lennart Staflin - -;; Author: Lennart Staflin <lenst@lysator.liu.se> -;; William M. Perry <wmperry@indiana.edu> -;; Synced up with Ben Wing's changes for XEmacs 19.14 by -;; Steven L Baur <steve@miranova.com> - -;; -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; Commentary: - -;;; Part of psgml.el - -;;; Menus for use with XEmacs - - -;;;; Code: - -(require 'psgml) -;;(require 'easymenu) - -(eval-and-compile - (autoload 'sgml-do-set-option "psgml-edit")) - -(defvar sgml-max-menu-size (/ (* (frame-height) 2) 3) - "*Max number of entries in Tags and Entities menus before they are split -into several panes.") - -;;;; Pop Up Menus - -(defun sgml-popup-menu (event title entries) - "Display a popup menu." - (setq entries - (loop for ent in entries collect - (vector (car ent) - (list 'setq 'value (list 'quote (cdr ent))) - t))) - (cond ((> (length entries) sgml-max-menu-size) - (setq entries - (loop for i from 1 while entries collect - (let ((submenu - (subseq entries 0 (min (length entries) - sgml-max-menu-size)))) - (setq entries (nthcdr sgml-max-menu-size - entries)) - (cons - (format "%s '%s'-'%s'" - title - (sgml-range-indicator (aref (car submenu) 0)) - (sgml-range-indicator - (aref (car (last submenu)) 0))) - submenu)))))) - (sgml-xemacs-get-popup-value (cons title entries))) - - -(defun sgml-range-indicator (string) - (substring string - 0 - (min (length string) sgml-range-indicator-max-length))) - - -(defun sgml-xemacs-get-popup-value (menudesc) - (let ((value nil) - (event nil)) - (popup-menu menudesc) - (while (popup-up-p) - (setq event (next-command-event event)) - (cond ((menu-event-p event) - (cond - ((eq (event-object event) 'abort) - (signal 'quit nil)) - ((eq (event-object event) 'menu-no-selection-hook) - nil) - ((commandp (event-object event)) - (call-interactively (event-object event)) - (signal 'quit nil)) - (t - (eval (event-object event))))) - ((button-release-event-p event) ; don't beep twice - nil) - ;; [sb] added condition - ((and (fboundp 'event-matches-key-specifier-p) - (event-matches-key-specifier-p event (quit-char))) - (signal 'quit nil)) - (t - (beep) - (message "please make a choice from the menu.")))) - value)) - -(defun sgml-popup-multi-menu (pos title menudesc) - "Display a popup menu. -MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...). -ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated -if the item is selected." - (popup-menu - (cons title - (loop for menu in menudesc collect - (cons (car menu) ; title - (loop for item in (cdr menu) collect - (if (stringp item) - item - (vector (car item) (cadr item) t)))))))) - - -;;;; XEmacs menu bar - -(defun sgml-make-options-menu (vars) - (loop for var in vars - for type = (sgml-variable-type var) - for desc = (sgml-variable-description var) - collect - (cond - ((eq type 'toggle) - (vector desc (list 'setq var (list 'not var)) - ':style 'toggle ':selected var)) - ((consp type) - (cons desc - (loop for c in type collect - (if (atom c) - (vector (prin1-to-string c) - (`(setq (, var) (, c))) - :style 'toggle - :selected (`(eq (, var) '(, c)))) - (vector (car c) - (`(setq (, var) '(,(cdr c)))) - :style 'toggle - :selected (`(eq (, var) '(,(cdr c))))))))) - (t - (vector desc - (`(sgml-do-set-option '(, var))) - t))))) - - -(unless (or (not (boundp 'emacs-major-version)) - (and (boundp 'emacs-minor-version) - (< emacs-minor-version 10))) - (loop for ent on sgml-main-menu - if (vectorp (car ent)) - do (cond - ((equal (aref (car ent) 0) "File Options >") - (setcar ent - (cons "File Options" - (sgml-make-options-menu sgml-file-options)))) - ((equal (aref (car ent) 0) "User Options >") - (setcar ent - (cons "User Options" - (sgml-make-options-menu sgml-user-options))))))) - - -;;;; Key definitions - -(define-key sgml-mode-map [button3] 'sgml-tags-menu) - - -;;;; Insert with properties - -(defun sgml-insert (props format &rest args) - (let ((start (point)) - tem) - (insert (apply (function format) - format - args)) - (remf props 'rear-nonsticky) ; not useful in XEmacs - - ;; Copy face prop from category - (when (setq tem (getf props 'category)) - (when (setq tem (get tem 'face)) - (set-face-underline-p (make-face 'underline) t) - (setf (getf props 'face) tem))) - - (add-text-properties start (point) props) - - ;; A read-only value of 1 is used for the text after values - ;; and this should in XEmacs be open at the front. - (if (eq 1 (getf props 'read-only)) - (set-extent-property - (extent-at start nil 'read-only) - 'start-open t)))) - - -;;;; Set face of markup - -(defun sgml-set-face-for (start end type) - (let ((face (cdr (assq type sgml-markup-faces))) - o) - (loop for e being the extents from start to end - do (when (extent-property e 'sgml-type) - (cond ((and (null o) - (eq type (extent-property e 'sgml-type))) - (setq o e)) - (t (delete-extent e))))) - - (cond (o - (set-extent-endpoints o start end)) - (face - (setq o (make-extent start end)) - (set-extent-property o 'sgml-type type) - (set-extent-property o 'face face) - (set-extent-property o 'start-open t) - (set-extent-face o face))))) - -(defun sgml-set-face-after-change (start end &optional pre-len) - ;; This should not be needed with start-open t - (when sgml-set-face - (let ((o (extent-at start nil 'sgml-type))) - (cond - ((null o)) - ((= start (extent-start-position o)) - (set-extent-endpoints o end (extent-end-position o))) - (t (delete-extent o)))))) - -;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el - -(defun sgml-clear-faces () - (interactive) - (loop for o being the overlays - if (extent-property o 'type) - do (delete-extent o))) - - -;;;; Functions not in XEmacs - -(unless (fboundp 'frame-width) - (defalias 'frame-width 'screen-width)) - -(unless (fboundp 'frame-height) - (defalias 'frame-height 'screen-height)) - -(unless (fboundp 'buffer-substring-no-properties) - (defalias 'buffer-substring-no-properties 'buffer-substring)) - - -;;;; Provide - -(provide 'psgml-xemacs) - - -;;; psgml-xemacs.el ends here
--- a/lisp/psgml/psgml.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1532 +0,0 @@ -;;; psgml.el --- SGML-editing mode with parsing support -;; $Id: psgml.el,v 1.10 1997/10/12 01:39:52 steve Exp $ - -;; Copyright (C) 1993, 1994, 1995, 1996 Lennart Staflin -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Lennart Staflin <lenst@lysator.liu.se> -;; James Clark <jjc@clark.com> -;; Maintainer: Lennart Staflin <lenst@lysator.liu.se> -;; Keywords: languages - -;; -;; This program 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 -;; of the License, or (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; Commentary: - -;; Major mode for editing the SGML document-markup language. - -;; Send bugs to lenst@lysator.liu.se - -;; WHAT IT CAN DO - -;; - Identify structural errors (but it is not a validator) -;; - Menus for inserting tags with only the contextually valid tags -;; - Edit attribute values in separate window with information about types -;; and defaults -;; - Hide attributes -;; - Fold elements -;; - Indent according to element nesting depth -;; - Show context -;; - Structure editing: move and kill by element -;; - Find next data context - -;; LIMITATIONS - -;; - only accepts the referece concrete syntax, though it does allow -;; unlimited lengths on names - - -;;; Code: - -(defconst psgml-version "1.0.1" - "Version of psgml package.") - -(defconst psgml-maintainer-address "lenst@lysator.liu.se") - -(require 'cl) -(require 'easymenu) - -(defvar sgml-debug nil) - -(defmacro sgml-debug (&rest x) - (list 'if 'sgml-debug (cons 'sgml-log-message x))) - - -;;;; Variables - -(defvar sgml-mode-abbrev-table nil - "Abbrev table in use in sgml-mode.") -(define-abbrev-table 'sgml-mode-abbrev-table ()) - -(defvar sgml-running-xemacs - (not (not (string-match "Lucid\\|XEmacs" emacs-version)))) - -;;; User settable options: - -(defgroup sgml nil - "Standard Generalized Markup Language" - :group 'languages) - -(defgroup psgml nil - "SGML-editing mode with parsing support" - :prefix "sgml-" - :group 'sgml) - -(defgroup psgml-insert nil - "Inserting features of psgml" - :prefix "sgml-" - :group 'psgml) - -(defgroup psgml-dtd nil - "DTD, CATALOG and DOCTYPE customizations in psgml" - :prefix "sgml-" - :group 'psgml) - - -(defcustom sgml-insert-missing-element-comment t - "*If true, and sgml-auto-insert-required-elements also true, -`sgml-insert-element' will insert a comment if there is an element required -but there is more than one to choose from." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-insert-end-tag-on-new-line nil - "*If true, `sgml-insert-element' will put the end-tag on a new line -after the start-tag. Useful on slow terminals if you find the end-tag after -the cursor irritating." - :type 'boolean - :group 'psgml-insert) - -(defvar sgml-doctype nil - "*If set, this should be the name of a file that contains the doctype -declaration to use. -Setting this variable automatically makes it local to the current buffer.") -(put 'sgml-doctype 'sgml-type 'string) -(make-variable-buffer-local 'sgml-doctype) - -(defcustom sgml-system-identifiers-are-preferred nil - "*If nil, PSGML will look up external entities by searching the catalogs -in `sgml-local-catalogs' and `sgml-catalog-files' and only if the -entity is not found in the catalogs will a given system identifer be -used. If the variable is non-nil and a system identifer is given, the -system identifier will be used for the entity. If no system identifier -is given the catalogs will searched." - :type 'boolean - :group 'psgml-dtd) - -(defcustom sgml-range-indicator-max-length 9 - "*Maximum number of characters used from the first and last entry -of a submenu to indicate the range of that menu." - :type 'integer - :group 'psgml) - -(defcustom sgml-default-doctype-name nil - "*Document type name to use if no document type declaration is present." - :type '(choice string (const nil)) - :group 'psgml-dtd) - -(put 'sgml-default-doctype-name 'sgml-type 'string-or-nil) - -(defcustom sgml-markup-faces '((start-tag . bold) - (end-tag . bold) - (comment . italic) - (pi . bold) - (sgml . bold) - (doctype . bold) - (entity . bold-italic) - (shortref . bold)) - "*List of markup to face mappings. -Element are of the form (MARKUP-TYPE . FACE). -Possible values for MARKUP-TYPE is: -comment - comment declaration -doctype - doctype declaration -end-tag -ignored - ignored marked section -ms-end - marked section start, if not ignored -ms-start- marked section end, if not ignored -pi - processing instruction -sgml - SGML declaration -start-tag -entity - general entity reference -shortref- short reference" - :type '(repeat (cons symbol face)) - :group 'psgml) - -(defvar sgml-buggy-subst-char-in-region - (or (not (boundp 'emacs-minor-version)) - (not (natnump emacs-minor-version)) - (< emacs-minor-version 23)) - "*If non-nil, work around a bug in subst-char-in-region. -The bug sets the buffer modified. If this is set, folding commands -will be slower.") - -(defcustom sgml-set-face nil - "*If non-nil, psgml will set the face of parsed markup." - :type 'boolean - :group 'psgml) -(put 'sgml-set-face 'sgml-desc "Set face of parsed markup") - -(defcustom sgml-live-element-indicator nil - "*If non-nil, indicate current element in mode line." - :type 'boolean - :group 'psgml) - -(defcustom sgml-auto-activate-dtd nil - "*If non-nil, loading a sgml-file will automatically try to activate its DTD. -Activation means either to parse the document type declaration or to -load a previously saved parsed DTD. The name of the activated DTD -will be shown in the mode line." - :type 'boolean - :group 'psgml-dtd) -(put 'sgml-auto-activate-dtd 'sgml-desc "Auto Activate DTD") - -(defcustom sgml-offer-save t - "*If non-nil, ask about saving modified buffers before \\[sgml-validate] is run." - :type 'boolean - :group 'psgml) - -(defvar sgml-parent-document nil - "* Used when the current file is part of a bigger document. - -The variable describes how the current file's content fit into the element -hierarchy. The variable should have the form - - (PARENT-FILE CONTEXT-ELEMENT* TOP-ELEMENT (HAS-SEEN-ELEMENT*)?) - -PARENT-FILE is a string, the name of the file contatining the - document entity. -CONTEXT-ELEMENT is a string, that is the name of an element type. - It can occur 0 or more times and is used to set up - exceptions and short reference map. Good candidates - for these elements are the elements open when the - entity pointing to the current file is used. -TOP-ELEMENT is a string that is the name of the element type - of the top level element in the current file. The file - should contain one instance of this element, unless - the last \(lisp) element of sgml-parent-document is a - list. If it is a list, the top level of the file - should follow the content model of top-element. -HAS-SEEN-ELEMENT is a string that is the name of an element type. This - element is satisfied in the content model of top-element. - -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'sgml-parent-document) -(put 'sgml-parent-document 'sgml-type 'list) - -(defcustom sgml-tag-region-if-active t ;; wing change - "*If non-nil, the Tags menu will tag a region if the region is -considered active by Emacs. If nil, region must be active and -transient-mark-mode/zmacs-regions must be on for the region to be tagged." - :type 'boolean - :group 'psgml) - -(defvar sgml-normalize-trims t - "*If non-nil, sgml-normalize will trim off white space from end of element -when adding end tag.") - -(defvar sgml-omittag t - "*Set to non-nil, if you use OMITTAG YES. - -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-omittag) -(put 'sgml-omittag 'sgml-desc "OMITTAG") - -(defvar sgml-shorttag t - "*Set to non-nil, if you use SHORTTAG YES. - -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-shorttag) -(put 'sgml-shorttag 'sgml-desc "SHORTTAG") - -(defvar sgml-minimize-attributes nil - "*Determines minimization of attributes inserted by edit-attributes. -Actually two things are done -1. If non-nil, omit attribute name, if attribute value is from a token group. -2. If 'max, omit attributes with default value. - -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-minimize-attributes) -(put 'sgml-minimize-attributes 'sgml-type - '(("No" . nil) ("Yes" . t) ("Max" . max))) - -(defvar sgml-always-quote-attributes t - "*If non-nil, quote all attribute values inserted after finishing edit attributes. -Setting this variable automatically makes it local to the current buffer.") - -(make-variable-buffer-local 'sgml-always-quote-attributes) - -(defcustom sgml-auto-insert-required-elements t - "*If non-nil, automatically insert required elements in the content -of an inserted element." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-balanced-tag-edit t - "*If non-nil, always insert start-end tag pairs." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-omittag-transparent (not sgml-balanced-tag-edit) ;; wing change - "*If non-nil, will show legal tags inside elements with omittable start tags -and legal tags beyond omittable end tags." - :type 'boolean - :group 'psgml) - -(defcustom sgml-leave-point-after-insert nil - "*If non-nil, the point will remain after inserted tag(s). -If nil, the point will be placed before the inserted tag(s)." - :type 'boolean - :group 'psgml-insert) - -(defcustom sgml-warn-about-undefined-elements t - "*If non-nil, print a warning when a tag for an undefined element is found." - :type 'boolean - :group 'psgml) - -(defcustom sgml-warn-about-undefined-entities t - "*If non-nil, print a warning when an undefined entity is found." - :type 'boolean - :group 'psgml) - -(defcustom sgml-ignore-undefined-elements nil - "*If non-nil, recover from an undefined element by ignoring the tag. -If nil, recover from an undefined element by assuming it can occur any -where and has content model ANY." - :type 'boolean - :group 'psgml) - -(defcustom sgml-recompile-out-of-date-cdtd 'ask - "*If non-nil, out of date compiled DTDs will be automatically recompiled. -If the value is `ask', PSGML will ask before recompiling. A `nil' -value will cause PSGML to silently load an out of date compiled DTD. -A DTD that referes to undefined external entities is always out of -date, thus in such case it can be useful to set this variable to -`nil'." - :type 'symbol - :group 'psgml-dtd) -(put 'sgml-recompile-out-of-date-cdtd 'sgml-type '(("No" . nil) - ("Yes" . t) - ("Ask" . ask))) - -(defcustom sgml-trace-entity-lookup nil - "*If non-nil, log messages about catalog files used to look for -external entities." - :type 'boolean - :group 'psgml-dtd) - -(defvar sgml-indent-step 2 - "*How much to increment indent for every element level. -If nil, no indentation. -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'sgml-indent-step) -(put 'sgml-indent-step 'sgml-type '(("None" . nil) 0 1 2 3 4 5 6 7 8)) - -(defvar sgml-indent-data nil - "*If non-nil, indent in data/mixed context also. -Setting this variable automatically makes it local to the current buffer.") -(make-variable-buffer-local 'sgml-indent-data) - -;;; Wing addition -(defcustom sgml-inhibit-indent-tags nil - "*List of tags within which indentation is inhibited. -The tags should be given as strings." - :type 'boolean - :group 'psgml) - -(defcustom sgml-data-directory (expand-file-name "sgml" data-directory) - "*Directory for pre-supplied data files (DTD's and such). -Set this before loading psgml." - :type 'directory - :group 'psgml) - -(defcustom sgml-system-path nil - ;; wing addition - "*List of directories used to look for system identifiers. -The directory listed in `sgml-data-directory' is always searched in -addition to the directories listed here." - :type '(repeat directory) - :group 'psgml) -(put 'sgml-system-path 'sgml-type 'list) - -(defun sgml-parse-colon-path (cd-path) - "Explode a colon-separated list of paths into a string list." - (let (cd-list (cd-start 0) cd-colon) - (setq cd-path (concat cd-path ":")) - (while (setq cd-colon (string-match ":" cd-path cd-start)) - (setq cd-list - (nconc cd-list - (list (if (= cd-start cd-colon) - nil - (substitute-in-file-name - (substring cd-path cd-start cd-colon)))))) - (setq cd-start (+ cd-colon 1))) - cd-list)) - -(defcustom sgml-public-map (sgml-parse-colon-path - (or (getenv "SGML_PATH") - ;; Wing change - (concat "%S:" (directory-file-name - sgml-data-directory) - "/%o/%c/%d"))) - - "*Mapping from public identifiers to file names. -This is a list of possible file names. To find the file for a public -identifier the elements of the list are used one at the time from the -beginning. If the element is a string a file name is constructed from -the string by substitution of the whole public identifier for %P, -owner for %O, public text class for %C, and public text description -for %D. The text class will be converted to lower case and the owner -and description will be transliterated according to the variable -sgml-public-transliterations. If the file exists it will be the file -used for the public identifier. An element can also be a dotted pair -(regexp . filename), the filename is a string treated as above, but -only if the regular expression, regexp, matches the public -identifier." - :type '(repeat file) - :group 'psgml-dtd) -(put 'sgml-public-map 'sgml-type 'list) - -(defcustom sgml-local-catalogs nil -"*A list of SGML entity catalogs to be searched first when parsing the buffer. -This is used in addtion to `sgml-catalog-files', and `sgml-public-map'. -This variable is automatically local to the buffer." - :type '(repeat file) - :group 'psgml-dtd) -(make-variable-buffer-local 'sgml-local-catalogs) -(put 'sgml-local-catalogs 'sgml-type 'list) - -(defcustom sgml-catalog-files (sgml-parse-colon-path - (or (getenv "SGML_CATALOG_FILES") - ;; Wing addition - (concat "CATALOG:" - (expand-file-name - "CATALOG" - sgml-data-directory)))) - "*List of catalog entry files. -The files are in the format defined in the SGML Open Draft Technical -Resolution on Entity Management." - :type '(repeat file) - :group 'psgml-dtd) -(put 'sgml-catalog-files 'sgml-type 'list) - -;;; Wing addition -(defcustom sgml-ecat-files (list - "ECAT" - "~/sgml/ECAT" - (expand-file-name "ECAT" sgml-data-directory)) - "*List of catalog files for PSGML." - :type '(repeat file) - :group 'psgml-dtd) -(put 'sgml-ecat-files 'sgml-type 'list) - -(defcustom sgml-local-ecat-files nil - "*List of local catalog files for PSGML. -Automatically becomes buffer local if set." - :type '(repeat file) - :group 'psgml-dtd) -(make-variable-buffer-local 'sgml-local-ecat-files) -(put 'sgml-local-ecat-files 'sgml-type 'list) - -(defvar sgml-public-transliterations '((? . ?_) (?/ . ?%)) - "*Transliteration for characters that should be avoided in file names. -This is a list of dotted pairs (FROM . TO); where FROM is the the -character to be translated to TO. This is used when parts of a public -identifier are used to construct a file name.") - -(defvar sgml-default-dtd-file nil - "*This is the default file name for saved DTD. -This is set by sgml-mode from the buffer file name. -Can be changed in the Local variables section of the file.") -(put 'sgml-default-dtd-file 'sgml-type 'string) -(put 'sgml-default-dtd-file 'sgml-desc "Default (saved) DTD File") - -(defvar sgml-exposed-tags '() - "*The list of tag names that remain visible, despite \\[sgml-hide-tags]. -Each name is a lowercase string, and start-tags and end-tags must be -listed individually. - -`sgml-exposed-tags' is local to each buffer in which it has been set; -use `setq-default' to set it to a value that is shared among buffers.") -(make-variable-buffer-local 'sgml-exposed-tags) -(put 'sgml-exposed-tags 'sgml-type 'list) - - -(defvar sgml-custom-markup nil - "*Menu entries to be added to the Markup menu. -The value should be a list of lists of two strings. The first is a -string is the menu line and the second string is the text inserted -when the menu item is chosen. The second string can contain a \\r -where the cursor should be left. Also if a selection is made -according the same rules as for the Tags menu, the selection is -replaced with the second string and \\r is replaced with the -selection. - -Example: - - ((\"Version1\" \"<![%Version1[\\r]]>\") - (\"New page\" \"<?NewPage>\")) -") - -(defcustom sgml-custom-dtd nil - "Menu entries to be added to the DTD menu. -The value should be a list of entries to be added to the DTD menu. -Every entry should be a list. The first element of the entry is a string -used as the menu entry. The second element is a string containing a -doctype declaration (this can be nil if no doctype). The rest of the -list should be a list of variables and values. For backward -compatibility a singel string instead of a variable is assigned to -sgml-default-dtd-file. All variables are made buffer local and are also -added to the buffers local variables list. - -Example: - ((\"HTML\" nil - sgml-default-dtd-file \"~/sgml/html.ced\" - sgml-omittag nil sgml-shorttag nil) - (\"HTML+\" \"<!doctype htmlplus system 'htmlplus.dtd'>\" - \"~/sgml/htmlplus.ced\" - sgml-omittag t sgml-shorttag nil) - (\"DOCBOOK\" \"<!doctype docbook system 'docbook.dtd'>\" - \"~/sgml/docbook.ced\" - sgml-omittag nil sgml-shorttag t))) -" - :type '(repeat (list (string :tag "Menu Entry") - (choice (const :tag "No doctype") - (string :tag "Declaration")) - (repeat :inline t - (list :inline t - (symbol :tag "Variable") - (sexp :tag "Value"))))) - :group 'psgml-dtd) - - - -;;; Faces used in edit attribute buffer: -(put 'sgml-default 'face 'underline) ; Face for #DEFAULT -(put 'sgml-fixed 'face 'underline) ; Face of #FIXED "..." - - -;;; sgmls is a free SGML parser available from -;;; ftp.uu.net:pub/text-processing/sgml -;;; Its error messages can be parsed by next-error. -;;; The -s option suppresses output. - -(defcustom sgml-validate-command (concat "nsgmls -s -m " - sgml-data-directory - "/CATALOG %s %s") - "*The shell command to validate an SGML document. - -This is a `format' control string that by default should contain two -`%s' conversion specifications: the first will be replaced by the -value of `sgml-declaration' \(or the empty string, if nil\); the -second will be replaced by the current buffer's file name \(or the -empty string, if nil\). - -If `sgml-validate-files' is non-nil, the format string should contain -one `%s' conversion specification for each element of its result. - -If sgml-validate-command is a list, then every element should be a -string. The strings will be tried in order and %-sequences in the -string will be replaced according to the list below, if the string contains -%-sequences with no replacement value the next string will be tried. - -%b means the visited file of the current buffer -%s means the SGML declaration specified in the sgml-declaration variable -%d means the file containing the DOCTYPE declaration, if not in the buffer -" - :type 'string - :group 'psgml) - -(defvar sgml-validate-files nil - "If non-nil, a function of no arguments that returns a list of file names. -These file names will serve as the arguments to the `sgml-validate-command' -format control string instead of the defaults.") - -(defvar sgml-validate-error-regexps - '((":\\(.+\\):\\([0-9]+\\):\\([0-9]+\\):[EX]: " 1 2 3) - ("\\(error\\|warning\\) at \\([^,]+\\), line \\([0-9]+\\)" 2 3) - ("\n[a-zA-Z]?:?[^0-9 \n\t:]+:[ \t]*\\([^ \n\t:]+\\):\ -\\([0-9]+\\):\\(\\([0-9]+\\)[: \t]\\)?" 1 2 4)) - "Alist of regexps to recognize error messages from `sgml-validate'. -See `compilation-error-regexp-alist'.") - -(defcustom sgml-declaration nil - "*If non-nil, this is the name of the SGML declaration file." - :type 'hook - :group 'psgml-dtd) -(put 'sgml-declaration 'sgml-type 'string) - -(defcustom sgml-mode-hook nil - "A hook or list of hooks to be run when entering sgml-mode" - :type 'hook - :group 'psgml) - -(defconst sgml-file-options - '( - sgml-omittag - sgml-shorttag - sgml-minimize-attributes - sgml-always-quote-attributes - sgml-indent-step - sgml-indent-data - sgml-doctype - sgml-parent-document - sgml-default-dtd-file - sgml-exposed-tags - sgml-local-catalogs - sgml-local-ecat-files - ) - "Options for the current file, can be saved or set from menu." - ) - -(defconst sgml-user-options - '( - sgml-set-face - sgml-live-element-indicator - sgml-auto-activate-dtd - sgml-offer-save - sgml-tag-region-if-active - sgml-normalize-trims - sgml-auto-insert-required-elements - sgml-balanced-tag-edit - sgml-omittag-transparent - sgml-leave-point-after-insert - sgml-insert-missing-element-comment - sgml-insert-end-tag-on-new-line - sgml-warn-about-undefined-elements - sgml-warn-about-undefined-entities - sgml-ignore-undefined-elements - sgml-recompile-out-of-date-cdtd - sgml-default-doctype-name - sgml-declaration - sgml-validate-command - sgml-markup-faces - sgml-system-identifiers-are-preferred - sgml-trace-entity-lookup - sgml-system-path - sgml-public-map - sgml-catalog-files - sgml-ecat-files - ) - "User options that can be saved or set from menu." - ) - -;;; Internal variables - -(defvar sgml-validate-command-history nil - "The minibuffer history list for `sgml-validate''s COMMAND argument.") - -(defvar sgml-mode-map nil "Keymap for SGML mode") - -(defvar sgml-active-dtd-indicator nil - "Displayed in the mode line") - - -;;;; User options handling - -(defun sgml-variable-description (var) - (or (get var 'sgml-desc) - (let ((desc (symbol-name var))) - (if (string= "sgml-" (substring desc 0 5)) - (setq desc (substring desc 5))) - (loop for c across-ref desc - do (if (eq c ?-) (setf c ? ))) - (capitalize desc)))) - -(defun sgml-variable-type (var) - (or (get var 'sgml-type) - (if (memq (symbol-value var) '(t nil)) - 'toggle))) - -(defun sgml-set-local-variable (var val) - "Set the value of variable VAR to VAL in buffer and local variables list." - (set (make-local-variable var) val) - (save-excursion - (let ((prefix "") - (suffix "") - (case-fold-search t)) - (goto-char (max (point-min) (- (point-max) 3000))) - (cond ((search-forward "Local Variables:" nil t) - (setq suffix (buffer-substring (point) - (save-excursion (end-of-line 1) - (point)))) - (setq prefix - (buffer-substring (save-excursion (beginning-of-line 1) - (point)) - (match-beginning 0)))) - (t - (goto-char (point-max)) - (unless (bolp) - (insert ?\n)) - (insert - "<!-- Keep this comment at the end of the file\n" - "Local variables:\n" - "mode: sgml\n" - "End:\n" - "-->\n") - (forward-line -3))) - (let* ((endpos (save-excursion - (search-forward (format "\n%send:" prefix)))) - (varpos (search-forward (format "\n%s%s:" prefix var) endpos t))) - (cond (varpos - (delete-region (point) - (save-excursion (end-of-line 1) - (point))) - (insert (format "%S" val) suffix)) - (t - (goto-char endpos) - (beginning-of-line 1) - (insert prefix (format "%s:%S" var val) suffix ?\n))))))) - -(defun sgml-valid-option (var) - (let ((type (sgml-variable-type var)) - (val (symbol-value var))) - (cond ((eq 'string type) - (stringp val)) - ((eq 'list-or-string type) - (or (stringp val) - (consp val))) - (t - t)))) - -(defun sgml-save-options () - "Save user options for sgml-mode that have buffer local values." - (interactive) - (loop for var in sgml-file-options do - (when (sgml-valid-option var) - (sgml-set-local-variable var (symbol-value var))))) - - -;;;; Run hook with args - -(unless (fboundp 'run-hook-with-args) - (defun run-hook-with-args (hook &rest args) - "Run HOOK with the specified arguments ARGS. -HOOK should be a symbol, a hook variable. If HOOK has a non-nil -value, that value may be a function or a list of functions to be -called to run the hook. If the value is a function, it is called with -the given arguments and its return value is returned. If it is a list -of functions, those functions are called, in order, -with the given arguments ARGS. -It is best not to depend on the value return by `run-hook-with-args', -as that may change." - (and (boundp hook) - (symbol-value hook) - (let ((value (symbol-value hook))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (mapcar '(lambda (foo) (apply foo args)) - value) - (apply value args)))))) - - - - -;;;; SGML mode: template functions - -(defun sgml-markup (entry text) - (cons entry - (` (lambda () - (interactive) - (sgml-insert-markup (, text)))))) - -(defun sgml-insert-markup (text) - (let ((end (sgml-mouse-region)) - before after - old-text) - (when end - (setq old-text (buffer-substring (point) end)) - (delete-region (point) end)) - (setq before (point)) - (if (stringp text) - (insert text) - (eval text)) - (setq after (point)) - (goto-char before) - (when (search-forward "\r" after t) - (delete-char -1)) - (when old-text (insert old-text)))) - -(defun sgml-mouse-region () - (let (start end) - (cond - (sgml-running-xemacs - (cond - ((null (mark-marker)) nil) - (t (setq start (region-beginning) - end (region-end))))) - ((and transient-mark-mode - mark-active) - (setq start (region-beginning) - end (region-end))) - ((and mouse-secondary-overlay - (eq (current-buffer) - (overlay-buffer mouse-secondary-overlay))) - (setq start (overlay-start mouse-secondary-overlay) - end (overlay-end mouse-secondary-overlay)) - (delete-overlay mouse-secondary-overlay))) - (when start - (goto-char start)) - end)) - - -;;;; SGML mode: indentation - -(defun sgml-indent-or-tab () - "Indent line in proper way for current major mode." - (interactive) - (if (null sgml-indent-step) - (insert-tab) - (funcall indent-line-function))) - -;;;; Bug reporting - -(eval-and-compile - (autoload 'reporter-submit-bug-report "reporter")) - -(defun sgml-submit-bug-report () - "Submit via mail a bug report on PSGML." - (interactive) - (and (y-or-n-p "Do you really want to submit a report on PSGML? ") - (reporter-submit-bug-report - psgml-maintainer-address - (concat "psgml.el " psgml-version) - (list - 'sgml-always-quote-attributes - 'sgml-auto-activate-dtd - 'sgml-auto-insert-required-elements - 'sgml-balanced-tag-edit - 'sgml-catalog-files - 'sgml-declaration - 'sgml-doctype - 'sgml-ecat-files - 'sgml-indent-data - 'sgml-indent-step - 'sgml-leave-point-after-insert - 'sgml-live-element-indicator - 'sgml-local-catalogs - 'sgml-local-ecat-files - 'sgml-markup-faces - 'sgml-minimize-attributes - 'sgml-normalize-trims - 'sgml-omittag - 'sgml-omittag-transparent - 'sgml-parent-document - 'sgml-public-map - 'sgml-set-face - 'sgml-shorttag - 'sgml-tag-region-if-active - )))) - - -;;;; SGML mode: keys and menus - -(if sgml-mode-map - () - (setq sgml-mode-map (make-sparse-keymap))) - -;;; Key commands - -(define-key sgml-mode-map [(tab)] 'sgml-indent-or-tab) -;;;(define-key sgml-mode-map [(?<)] 'sgml-insert-tag) -(define-key sgml-mode-map [(?>)] 'sgml-close-angle) -(define-key sgml-mode-map [(?/)] 'sgml-slash) -(define-key sgml-mode-map [(control ?c) (?#)] 'sgml-make-character-reference) -(define-key sgml-mode-map [(control ?c) (?-)] 'sgml-untag-element) -(define-key sgml-mode-map [(control ?c) (?+)] 'sgml-insert-attribute) -(define-key sgml-mode-map [(control ?c) (?/)] 'sgml-insert-end-tag) -(define-key sgml-mode-map [(control ?c) (?<)] 'sgml-insert-tag) -(define-key sgml-mode-map [(control ?c) (?=)] 'sgml-change-element-name) -(define-key sgml-mode-map [(control ?c) (control ?a)] 'sgml-edit-attributes) -(define-key sgml-mode-map [(control ?c) (control ?c)] 'sgml-show-context) -(define-key sgml-mode-map [(control ?c) (control ?d)] 'sgml-next-data-field) -(define-key sgml-mode-map [(control ?c) (control ?e)] 'sgml-insert-element) -(define-key sgml-mode-map [(control ?c) (control ?k)] 'sgml-kill-markup) -(define-key sgml-mode-map [(control ?c) (control ?l)] 'sgml-show-or-clear-log) -(define-key sgml-mode-map [(control ?c) (control ?n)] 'sgml-up-element) -(define-key sgml-mode-map [(control ?c) (control ?o)] 'sgml-next-trouble-spot) -(define-key sgml-mode-map [(control ?c) (control ?p)] 'sgml-parse-prolog) -(define-key sgml-mode-map [(control ?c) (control ?q)] 'sgml-fill-element) -(define-key sgml-mode-map [(control ?c) (control ?r)] 'sgml-tag-region) -(define-key sgml-mode-map [(control ?c) (control ?s)] 'sgml-unfold-line) -(define-key sgml-mode-map [(control ?c) (control ?t)] 'sgml-list-valid-tags) -(define-key sgml-mode-map [(control ?c) (control ?v)] 'sgml-validate) -(define-key sgml-mode-map [(control ?c) (control ?w)] 'sgml-what-element) -(define-key sgml-mode-map [(control ?c) (control ?z)] 'sgml-trim-and-leave-element) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?e)] 'sgml-fold-element) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?r)] 'sgml-fold-region) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?s)] 'sgml-fold-subelement) -(define-key sgml-mode-map [(control ?c) (control ?f) (control ?x)] 'sgml-expand-element) -(define-key sgml-mode-map [(meta control ?O)] 'sgml-split-element) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?e)] 'sgml-unfold-element) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?a)] 'sgml-unfold-all) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?l)] 'sgml-unfold-line) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?d)] 'sgml-custom-dtd) -(define-key sgml-mode-map [(control ?c) (control ?u) (control ?m)] 'sgml-custom-markup) - -(define-key sgml-mode-map [(meta control ?a)] 'sgml-beginning-of-element) -(define-key sgml-mode-map [(meta control ?e)] 'sgml-end-of-element) -(define-key sgml-mode-map [(meta control ?f)] 'sgml-forward-element) -(define-key sgml-mode-map [(meta control ?b)] 'sgml-backward-element) -(define-key sgml-mode-map [(meta control ?d)] 'sgml-down-element) -(define-key sgml-mode-map [(meta control ?u)] 'sgml-backward-up-element) -(define-key sgml-mode-map [(meta control ?k)] 'sgml-kill-element) -(define-key sgml-mode-map [(meta control ?@)] 'sgml-mark-element) -(define-key sgml-mode-map [(meta control ?h)] 'sgml-mark-current-element) -(define-key sgml-mode-map [(meta control ?t)] 'sgml-transpose-element) -(define-key sgml-mode-map [(meta tab)] 'sgml-complete) - -;;;; Menu bar - -(easy-menu-define - sgml-dtd-menu sgml-mode-map "DTD menu" - '("DTD")) - -(defconst sgml-dtd-root-menu - '("DTD" - ["Parse DTD" sgml-parse-prolog t] - ("Info" - ["General DTD info" sgml-general-dtd-info t] - ["Describe element type" sgml-describe-element-type t] - ["Describe entity" sgml-describe-entity t] - ["List elements" sgml-list-elements t] - ["List attributes" sgml-list-attributes t] - ["List terminals" sgml-list-terminals t] - ["List content elements" sgml-list-content-elements t] - ["List occur in elements" sgml-list-occur-in-elements t] - ) - "--" - ["Load Parsed DTD" sgml-load-dtd t] - ["Save Parsed DTD" sgml-save-dtd t] - )) - -(easy-menu-define - sgml-view-menu sgml-mode-map "View menu" - '("View" - ["Fold Element" sgml-fold-element t] - ["Fold Subelement" sgml-fold-subelement t] - ["Unfold Line" sgml-unfold-line t] - ["Unfold Element" sgml-unfold-element t] - ["Expand" sgml-expand-element t] - ["Fold Region" sgml-fold-region t] - ["Unfold All" sgml-unfold-all t] - ["Hide Tags" sgml-hide-tags t] - ["Hide Attributes" sgml-hide-attributes t] - ["Show All Tags" sgml-show-tags t] - ) - ) - - -(defconst sgml-markup-root-menu - '("Markup" - ["Insert Element" sgml-element-menu t] - ["Insert Start-Tag" sgml-start-tag-menu t] - ["Insert End-Tag" sgml-end-tag-menu t] - ["Tag Region" sgml-tag-region-menu t] - ["Insert Attribute" sgml-attrib-menu t] - ["Insert Entity" sgml-entities-menu t] - )) - -(easy-menu-define - sgml-markup-menu sgml-mode-map "Markup menu" - sgml-markup-root-menu) - -(easy-menu-define - sgml-move-menu sgml-mode-map "Menu of move commands" - '("Move" - ["Next trouble spot" sgml-next-trouble-spot t] - ["Next data field" sgml-next-data-field t] - ["Forward element" sgml-forward-element t] - ["Backward element" sgml-backward-element t] - ["Up element" sgml-up-element t] - ["Down element" sgml-down-element t] - ["Backward up element" sgml-backward-up-element t] - ["Beginning of element" sgml-beginning-of-element t] - ["End of element" sgml-end-of-element t] - )) - -(easy-menu-define - sgml-modify-menu sgml-mode-map "Menu of modification commands" - '("Modify" - ["Normalize" sgml-normalize t] - ["Expand All Short References" sgml-expand-all-shortrefs t] - ["Expand Entity Reference" sgml-expand-entity-reference t] - ["Normalize Element" sgml-normalize-element t] - ["Make Character Reference" sgml-make-character-reference t] - ["Unmake Character Reference" (sgml-make-character-reference t) t] - ["Fill Element" sgml-fill-element t] - ["Change Element Name..." sgml-change-element-name t] - ["Edit Attributes..." sgml-edit-attributes t] - ["Kill Markup" sgml-kill-markup t] - ["Kill Element" sgml-kill-element t] - ["Untag Element" sgml-untag-element t] - ["Trim and leave element" sgml-trim-and-leave-element t] - ["Decode Character Entities" sgml-charent-to-display-char t] - ["Encode Characters" sgml-display-char-to-charent t] - ) - ) - -(easy-menu-define - sgml-main-menu sgml-mode-map "Main menu" - '("SGML" - ["Reset Buffer" normal-mode t] - ["End Element" sgml-insert-end-tag t] - ["Show Context" sgml-show-context t] - ["What Element" sgml-what-element t] - ["List Valid Tags" sgml-list-valid-tags t] - ["Show/Hide Warning Log" sgml-show-or-clear-log t] - ["Validate" sgml-validate t] - ["File Options >" sgml-file-options-menu t] - ["User Options >" sgml-user-options-menu t] - ["Save File Options" sgml-save-options t] - ["Submit Bug Report" sgml-submit-bug-report t] - ) - ) - - -(defun sgml-build-custom-menus () - "Build custom parts of Markup and DTD menus." - (let ((button3 (lookup-key (current-local-map) [button3]))) - (easy-menu-define - sgml-markup-menu sgml-mode-map "Markup menu" - (append sgml-markup-root-menu - (list "----") - (loop for e in sgml-custom-markup collect - (vector (first e) - (` (sgml-insert-markup (, (cadr e)))) - t)))) - (easy-menu-define - sgml-dtd-menu sgml-mode-map "DTD menu" - (append sgml-dtd-root-menu - (list "----") - (loop for e in sgml-custom-dtd collect - (vector (first e) - (` (sgml-doctype-insert (, (cadr e)) - '(, (cddr e)))) - t)))) - (unless (or (null button3) - (numberp button3)) - (local-set-key [button3] button3)))) - - -;;;; Post command hook - -(defvar sgml-auto-activate-dtd-tried nil) -(make-variable-buffer-local 'sgml-auto-activate-dtd-tried) - -(defvar sgml-buffer-parse-state nil - "If the buffers DTD has been activated this contains the parser state. -The parser state has been created with `sgml-make-pstate' and contains -the information about the DTD and the parse tree. This parse state is -actually only the state that persists between commands.") -(make-variable-buffer-local 'sgml-buffer-parse-state) - -(eval-and-compile ; Interface to psgml-parse - (loop for fun in '(sgml-need-dtd sgml-update-display - sgml-fontify-buffer - sgml-subst-expand - sgml-declaration) - do (autoload fun "psgml-parse"))) - - -(defun sgml-command-post () - (when (eq major-mode 'sgml-mode) - (when (and (null sgml-buffer-parse-state) - sgml-auto-activate-dtd - (null sgml-auto-activate-dtd-tried) - (not (zerop (buffer-size))) - (looking-at ".*<")) - (setq sgml-auto-activate-dtd-tried t) - (sgml-need-dtd) - (sgml-fontify-buffer 0)) - (when sgml-buffer-parse-state - (sgml-update-display)))) - - -;;;; SGML mode: major mode definition - -;;; This section is mostly from sgml-mode by James Clark. - -;;;###autoload -(defun sgml-mode () - "Major mode for editing SGML.\\<sgml-mode-map> -Makes > display the matching <. Makes / display matching /. -Use \\[sgml-validate] to validate your document with an SGML parser. - -You can find information with: -\\[sgml-show-context] Show the nesting of elements at cursor position. -\\[sgml-list-valid-tags] Show the tags valid at cursor position. - -Insert tags with completion of contextually valid tags with \\[sgml-insert-tag]. -End the current element with \\[sgml-insert-end-tag]. Insert an element (i.e. -both start and end tag) with \\[sgml-insert-element]. Or tag a region with -\\[sgml-tag-region]. - -To tag a region with the mouse, use transient mark mode or secondary selection. - -Structure editing: -\\[sgml-backward-element] Moves backwards over the previous element. -\\[sgml-forward-element] Moves forward over the next element. -\\[sgml-down-element] Move forward and down one level in the element structure. -\\[sgml-backward-up-element] Move backward out of this element level. -\\[sgml-beginning-of-element] Move to after the start tag of the current element. -\\[sgml-end-of-element] Move to before the end tag of the current element. -\\[sgml-kill-element] Kill the element following the cursor. - -Finding interesting positions -\\[sgml-next-data-field] Move forward to next point where data is allowed. -\\[sgml-next-trouble-spot] Move forward to next point where something is - amiss with the structure. - -Folding and unfolding -\\[sgml-fold-element] Fold the lines comprising the current element, leaving - the first line visible. -\\[sgml-fold-subelement] Fold the elements in the content of the current element. - Leaving the first line of every element visible. -\\[sgml-unfold-line] Show hidden lines in current line. - -User options: - -sgml-omittag Set this to reflect OMITTAG in the SGML declaration. -sgml-shortag Set this to reflect SHORTTAG in the SGML declaration. -sgml-auto-insert-required-elements If non-nil, automatically insert required - elements in the content of an inserted element. -sgml-balanced-tag-edit If non-nil, always insert start-end tag pairs. -sgml-omittag-transparent If non-nil, will show legal tags inside elements - with omitable start tags and legal tags beyond omitable end tags. -sgml-leave-point-after-insert If non-nil, the point will remain after - inserted tag(s). -sgml-warn-about-undefined-elements If non-nil, print a warning when a tag - for a undefined element is found. -sgml-max-menu-size Max number of entries in Tags and Entities menus before - they are split into several panes. -sgml-always-quote-attributes If non-nil, quote all attribute values - inserted after finishing edit attributes. -sgml-minimize-attributes Determines minimization of attributes inserted by - edit-attributes. -sgml-normalize-trims If non-nil, sgml-normalize will trim off white space - from end of element when adding end tag. -sgml-indent-step How much to increament indent for every element level. -sgml-indent-data If non-nil, indent in data/mixed context also. -sgml-set-face If non-nil, psgml will set the face of parsed markup. -sgml-markup-faces The faces used when the above variable is non-nil. -sgml-system-path List of directories used to look for system identifiers. -sgml-public-map Mapping from public identifiers to file names. -sgml-offer-save If non-nil, ask about saving modified buffers before - \\[sgml-validate] is run. - -All bindings: -\\{sgml-mode-map} -" - (interactive) - (kill-all-local-variables) - (setq local-abbrev-table sgml-mode-abbrev-table) - (use-local-map sgml-mode-map) - (setq mode-name "SGML") - (setq major-mode 'sgml-mode) - - ;; A start or end tag by itself on a line separates a paragraph. - ;; This is desirable because SGML discards a newline that appears - ;; immediately after a start tag or immediately before an end tag. - - (set (make-local-variable 'paragraph-separate) - "^[ \t\n]*$\\|\ -^[ \t]*</?\\([A-Za-z]\\([-.A-Za-z0-9= \t\n]\\|\ -\"[^\"]*\"\\|'[^']*'\\)*\\)?>$") - (set (make-local-variable 'paragraph-start) - paragraph-separate) - - (set-syntax-table text-mode-syntax-table) - (make-local-variable 'comment-start) - (setq comment-start "<!-- ") - (make-local-variable 'comment-end) - (setq comment-end " -->") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'sgml-comment-indent) - (make-local-variable 'comment-start-skip) - ;; This will allow existing comments within declarations to be - ;; recognized. [Does not work well with auto-fill, Lst/940205] - ;;(setq comment-start-skip "--[ \t]*") - (setq comment-start-skip "<!--[ \t]*") - ;; Added for psgml: - (make-local-variable 'indent-line-function) - (setq indent-line-function 'sgml-indent-line) - (make-local-variable 'mode-line-format) - ;; Modify mode-line-format with susbt (sugested by wing) - (setq mode-line-format - (subst '("" mode-name sgml-active-dtd-indicator) 'mode-name - mode-line-format)) - (make-local-variable 'sgml-default-dtd-file) - (when (setq sgml-default-dtd-file (sgml-default-dtd-file)) - (unless (file-exists-p sgml-default-dtd-file) - (setq sgml-default-dtd-file nil))) - (add-hook 'post-command-hook 'sgml-command-post 'append) - (run-hooks 'text-mode-hook 'sgml-mode-hook) - (sgml-build-custom-menus) - (easy-menu-add sgml-main-menu) - (easy-menu-add sgml-modify-menu) - (easy-menu-add sgml-move-menu) - (easy-menu-add sgml-markup-menu) - (easy-menu-add sgml-view-menu) - (easy-menu-add sgml-dtd-menu)) - -(defun sgml-default-dtd-file () - (and (buffer-file-name) - (let ((base (file-name-nondirectory (buffer-file-name)))) - (concat - (cond ((string-match "\\.[^.]+$" base) - (substring base 0 (match-beginning 0))) - (t - base)) - ".ced")))) - -(defun sgml-comment-indent () - (if (and (looking-at "--") - (not (and (eq (char-after (1- (point))) ?!) - (eq (char-after (- (point) 2)) ?<)))) - (progn - (skip-chars-backward " \t") - (max comment-column (1+ (current-column)))) - 0)) - -(defconst sgml-start-tag-regex - "<[A-Za-z]\\([-.A-Za-z0-9= \n\t]\\|\"[^\"]*\"\\|'[^']*'\\)*" - "Regular expression that matches a non-empty start tag. -Any terminating > or / is not matched.") - -(defvar sgml-mode-markup-syntax-table nil - "Syntax table used for scanning SGML markup.") - -(if sgml-mode-markup-syntax-table - () - (setq sgml-mode-markup-syntax-table (make-syntax-table)) - (modify-syntax-entry ?< "(>" sgml-mode-markup-syntax-table) - (modify-syntax-entry ?> ")<" sgml-mode-markup-syntax-table) - (modify-syntax-entry ?- "_ 1234" sgml-mode-markup-syntax-table) - (modify-syntax-entry ?\' "\"" sgml-mode-markup-syntax-table)) - -(defconst sgml-angle-distance 4000 - "*If non-nil, is the maximum distance to search for matching <.") - -(defun sgml-close-angle (arg) - "Insert > and display matching <." - (interactive "p") - (insert-char ?> arg) - (if (> arg 0) - (let ((oldpos (point)) - (blinkpos)) - (save-excursion - (save-restriction - (if sgml-angle-distance - (narrow-to-region (max (point-min) - (- (point) sgml-angle-distance)) - oldpos)) - ;; See if it's the end of a marked section. - (and (> (- (point) (point-min)) 3) - (eq (char-after (- (point) 2)) ?\]) - (eq (char-after (- (point) 3)) ?\]) - (re-search-backward "<!\\[\\(-?[A-Za-z0-9. \t\n&;]\\|\ ---\\([^-]\\|-[^-]\\)*--\\)*\\[" - (point-min) - t) - (let ((msspos (point))) - (if (and (search-forward "]]>" oldpos t) - (eq (point) oldpos)) - (setq blinkpos msspos)))) - ;; This handles cases where the > ends one of the following: - ;; markup declaration starting with <! (possibly including a - ;; declaration subset); start tag; end tag; SGML declaration. - (if blinkpos - () - (goto-char oldpos) - (condition-case () - (let ((oldtable (syntax-table)) - (parse-sexp-ignore-comments t)) - (unwind-protect - (progn - (set-syntax-table sgml-mode-markup-syntax-table) - (setq blinkpos (scan-sexps oldpos -1))) - (set-syntax-table oldtable))) - (error nil)) - (and blinkpos - (goto-char blinkpos) - (or - ;; Check that it's a valid delimiter in context. - (not (looking-at - "<\\(\\?\\|/?[A-Za-z>]\\|!\\([[A-Za-z]\\|--\\)\\)")) - ;; Check that it's not a net-enabling start tag - ;; nor an unclosed start-tag. - (looking-at (concat sgml-start-tag-regex "[/<]")) - ;; Nor an unclosed end-tag. - (looking-at "</[A-Za-z][-.A-Za-z0-9]*[ \t]*<")) - (setq blinkpos nil))) - (if blinkpos - () - ;; See if it's the end of a processing instruction. - (goto-char oldpos) - (if (search-backward "<?" (point-min) t) - (let ((pipos (point))) - (if (and (search-forward ">" oldpos t) - (eq (point) oldpos)) - (setq blinkpos pipos)))))) - (if blinkpos - (progn - (goto-char blinkpos) - (if (pos-visible-in-window-p) - (sit-for 1) - (message "Matches %s" - (buffer-substring blinkpos - (progn (end-of-line) - (point))))))))))) - -;;; I doubt that null end tags are used much for large elements, -;;; so use a small distance here. -(defconst sgml-slash-distance 1000 - "*If non-nil, is the maximum distance to search for matching /.") - -(defun sgml-slash (arg) - "Insert / and display any previous matching /. -Two /s are treated as matching if the first / ends a net-enabling -start tag, and the second / is the corresponding null end tag." - (interactive "p") - (insert-char ?/ arg) - (if (> arg 0) - (let ((oldpos (point)) - (blinkpos) - (level 0)) - (save-excursion - (save-restriction - (if sgml-slash-distance - (narrow-to-region (max (point-min) - (- (point) sgml-slash-distance)) - oldpos)) - (if (and (re-search-backward sgml-start-tag-regex (point-min) t) - (eq (match-end 0) (1- oldpos))) - () - (goto-char (1- oldpos)) - (while (and (not blinkpos) - (search-backward "/" (point-min) t)) - (let ((tagend (save-excursion - (if (re-search-backward sgml-start-tag-regex - (point-min) t) - (match-end 0) - nil)))) - (if (eq tagend (point)) - (if (eq level 0) - (setq blinkpos (point)) - (setq level (1- level))) - (setq level (1+ level))))))) - (if blinkpos - (progn - (goto-char blinkpos) - (if (pos-visible-in-window-p) - (sit-for 1) - (message "Matches %s" - (buffer-substring (progn - (beginning-of-line) - (point)) - (1+ blinkpos)))))))))) - -(eval-and-compile - (autoload 'compile-internal "compile" "")) - -(defun sgml-default-validate-command () - (cond - ((consp sgml-validate-command) - (let ((validate-subst - (list - (cons ?b (and (buffer-file-name) - (file-name-nondirectory (buffer-file-name)))) - (cons ?s (sgml-declaration)) - (cons ?v sgml-declaration) - (cons ?d sgml-doctype)))) - (loop for template in sgml-validate-command - thereis - (sgml-subst-expand template validate-subst)))) - (t - (apply 'format sgml-validate-command - (if sgml-validate-files - (funcall sgml-validate-files) - (list (or sgml-declaration "") - (let ((name (buffer-file-name))) - (if name - (file-name-nondirectory name) - "")))))))) - -(defun sgml-validate (command) - "Validate an SGML document. -Runs COMMAND, a shell command, in a separate process asynchronously -with output going to the buffer *compilation*. -You can then use the command \\[next-error] to find the next error message -and move to the line in the SGML document that caused it." - (interactive - (list (read-from-minibuffer "Validate command: " - (sgml-default-validate-command) - nil nil 'sgml-validate-command-history))) - (if sgml-offer-save - (save-some-buffers nil nil)) - (compile-internal command "No more errors" "SGML validation" - nil - sgml-validate-error-regexps)) - - - -;;;; Autoloads and hooks - -(autoload 'sgml-doctype-insert "psgml-edit" - nil - nil nil) -(autoload 'sgml-indent-line "psgml-edit" nil) -(autoload 'sgml-element-endable-p "psgml-edit" nil) - -;;; Generated by sgml-build-autoloads - -(autoload 'sgml-load-dtd "psgml-parse" "Load a saved DTD from FILE." t) -(autoload 'sgml-show-or-clear-log "psgml-parse" "Show the *SGML LOG* buffer if it is not showing, or clear and -remove it if it is showing." t) -(autoload 'sgml-parse-prolog "psgml-parse" "Parse the document prolog to learn the DTD." t) -(autoload 'sgml-beginning-of-element "psgml-edit" "Move to after the start-tag of the current element. -If the start-tag is implied, move to the start of the element." t) -(autoload 'sgml-end-of-element "psgml-edit" "Move to before the end-tag of the current element." t) -(autoload 'sgml-backward-up-element "psgml-edit" "Move backward out of this element level. -That is move to before the start-tag or where a start-tag is implied." t) -(autoload 'sgml-up-element "psgml-edit" "Move forward out of this element level. -That is move to after the end-tag or where an end-tag is implied." t) -(autoload 'sgml-forward-element "psgml-edit" "Move forward over next element." t) -(autoload 'sgml-backward-element "psgml-edit" "Move backward over previous element at this level. -With implied tags this is ambigous." t) -(autoload 'sgml-down-element "psgml-edit" "Move forward and down one level in the element structure." t) -(autoload 'sgml-kill-element "psgml-edit" "Kill the element following the cursor." t) -(autoload 'sgml-transpose-element "psgml-edit" "Interchange element before point with element after point, leave point after." t) -(autoload 'sgml-mark-element "psgml-edit" "Set mark after next element." t) -(autoload 'sgml-mark-current-element "psgml-edit" "Set mark at end of current element, and leave point before current element." t) -(autoload 'sgml-change-element-name "psgml-edit" "Replace the name of the current element with a new name. -Eventual attributes of the current element will be translated if -possible." t) -(autoload 'sgml-untag-element "psgml-edit" "Remove tags from current element." t) -(autoload 'sgml-kill-markup "psgml-edit" "Kill next tag, markup declaration or process instruction." t) -(autoload 'sgml-fold-region "psgml-edit" "Hide (or if prefixarg unhide) region. -If called from a program first two arguments are start and end of -region. And optional third argument true unhides." t) -(autoload 'sgml-fold-element "psgml-edit" "Fold the lines comprising the current element, leaving the first line visible. -This uses the selective display feature." t) -(autoload 'sgml-fold-subelement "psgml-edit" "Fold all elements current elements content, leaving the first lines visible. -This uses the selective display feature." t) -(autoload 'sgml-unfold-line "psgml-edit" "Show hidden lines in current line." t) -(autoload 'sgml-unfold-element "psgml-edit" "Show all hidden lines in current element." t) -(autoload 'sgml-expand-element "psgml-edit" "As sgml-fold-subelement, but unfold first." t) -(autoload 'sgml-unfold-all "psgml-edit" "Show all hidden lines in buffer." t) -(autoload 'sgml-next-data-field "psgml-edit" "Move forward to next point where data is allowed." t) -(autoload 'sgml-next-trouble-spot "psgml-edit" "Move forward to next point where something is amiss with the structure." t) -(autoload 'sgml-list-valid-tags "psgml-edit" "Display a list of the contextually valid tags." t) -(autoload 'sgml-show-context "psgml-edit" "Display where the cursor is in the element hierarchy." t) -(autoload 'sgml-what-element "psgml-edit" "Display what element is under the cursor." t) -(autoload 'sgml-insert-tag "psgml-edit" "Insert a tag, reading tag name in minibuffer with completion. -If the variable sgml-balanced-tag-edit is t, also inserts the -corresponding end tag. If sgml-leave-point-after-insert is t, the point -is left after the inserted tag(s), unless the element has som required -content. If sgml-leave-point-after-insert is nil the point is left -after the first tag inserted." t) -(autoload 'sgml-insert-element "psgml-edit" "Reads element name from minibuffer and inserts start and end tags." t) -(autoload 'sgml-tag-region "psgml-edit" "Reads element name from minibuffer and inserts start and end tags." t) -(autoload 'sgml-insert-end-tag "psgml-edit" "Insert end-tag for the current open element." t) -(autoload 'sgml-insert-attribute "psgml-edit" "Read attribute name and value from minibuffer and insert attribute spec." t) -(autoload 'sgml-split-element "psgml-edit" "Split the current element at point. -If repeated, the containing element will be split before the beginning -of then current element." t) -(autoload 'sgml-custom-dtd "psgml-edit" "Insert a DTD declaration from the sgml-custom-dtd alist." t) -(autoload 'sgml-custom-markup "psgml-edit" "Insert markup from the sgml-custom-markup alist." t) -(autoload 'sgml-tags-menu "psgml-edit" "Pop up a menu with valid tags and insert the choosen tag. -If the variable sgml-balanced-tag-edit is t, also inserts the -corresponding end tag. If sgml-leave-point-after-insert is t, the point -is left after the inserted tag(s), unless the element has som required -content. If sgml-leave-point-after-insert is nil the point is left -after the first tag inserted." t) -(autoload 'sgml-element-menu "psgml-edit" "Pop up a menu with valid elements and insert choice. -If sgml-leave-point-after-insert is nil the point is left after the first -tag inserted." t) -(autoload 'sgml-start-tag-menu "psgml-edit" "Pop up a menu with valid start-tags and insert choice." t) -(autoload 'sgml-end-tag-menu "psgml-edit" "Pop up a menu with valid end-tags and insert choice." t) -(autoload 'sgml-tag-region-menu "psgml-edit" "Pop up a menu with valid elements and tag current region with the choice." t) -(autoload 'sgml-entities-menu "psgml-edit" nil t) -(autoload 'sgml-attrib-menu "psgml-edit" "Pop up a menu of the attributes of the current element -\(or the element whith start-tag before point)." t) -(autoload 'sgml-fill-element "psgml-edit" "Fill bigest enclosing element with mixed content. -If current element has pure element content, recursively fill the -subelements." t) -(autoload 'sgml-edit-attributes "psgml-edit" "Edit attributes of current element. -Editing is done in a separate window." t) -(autoload 'sgml-edit-attrib-finish "psgml-edit" "Finish editing and insert attribute values in original buffer." t) -(autoload 'sgml-edit-attrib-default "psgml-edit" "Set current attribute value to default." t) -(autoload 'sgml-edit-attrib-clear "psgml-edit" "Kill the value of current attribute." t) -(autoload 'sgml-edit-attrib-field-start "psgml-edit" "Go to the start of the attribute value field." t) -(autoload 'sgml-edit-attrib-field-end "psgml-edit" "Go to the end of the attribute value field." t) -(autoload 'sgml-edit-attrib-next "psgml-edit" "Move to next attribute value." t) -(autoload 'sgml-hide-tags "psgml-edit" "Hide all tags in buffer." t) -(autoload 'sgml-show-tags "psgml-edit" "Show hidden tags in buffer." t) -(autoload 'sgml-hide-attributes "psgml-edit" "Hide all attribute specifications in the buffer." t) -(autoload 'sgml-show-attributes "psgml-edit" "Show all attribute specifications in the buffer." t) -(autoload 'sgml-expand-all-shortrefs "psgml-edit" "Expand all short references in the buffer. -Short references to text entities are expanded to the replacement text -of the entity other short references are expanded into general entity -references. If argument, TO-ENTITY, is non-nil, or if called -interactive with numeric prefix argument, all short references are -replaced by generaly entity references." t) -(autoload 'sgml-normalize "psgml-edit" "Normalize buffer by filling in omitted tags and expanding empty tags. -Argument TO-ENTITY controls how short references are expanded as with -`sgml-expand-all-shortrefs'. An optional argument ELEMENT can be the -element to normalize insted of the whole buffer, if used no short -references will be expanded." t) -(autoload 'sgml-normalize-element "psgml-edit" nil t) -(autoload 'sgml-make-character-reference "psgml-edit" "Convert character after point into a character reference. -If called with a numeric argument, convert a character reference back -to a normal character. If called from a program, set optional -argument INVERT to non-nil." t) -(autoload 'sgml-expand-entity-reference "psgml-edit" "Insert the text of the entity referenced at point." t) -(autoload 'sgml-complete "psgml-edit" "Complete the word/tag/entity before point. -If it is a tag (starts with < or </) complete with valid tags. -If it is an entity (starts with &) complete with declared entities. -If it is a markup declaration (starts with <!) complete with markup -declaration names. -If it is something else complete with ispell-complete-word." t) -(autoload 'sgml-file-options-menu "psgml-edit" nil t) -(autoload 'sgml-user-options-menu "psgml-edit" nil t) -(autoload 'sgml-save-dtd "psgml-dtd" "Save the parsed dtd on FILE." t) -(autoload 'sgml-list-elements "psgml-info" "List the elements and their attributes in the current DTD." t) -(autoload 'sgml-list-attributes "psgml-info" "List the attributes and in which elements they occur." t) -(autoload 'sgml-list-terminals "psgml-info" "List the elements that can have data in their content." t) -(autoload 'sgml-list-content-elements "psgml-info" "List all element types and the element types that can occur in its content." t) -(autoload 'sgml-list-occur-in-elements "psgml-info" "List all element types and where it can occur." t) -(autoload 'sgml-describe-entity "psgml-info" "Describe the properties of an entity as declared in the current DTD." t) -(autoload 'sgml-describe-element-type "psgml-info" "Describe the properties of an element type as declared in the current DTD." t) -(autoload 'sgml-general-dtd-info "psgml-info" "Display information about the current DTD." t) -(autoload 'sgml-charent-to-display-char "psgml-charent" "Replace character entities with their display character equivalents" t) -(autoload 'sgml-display-char-to-charent "psgml-charent" "Replace displayable characters with their character entity equivalents" t) - - -;;;; Last provisions -(provide 'psgml) -(provide 'sgml-mode) - -(cond - (sgml-running-xemacs - (require 'psgml-xemacs)) - (t - (require 'psgml-other))) - -;;; psgml.el ends here
--- a/lisp/psgml/tempo.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,777 +0,0 @@ -;;; tempo.el --- Flexible template insertion -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. - -;; Author: David K}gedal <davidk@lysator.liu.se > -;; Created: 16 Feb 1994 -;; Modified: 20 Jun 1995 -;; Version: 1.2.4 -;; Keywords: extensions, languages, tools -;; $Revision: 1.2 $ - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This file provides a simple way to define powerful templates, or -;; macros, if you wish. It is mainly intended for, but not limited to, -;; other programmers to be used for creating shortcuts for editing -;; certain kind of documents. It was originally written to be used by -;; a HTML editing mode written by Nelson Minar <nelson@santafe.edu>, -;; and his html-helper-mode.el is probably the best example of how to -;; use this program. - -;; A template is defined as a list of items to be inserted in the -;; current buffer at point. Some of the items can be simple strings, -;; while other can control formatting or define special points of -;; interest in the inserted text. - -;; If a template defines a "point of interest" that point is inserted -;; in a buffer-local list of "points of interest" that the user can -;; jump between with the commands `tempo-backward-mark' and -;; `tempo-forward-mark'. If the template definer provides a prompt for -;; the point, and the variable `tempo-interactive' is non-nil, the -;; user will be prompted for a string to be inserted in the buffer, -;; using the minibuffer. - -;; The template can also define one point to be replaced with the -;; current region if the template command is called with a prefix (or -;; a non-nil argument). - -;; More flexible templates can be created by including lisp symbols, -;; which will be evaluated as variables, or lists, which will will be -;; evaluated as lisp expressions. - -;; See the documentation for tempo-define-template for the different -;; items that can be used to define a tempo template. - -;; One of the more powerful features of tempo templates are automatic -;; completion. With every template can be assigned a special tag that -;; should be recognized by `tempo-complete-tag' and expanded to the -;; complete template. By default the tags are added to a global list -;; of template tags, and are matched against the last word before -;; point. But if you assign your tags to a specific list, you can also -;; specify another method for matching text in the buffer against the -;; tags. In the HTML mode, for instance, the tags are matched against -;; the text between the last `<' and point. - -;; When defining a template named `foo', a symbol named -;; `tempo-template-foo' will be created whose value as a variable will -;; be the template definition, and its function value will be an -;; interactive function that inserts the template at the point. - -;; The latest tempo.el distribution can be fetched from -;; ftp.lysator.liu.se in the directory /pub/emacs - -;; There is also a WWW page at -;; http://www.lysator.liu.se/~davidk/elisp/ which has some information - -;;; Known bugs: - -;; If the 'o is the first element in a template, strange things can -;; happen when the template is inserted at the beginning of a -;; line. This is due to strange behaviour in open-line. But it should -;; be easily avoided. - -;; The 'o tag is also a problem when including the region. This will -;; be looked into. - -;; Clicking mouse-2 in the completion buffer gives strange results. - -;; There is a bug in some emacs versions that prevents completion from -;; working. If it doesn't work for you, send me a note indicating your -;; emacs version and your problems. - -;;; Contributors: - -;; These people have given me importand feedback and new ideas for -;; tempo.el. Thanks. - -;; Nelson Minar <nelson@santafe.edu> -;; Richard Stallman <rms@gnu.ai.mit.edu> -;; Lars Lindberg <Lars.Lindberg@sypro.cap.se> -;; Glen Whitney <Glen.Whitney@math.lsa.umich.edu> - -;;; Code: - -;; (provide 'tempo) - -;;; User options - -(defgroup tempo nil - "Flexible template insertion" - :group 'extensions) - - -(defcustom tempo-interactive t ;; wing change - "*Prompt user for strings in templates. -If this variable is non-nil, `tempo-insert' prompts the -user for text to insert in the templates" - :type 'boolean - :group 'tempo) - -(defcustom tempo-insert-region nil - "*Automatically insert current region when there is a `r' in the template -If this variable is NIL, `r' elements will be treated just like `p' -elements, unless the template function is given a prefix (or a non-nil -argument). If this variable is non-NIL, the behaviour is reversed. - -In Transient Mark mode, this option is unused." - :type 'boolean - :group 'tempo) - -(defcustom tempo-show-completion-buffer t - "*If non-NIL, show a buffer with possible completions, when only -a partial completion can be found" - :type 'boolean - :group 'tempo) - -(defcustom tempo-leave-completion-buffer nil - "*If NIL, a completion buffer generated by \\[tempo-complete-tag] -disappears at the next keypress; otherwise, it remains forever." - :type 'boolean - :group 'tempo) - -;;; Internal variables - -(defvar tempo-insert-string-functions nil - "List of functions to run when inserting a string. -Each function is called with a single arg, STRING and should return -another string. This could be used for making all strings upcase by -setting it to '(upcase), for example.") - -(defvar tempo-tags nil - "An association list with tags and corresponding templates") - -(defvar tempo-local-tags '((tempo-tags . nil)) - "A list of locally installed tag completion lists. -It is a association list where the car of every element is a symbol -whose varable value is a template list. The cdr part, if non-nil, is a -function or a regexp that defines the string to match. See the -documentation for the function `tempo-complete-tag' for more info. - -`tempo-tags' is always in the last position in this list.") - -(defvar tempo-collection nil - "A collection of all the tags defined for the current buffer.") - -(defvar tempo-dirty-collection t - "Indicates if the tag collection needs to be rebuilt.") - -(defvar tempo-marks nil - "A list of marks to jump to with `\\[tempo-forward-mark]' and `\\[tempo-backward-mark]'.") - -(defvar tempo-match-finder "\\b\\([^\\b]+\\)\\=" - "The regexp or function used to find the string to match against tags. - -If `tempo-match-finder is a string, it should contain a regular -expression with at least one \\( \\) pair. When searching for tags, -`tempo-complete-tag' calls `re-search-backward' with this string, and -the string between the first \\( and \\) is used for matching against -each string in the tag list. If one is found, the whole text between -the first \\( and the point is replaced with the inserted template. - -You will probably want to include \\ \= at the end of the regexp to -make sure that the string is matched only against text adjacent to the -point. - -If `tempo-match-finder' is a symbol, it should be a function that -returns a pair of the form (STRING . POS), where STRING is the string -used for matching and POS is the buffer position after which text -should be replaced with a template.") - -(defvar tempo-user-elements nil - "Element handlers for user-defined elements. -A list of symbols which are bound to functions that take one argument. -This function should return somthing to be sent to `tempo-insert' if -it recognizes the argument, and NIL otherwise") - -(defvar tempo-named-insertions nil - "Temporary storage for named insertions") - -(defvar tempo-region-start (make-marker) - "Region start when inserting around the region") - -(defvar tempo-region-stop (make-marker) - "Region stop when inserting around the region") - -;; Make some variables local to every buffer - -(make-variable-buffer-local 'tempo-marks) -(make-variable-buffer-local 'tempo-local-tags) -(make-variable-buffer-local 'tempo-match-finder) -(make-variable-buffer-local 'tempo-collection) -(make-variable-buffer-local 'tempo-dirty-collection) - -;;; Functions - -;;; First some useful functions and macros - -(defun tempo-mapc (fun lst) - (if (null lst) nil - (funcall fun (car lst)) - (tempo-mapc fun (cdr lst)))) - -(defmacro tempo-dolist (il &rest forms) - (let ((i (car il)) - (l (car (cdr il)))) - (list 'tempo-mapc - (list 'function (append (list 'lambda - (list i)) - forms)) - (car (cdr il))))) -(put 'tempo-dolist 'lisp-indent-function 1) - -;; -;; tempo-define-template - -(defun tempo-define-template (name elements &optional tag documentation taglist) - "Define a template. -This function creates a template variable `tempo-template-NAME' and an -interactive function `tempo-template-NAME' that inserts the template -at the point. The created function is returned. - -NAME is a string that contains the name of the template, ELEMENTS is a -list of elements in the template, TAG is the tag used for completion, -DOCUMENTATION is the documentation string for the insertion command -created, and TAGLIST (a symbol) is the tag list that TAG (if provided) -should be added to). If TAGLIST is nil and TAG is non-nil, TAG is -added to `tempo-tags' - -The elements in ELEMENTS can be of several types: - - - A string. It is sent to the hooks in `tempo-insert-string-functions', - and the result is inserted. - - The symbol 'p. This position is saved in `tempo-marks'. - - The symbol 'r. If `tempo-insert' is called with ON-REGION non-nil - the current region is placed here. Otherwise it works like 'p. - - (p PROMPT <NAME> <NOINSERT>) If `tempo-interactive' is non-nil, the - user is prompted in the minbuffer with PROMPT for a string to be - inserted. If the optional parameter NAME is non-nil, the text is - saved for later insertion with the `s' tag. If there already is - something saved under NAME that value is used instead and no - prompting is made. If NOINSERT is provided and non-nil, nothing is - inserted, but text is still saved when a NAME is provided. For - clarity, the symbol 'noinsert should be used as argument. - - (P PROMPT <NAME> <NOINSERT>) Works just like the previous tag, but - forces tempo-interactive to be true. - - (r PROMPT <NAME> <NOINSERT>) like the previous, but if - `tempo-interactive' is nil and `tempo-insert' is called with - ON-REGION non-nil, the current region is placed here. This usually - happens when you call the template function with a prefix argument. - - (s NAME) Inserts text previously read with the (p ..) construct. - Finds the insertion saved under NAME and inserts it. Acts like 'p - if tempo-interactive is nil. - - '& If there is only whitespace between the line start and point, - nothing happens. Otherwise a newline is inserted. - - '% If there is only whitespace between point and end-of-line - nothing happens. Otherwise a newline is inserted. - - 'n inserts a newline. - - '> The line is indented using `indent-according-to-mode'. Note that - you often should place this item after the text you want on the - line. - - 'r> Like r, but it also indents the region. - - 'n> Inserts a newline and indents line. - - 'o Like '% but leaves the point before the newline. - - nil. It is ignored. - - Anything else. It is evaluated and the result is treated as an - element to be inserted. One additional tag is useful for these - cases. If an expression returns a list '(l foo bar), the elements - after 'l will be inserted according to the usual rules. This makes - it possible to return several elements from one expression." - - (let* ((template-name (intern (concat "tempo-template-" - name))) - (command-name template-name)) - (set template-name elements) - (fset command-name (list 'lambda (list '&optional 'arg) - (or documentation - (concat "Insert a " name ".")) - (list 'interactive "*P") - (list 'tempo-insert-template (list 'quote - template-name) - (list 'if 'tempo-insert-region - (list 'not 'arg) 'arg)))) - (and tag - (tempo-add-tag tag template-name taglist)) - command-name)) - -;;; -;;; tempo-insert-template - -(defun tempo-insert-template (template on-region) - "Insert a template. -TEMPLATE is the template to be inserted. If ON-REGION is non-nil the -`r' elements are replaced with the current region. In Transient Mark -mode, ON-REGION is ignored and assumed true if the region is active." - (unwind-protect - (progn - (if (or (and (boundp 'transient-mark-mode) ; For Emacs - transient-mark-mode - mark-active) - (and (boundp 'zmacs-regions) ; For XEmacs - zmacs-regions (mark))) - (setq on-region t)) - (and on-region - (set-marker tempo-region-start (min (mark) (point))) - (set-marker tempo-region-stop (max (mark) (point)))) - (if on-region - (goto-char tempo-region-start)) - (save-excursion - (tempo-insert-mark (point-marker)) - (mapcar (function (lambda (elt) - (tempo-insert elt on-region))) - (symbol-value template)) - (tempo-insert-mark (point-marker))) - (tempo-forward-mark)) - (tempo-forget-insertions) - ;; Should I check for zmacs here too??? - (and (boundp 'transient-mark-mode) - transient-mark-mode - (deactivate-mark)))) - -;;; -;;; tempo-insert - -(defun tempo-insert (element on-region) - "Insert a template element. -Insert one element from a template. If ON-REGION is non-nil the `r' -elements are replaced with the current region. - -See documentation for `tempo-define-template' for the kind of elements -possible." - (cond ((stringp element) (tempo-process-and-insert-string element)) - ((and (consp element) - (eq (car element) 'p)) (tempo-insert-prompt-compat - (cdr element))) - ((and (consp element) - (eq (car element) 'P)) (let ((tempo-interactive t)) - (tempo-insert-prompt-compat - (cdr element)))) -;;; ((and (consp element) -;;; (eq (car element) 'v)) (tempo-save-named -;;; (nth 1 element) -;;; nil -;;; (nth 2 element))) - ((and (consp element) - (eq (car element) 'r)) (if on-region - (goto-char tempo-region-stop) - (tempo-insert-prompt-compat - (cdr element)))) - ((and (consp element) - (eq (car element) 's)) (tempo-insert-named (car (cdr element)))) - ((and (consp element) - (eq (car element) 'l)) (mapcar (function - (lambda (elt) - (tempo-insert elt on-region))) - (cdr element))) - ((eq element 'p) (tempo-insert-mark (point-marker))) - ((eq element 'r) (if on-region - (goto-char tempo-region-stop) - (tempo-insert-mark (point-marker)))) - ((eq element 'r>) (if on-region - (progn - (goto-char tempo-region-stop) - (indent-region (mark) (point) nil)) - (tempo-insert-mark (point-marker)))) - ((eq element '>) (indent-according-to-mode)) - ((eq element '&) (if (not (or (= (current-column) 0) - (save-excursion - (re-search-backward - "^\\s-*\\=" nil t)))) - (insert "\n"))) - ((eq element '%) (if (not (or (eolp) - (save-excursion - (re-search-forward - "\\=\\s-*$" nil t)))) - (insert "\n"))) - ((eq element 'n) (insert "\n")) - ((eq element 'n>) (insert "\n") (indent-according-to-mode)) - ;; Bug: If the 'o is the first element in a template, strange - ;; things can happen when the template is inserted at the - ;; beginning of a line. - ((eq element 'o) (if (not (or on-region - (eolp) - (save-excursion - (re-search-forward - "\\=\\s-*$" nil t)))) - (open-line 1))) - ((null element)) - (t (tempo-insert (or (tempo-is-user-element element) - (eval element)) - on-region)))) - -;;; -;;; tempo-insert-prompt - -(defun tempo-insert-prompt-compat (prompt) - "Compatibility hack for tempo-insert-prompt. -PROMPT can be either a prompt string, or a list of arguments to -tempo-insert-prompt, or nil." - (if (consp prompt) ; not NIL either - (apply 'tempo-insert-prompt prompt) - (tempo-insert-prompt prompt))) - -(defun tempo-insert-prompt (prompt &optional save-name no-insert) - "Prompt for a text string and insert it in the current buffer. -If the variable `tempo-interactive' is non-nil the user is prompted -for a string in the minibuffer, which is then inserted in the current -buffer. If `tempo-interactive' is nil, the current point is placed on -`tempo-mark'. - -PROMPT is the prompt string, SAVE-NAME is a name to save the inserted -text under. If the optional argument NO-INSERT is non-nil, no text i -inserted. This can be useful when there is a SAVE-NAME. - -If there already is a value for SAVE-NAME, it is used and the user is -never prompted." - (let (insertion - (previous (and save-name - (tempo-lookup-named save-name)))) - (cond - ;; Insert previous value, unless no-insert is non-nil - ((and previous - (not no-insert)) - (tempo-insert-named save-name)) ; A double lookup here, but who - ; cares - ;; If no-insert is non-nil, don't insert the previous value. Just - ;; keep it - (previous - nil) - ;; No previous value. Prompt or insert mark - (tempo-interactive - (if (not (stringp prompt)) - (error "tempo: The prompt (%s) is not a string" prompt)) - (setq insertion (read-string prompt)) - (or no-insert - (insert insertion)) - (if save-name - (tempo-save-named save-name insertion))) - (t - (tempo-insert-mark (point-marker)))))) - -;;; -;;; tempo-is-user-element - -(defun tempo-is-user-element (element) - "Tries all the user-defined element handlers in -`tempo-user-elements'" - ;; Sigh... I need (some list) - (catch 'found - (mapcar (function (lambda (handler) - (let ((result (funcall handler element))) - (if result (throw 'found result))))) - tempo-user-elements) - (throw 'found nil))) - -;;; -;;; tempo-forget-insertions - -(defun tempo-forget-insertions () - "Forget all the saved named insertions." - (setq tempo-named-insertions nil)) - -;;; -;;; tempo-save-named - -(defun tempo-save-named (name data) ; Had an optional prompt for 'v - "Save some data for later insertion -The contents of DATA is saved under the name NAME. - -The data can later be retrieved with `tempo-lookup-named'. - -This function returns nil, so it can be used in a template without -inserting anything." - (setq tempo-named-insertions - (cons (cons name data) - tempo-named-insertions)) - nil) - -;;; -;;; tempo-lookup-named - -(defun tempo-lookup-named (name) - "Lookup some saved data under the name NAME. -Returns the data if NAME was found, and nil otherwise." - (cdr (assq name tempo-named-insertions))) - -;;; -;;; tempo-insert-named - -(defun tempo-insert-named (name) - "Insert the previous insertion saved under a named specified in NAME. -If there is no such name saved, a tempo mark is inserted. - -Note that if the data is a string, it will not be run through the string -processor." - (let* ((insertion (tempo-lookup-named name))) - (cond ((null insertion) - (tempo-insert-mark (point-marker))) - ((stringp insertion) - (insert insertion)) - (t - (tempo-insert insertion nil))))) - - -;;; -;;; tempo-process-and-insert-string - -(defun tempo-process-and-insert-string (string) - "Insert a string from a template. -Run a string through the preprocessors in `tempo-insert-string-functions' -and insert the results." - (cond ((null tempo-insert-string-functions) - nil) - ((symbolp tempo-insert-string-functions) - (setq string - (funcall tempo-insert-string-functions string))) - ((listp tempo-insert-string-functions) - (tempo-dolist (fn tempo-insert-string-functions) - (setq string (funcall fn string)))) - (t - (error "Bogus value in tempo-insert-string-functions: %s" - tempo-insert-string-functions))) - (insert string)) - -;;; -;;; tempo-insert-mark - -(defun tempo-insert-mark (mark) - "Insert a mark `tempo-marks' while keeping it sorted" - (cond ((null tempo-marks) (setq tempo-marks (list mark))) - ((< mark (car tempo-marks)) (setq tempo-marks (cons mark tempo-marks))) - (t (let ((lp tempo-marks)) - (while (and (cdr lp) - (<= (car (cdr lp)) mark)) - (setq lp (cdr lp))) - (if (not (= mark (car lp))) - (setcdr lp (cons mark (cdr lp)))))))) - -;;; -;;; tempo-forward-mark - -(defun tempo-forward-mark () - "Jump to the next mark in `tempo-forward-mark-list'." - (interactive) - (let ((next-mark (catch 'found - (mapcar - (function - (lambda (mark) - (if (< (point) mark) - (throw 'found mark)))) - tempo-marks) - ;; return nil if not found - nil))) - (if next-mark - (goto-char next-mark)))) - -;;; -;;; tempo-backward-mark - -(defun tempo-backward-mark () - "Jump to the previous mark in `tempo-back-mark-list'." - (interactive) - (let ((prev-mark (catch 'found - (let (last) - (mapcar - (function - (lambda (mark) - (if (<= (point) mark) - (throw 'found last)) - (setq last mark))) - tempo-marks) - last)))) - (if prev-mark - (goto-char prev-mark)))) - -;;; -;;; tempo-add-tag - -(defun tempo-add-tag (tag template &optional tag-list) - "Add a template tag. -Add the TAG, that should complete to TEMPLATE to the list in TAG-LIST, -or to `tempo-tags' if TAG-LIST is nil." - - (interactive "sTag: \nCTemplate: ") - (if (null tag-list) - (setq tag-list 'tempo-tags)) - (if (not (assoc tag (symbol-value tag-list))) - (set tag-list (cons (cons tag template) (symbol-value tag-list)))) - (tempo-invalidate-collection)) - -;;; -;;; tempo-use-tag-list - -(defun tempo-use-tag-list (tag-list &optional completion-function) - "Install TAG-LIST to be used for template completion in the current buffer. -TAG-LIST is a symbol whose variable value is a tag list created with -`tempo-add-tag'. - -COMPLETION-FUNCTION is an obsolete option for specifyingis an optional -function or string that is used by `\\[tempo-complete-tag]' to find a -string to match the tag against. It has the same definition as the -variable `tempo-match-finder'. In this version, supplying a -COMPLETION-FUNCTION just sets `tempo-match-finder' locally." - (let ((old (assq tag-list tempo-local-tags))) - (if old - (setcdr old completion-function) - (setq tempo-local-tags (cons (cons tag-list completion-function) - tempo-local-tags)))) - (if completion-function - (setq tempo-match-finder completion-function)) - (tempo-invalidate-collection)) - -;;; -;;; tempo-invalidate-collection - -(defun tempo-invalidate-collection () - "Marks the tag collection as obsolete. -Whenever it is needed again it will be rebuilt." - (setq tempo-dirty-collection t)) - -;;; -;;; tempo-build-collection - -(defun tempo-build-collection () - "Build a collection of all the tags and return it. -If `tempo-dirty-collection' is NIL, the old collection is reused." - (prog1 - (or (and (not tempo-dirty-collection) - tempo-collection) - (setq tempo-collection - (apply (function append) - (mapcar (function (lambda (tag-list) - ; If the format for - ; tempo-local-tags changes, - ; change this - (eval (car tag-list)))) - tempo-local-tags)))) - (setq tempo-dirty-collection nil))) - -;;; -;;; tempo-find-match-string - -(defun tempo-find-match-string (finder) - "Find a string to be matched against a tag list. -FINDER is a function or a string. Returns (STRING . POS), or nil -if no reasonable string is found." - (cond ((stringp finder) - (let (successful) - (save-excursion - (or (setq successful (re-search-backward finder nil t)) - 0)) - (if successful - (cons (buffer-substring (match-beginning 1) - (match-end 1)) ; This seems to be a - ; bug in emacs - (match-beginning 1)) - nil))) - (t - (funcall finder)))) - -;;; -;;; tempo-complete-tag - -(defun tempo-complete-tag (&optional silent) - "Look for a tag and expand it. -All the tags in the tag lists in `tempo-local-tags' - (this includes `tempo-tags') are searched for a match for the text -before the point. The way the string to match for is determined can -be altered with the variable `tempo-match-finder'. If -`tempo-match-finder' returns nil, then the results are the same as -no match at all. - -If a single match is found, the corresponding template is expanded in -place of the matching string. - -If a partial completion or no match at all is found, and SILENT is -non-NIL, the function will give a signal. - -If a partial completion is found and `tempo-show-completion-buffer' is -non-NIL, a buffer containing possible completions is displayed." - - ;; This function may look like a hack, but this is how I want it to - ;; work. - (interactive "*") - (let* ((collection (tempo-build-collection)) - (match-info (tempo-find-match-string tempo-match-finder)) - (match-string (car match-info)) - (match-start (cdr match-info)) - (exact (assoc match-string collection)) - (compl (or (car exact) - (and match-info (try-completion match-string collection))))) - (if compl (delete-region match-start (point))) - (cond ((null match-info) (or silent (ding))) - ((null compl) (or silent (ding))) - ((eq compl t) (tempo-insert-template - (cdr (assoc match-string - collection)) - nil)) - (t (if (setq exact (assoc compl collection)) - (tempo-insert-template (cdr exact) nil) - (insert compl) - (or silent (ding)) - (if tempo-show-completion-buffer - (tempo-display-completions match-string - collection))))))) - - -;;; -;;; tempo-display-completions - -(defun tempo-display-completions (string tag-list) - "Show a buffer containing possible completions for STRING." - (if tempo-leave-completion-buffer - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (all-completions string tag-list))) - (save-window-excursion - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (all-completions string tag-list))) - (sit-for 32767)))) - -;;; -;;; tempo-expand-if-complete - -(defun tempo-expand-if-complete () - "Expand the tag before point if it is complete. -Returns non-nil if an expansion was made and nil otherwise. - -This could as an example be used in a command that is bound to the -space bar, and looks something like this: - -(defun tempo-space () - (interactive \"*\") - (or (tempo-expand-if-complete) - (insert \" \")))" - - (interactive "*") - (let* ((collection (tempo-build-collection)) - (match-info (tempo-find-match-string tempo-match-finder)) - (match-string (car match-info)) - (match-start (cdr match-info)) - (exact (assoc match-string collection))) - (if exact - (progn - (delete-region match-start (point)) - (tempo-insert-template (cdr exact) nil) - t) - nil))) - -(provide 'tempo) - -;;; tempo.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/site-start.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,2 @@ +;; site-start.el --- Site wide run time initialization +;; This file is executed before a user's init file is executed.
--- a/lisp/tl/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'tl-autoloads) (error "Already loaded")) - -;;;### (autoloads (view-charset) "char-table" "tl/char-table.el") - -(autoload 'view-charset "char-table" "\ -Display character table of CHARSET." t nil) - -;;;*** - -;;;### (autoloads (view-charset-by-menu) "chartblxmas" "tl/chartblxmas.el") - -(autoload 'view-charset-by-menu "chartblxmas" "\ -Display character table of CHARSET by pop-up menu." t nil) - -;;;*** - -(provide 'tl-autoloads)
--- a/lisp/tl/char-table.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +0,0 @@ -;;; char-table.el --- display table of charset - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: char-table.el,v 1.3 1997/06/29 23:13:25 steve Exp $ -;; Keywords: character, mule - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defsubst char-position-to-string (charset r l &optional plane) - (char-to-string - (if plane - (make-char charset plane (+ (* r 16) l)) - (make-char charset (+ (* r 16) l)) - ))) - -(defsubst char-table-1 (charset r l plane) - (let* ((str (char-position-to-string charset r l plane)) - (lp (- 3 (string-width str))) - (rp (/ lp 2))) - (setq lp - (if (= (mod lp 2) 0) - rp - (1+ rp))) - (concat (make-string lp ? ) str (make-string rp ? )) - )) - -(defun insert-94-charset-table (charset &optional plane ofs) - (if (null ofs) - (setq ofs 0) - ) - (insert (format - "[%02x]$B("(B 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F\n" - (or plane 0))) - (insert "$B(!(!(+(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(B\n") - (let ((j 2)) - (insert (format "%02x%x$B("(B " (or plane 0) (* (+ j ofs) 16))) - (let ((k 1)) - (while (< k 16) - (insert (char-table-1 charset j k plane)) - (setq k (+ k 1)) - ) - (insert "\n") - ) - (setq j 3) - (while (< j 7) - (insert (format "%02x%x$B("(B" (or plane 0) (* (+ j ofs) 16))) - (let ((k 0)) - (while (< k 16) - (insert (char-table-1 charset j k plane)) - (setq k (+ k 1)) - ) - (insert "\n") - ) - (setq j (+ j 1)) - ) - (insert (format "%02x%x$B("(B" (or plane 0) (* (+ j ofs) 16))) - (let ((k 0)) - (while (< k 15) - (insert (char-table-1 charset j k plane)) - (setq k (+ k 1)) - ) - (insert "\n") - ) - )) - -(defun insert-96-charset-table (charset &optional plane ofs) - (if (null ofs) - (setq ofs 0) - ) - (insert (format - "[%02x]$B("(B 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F\n" - (or plane 0))) - (insert "$B(!(!(+(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(!(B\n") - (let ((j 2)) - (while (< j 8) - (insert (format "%02x%x$B("(B" (or plane 0) (* (+ j ofs) 16))) - (let ((k 0)) - (while (< k 16) - (insert (char-table-1 charset j k plane)) - (setq k (+ k 1)) - ) - (insert "\n") - ) - (setq j (1+ j)) - ))) - -(defun insert-94x94-charset-table (charset) - (insert-94-charset-table charset 33) - (let ((i 34)) - (while (< i 127) - (insert "$B(,(,(;(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(B\n") - (insert-94-charset-table charset i) - (setq i (1+ i)) - ))) - -(defun insert-96x96-charset-table (charset) - (insert-96-charset-table charset 32) - (let ((i 33)) - (while (< i 128) - (insert "$B(,(,(;(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(B\n") - (insert-96-charset-table charset i) - (setq i (1+ i)) - ))) - -(defun insert-charset-table (charset) - "Insert character table of CHARSET." - (insert "$B(,(,(8(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(B\n") - (let ((cc (charset-chars charset)) - (cd (charset-dimension charset)) - ) - (cond ((= cd 1) - (cond ((= cc 94) - (insert-94-charset-table charset) - ) - ((= cc 96) - (insert-96-charset-table charset) - )) - ) - ((= cd 2) - (cond ((= cc 94) - (insert-94x94-charset-table charset) - ) - ((= cc 96) - (insert-96x96-charset-table charset) - )) - ))) - (insert "$B(,(,(:(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(,(B\n") - ) - -;;;###autoload -(defun view-charset (charset) - "Display character table of CHARSET." - (interactive - (list - (let ((charset-alist - (mapcar (function - (lambda (charset) - (cons (charset-doc-string charset) charset) - )) - (charset-list)))) - (cdr (assoc (completing-read "What charset: " - charset-alist nil t nil) - charset-alist)) - ))) - (let* ((desc (charset-doc-string charset)) - (buf (concat "*Charset table for " - (charset-doc-string charset) - "*"))) - (unless (get-buffer buf) - (let ((the-buf (current-buffer))) - (set-buffer (get-buffer-create buf)) - (insert (format "%s (%s)\n" desc charset)) - (let ((msg (format "Generating char table for %s..." desc))) - (message msg) - (insert-charset-table charset) - (message "%s Done." msg) - ) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (set-buffer the-buf) - )) - (view-buffer buf) - )) - - -;;; @ end -;;; - -(provide 'char-table) - -;;; char-table.el ends here
--- a/lisp/tl/char-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -;;; char-util.el --- character utility - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: char-util.el,v 1.1 1997/01/30 02:27:29 steve Exp $ -;; Keywords: character, Emacs/mule - -;; This file is not part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defun row-line-to-char (r l) - (int-char (+ (* r 16) l)) - ) - -(defun row-line-to-string (r l) - (char-to-string (row-line-to-char r l)) - ) - -(defun print-row-line (r l) - (interactive (and (looking-at "\\([0-9]+\\)/\\([0-9]+\\)") - (list (string-to-number - (buffer-substring (match-beginning 1) - (match-end 1))) - (string-to-number - (buffer-substring (match-beginning 2) - (match-end 2))) - ))) - (message (row-line-to-string r l)) - ) - -(defun char-to-row-line-form (chr) - (setq chr (char-int chr)) - (format "%d/%d" (/ chr 16)(mod chr 16)) - ) - -(defun char-to-byte-list (chr) - (let ((rest (mapcar (function identity) - (char-to-string chr)) - )) - (if (cdr rest) - (cons (car rest) - (mapcar (lambda (byte) - (logand byte 127) - ) - (cdr rest))) - (cons 'ascii rest) - ))) - -(defun char-to-row-cell-form (chr) - (let ((cl (char-to-byte-list chr))) - (if (= (length cl) 2) - (char-to-row-line-form (nth 1 cl)) - (format "%02d-%02d" (- (nth 1 cl) 32)(- (nth 2 cl) 32)) - ))) - -(defun show-char-info (char) - (interactive (list (char-after (point)))) - (let ((cl (char-to-byte-list char))) - (message (format "%s: %s %s" - (charset-description (car cl)) - (mapconcat (lambda (byte) - (format "%02x" byte) - ) - (cdr cl) "") - (if (= (length cl) 2) - (char-to-row-line-form (nth 1 cl)) - (format "%02d-%02d" (- (nth 1 cl) 32)(- (nth 2 cl) 32)) - ) - )))) - - -;;; @ end -;;; - -(provide 'char-util) - -;;; char-util.el ends here
--- a/lisp/tl/chartblxmas.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -;;; chartblxmas.el --- display table of charset by pop-up menu - -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: chartblxmas.el,v 1.1 1997/06/29 23:21:49 steve Exp $ -;; Keywords: character, XEmacs/mule - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;;; Code: - -(require 'alist) -(require 'char-table) - -(defun classify-charsets-by-dimension-and-chars (charset-list) - (let (dest) - (while charset-list - (let* ((charset (car charset-list)) - (chars (charset-chars charset)) - (dim (charset-dimension charset)) - (dim-alist (cdr (assq dim dest))) - ) - (setq dest - (put-alist dim - (put-alist chars - (cons charset - (cdr (assq chars dim-alist))) - dim-alist) - dest)) - ) - (setq charset-list (cdr charset-list)) - ) - dest)) - - -;;;###autoload -(defun view-charset-by-menu () - "Display character table of CHARSET by pop-up menu." - (interactive) - (popup-menu - (cons - "Character set:" - (mapcar (function - (lambda (cat) - (cons (car cat) - (sort - (mapcar (function - (lambda (charset) - (vector (charset-doc-string charset) - `(view-charset ',charset) - t) - )) - (cdr cat)) - (function - (lambda (a b) - (string< (aref a 0)(aref b 0)) - )))))) - (sort - (let ((rest - (classify-charsets-by-dimension-and-chars (charset-list)) - )) - (while rest - (let* ((r (car rest)) - (d (car r))) - (setq r (cdr r)) - (while r - (let* ((p (car r)) - (n (int-to-string (car p))) - (s n) - (i 1)) - (while (< i d) - (setq s (concat s " x " n)) - (setq i (1+ i))) - (set-alist 'dest (concat s " character set") (cdr p))) - (setq r (cdr r)) - )) - (setq rest (cdr rest))) - dest) - (function (lambda (a b) - (string< (car a)(car b)) - ))) - )))) - -;;; chartblxmas.el ends here
--- a/lisp/tl/cless.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -;;; cless.el --- Common lisp and Emacs Lisp source sharing - -;; Copyright (C) 1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: cless.el,v 1.2 1996/12/28 21:03:08 steve Exp $ -;; Keywords: common lisp - -;; This file is not part of GNU Emacs. - -;; This program 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. - -;; This program 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 This program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'cl) - -(defun call-after-loaded (module func &optional hook-name) - "If MODULE is provided, then FUNC is called. -Otherwise func is set to MODULE-load-hook. -If optional argument HOOK-NAME is specified, -it is used as hook to set. [cless.el; imported from tl-misc.el]" - (if (featurep module) - (funcall func) - (progn - (if (null hook-name) - (setq hook-name - (intern (concat (symbol-name module) "-load-hook"))) - ) - (add-hook hook-name func) - ))) - -(defun define-cless-alias (alias func) - (defalias alias func) - (call-after-loaded - 'cl-macs - (` (lambda () - (define-compiler-macro (, alias) (&rest args) - (cons (, (list 'quote func)) args) - )) - )) - ) - -(define-cless-alias 'FLOOR 'floor*) -(define-cless-alias 'CEILING 'ceiling*) -(define-cless-alias 'TRUNCATE 'truncate*) -(define-cless-alias 'ROUND 'round*) -(define-cless-alias 'MOD 'mod*) - -(define-cless-alias 'DELETE 'delete*) -(define-cless-alias 'SORT 'sort*) -(define-cless-alias 'MEMBER 'member*) -(define-cless-alias 'ASSOC 'assoc*) -(define-cless-alias 'RASSOC 'rassoc*) - -(define-cless-alias 'MAPCAR 'mapcar*) - -(define-cless-alias 'DEFUN 'defun*) - - - -;;; @ end -;;; - -(provide 'cless) - -;;; cless.el ends here
--- a/lisp/tl/range.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -;;; range.el --- range functions - -;; Copyright (C) 1987 .. 1996 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: range.el,v 1.2 1996/12/28 21:03:09 steve Exp $ -;; Keywords: range - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 This program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -;; These functions were imported from September Gnus 0.40. - -(defun compress-sorted-numbers (numbers &optional always-list) - "Convert list of numbers to a list of ranges or a single range. -If ALWAYS-LIST is non-nil, this function will always release a list of -ranges. [range.el]" - (let* ((first (car numbers)) - (last (car numbers)) - result) - (if (null numbers) - nil - (if (not (listp (cdr numbers))) - numbers - (while numbers - (cond ((= last (car numbers)) nil) ;Omit duplicated number - ((= (1+ last) (car numbers)) ;Still in sequence - (setq last (car numbers))) - (t ;End of one sequence - (setq result - (cons (if (= first last) first - (cons first last)) result)) - (setq first (car numbers)) - (setq last (car numbers)))) - (setq numbers (cdr numbers))) - (if (and (not always-list) (null result)) - (if (= first last) (list first) (cons first last)) - (nreverse (cons (if (= first last) first (cons first last)) - result))))))) - -(defun expand-range (range) - "Expand a range into a list of numbers. [range.el]" - (cond ((numberp range) - range) - ((numberp (cdr range)) - (index (car range)(cdr range)) - ) - (t - (let (dest ret) - (mapcar (function - (lambda (sec) - (setq ret (expand-range sec)) - (setq dest - (nconc dest - (if (and (listp ret) - (listp (cdr ret))) - ret - (list ret) - ))) - )) - range) - dest)))) - -(defun member-of-range (number range) - "Return t if NUMBER is a member of RANGE. [range.el]" - (cond ((numberp range) - (= number range) - ) - ((numberp (cdr range)) - (and (<= (car range) number) - (<= number (cdr range)) - ) - ) - (t - (catch 'tag - (while range - (if (member-of-range number (car range)) - (throw 'tag t) - ) - (setq range (cdr range)) - )) - ))) - - -;;; @ end -;;; - -(provide 'range) - -;;; range.el ends here
--- a/lisp/tl/texi-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ -;;; texi-util.el --- Texinfo utility - -;; Copyright (C) 1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: texi-util.el,v 1.2 1996/12/28 21:03:09 steve Exp $ -;; Keywords: Texinfo - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defun texinfo-all-menu-titles-update () - (interactive) - (goto-char (point-min)) - (while (search-forward "\n@menu\n" nil t) - (goto-char (match-end 0)) - (while (looking-at "* \\([^:]+\\)::") - (let ((title (buffer-substring (match-beginning 1)(match-end 1))) - subj) - (save-excursion - (let ((ret - (re-search-forward - (format - "@node %s.*\n@\\(chapter\\|\\(sub\\)*section\\) \\(.+\\)" - (regexp-quote title))))) - (if ret - (let ((data (last (match-data) 2))) - (setq subj (buffer-substring (car data) - (car (cdr data)))) - )) - )) - (if subj - (or (string= subj title) - (progn - (end-of-line) - (insert subj) - ))) - (end-of-line) - (forward-char) - )))) - - -;;; @ end -;;; - -(provide 'texi-util) - -;;; texi-util.el ends here
--- a/lisp/tl/tl-atype.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -;;; tl-atype.el --- atype functions - -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tl-atype.el,v 1.3 1997/06/06 00:57:42 steve Exp $ -;; Keywords: atype - -;; This file is part of XEmacs. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tl-list) -(require 'atype) - - -;;; @ field -;;; - -(defalias 'fetch-field 'assoc) -(defalias 'fetch-field-value 'assoc-value) -(defalias 'put-field 'put-alist) -(defalias 'delete-field 'del-alist) - -(defun put-fields (tp c) - (catch 'tag - (let ((r tp) f ret) - (while r - (setq f (car r)) - (if (not (if (setq ret (fetch-field (car f) c)) - (equal (cdr ret)(cdr f)) - (setq c (cons f c)) - )) - (throw 'tag 'error)) - (setq r (cdr r)) - )) - c)) - - -;;; @ end -;;; - -(provide 'tl-atype) - -;;; tl-atype.el ends here
--- a/lisp/tl/tl-list.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,322 +0,0 @@ -;;; tl-list.el --- utility functions about list - -;; Copyright (C) 1987 .. 1996 Free Software Foundation, Inc. -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> -;; Version: $Id: tl-list.el,v 1.3 1997/06/06 00:57:42 steve Exp $ -;; Keywords: list - -;; This file is part of XEmacs. - -;; This program 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. - -;; This program 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 This program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'file-detect) - -(cond ((file-installed-p "cl-seq.elc") - (require 'cless) - ) - (t - ;; New cl is not exist (Don't use old cl.el) - -(defun last (ls &optional n) - "Returns the last element in list LS. -With optional argument N, returns Nth-to-last link (default 1). -\[tl-list.el; tomo's Common Lisp emulating function]" - (nthcdr (- (length ls) (or n 1)) ls) - ) - -;; imported from cl.el -(defun list* (arg &rest rest) - "Return a new list with specified args as elements, cons'd to last arg. -Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to -`(cons A (cons B (cons C D)))'." - (cond ((not rest) arg) - ((not (cdr rest)) (cons arg (car rest))) - (t (let* ((n (length rest)) - (copy (copy-sequence rest)) - (last (nthcdr (- n 2) copy))) - (setcdr last (car (cdr last))) - (cons arg copy))))) - -(defconst :test ':test) - -(defun MEMBER (elt list &rest keywords) - (let ((test - (or - (let ((ret (memq ':test keywords))) - (car (cdr ret)) - ) - 'eq))) - (cond ((eq test 'eq) - (memq elt list) - ) - ((eq test 'equal) - (member elt list) - ) - (t - (catch 'tag - (while list - (let* ((cell (car list)) - (ret (funcall test elt cell)) - ) - (if ret - (throw 'tag list) - )) - (setq list (cdr list)) - )))))) - -(defun ASSOC (key alist &rest keywords) - (let ((test - (or - (let ((ret (memq ':test keywords))) - (car (cdr ret)) - ) - 'eq))) - (cond ((eq test 'eq) - (assq key alist) - ) - ((eq test 'equal) - (assoc key alist) - ) - (t - (catch 'tag - (while alist - (let* ((cell (car alist)) - (ret (funcall test key (car cell))) - ) - (if ret - (throw 'tag cell) - )) - (setq alist (cdr alist)) - )))))) -)) - -(autoload 'compress-sorted-numbers "range") -(autoload 'expand-range "range") -(autoload 'member-of-range "range") - - -;;; @ list -;;; - -(defun nnth-prev (n ls) - "Modify list LS to remove elements after N th. [tl-list.el]" - (and (> n 0) - (let ((cell (nthcdr (1- n) ls))) - (if (consp cell) - (setcdr cell nil) - ) - ls))) - -(defun nth-prev (n ls) - "Return the first N elements. [tl-list.el]" - (let (dest) - (while (and (> n 0) ls) - (setq dest (cons (car ls) dest)) - (setq ls (cdr ls) - n (1- n)) - ) - (nreverse dest) - )) - -(defun nexcept-nth (n ls) - "Modify list LS to remove N th element. [tl-list.el]" - (cond ((< n 0) ls) - ((= n 0) (cdr ls)) - (t - (let ((cell (nthcdr (1- n) ls))) - (if (consp cell) - (setcdr cell (cdr (cdr cell))) - )) - ls))) - -(defun except-nth (n ls) - "Return elements of LS except N th. [tl-list.el]" - (if (< n 0) - ls - (let (dest) - (while (and (> n 0) ls) - (setq dest (cons (car ls) dest)) - (setq ls (cdr ls) - n (1- n)) - ) - (setq ls (cdr ls)) - (while dest - (setq ls (cons (car dest) ls)) - (setq dest (cdr dest)) - ) - ls))) - -(defun last-element (ls) - "Return last element. [tl-list.el]" - (car (last ls)) - ) - -(defun cons-element (elt ls) - "Cons ELT to LS if ELT is not nil. [tl-list.el]" - (if elt - (cons elt ls) - ls)) - -(defun cons-if (elt ls) - "Cons ELT to LS if LS is not nil, otherwise return nil. [tl-list.el]" - (if ls - (cons elt ls) - )) - -(defun append-element (ls elt) - "Append ELT to last of LS if ELT is not nil. [tl-list.el]" - (if elt - (append ls (list elt)) - ls)) - - -;;; @ permutation and combination -;;; - -(defun every-combination (prev &rest rest) - "Every arguments are OR list, -and return list of all possible sequence. [tl-list.el]" - (if (null prev) - (setq prev '(nil)) - ) - (cond ((null rest) - (mapcar 'list prev) - ) - (t (let (dest - (pr prev) - (rest-mixed (apply 'every-combination rest)) - ) - (while pr - (let ((rr rest-mixed)) - (while rr - (setq dest (cons (cons (car pr)(car rr)) dest)) - (setq rr (cdr rr)) - )) - (setq pr (cdr pr)) - ) - (nreverse dest) - )) - )) - -(defun permute (&rest ls) - "Return permutation of arguments as list. [tl-list.el]" - (let ((len (length ls))) - (if (<= len 1) - (list ls) - (let (prev - (rest ls) - c dest) - (while rest - (setq c (car rest)) - (setq rest (cdr rest)) - (setq dest - (nconc dest - (mapcar (function - (lambda (s) - (cons c s) - )) - (apply (function permute) - (append prev rest)) - ))) - (setq prev (nconc prev (list c))) - ) - dest) - ))) - - -;;; @ index -;;; - -(defun index (start end &optional inc) - "Return list of numbers from START to END. -Element of the list increases by INC (default value is 1). -\[tl-list.el; ELIS compatible function]" - (or inc - (setq inc 1) - ) - (let ((pred (if (>= inc 0) - (function <=) - (function >=) - )) - (i start) - dest) - (while (funcall pred i end) - (setq dest (cons i dest)) - (setq i (+ i inc)) - ) - (nreverse dest) - )) - - -;;; @ set -;;; - -(defun map-union (func ls) - "Apply FUNC to each element of LS. -And return union of each result returned by FUNC. [tl-list.el]" - (let ((r ls) ret rc dest) - (while r - (setq ret (funcall func (car r))) - (while ret - (setq rc (car ret)) - (or (member rc dest) - (setq dest (cons rc dest)) - ) - (setq ret (cdr ret)) - ) - (setq r (cdr r)) - ) - (nreverse dest) - )) - - -;;; @ alist -;;; - -(require 'alist) - -(defun assoc-value (item alist) - "Return value of <ITEM> from <ALIST>. [tl-list.el]" - (cdr (assoc item alist)) - ) - - -;;; @ poly-apply -;;; - -(defun poly-funcall (functions arg) - (while functions - (setq arg (funcall (car functions) arg) - functions (cdr functions)) - ) - arg) - - -;;; @ end -;;; - -(provide 'tl-list) - -(require 'tl-seq) -(require 'tl-atype) - -;;; tl-list.el ends here
--- a/lisp/tl/tl-misc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -;;; tl-misc.el --- miscellaneous utility of tl. - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: tl-misc.el,v 1.2 1996/12/28 21:03:10 steve Exp $ -;; Keywords: load-path, module, structure - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 This program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'tl-str) - -(autoload 'add-path "file-detect") -(autoload 'get-latest-path "file-detect") -(autoload 'file-installed-p "file-detect") - - -;;; @ module and hook -;;; - -(defun call-after-loaded (module func &optional hook-name) - "If MODULE is provided, then FUNC is called. -Otherwise func is set to MODULE-load-hook. -If optional argument HOOK-NAME is specified, -it is used as hook to set. [tl-misc.el]" - (if (featurep module) - (funcall func) - (progn - (if (null hook-name) - (setq hook-name (symbol-concat module "-load-hook")) - ) - (add-hook hook-name func) - ))) - - -;;; @ structure -;;; - -(defmacro define-structure (name &rest slots) - (let ((pred (symbol-concat name '-p))) - (cons 'progn - (nconc - (list - (` (defun (, pred) (obj) - (and (vectorp obj) - (eq (elt obj 0) '(, name)) - )) - ) - (` (defun (, (symbol-concat name '/create)) (, slots) - (, (cons 'vector (cons (list 'quote name) slots))) - ) - )) - (let ((i 1)) - (mapcar (function - (lambda (slot) - (prog1 - (` (defun (, (symbol-concat name '/ slot)) (obj) - (if ((, pred) obj) - (elt obj (, i)) - )) - ) - (setq i (+ i 1)) - ) - )) slots) - ) - (list (list 'quote name)) - )))) - - -;;; @ end -;;; - -(provide 'tl-misc) - -;;; tl-misc.el ends here
--- a/lisp/tl/tl-num.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -;;; -;;; $Id: tl-num.el,v 1.3 1997/04/05 19:32:20 steve Exp $ -;;; -;;; by MORIOKA Tomohiko <morioka@jaist.ac.jp>, 1993/10/4 -;;; - -(require 'emu) -(require 'tl-seq) - - -;;; @ n base -;;; - -(defun n-char-to-int (chr) - "Convert n base character CHR to integer (n <= 36). [tl-num]" - (cond ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) - ((and (<= ?A chr)(<= chr ?Z)) (+ (- chr ?A) 10)) - ((and (<= ?a chr)(<= chr ?z)) (+ (- chr ?a) 10)) - )) - -(defun int-to-n-char (n) - "Convert integer N to n base character (n <= 36). [tl-num]" - (if (< n 10) - (+ ?0 n) - (+ ?A (- n 10)) - )) - -(defun base-seq-to-int (base seq) - "Convert n base number sequence SEQ to number. [tl-num]" - (foldl (function - (lambda (n m) - (+ (* n base) m) - )) - 0 seq)) - -(defun base-char-seq-to-int (base seq) - "Convert n base char sequence SEQ to number. [tl-num]" - (foldl (function - (lambda (n chr) - (+ (* n base)(n-char-to-int chr)) - )) - 0 seq)) - - -;;; @ Hex -;;; - -(defun hex-char-to-number (chr) - "Convert hex character CHR to number. [tl-num]" - (cond ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0)) - ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10)) - ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10)) - )) - -(defalias 'number-to-hex-char 'int-to-n-char) - -(defun hex-seq-to-int (seq) - "Convert hex number sequence SEQ to integer. [tl-num]" - (base-seq-to-int 16 seq) - ) - -(defun hex-char-seq-to-int (seq) - "Convert hex char sequence SEQ to integer. [tl-num]" - (base-char-seq-to-int 16 seq) - ) - - -;;; @ end -;;; - -(provide 'tl-num)
--- a/lisp/tl/tl-seq.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -;;; tl-seq.el --- sequence functions - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: tl-seq.el,v 1.2 1996/12/28 21:03:10 steve Exp $ -;; Keywords: sequence - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 This program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'file-detect) - -(cond ((file-installed-p "cl-seq.elc") - (require 'cl) - ) - (t - (defun find-if (pred seq) - "Return the first element of sequence SEQ satisfying PRED. -\[tl-seq.el]" - (let ((i 0)(len (length seq)) element) - (catch 'tag - (while (< i len) - (if (funcall pred (setq element (elt seq i))) - (throw 'tag element) - ) - (setq i (+ i 1)) - )) - )) - - (defun find (item seq) - "Return the first element which is found in sequence SEQ as item. -\[tl-seq.el]" - (find-if (function - (lambda (elt) - (eq elt item) - )) - seq)) - )) - -(defun foldr (func a seq) - "Return (func (func (func (... (func a Sn) ...) S2) S1) S0) -when func's argument is 2 and seq is a sequence whose -elements = S0 S1 S2 ... Sn. [tl-seq.el]" - (let ((i (length seq))) - (while (> i 0) - (setq i (1- i)) - (setq a (funcall func a (elt seq i))) - ) - a)) - -(defun foldl (func a seq) - "Return (... (func (func (func a S0) S1) S2) ...) -when func's argument is 2 and seq is a sequence whose -elements = S0 S1 S2 .... [tl-seq.el]" - (let ((len (length seq)) - (i 0)) - (while (< i len) - (setq a (funcall func a (elt seq i))) - (setq i (1+ i)) - ) - a)) - -(defun pack-sequence (seq size) - (let ((len (length seq)) (p 0) obj - unit (i 0) - dest) - (while (< p len) - (setq obj (elt seq p)) - (setq unit (cons obj unit)) - (setq i (1+ i)) - (if (= i size) - (progn - (setq dest (cons (reverse unit) dest)) - (setq unit nil) - (setq i 0) - )) - (setq p (1+ p)) - ) - (if unit - (setq dest (cons (reverse unit) dest)) - ) - (reverse dest) - )) - - -;;; @ end -;;; - -(provide 'tl-seq) - -;;; tl-seq.el ends here
--- a/lisp/tl/tl-str.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,310 +0,0 @@ -;;; tl-str.el --- Emacs Lisp Library module about string - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tl-str.el,v 1.3 1997/01/30 02:22:47 steve Exp $ -;; Keywords: string - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'tl-list) - - -;;; @ converter -;;; - -(defun expand-char-ranges (str) - (let ((i 0) - (len (length str)) - chr pchr nchr - (dest "")) - (while (< i len) - (setq chr (elt str i)) - (cond ((and pchr (eq chr ?-)) - (setq pchr (1+ pchr)) - (setq i (1+ i)) - (setq nchr (elt str i)) - (while (<= pchr nchr) - (setq dest (concat dest (char-to-string pchr))) - (setq pchr (1+ pchr)) - ) - ) - (t - (setq dest (concat dest (char-to-string chr))) - )) - (setq pchr chr) - (setq i (1+ i)) - ) - dest)) - - -;;; @ space -;;; - -(defun eliminate-top-spaces (str) - "Eliminate top sequence of space or tab and return it. [tl-str.el]" - (if (string-match "^[ \t]+" str) - (substring str (match-end 0)) - str)) - -(defun eliminate-last-spaces (str) - "Eliminate last sequence of space or tab and return it. [tl-str.el]" - (if (string-match "[ \t]+$" str) - (substring str 0 (match-beginning 0)) - str)) - -(defun replace-space-with-underline (str) - (mapconcat (function - (lambda (arg) - (char-to-string - (if (eq arg ?\ ) - ?_ - arg)))) str "") - ) - - -;;; @ version -;;; - -(defun version-to-list (str) - (if (string-match "[0-9]+" str) - (let ((dest - (list - (string-to-number - (substring str (match-beginning 0)(match-end 0)) - )))) - (setq str (substring str (match-end 0))) - (while (string-match "^\\.[0-9]+" str) - (setq dest - (cons - (string-to-number - (substring str (1+ (match-beginning 0))(match-end 0))) - dest)) - (setq str (substring str (match-end 0))) - ) - (nreverse dest) - ))) - -(defun version< (v1 v2) - (or (listp v1) - (setq v1 (version-to-list v1)) - ) - (or (listp v2) - (setq v2 (version-to-list v2)) - ) - (catch 'tag - (while (and v1 v2) - (cond ((< (car v1)(car v2)) - (throw 'tag v2) - ) - ((> (car v1)(car v2)) - (throw 'tag nil) - )) - (setq v1 (cdr v1) - v2 (cdr v2)) - ) - v2)) - -(defun version<= (v1 v2) - (or (listp v1) - (setq v1 (version-to-list v1)) - ) - (or (listp v2) - (setq v2 (version-to-list v2)) - ) - (catch 'tag - (while (and v1 v2) - (cond ((< (car v1)(car v2)) - (throw 'tag v2) - ) - ((> (car v1)(car v2)) - (throw 'tag nil) - )) - (setq v1 (cdr v1) - v2 (cdr v2)) - ) - (or v2 (and (null v1)(null v2))) - )) - -(defun version> (v1 v2) - (or (listp v1) - (setq v1 (version-to-list v1)) - ) - (or (listp v2) - (setq v2 (version-to-list v2)) - ) - (catch 'tag - (while (and v1 v2) - (cond ((> (car v1)(car v2)) - (throw 'tag v1) - ) - ((< (car v1)(car v2)) - (throw 'tag nil) - )) - (setq v1 (cdr v1) - v2 (cdr v2)) - ) - v1)) - -(defun version>= (v1 v2) - (or (listp v1) - (setq v1 (version-to-list v1)) - ) - (or (listp v2) - (setq v2 (version-to-list v2)) - ) - (catch 'tag - (while (and v1 v2) - (cond ((> (car v1)(car v2)) - (throw 'tag v1) - ) - ((< (car v1)(car v2)) - (throw 'tag nil) - )) - (setq v1 (cdr v1) - v2 (cdr v2)) - ) - (or v1 (and (null v1)(null v2))) - )) - - -;;; @ RCS version -;;; - -(defun get-version-string (id) - "Return a version-string from RCS ID. [tl-str.el]" - (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id) - (substring id (match-beginning 1)(match-end 1)) - )) - - -;;; @ file name -;;; - -(defun file-name-non-extension (filename) - (if (string-match "\\.[^.]+$" filename) - (substring filename 0 (match-beginning 0)) - filename)) - -(autoload 'replace-as-filename "filename" - "Return safety filename from STRING.") - - -;;; @ symbol -;;; - -(defun symbol-concat (&rest args) - "Return a symbol whose name is concatenation of arguments ARGS -which are string or symbol. [tl-str.el]" - (intern (apply (function concat) - (mapcar (function - (lambda (s) - (cond ((symbolp s) (symbol-name s)) - ((stringp s) s) - ) - )) - args))) - ) - - -;;; @ matching -;;; - -(defun top-string-match (pat str) - "Return a list (MATCHED REST) if string PAT is top substring of -string STR. [tl-str.el]" - (if (string-match - (concat "^" (regexp-quote pat)) - str) - (list pat (substring str (match-end 0))) - )) - -(defun middle-string-match (pat str) - "Return a list (PREVIOUS MATCHED REST) if string PAT is found in -string STR. [tl-str.el]" - (if (equal pat str) - (list nil pat nil) - (if (string-match (regexp-quote pat) str) - (let ((b (match-beginning 0)) - (e (match-end 0)) ) - (list (if (not (= b 0)) - (substring str 0 b) - ) - pat - (if (> (length str) e) - (substring str e) - ) - ))))) - -(defun re-top-string-match (pat str) - "Return a list (MATCHED REST) if regexp PAT is matched as top -substring of string STR. [tl-str.el]" - (if (string-match (concat "^" pat) str) - (let ((e (match-end 0))) - (list (substring str 0 e)(substring str e)) - ))) - - -;;; @ compare -;;; - -(defun string-compare-from-top (str1 str2) - (let* ((len1 (length str1)) - (len2 (length str2)) - (len (min len1 len2)) - (p 0) - c1 c2) - (while (and (< p len) - (progn - (setq c1 (sref str1 p) - c2 (sref str2 p)) - (eq c1 c2) - )) - (setq p (+ p (char-length c1))) - ) - (and (> p 0) - (let ((matched (substring str1 0 p)) - (r1 (and (< p len1)(substring str1 p))) - (r2 (and (< p len2)(substring str2 p))) - ) - (if (eq r1 r2) - matched - (list 'seq matched (list 'or r1 r2)) - ))))) - - -;;; @ regexp -;;; - -(defun regexp-* (regexp) - (concat regexp "*")) - -(defun regexp-or (&rest args) - (concat "\\(" (mapconcat (function identity) args "\\|") "\\)")) - - -;;; @ end -;;; - -(provide 'tl-str) - -;;; tl-str.el ends here
--- a/lisp/tl/tu-comment.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -;;; tu-comment.el --- a comment out utility for Lisp programs. - -;; Copyright (C) 1995,1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/10/27 -;; Version: $Id: tu-comment.el,v 1.2 1996/12/28 21:03:11 steve Exp $ -;; Keywords: comment, Lisp - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to install. -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; (autoload 'comment-sexp "tu-comment" nil t) -;; (global-set-key "\C-c\C-q" 'comment-sexp) -;; - How to use. -;; type `C-c C-q' at the beginning of S-expression you want to -;; comment out. - -;;; Code: - -(defvar comment-sexp-first-line-method-alist - '((emacs-lisp-mode . comment-sexp-middle-line-method-for-lisp) - (lisp-interaction-mode . comment-sexp-middle-line-method-for-lisp) - (lisp-mode . comment-sexp-middle-line-method-for-lisp) - (scheme-mode . comment-sexp-middle-line-method-for-lisp) - (c-mode . comment-sexp-first-line-method-for-c) - (c++-mode . comment-sexp-middle-line-method-for-c++) - )) - -(defvar comment-sexp-middle-line-method-alist - '((emacs-lisp-mode . comment-sexp-middle-line-method-for-lisp) - (lisp-interaction-mode . comment-sexp-middle-line-method-for-lisp) - (lisp-mode . comment-sexp-middle-line-method-for-lisp) - (scheme-mode . comment-sexp-middle-line-method-for-lisp) - (c-mode . comment-sexp-middle-line-method-for-c) - (c++-mode . comment-sexp-middle-line-method-for-c++) - )) - -(defvar comment-sexp-last-line-method-alist - '((emacs-lisp-mode . comment-sexp-last-line-method-for-dummy) - (lisp-interaction-mode . comment-sexp-last-line-method-for-dummy) - (lisp-mode . comment-sexp-last-line-method-for-dummy) - (scheme-mode . comment-sexp-last-line-method-for-dummy) - (c-mode . comment-sexp-last-line-method-for-c) - (c++-mode . comment-sexp-last-line-method-for-dummy) - )) - -(defun comment-sexp-middle-line-method-for-lisp () - (insert ";; ") - ) - -(defun comment-sexp-middle-line-method-for-c++ () - (insert "// ") - ) - -(defun comment-sexp-first-line-method-for-c () - (insert "/* ") - ) - -(defun comment-sexp-middle-line-method-for-c () - (insert " * ") - ) - -(defun comment-sexp-last-line-method-for-c (c) - (insert "\n") - (while (< 0 c) - (insert " ") - (setq c (1- c)) - ) - (insert " */") - ) - -(defun comment-sexp-last-line-method-for-dummy (c)) - -(defun comment-sexp () - (interactive) - (let ((c (current-column)) - (b (save-excursion - (beginning-of-line) - (point))) - (e (save-excursion - (forward-sexp) - (point) - )) - ) - (save-excursion - (save-restriction - (narrow-to-region b e) - (untabify b e) - - (beginning-of-line) - (move-to-column c) - (funcall - (cdr (assq major-mode comment-sexp-first-line-method-alist))) - (forward-line) - - (while (< (point) (point-max)) - (beginning-of-line) - (move-to-column c) - (funcall - (cdr (assq major-mode comment-sexp-middle-line-method-alist))) - (forward-line) - ) - - (funcall - (cdr (assq major-mode comment-sexp-last-line-method-alist)) c) - )))) - -;;; tu-comment.el ends here
--- a/lisp/tl/tu-replace.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -;;; tu-replace.el --- a replacing utility for GNU Emacs - -;; Copyright (C) 1995,1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tu-replace.el,v 1.2 1996/12/28 21:03:11 steve Exp $ -;; Keywords: replace - -;; This file is part of tl (Tiny Library). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; - How to install. -;; 1. bytecompile this file and copy it to the apropriate directory. -;; 2. put the following lines to your ~/.emacs: -;; (autoload 'edit-replace-region "tu-replace" nil t) -;; - How to use. -;; 1. mark in beginning of region you want to replace. -;; 2. go to end of region you want to replace. -;; 3. type M-x edit-replace-region [CR] -;; then entering to ``edit-replace mode''. -;; 4. edit replacement string. -;; 5. type C-c C-c then specified region will be replaced. - -;;; Code: - -(defvar edit-replace-mode-map nil) -(if (null edit-replace-mode-map) - (progn - (setq edit-replace-mode-map (copy-keymap text-mode-map)) - (define-key edit-replace-mode-map - "\C-c\C-c" (function edit-replace-query-replace)) - )) - -(make-variable-buffer-local 'edit-replace-original-buffer) -(make-variable-buffer-local 'edit-replace-start-point) -(make-variable-buffer-local 'edit-replace-end-point) - -(defvar edit-replace-original-buffer nil) -(defvar edit-replace-start-point nil) -(defvar edit-replace-end-point nil) - -(defun edit-replace-region (beg end &optional str) - (interactive "r") - (let ((the-buf (current-buffer)) - (buf (get-buffer-create " *edit-replace*"))) - (pop-to-buffer buf) - (setq major-mode 'edit-replace) - (setq mode-name "edit for replace") - (use-local-map edit-replace-mode-map) - (setq edit-replace-original-buffer the-buf) - (setq edit-replace-start-point beg) - (setq edit-replace-end-point end) - )) - -(defun edit-replace-query-replace () - (interactive) - (let ((beg edit-replace-start-point) - (end edit-replace-end-point) - str - (rstr (buffer-string)) - ) - (switch-to-buffer edit-replace-original-buffer) - (setq str (buffer-substring beg end)) - (goto-char beg) - (query-replace str rstr) - )) - -;;; tu-replace.el ends here
--- a/lisp/tm/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,147 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'tm-autoloads) (error "Already loaded")) - -;;;### (autoloads (mime/editor-mode) "tm-edit" "tm/tm-edit.el") - -(autoload 'mime/editor-mode "tm-edit" "\ -MIME minor mode for editing the tagged MIME message. - -In this mode, basically, the message is composed in the tagged MIME -format. The message tag looks like: - - --[[text/plain; charset=ISO-2022-JP][7bit]] - -The tag specifies the MIME content type, subtype, optional parameters -and transfer encoding of the message following the tag. Messages -without any tag are treated as `text/plain' by default. Charset and -transfer encoding are automatically defined unless explicitly -specified. Binary messages such as audio and image are usually hidden. -The messages in the tagged MIME format are automatically translated -into a MIME compliant message when exiting this mode. - -Available charsets depend on Emacs version being used. The following -lists the available charsets of each emacs. - -EMACS 18: US-ASCII is only available. -NEmacs: US-ASCII and ISO-2022-JP are available. -EMACS 19: US-ASCII and ISO-8859-1 (or other charset) are available. -XEmacs 19: US-ASCII and ISO-8859-1 (or other charset) are available. -Mule: US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R, - ISO-2022-JP, ISO-2022-JP-2, ISO-2022-KR, BIG5 and - ISO-2022-INT-1 are available. - -ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to -be used to represent multilingual text in intermixed manner. Any -languages that has no registered charset are represented as either -ISO-2022-JP-2 or ISO-2022-INT-1 in mule. - -If you want to use non-ISO-8859-1 charset in EMACS 19 or XEmacs 19, -please set variable `default-mime-charset'. This variable must be -symbol of which name is a MIME charset. - -If you want to add more charsets in mule, please set variable -`charsets-mime-charset-alist'. This variable must be alist of which -key is list of leading-char/charset and value is symbol of MIME -charset. (leading-char is a term of MULE 1.* and 2.*. charset is a -term of XEmacs/mule, mule merged EMACS and MULE 3.*) If name of -coding-system is different as MIME charset, please set variable -`mime-charset-coding-system-alist'. This variable must be alist of -which key is MIME charset and value is coding-system. - -Following commands are available in addition to major mode commands: - -[make single part] -\\[mime-editor/insert-text] insert a text message. -\\[mime-editor/insert-file] insert a (binary) file. -\\[mime-editor/insert-external] insert a reference to external body. -\\[mime-editor/insert-voice] insert a voice message. -\\[mime-editor/insert-message] insert a mail or news message. -\\[mime-editor/insert-mail] insert a mail message. -\\[mime-editor/insert-signature] insert a signature file at end. -\\[mime-editor/insert-key] insert PGP public key. -\\[mime-editor/insert-tag] insert a new MIME tag. - -[make enclosure (maybe multipart)] -\\[mime-editor/enclose-alternative-region] enclose as multipart/alternative. -\\[mime-editor/enclose-parallel-region] enclose as multipart/parallel. -\\[mime-editor/enclose-mixed-region] enclose as multipart/mixed. -\\[mime-editor/enclose-digest-region] enclose as multipart/digest. -\\[mime-editor/enclose-signed-region] enclose as PGP signed. -\\[mime-editor/enclose-encrypted-region] enclose as PGP encrypted. -\\[mime-editor/enclose-quote-region] enclose as verbose mode (to avoid to expand tags) - -[other commands] -\\[mime-editor/set-transfer-level-7bit] set transfer-level as 7. -\\[mime-editor/set-transfer-level-8bit] set transfer-level as 8. -\\[mime-editor/set-split] set message splitting mode. -\\[mime-editor/set-sign] set PGP-sign mode. -\\[mime-editor/set-encrypt] set PGP-encryption mode. -\\[mime-editor/preview-message] preview editing MIME message. -\\[mime-editor/exit] exit and translate into a MIME compliant message. -\\[mime-editor/help] show this help. -\\[mime-editor/maybe-translate] exit and translate if in MIME mode, then split. - -Additional commands are available in some major modes: -C-c C-c exit, translate and run the original command. -C-c C-s exit, translate and run the original command. - -The following is a message example written in the tagged MIME format. -TABs at the beginning of the line are not a part of the message: - - This is a conventional plain text. It should be translated - into text/plain. - --[[text/plain]] - This is also a plain text. But, it is explicitly specified as - is. - --[[text/plain; charset=ISO-8859-1]] - This is also a plain text. But charset is specified as - iso-8859-1. - - ¡Hola! Buenos días. ¿Cómo está usted? - --[[text/enriched]] - This is a <bold>enriched text</bold>. - --[[image/gif][base64]]...image encoded in base64 here... - --[[audio/basic][base64]]...audio encoded in base64 here... - -User customizable variables (not documented all of them): - mime-prefix - Specifies a key prefix for MIME minor mode commands. - - mime-ignore-preceding-spaces - Preceding white spaces in a message body are ignored if non-nil. - - mime-ignore-trailing-spaces - Trailing white spaces in a message body are ignored if non-nil. - - mime-auto-hide-body - Hide a non-textual body message encoded in base64 after insertion - if non-nil. - - mime-editor/transfer-level - A number of network transfer level. It should be bigger than 7. - If you are in 8bit-through environment, please set 8. - - mime-editor/voice-recorder - Specifies a function to record a voice message and encode it. - The function `mime-editor/voice-recorder-for-sun' is for Sun - SparcStations. - - mime/editor-mode-hook - Turning on MIME mode calls the value of mime/editor-mode-hook, if - it is non-nil. - - mime-editor/translate-hook - The value of mime-editor/translate-hook is called just before translating - the tagged MIME format into a MIME compliant message if it is - non-nil. If the hook call the function mime-editor/insert-signature, - the signature file will be inserted automatically. - - mime-editor/exit-hook - Turning off MIME mode calls the value of mime-editor/exit-hook, if it is - non-nil." t nil) - -(defalias 'edit-mime 'mime/editor-mode) - -;;;*** - -(provide 'tm-autoloads)
--- a/lisp/tm/gnus-art-mime.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -;;; gnus-art-mime.el --- MIME extension for article mode of Gnus - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/8/6 -;; Version: -;; $Id: gnus-art-mime.el,v 1.2 1997/02/15 22:21:25 steve Exp $ -;; Keywords: news, MIME, multimedia, multilingual, encoded-word - -;; This file is not part of GNU Emacs yet. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'gnus-mime) -(require 'gnus-art) -(require 'tm-view) - -(autoload 'mime-eword/decode-region "tm-ew-d" - "Decode MIME encoded-words in region." t) -(autoload 'mime/decode-message-header "tm-ew-d" - "Decode MIME encoded-words in message header." t) - - -;;; @ encoded-word -;;; - -;;; `gnus-decode-rfc1522' of Gnus works only Q-encoded iso-8859-1 -;;; encoded-words. In addition, it does not apply decoding rule of -;;; RFC 1522 and it does not do unfolding. So gnus-mime defines own -;;; function using tm-ew-d. - -(defun gnus-decode-encoded-word () - (goto-char (point-min)) - (if (re-search-forward "^[0-9]+\t" nil t) - (progn - (goto-char (point-min)) - ;; for XOVER - (while (re-search-forward "^[0-9]+\t\\([^\t]+\\)\t" nil t) - (mime-eword/decode-region (match-beginning 1) (match-end 1) - 'unfolding 'must-unfold) - (if (re-search-forward "[^\t]+" nil t) - (mime-eword/decode-region (match-beginning 0)(match-end 0) - 'unfolding 'must-unfold) - ) - )) - (mime-eword/decode-region (point-min)(point-max) t) - )) - -(defalias 'gnus-decode-rfc1522 'gnus-decode-encoded-word) - -;; In addition, latest RFC about encoded-word is RFC 2047. (^_^; - - -;;; @ article filter -;;; - -(defun gnus-article-preview-mime-message () - (make-local-variable 'tm:mother-button-dispatcher) - (setq tm:mother-button-dispatcher - (function gnus-article-push-button)) - (let ((mime-viewer/ignored-field-regexp "^:$") - (default-mime-charset - (save-excursion - (set-buffer gnus-summary-buffer) - default-mime-charset)) - ) - (save-window-excursion - (mime/viewer-mode nil nil nil gnus-original-article-buffer - gnus-article-buffer - gnus-article-mode-map) - )) - (run-hooks 'tm-gnus/article-prepare-hook) - ) - -(defun gnus-article-decode-encoded-word () - (decode-mime-charset-region (point-min)(point-max) - (save-excursion - (set-buffer gnus-summary-buffer) - default-mime-charset)) - (mime/decode-message-header) - (run-hooks 'tm-gnus/article-prepare-hook) - ) - - -;;; @ for tm-view -;;; - -(defun gnus-content-header-filter () - (goto-char (point-min)) - (mime-preview/cut-header) - (decode-mime-charset-region (point-min)(point-max) default-mime-charset) - (mime/decode-message-header) - ) - -(defun mime-viewer/quitting-method-for-gnus () - (if (not gnus-show-mime) - (mime-viewer/kill-buffer)) - (delete-other-windows) - (gnus-article-show-summary) - (if (or (not gnus-show-mime) - (null gnus-have-all-headers)) - (gnus-summary-select-article nil t) - )) - -(call-after-loaded - 'tm-view - (lambda () - (set-alist 'mime-viewer/content-header-filter-alist - 'gnus-original-article-mode - (function gnus-content-header-filter)) - - (set-alist 'mime-viewer/code-converter-alist - 'gnus-original-article-mode - (function mime-charset/decode-buffer)) - - (set-alist 'mime-viewer/quitting-method-alist - 'gnus-original-article-mode - (function mime-viewer/quitting-method-for-gnus)) - - (set-alist 'mime-viewer/show-summary-method - 'gnus-original-article-mode - (function mime-viewer/quitting-method-for-gnus)) - )) - - -;;; @ for BBDB -;;; - -(call-after-loaded - 'bbdb - (function - (lambda () - (require 'tm-bbdb) - ))) - -(autoload 'tm-bbdb/update-record "tm-bbdb") - -(defun tm-gnus/bbdb-setup () - (if (and (boundp 'gnus-article-prepare-hook) - (memq 'bbdb/gnus-update-record gnus-article-prepare-hook) - ) - (progn - (remove-hook 'gnus-article-prepare-hook 'bbdb/gnus-update-record) - (add-hook 'gnus-article-display-hook 'tm-bbdb/update-record) - ))) - -(add-hook 'gnus-startup-hook 'tm-gnus/bbdb-setup t) - -(tm-gnus/bbdb-setup) - - -;;; @ end -;;; - -(provide 'gnus-art-mime) - -;;; gnus-art-mime.el ends here
--- a/lisp/tm/gnus-charset.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,173 +0,0 @@ -;;; gnus-charset.el --- MIME charset extension for Gnus - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/8/6 -;; Version: -;; $Id: gnus-charset.el,v 1.3 1997/03/16 03:05:45 steve Exp $ -;; Keywords: news, MIME, multimedia, multilingual, encoded-word - -;; This file is not part of GNU Emacs yet. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'gnus) - -(defvar gnus-is-red-gnus-or-later - (or (featurep 'gnus-load) - (module-installed-p 'gnus-sum) - )) - - -;;; @ newsgroup default charset -;;; - -(defvar gnus-newsgroup-default-charset-alist nil) - -(defun gnus-set-newsgroup-default-charset (newsgroup charset) - "Set CHARSET for the NEWSGROUP as default MIME charset." - (let* ((ng-regexp (concat "^" (regexp-quote newsgroup) "\\($\\|\\.\\)")) - (pair (assoc ng-regexp gnus-newsgroup-default-charset-alist)) - ) - (if pair - (setcdr pair charset) - (setq gnus-newsgroup-default-charset-alist - (cons (cons ng-regexp charset) - gnus-newsgroup-default-charset-alist)) - ))) - - -;;; @ for mule (Multilingual support) -;;; - -(cond - ((featurep 'mule) - (require 'emu) - (defvar nntp-open-binary-connection-function - (if gnus-is-red-gnus-or-later - ;; maybe Red Gnus - (if (boundp 'nntp-open-connection-function) - nntp-open-connection-function - 'nntp-open-network-stream) - ;; maybe Gnus 5.[01] or Gnus 5.[23] - (if (boundp 'nntp-open-server-function) - nntp-open-server-function - 'nntp-open-network-stream) - )) - (defun nntp-open-network-stream-with-no-code-conversion (&rest args) - (let ((proc (apply nntp-open-binary-connection-function args))) - (set-process-input-coding-system proc *noconv*) - proc)) - (if gnus-is-red-gnus-or-later - (setq nntp-open-connection-function - 'nntp-open-network-stream-with-no-code-conversion) - (setq nntp-open-server-function - 'nntp-open-network-stream-with-no-code-conversion) - ) - (call-after-loaded - 'nnheader - (lambda () - (defun nnheader-find-file-noselect (&rest args) - (as-binary-input-file - (let ((format-alist nil) - (auto-mode-alist (nnheader-auto-mode-alist)) - (default-major-mode 'fundamental-mode) - (after-insert-file-functions ; for jam-code-guess - (if (memq 'jam-code-guess-after-insert-file-function - after-insert-file-functions) - '(jam-code-guess-after-insert-file-function)))) - (apply 'find-file-noselect args))) - ) - ;; Red Gnus 0.67 or later - (defun nnheader-insert-file-contents - (filename &optional visit beg end replace) - (as-binary-input-file - (let ((format-alist nil) - (auto-mode-alist (nnheader-auto-mode-alist)) - (default-major-mode 'fundamental-mode) - (enable-local-variables nil) - (after-insert-file-functions ; for jam-code-guess - (if (memq 'jam-code-guess-after-insert-file-function - after-insert-file-functions) - '(jam-code-guess-after-insert-file-function)))) - (insert-file-contents filename visit beg end replace)) - ) - ;; for gnspool on OS/2 - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - ) - ;; imported from Red Gnus 0.66 - (or (fboundp 'nnheader-auto-mode-alist) - (defun nnheader-auto-mode-alist () - (let ((alist auto-mode-alist) - out) - (while alist - (when (listp (cdar alist)) - (push (car alist) out)) - (pop alist)) - (nreverse out))) - ) - ;; alias for Old Gnus - (defalias 'nnheader-insert-file-contents-literally - 'nnheader-insert-file-contents) - )) - (call-after-loaded - 'nnmail - (lambda () - (defun nnmail-find-file (file) - "Insert FILE in server buffer safely. [gnus-charset.el]" - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((format-alist nil) - (after-insert-file-functions ; for jam-code-guess - (if (memq 'jam-code-guess-after-insert-file-function - after-insert-file-functions) - '(jam-code-guess-after-insert-file-function))) - ) - (as-binary-input-file - (condition-case () - (progn (insert-file-contents file) t) - (file-error nil)) - ))) - )) - (defun gnus-prepare-save-mail-function () - (setq file-coding-system *noconv* - buffer-file-coding-system 'no-conversion) - ) - (add-hook 'nnmail-prepare-save-mail-hook - 'gnus-prepare-save-mail-function) - - (gnus-set-newsgroup-default-charset "alt.chinese" 'hz-gb-2312) - (gnus-set-newsgroup-default-charset "alt.chinese.text.big5" 'cn-big5) - (gnus-set-newsgroup-default-charset "fj" 'iso-2022-jp-2) - (gnus-set-newsgroup-default-charset "han" 'euc-kr) - (gnus-set-newsgroup-default-charset "hk" 'cn-big5) - (gnus-set-newsgroup-default-charset "hkstar" 'cn-big5) - (gnus-set-newsgroup-default-charset "relcom" 'koi8-r) - (gnus-set-newsgroup-default-charset "tw" 'cn-big5) - )) - - -;;; @ end -;;; - -(provide 'gnus-charset) - -;;; gnus-charset.el ends here
--- a/lisp/tm/gnus-mime.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -;;; gnus-mime.el --- MIME extensions for Gnus - -;; Copyright (C) 1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/8/6 -;; Version: $Revision: 1.6 $ -;; Keywords: news, MIME, multimedia, multilingual, encoded-word - -;; This file is not part of GNU Emacs yet. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tl-misc) - - -;;; @ version -;;; - -(defconst gnus-mime-RCS-ID - "$Id: gnus-mime.el,v 1.6 1997/03/16 03:05:45 steve Exp $") - -(defconst gnus-mime-version - (get-version-string gnus-mime-RCS-ID)) - - -;;; @ variables -;;; - -(defvar gnus-show-mime t - "*If non-nil, do mime processing of articles. -The articles will simply be fed to the function given by -`gnus-show-mime-method'.") - -(defvar gnus-show-mime-method 'gnus-article-preview-mime-message - "*Function to process a MIME message. -The function is called from the article buffer.") - -(defvar gnus-decode-encoded-word-method 'gnus-article-decode-encoded-word - "*Function to decode a MIME encoded-words. -The function is called from the article buffer.") - -(defvar gnus-parse-headers-hook - '(gnus-set-summary-default-charset gnus-decode-rfc1522) - "*A hook called before parsing the headers.") - - -;;; @ load -;;; - -(require 'gnus) -(require 'gnus-charset) - - -;;; @ end -;;; - -(provide 'gnus-mime) - -(or gnus-is-red-gnus-or-later - (require 'gnus-mime-old) - ) - -(call-after-loaded 'gnus-art (lambda () - (require 'gnus-art-mime) - )) -(call-after-loaded 'gnus-sum (lambda () - (require 'gnus-sum-mime) - )) - -(run-hooks 'gnus-mime-load-hook) - -;;; gnus-mime.el ends here
--- a/lisp/tm/gnus-sum-mime.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -;;; gnus-sum-mime.el --- MIME extension for summary mode of Gnus - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/8/6 -;; Version: -;; $Id: gnus-sum-mime.el,v 1.6 1997/04/10 05:55:52 steve Exp $ -;; Keywords: news, MIME, multimedia, multilingual, encoded-word - -;; This file is not part of GNU Emacs yet. - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'gnus-mime) -(require 'gnus-sum) - - -;;; @ summary filter -;;; - -(defun gnus-set-summary-default-charset () - (let ((charset - (if (buffer-live-p gnus-summary-buffer) - (save-excursion - (set-buffer gnus-summary-buffer) - (let ((ret (assoc-if (function - (lambda (key) - (string-match key gnus-newsgroup-name) - )) - gnus-newsgroup-default-charset-alist) - )) - (if ret - (progn - (make-local-variable 'default-mime-charset) - (setq default-mime-charset (cdr ret)) - )) - ) - default-mime-charset) - default-mime-charset))) - (goto-char (point-min)) - (while (< (point)(point-max)) - (decode-mime-charset-region (point) (point-at-eol) charset) - (end-of-line) - (let (signal-error-on-buffer-boundary) ; for XEmacs - (forward-char)) - ))) - - -;;; @ command functions -;;; - -(defun gnus-summary-preview-mime-message (arg) - "MIME decode and play this message." - (interactive "P") - (let ((gnus-break-pages nil)) - (gnus-summary-select-article t t) - ) - (pop-to-buffer gnus-original-article-buffer t) - (let (buffer-read-only) - (if (text-property-any (point-min) (point-max) 'invisible t) - (remove-text-properties (point-min) (point-max) - gnus-hidden-properties) - )) - (mime/viewer-mode nil nil nil gnus-original-article-buffer - gnus-article-buffer) - ) - -(defun gnus-summary-scroll-down () - "Scroll down one line current article." - (interactive) - (gnus-summary-scroll-up -1) - ) - -(define-key gnus-summary-mode-map "v" - (function gnus-summary-preview-mime-message)) -(define-key gnus-summary-mode-map "\e\r" - (function gnus-summary-scroll-down)) - - -;;; @ for tm-partial -;;; - -(defun gnus-mime-partial-preview-function () - (gnus-summary-preview-mime-message (gnus-summary-article-number)) - ) - -(call-after-loaded - 'tm-partial - (function - (lambda () - (set-atype 'mime/content-decoding-condition - '((type . "message/partial") - (method . mime-article/grab-message/partials) - (major-mode . gnus-original-article-mode) - (summary-buffer-exp . gnus-summary-buffer) - )) - (set-alist 'tm-partial/preview-article-method-alist - 'gnus-original-article-mode - 'gnus-mime-partial-preview-function) - ))) - - -;;; @ end -;;; - -(provide 'gnus-sum-mime) - -;;; gnus-sum-mime.el ends here
--- a/lisp/tm/message-mime.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -;;; message-mime.el --- MIME extensions for message.el - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/8/6 -;; Version: -;; $Id: message-mime.el,v 1.3 1997/02/15 22:21:26 steve Exp $ -;; Keywords: news, MIME, multimedia, multilingual, encoded-word - -;; This file is not part of GNU Emacs yet. - -;; This program 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. - -;; This program 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 This program. If not, write to the Free Software -;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(require 'tm-edit) - -(setq message-forward-start-separator - (concat (mime-make-tag "message" "rfc822") "\n")) - -(setq message-forward-end-separator "") - -(or (string-match message-included-forward-headers "Mime-Version:") - (setq message-included-forward-headers - (concat message-included-forward-headers "\\|^Mime-Version:")) - ) - -(or (string-match message-included-forward-headers "Content-Type:") - (setq message-included-forward-headers - (concat message-included-forward-headers "\\|^Content-Type:")) - ) - -(or (string-match message-included-forward-headers - "Content-Transfer-Encoding:") - (setq message-included-forward-headers - (concat message-included-forward-headers - "\\|^Content-Transfer-Encoding:")) - ) - -;;; @ for tm-edit -;;; - -;; suggested by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;; 1995/11/08 (c.f. [tm ML:1067]) -(defun message-mime-insert-article (&optional message) - (interactive) - (let ((message-cite-function 'mime-editor/inserted-message-filter) - (message-reply-buffer gnus-original-article-buffer) - ) - (message-yank-original nil) - )) - -(set-alist 'mime-editor/message-inserter-alist - 'message-mode (function message-mime-insert-article)) -(set-alist 'mime-editor/split-message-sender-alist - 'message-mode - (lambda () - (interactive) - (let (message-send-hook - message-sent-message-via) - (message-send) - ))) - - -;;; @ end -;;; - -(provide 'message-mime) - -;;; message-mime.el ends here
--- a/lisp/tm/mime-setup.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -;;; mime-setup.el --- setup file for tm viewer and composer. - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: mime-setup.el,v 1.6 1997/06/06 00:57:42 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tm-setup) - -(autoload 'mime/editor-mode "tm-edit" - "Minor mode for editing MIME message." t) -(autoload 'mime/decode-message-header "tm-ew-d" - "Decode MIME encoded-words in message header." t) - -(defun mime-setup-decode-message-header () - (save-excursion - (save-restriction - (goto-char (point-min)) - (narrow-to-region - (point-min) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (match-beginning 0) - (point-max) - )) - (mime/decode-message-header) - (set-buffer-modified-p nil) - ))) - -(add-hook 'mime/editor-mode-hook 'mime-setup-decode-message-header) - - -;;; @ variables -;;; - -(defvar mime-setup-use-sc nil - "If it is not nil, mime-setup requires sc-setup. [mime-setup.el]") - -(defvar mime-setup-use-signature t - "If it is not nil, mime-setup sets up to use signature.el. -\[mime-setup.el]") - -(defvar mime-setup-default-signature-key "\C-c\C-s" - "*Key to insert signature. [mime-setup.el]") - -(defvar mime-setup-signature-key-alist '((mail-mode . "\C-c\C-w")) - "Alist of major-mode vs. key to insert signature. [mime-setup.el]") - - -;;; @ for signature -;;; - -(defun mime-setup-set-signature-key () - (let ((key (or (cdr (assq major-mode mime-setup-signature-key-alist)) - mime-setup-default-signature-key))) - (define-key (current-local-map) key (function insert-signature)) - )) - -(if mime-setup-use-signature - (progn - (autoload 'insert-signature "signature" "Insert signature" t) - (add-hook 'mime/editor-mode-hook 'mime-setup-set-signature-key) - (setq gnus-signature-file nil) - (setq mail-signature nil) - (setq message-signature nil) - )) - - -;;; @ about SuperCite -;;; - -(if mime-setup-use-sc - (require 'sc-setup) - ) - - -;;; @ for mu-cite -;;; - -(add-hook 'mu-cite/pre-cite-hook 'mime/decode-message-header) - - -;;; @ for mail-mode, RMAIL and VM -;;; - -(add-hook 'mail-setup-hook 'mime/decode-message-header) -(add-hook 'mail-setup-hook 'mime/editor-mode 'append) -(add-hook 'mail-send-hook 'mime-editor/maybe-translate) -(set-alist 'mime-editor/split-message-sender-alist - 'mail-mode (function - (lambda () - (interactive) - (funcall send-mail-function) - ))) - -;;; @ for mh-e -;;; - -(defun mime-setup-mh-draft-setting () - (mime/editor-mode) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator "--------") - (save-excursion - (goto-char (point-min)) - (setq buffer-read-only nil) - (if (re-search-forward "^-*$" nil t) - (progn - (replace-match mail-header-separator) - (set-buffer-modified-p (buffer-modified-p)) - )) - )) - -(add-hook 'mh-letter-mode-hook 'mime-setup-mh-draft-setting t) -(add-hook 'mh-before-send-letter-hook 'mime-editor/maybe-translate) - - -;;; @ for GNUS -;;; - -(add-hook 'news-reply-mode-hook 'mime/editor-mode) -(add-hook 'news-inews-hook 'mime-editor/maybe-translate) - - -;;; @ for message (September Gnus 0.58 or later) -;;; - -(defun message-maybe-setup-default-charset () - (let ((charset - (and (boundp 'gnus-summary-buffer) - (buffer-live-p gnus-summary-buffer) - (save-excursion - (set-buffer gnus-summary-buffer) - default-mime-charset)))) - (if charset - (progn - (make-local-variable 'default-mime-charset) - (setq default-mime-charset charset) - )))) - -(or (boundp 'epoch::version) - (progn - (add-hook 'message-setup-hook 'mime/editor-mode) - (add-hook 'message-setup-hook 'message-maybe-setup-default-charset) - (add-hook 'message-send-hook 'mime-editor/maybe-translate) - (add-hook 'message-header-hook 'mime/encode-message-header) - - (call-after-loaded - 'message - (function - (lambda () - (require 'message-mime) - ))) - )) - - -;;; @ end -;;; - -(provide 'mime-setup) - -(run-hooks 'mime-setup-load-hook) - -;;; mime-setup.el ends here -;;; -;;; Local Variables: -;;; mode: emacs-lisp -;;; End:
--- a/lisp/tm/sc-setup.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -;;; -;;; $Id: sc-setup.el,v 1.2 1996/12/28 21:03:13 steve Exp $ -;;; - -(require 'emu) - - -;;; @ for Super Cite -;;; - -(if (< emacs-major-version 19) - (autoload 'sc-cite-original "sc" nil t) - (autoload 'sc-cite-original "supercite" "supercite 3.1" t) - (autoload 'sc-submit-bug-report "supercite" "Supercite 3.1" t) - ) - -(setq sc-citation-leader "") - -(cond ((boundp 'MULE) - ;; for MULE - (setq sc-cite-regexp "\\s *\\([a-zA-Z0-9]\\|\\cj\\)*>+\\s *") - ) - ((boundp 'NEMACS) - ;; for Nemacs - (setq sc-cite-regexp - "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*>+\\s *") - )) - -(if (< emacs-major-version 19) - (progn - (defun my-sc-overload-hook () - (require 'sc-oloads) - (sc-overload-functions) - ) - - ;; @@ for all but mh-e - ;; - (setq mail-yank-hooks (function sc-cite-original)) - - ;; @@ for RMAIL, PCMAIL, GNUS - ;; - (add-hook 'mail-setup-hook (function my-sc-overload-hook)) - - ;; @@ for Gnus - ;; - (add-hook 'news-reply-mode-hook (function my-sc-overload-hook)) - (add-hook 'gnews-ready-hook (function my-sc-overload-hook)) - - ;; @@ for mh-e - ;; - (add-hook 'mh-letter-mode-hook (function my-sc-overload-hook)) - (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only - ) - (add-hook 'mail-citation-hook 'sc-cite-original) - (setq news-reply-header-hook nil) - ) - - -;;; @ for sc-register -;;; -;; (setq sc-load-hook -;; '(lambda () -;; (require 'sc-register) -;; (setq sc-rewrite-header-list -;; (append sc-rewrite-header-list -;; (list (list 'sc-header-in-Japanese)) -;; )) -;; (setq sc-preferred-header-style -;; (- (length sc-rewrite-header-list) 1)) -;; )) -(setq sc-preferred-attribution 'registeredname) - - -;;; @ end -;;; - -(provide 'sc-setup)
--- a/lisp/tm/signature.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,160 +0,0 @@ -;;; signature.el --- a signature utility for GNU Emacs - -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;; Artur Pioro <artur@flugor.if.uj.edu.pl> -;; KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp> -;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Created: 1994/7/11 -;; Version: -;; $Id: signature.el,v 1.2 1996/12/28 21:03:13 steve Exp $ -;; Keywords: mail, news, signature - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) - - -;;; @ valiables -;;; - -(defvar signature-insert-at-eof nil - "*If non-nil, insert signature at the end of file.") - -(defvar signature-delete-blank-lines-at-eof nil - "*If non-nil, signature-insert-at-eof deletes blank lines at the end -of file.") - -(defvar signature-load-hook nil - "*List of functions called after signature.el is loaded.") - -(defvar signature-file-name "~/.signature" - "*Name of file containing the user's signature.") - -(defvar signature-file-alist nil) - -(defvar signature-file-prefix nil - "*String containing optional prefix for the signature file names") - -(defvar signature-insert-hook nil - "*List of functions called before inserting a signature.") - -(defvar signature-use-bbdb nil - "*If non-nil, Register sigtype to BBDB.") - -;;; -;;; Example: -;;; -;;; (setq signature-file-alist -;;; '((("Newsgroups" . "zxr") . "~/.signature-sun") -;;; (("To" . "uramimi") . "~/.signature-sun") -;;; (("Newsgroups" . "jokes") . "~/.signature-jokes") -;;; (("To" . "tea") . "~/.signature-jokes") -;;; (("To" . ("sim" "oku")) . "~/.signature-formal") -;;; )) - -(autoload 'signature/get-sigtype-from-bbdb "tm-bbdb") - -(defun signature/get-sigtype-interactively (&optional default) - (read-file-name "Insert your signature: " - (or default (concat signature-file-name "-")) - (or default signature-file-name) - nil)) - -(defun signature/get-signature-file-name () - (save-excursion - (save-restriction - (narrow-to-region - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (match-beginning 0) - (point-max) - )) - (catch 'found - (let ((alist signature-file-alist) cell field value) - (while alist - (setq cell (car alist) - field (std11-field-body (car (car cell))) - value (cdr (car cell))) - (cond ((functionp value) - (let ((name (apply value field (cdr cell)))) - (if name - (throw 'found - (concat signature-file-prefix name)) - ))) - ((stringp field) - (cond ((consp value) - (while value - (if (string-match (car value) field) - (throw 'found - (concat - signature-file-prefix (cdr cell))) - (setq value (cdr value)) - ))) - ((stringp value) - (if (string-match value field) - (throw 'found - (concat - signature-file-prefix (cdr cell))) - ))))) - (setq alist (cdr alist)) - )) - signature-file-name)))) - -(defun insert-signature (&optional arg) - "Insert the file named by signature-file-name. -It is inserted at the end of file if signature-insert-at-eof is non-nil, -and otherwise at the current point. A prefix argument enables user to -specify a file named <signature-file-name>-DISTRIBUTION interactively." - (interactive "P") - (let ((signature-file-name - (expand-file-name - (or (and signature-use-bbdb - (signature/get-sigtype-from-bbdb arg)) - (and arg - (signature/get-sigtype-interactively)) - (signature/get-signature-file-name)) - ))) - (or (file-readable-p signature-file-name) - (error "Cannot open signature file: %s" signature-file-name)) - (if signature-insert-at-eof - (progn - (goto-char (point-max)) - (or (bolp) (insert "\n")) - (if signature-delete-blank-lines-at-eof (delete-blank-lines)) - )) - (run-hooks 'signature-insert-hook) - (insert-file-contents signature-file-name) - (force-mode-line-update) - signature-file-name)) - - -;;; @ end -;;; - -(provide 'signature) - -(run-hooks 'signature-load-hook) - -;;; signature.el ends here
--- a/lisp/tm/tm-bbdb.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,302 +0,0 @@ -;;; tm-bbdb.el --- tm shared module for BBDB - -;; Copyright (C) 1995,1996 Shuhei KOBAYASHI -;; Copyright (C) 1996 Artur Pioro - -;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Artur Pioro <artur@flugor.if.uj.edu.pl> -;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Version: $Id: tm-bbdb.el,v 1.1.1.2 1996/12/21 20:50:46 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) -(require 'tm-ew-d) -(require 'tm-view) -(if (module-installed-p 'bbdb-com) - (require 'bbdb-com) - (eval-when-compile - ;; imported from bbdb-1.51 - (defmacro bbdb-pop-up-elided-display () - '(if (boundp 'bbdb-pop-up-elided-display) - bbdb-pop-up-elided-display - bbdb-elided-display)) - (defmacro bbdb-user-mail-names () - "Returns a regexp matching the address of the logged-in user" - '(or bbdb-user-mail-names - (setq bbdb-user-mail-names - (concat "\\b" (regexp-quote (user-login-name)) "\\b")))) - )) - - -;;; @ User Variables -;;; - -(defvar tm-bbdb/use-mail-extr t - "*If non-nil, `mail-extract-address-components' is used. -Otherwise `tm-bbdb/extract-address-components' overrides it.") - -(defvar tm-bbdb/auto-create-p nil - "*If t, create new BBDB records automatically. -If function, then it is called with no arguments to decide whether an -entry should be automatically creaded. - -tm-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or -`bbdb/news-auto-create-p' unless other tm-MUA overrides it.") - -(defvar tm-bbdb/delete-empty-window nil - "*If non-nil, delete empty BBDB window. -All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty. -If you prefer behavior of bbdb-gnus, set this variable to t. - -For framepop users: If empty, `framepop-banish' is used instead.") - -;;; @ mail-extr -;;; - -(defun tm-bbdb/extract-address-components (str) - (let* ((ret (std11-extract-address-components str)) - (phrase (car ret)) - (address (car (cdr ret))) - (methods tm-bbdb/canonicalize-full-name-methods)) - (while (and phrase methods) - (setq phrase (funcall (car methods) phrase) - methods (cdr methods))) - (if (string= address "") (setq address nil)) - (if (string= phrase "") (setq phrase nil)) - (list phrase address) - )) - -(or tm-bbdb/use-mail-extr - (progn - (require 'mail-extr) ; for `what-domain' - (or (fboundp 'tm:mail-extract-address-components) - (fset 'tm:mail-extract-address-components - (symbol-function 'mail-extract-address-components))) - (fset 'mail-extract-address-components - (symbol-function 'tm-bbdb/extract-address-components)) - )) - - -;;; @ bbdb-extract-field-value -;;; - -(or (fboundp 'tm:bbdb-extract-field-value) - (progn - ;; (require 'bbdb-hooks) ; not provided. - ;; (or (fboundp 'bbdb-extract-field-value) ; defined as autoload - (or (fboundp 'bbdb-header-start) - (load "bbdb-hooks")) - (fset 'tm:bbdb-extract-field-value - (symbol-function 'bbdb-extract-field-value)) - (defun bbdb-extract-field-value (field) - (let ((value (tm:bbdb-extract-field-value field))) - (and value - (mime-eword/decode-string value)))) - )) - - -;;; @ full-name canonicalization methods -;;; - -(defun tm-bbdb/canonicalize-spaces (str) - (let (dest) - (while (string-match "\\s +" str) - (setq dest (cons (substring str 0 (match-beginning 0)) dest)) - (setq str (substring str (match-end 0))) - ) - (or (string= str "") - (setq dest (cons str dest))) - (setq dest (nreverse dest)) - (mapconcat 'identity dest " ") - )) - -(defun tm-bbdb/canonicalize-dots (str) - (let (dest) - (while (string-match "\\." str) - (setq dest (cons (substring str 0 (match-end 0)) dest)) - (setq str (substring str (match-end 0))) - ) - (or (string= str "") - (setq dest (cons str dest))) - (setq dest (nreverse dest)) - (mapconcat 'identity dest " ") - )) - -(defvar tm-bbdb/canonicalize-full-name-methods - '(mime-eword/decode-string - tm-bbdb/canonicalize-dots - tm-bbdb/canonicalize-spaces)) - - -;;; @ BBDB functions for mime/viewer-mode -;;; - -(defun tm-bbdb/update-record (&optional offer-to-create) - "Return the record corresponding to the current MIME previewing message. -Creating or modifying it as necessary. A record will be created if -tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and -the user confirms the creation." - (save-excursion - (if (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (set-buffer mime::article/preview-buffer)) - (if bbdb-use-pop-up - (tm-bbdb/pop-up-bbdb-buffer offer-to-create) - (let* ((from (std11-field-body "From")) - (addr (if from - (car (cdr (mail-extract-address-components from)))))) - (if (or (null from) - (null addr) - (string-match (bbdb-user-mail-names) addr)) - (setq from (or (std11-field-body "To") from)) - ) - (if from - (bbdb-annotate-message-sender - from t - (or (bbdb-invoke-hook-for-value tm-bbdb/auto-create-p) - offer-to-create) - offer-to-create)) - )))) - -(defun tm-bbdb/annotate-sender (string) - "Add a line to the end of the Notes field of the BBDB record -corresponding to the sender of this message." - (interactive - (list (if bbdb-readonly-p - (error "The Insidious Big Brother Database is read-only.") - (read-string "Comments: ")))) - (bbdb-annotate-notes (tm-bbdb/update-record t) string)) - -(defun tm-bbdb/edit-notes (&optional arg) - "Edit the notes field or (with a prefix arg) a user-defined field -of the BBDB record corresponding to the sender of this message." - (interactive "P") - (let ((record (or (tm-bbdb/update-record t) - (error "")))) - (bbdb-display-records (list record)) - (if arg - (bbdb-record-edit-property record nil t) - (bbdb-record-edit-notes record t)))) - -(defun tm-bbdb/show-sender () - "Display the contents of the BBDB for the sender of this message. -This buffer will be in bbdb-mode, with associated keybindings." - (interactive) - (let ((record (tm-bbdb/update-record t))) - (if record - (bbdb-display-records (list record)) - (error "unperson")))) - -(defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create) - "Make the *BBDB* buffer be displayed along with the MIME preview window(s), -displaying the record corresponding to the sender of the current message." - (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer))) - (or framepop - (bbdb-pop-up-bbdb-buffer - (function - (lambda (w) - (let ((b (current-buffer))) - (set-buffer (window-buffer w)) - (prog1 (eq major-mode 'mime/viewer-mode) - (set-buffer b))))))) - (let ((bbdb-gag-messages t) - (bbdb-use-pop-up nil) - (bbdb-electric-p nil)) - (let ((record (tm-bbdb/update-record offer-to-create)) - (bbdb-elided-display (bbdb-pop-up-elided-display)) - (b (current-buffer))) - (if framepop - (if record - (bbdb-display-records (list record)) - (framepop-banish)) - (bbdb-display-records (if record (list record) nil)) - (if (and (null record) - tm-bbdb/delete-empty-window) - (delete-windows-on (get-buffer "*BBDB*")))) - (set-buffer b) - record)))) - -(defun tm-bbdb/define-keys () - (let ((mime/viewer-mode-map (current-local-map))) - (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes) - (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender) - )) - -(add-hook 'mime-viewer/define-keymap-hook 'tm-bbdb/define-keys) - - -;;; @ for signature.el -;;; - -(defun signature/get-bbdb-sigtype (addr) - "Extract sigtype information from BBDB." - (let ((record (bbdb-search-simple nil addr))) - (and record - (bbdb-record-getprop record 'sigtype)) - )) - -(defun signature/set-bbdb-sigtype (sigtype addr) - "Add sigtype information to BBDB." - (let* ((bbdb-notice-hook nil) - (record (bbdb-annotate-message-sender - addr t - (bbdb-invoke-hook-for-value - bbdb/mail-auto-create-p) - t))) - (if record - (progn - (bbdb-record-putprop record 'sigtype sigtype) - (bbdb-change-record record nil)) - ))) - -(defun signature/get-sigtype-from-bbdb (&optional verbose) - (let* ((to (std11-field-body "To")) - (addr (and to - (car (cdr (mail-extract-address-components to))))) - (sigtype (signature/get-bbdb-sigtype addr)) - return - ) - (if addr - (if verbose - (progn - (setq return (signature/get-sigtype-interactively sigtype)) - (if (and (not (string-equal return sigtype)) - (y-or-n-p - (format "Register \"%s\" for <%s>? " return addr)) - ) - (signature/set-bbdb-sigtype return addr) - ) - return) - (or sigtype - (signature/get-signature-file-name)) - )) - )) - - -;;; @ end -;;; - -(provide 'tm-bbdb) - -(run-hooks 'tm-bbdb-load-hook) - -;;; end of tm-bbdb.el
--- a/lisp/tm/tm-def.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,390 +0,0 @@ -;;; tm-def.el --- definition module for tm - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tm-def.el,v 1.6 1997/04/10 05:55:52 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, definition - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) - - -;;; @ variables -;;; - -(defvar mime/tmp-dir (or (getenv "TM_TMP_DIR") "/tmp/")) - -(defvar mime/use-multi-frame - (and (>= emacs-major-version 19) window-system)) - -(defvar mime/find-file-function - (if mime/use-multi-frame - (function find-file-other-frame) - (function find-file) - )) - -(defvar mime/output-buffer-window-is-shared-with-bbdb t - "*If t, mime/output-buffer window is shared with BBDB window.") - - -;;; @ constants -;;; - -(defconst mime/output-buffer-name "*MIME-out*") -(defconst mime/temp-buffer-name " *MIME-temp*") - - -;;; @ charset and encoding -;;; - -(defvar mime-charset-type-list - '((us-ascii 7 nil) - (iso-8859-1 8 "quoted-printable") - (iso-8859-2 8 "quoted-printable") - (iso-8859-3 8 "quoted-printable") - (iso-8859-4 8 "quoted-printable") - (iso-8859-5 8 "quoted-printable") - (koi8-r 8 "quoted-printable") - (iso-8859-7 8 "quoted-printable") - (iso-8859-8 8 "quoted-printable") - (iso-8859-9 8 "quoted-printable") - (iso-2022-jp 7 "base64") - (iso-2022-kr 7 "base64") - (euc-kr 8 "base64") - (gb2312 8 "quoted-printable") - (big5 8 "base64") - (iso-2022-jp-2 7 "base64") - (iso-2022-int-1 7 "base64") - )) - -(defun mime/encoding-name (transfer-level &optional not-omit) - (cond ((> transfer-level 8) "binary") - ((= transfer-level 8) "8bit") - (not-omit "7bit") - )) - -(defun mime/make-charset-default-encoding-alist (transfer-level) - (mapcar (function - (lambda (charset-type) - (let ((charset (upcase (symbol-name (car charset-type)))) - (type (nth 1 charset-type)) - (encoding (nth 2 charset-type)) - ) - (if (<= type transfer-level) - (cons charset (mime/encoding-name type)) - (cons charset encoding) - )))) - mime-charset-type-list)) - - -;;; @ button -;;; - -(defun tm:set-face-region (b e face) - (let ((overlay (make-overlay b e))) - (overlay-put overlay 'face face) - )) - -(defvar tm:button-face 'bold - "Face used for content-button or URL-button of MIME-Preview buffer. -\[tm-def.el]") - -(defvar tm:mouse-face 'highlight - "Face used for MIME-preview buffer mouse highlighting. [tm-def.el]") - -(defvar tm:warning-face nil - "Face used for invalid encoded-word.") - -(defun tm:add-button (from to func &optional data) - "Create a button between FROM and TO with callback FUNC and data DATA." - (and tm:button-face - (overlay-put (make-overlay from to) 'face tm:button-face)) - (add-text-properties from to - (append (and tm:mouse-face - (list 'mouse-face tm:mouse-face)) - (list 'tm-callback func) - (and data (list 'tm-data data)) - )) - ) - -(defvar tm:mother-button-dispatcher nil) - -(defun tm:button-dispatcher (event) - "Select the button under point." - (interactive "e") - (let (buf point func data) - (save-window-excursion - (mouse-set-point event) - (setq buf (current-buffer) - point (point) - func (get-text-property (point) 'tm-callback) - data (get-text-property (point) 'tm-data) - ) - ) - (save-excursion - (set-buffer buf) - (goto-char point) - (if func - (apply func data) - (if (fboundp tm:mother-button-dispatcher) - (funcall tm:mother-button-dispatcher event) - ) - )))) - - -;;; @ for URL -;;; - -(defvar tm:URL-regexp - "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]") - -(defvar browse-url-browser-function nil) - -(defun tm:browse-url (&optional url) - (if (fboundp browse-url-browser-function) - (if url - (funcall browse-url-browser-function url) - (call-interactively browse-url-browser-function)) - (if (fboundp tm:mother-button-dispatcher) - (call-interactively tm:mother-button-dispatcher) - ) - )) - - -;;; @ PGP -;;; - -(defvar pgp-function-alist - '( - ;; for tm-pgp - (verify mc-verify "mc-toplev") - (decrypt mc-decrypt "mc-toplev") - (fetch-key mc-pgp-fetch-key "mc-pgp") - (snarf-keys mc-snarf-keys "mc-toplev") - ;; for tm-edit - (mime-sign tm:mc-pgp-sign-region "tm-edit-mc") - (traditional-sign mc-pgp-sign-region "mc-pgp") - (encrypt tm:mc-pgp-encrypt-region "tm-edit-mc") - (insert-key mc-insert-public-key "mc-toplev") - ) - "Alist of service names vs. corresponding functions and its filenames. -Each element looks like (SERVICE FUNCTION FILE). - -SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', -`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' -or `insert-key'. - -Function is a symbol of function to do specified SERVICE. - -FILE is string of filename which has definition of corresponding -FUNCTION.") - -(defmacro pgp-function (method) - "Return function to do service METHOD." - (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist))))) - ) - -(mapcar (function - (lambda (method) - (autoload (second method)(third method)) - )) - pgp-function-alist) - - -;;; @ definitions about MIME -;;; - -(defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=") -(defconst mime/token-regexp (concat "[^" mime/tspecials "]+")) -(defconst mime/charset-regexp mime/token-regexp) - -(defconst mime/content-type-subtype-regexp - (concat mime/token-regexp "/" mime/token-regexp)) - -(defconst mime/disposition-type-regexp mime/token-regexp) - - -;;; @@ Base64 -;;; - -(defconst base64-token-regexp "[A-Za-z0-9+/]") -(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]") - -(defconst mime/B-encoded-text-regexp - (concat "\\(\\(" - base64-token-regexp - base64-token-regexp - base64-token-regexp - base64-token-regexp - "\\)*" - base64-token-regexp - base64-token-regexp - base64-token-padding-regexp - base64-token-padding-regexp - "\\)")) - -(defconst mime/B-encoding-and-encoded-text-regexp - (concat "\\(B\\)\\?" mime/B-encoded-text-regexp)) - - -;;; @@ Quoted-Printable -;;; - -(defconst quoted-printable-hex-chars "0123456789ABCDEF") -(defconst quoted-printable-octet-regexp - (concat "=[" quoted-printable-hex-chars - "][" quoted-printable-hex-chars "]")) - -(defconst mime/Q-encoded-text-regexp - (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+")) -(defconst mime/Q-encoding-and-encoded-text-regexp - (concat "\\(Q\\)\\?" mime/Q-encoded-text-regexp)) - - -;;; @ rot13-47 -;;; -;; caesar-region written by phr@prep.ai.mit.edu Nov 86 -;; modified by tower@prep Nov 86 -;; gnus-caesar-region -;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47. -(defun tm:caesar-region (&optional n) - "Caesar rotation of region by N, default 13, for decrypting netnews. -ROT47 will be performed for Japanese text in any case." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (cond ((not (numberp n)) (setq n 13)) - (t (setq n (mod n 26)))) ;canonicalize N - (if (not (zerop n)) ; no action needed for a rot of 0 - (progn - (if (or (not (boundp 'caesar-translate-table)) - (/= (aref caesar-translate-table ?a) (+ ?a n))) - (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (message "Building caesar-translate-table...") - (setq caesar-translate-table (make-vector 256 0)) - (while (< i 256) - (aset caesar-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower) upper (upcase lower) i 0) - (while (< i 26) - (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) - (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) - (setq i (1+ i))) - ;; ROT47 for Japanese text. - ;; Thanks to ichikawa@flab.fujitsu.junet. - (setq i 161) - (let ((t1 (logior ?O 128)) - (t2 (logior ?! 128)) - (t3 (logior ?~ 128))) - (while (< i 256) - (aset caesar-translate-table i - (let ((v (aref caesar-translate-table i))) - (if (<= v t1) (if (< v t2) v (+ v 47)) - (if (<= v t3) (- v 47) v)))) - (setq i (1+ i)))) - (message "Building caesar-translate-table...done"))) - (let ((from (region-beginning)) - (to (region-end)) - (i 0) str len) - (setq str (buffer-substring from to)) - (setq len (length str)) - (while (< i len) - (aset str i (aref caesar-translate-table (aref str i))) - (setq i (1+ i))) - (goto-char from) - (delete-region from to) - (insert str))))) - - -;;; @ field -;;; - -(defun tm:set-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (set sym field-list) - (set regexp-sym - (concat "^" (apply (function regexp-or) field-list) ":")) - ) - -(defun tm:add-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (let ((fields (eval sym))) - (mapcar (function - (lambda (field) - (or (member field fields) - (setq fields (cons field fields)) - ) - )) - (reverse field-list) - ) - (set regexp-sym - (concat "^" (apply (function regexp-or) fields) ":")) - (set sym fields) - )) - -(defun tm:delete-fields (sym field-list &optional regexp-sym) - (or regexp-sym - (setq regexp-sym - (let ((name (symbol-name sym))) - (intern - (concat (if (string-match "\\(.*\\)-list" name) - (substring name 0 (match-end 1)) - name) - "-regexp") - ))) - ) - (let ((fields (eval sym))) - (mapcar (function - (lambda (field) - (setq fields (delete field fields)) - )) - field-list) - (set regexp-sym - (concat "^" (apply (function regexp-or) fields) ":")) - (set sym fields) - )) - - -;;; @ end -;;; - -(provide 'tm-def) - -;;; tm-def.el ends here
--- a/lisp/tm/tm-edit-mc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,165 +0,0 @@ -;;; tm-edit-mc.el --- Mailcrypt interface for tm-edit - -;; Copyright (C) 1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tm-edit-mc.el,v 1.2 1996/12/28 21:03:13 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, multilingual, security, PGP - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mailcrypt) -(load "mc-pgp") - -(defun tm:mc-pgp-generic-parser (result) - (let ((ret (mc-pgp-generic-parser result))) - (if (consp ret) - (vector (car ret)(cdr ret)) - ))) - -(defun tm:mc-process-region - (beg end passwd program args parser &optional buffer boundary) - (let ((obuf (current-buffer)) - (process-connection-type nil) - mybuf result rgn proc) - (unwind-protect - (progn - (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp"))) - (set-buffer mybuf) - (erase-buffer) - (set-buffer obuf) - (buffer-disable-undo mybuf) - (setq proc - (apply 'start-process "*PGP*" mybuf program args)) - (if passwd - (progn - (process-send-string proc (concat passwd "\n")) - (or mc-passwd-timeout (mc-deactivate-passwd t)))) - (process-send-region proc beg end) - (process-send-eof proc) - (while (eq 'run (process-status proc)) - (accept-process-output proc 5)) - (setq result (process-exit-status proc)) - ;; Hack to force a status_notify() in Emacs 19.29 - (delete-process proc) - (set-buffer mybuf) - (goto-char (point-max)) - (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - ;; CRNL -> NL - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - ;; Hurm. FIXME; must get better result codes. - (if (stringp result) - (error "%s exited abnormally: '%s'" program result) - (setq rgn (funcall parser result)) - ;; If the parser found something, migrate it - (if (consp rgn) - (progn - (set-buffer obuf) - (if boundary - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (insert (format "--%s\n" boundary)) - (goto-char (point-max)) - (insert (format "\n--%s -Content-Type: application/pgp-signature -Content-Transfer-Encoding: 7bit - -" boundary)) - (insert-buffer-substring mybuf (car rgn) (cdr rgn)) - (goto-char (point-max)) - (insert (format "\n--%s--\n" boundary)) - ) - (delete-region beg end) - (goto-char beg) - (insert-buffer-substring mybuf (car rgn) (cdr rgn)) - ) - (set-buffer mybuf) - (delete-region (car rgn) (cdr rgn))))) - ;; Return nil on failure and exit code on success - (if rgn result)) - ;; Cleanup even on nonlocal exit - (if (and proc (eq 'run (process-status proc))) - (interrupt-process proc)) - (set-buffer obuf) - (or buffer (null mybuf) (kill-buffer mybuf))))) - -(defun tm:mc-pgp-sign-region (start end &optional id unclear boundary) - ;; (if (not (boundp 'mc-pgp-user-id)) - ;; (load "mc-pgp") - ;; ) - (let ((process-environment process-environment) - (buffer (get-buffer-create mc-buffer-name)) - passwd args key - (parser (function mc-pgp-generic-parser)) - (pgp-path mc-pgp-path) - ) - (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id))) - (setq passwd - (mc-activate-passwd - (cdr key) - (format "PGP passphrase for %s (%s): " (car key) (cdr key)))) - (setenv "PGPPASSFD" "0") - (setq args - (cons - (if boundary - "-fbast" - "-fast") - (list "+verbose=1" "+language=en" - (format "+clearsig=%s" (if unclear "off" "on")) - "+batchmode" "-u" (cdr key)))) - (if mc-pgp-comment - (setq args (cons (format "+comment=%s" mc-pgp-comment) args)) - ) - (message "Signing as %s ..." (car key)) - (if (tm:mc-process-region - start end passwd pgp-path args parser buffer boundary) - (progn - (if boundary - (progn - (goto-char (point-min)) - (insert - (format "\ ---[[multipart/signed; protocol=\"application/pgp-signature\"; - boundary=\"%s\"; micalg=pgp-md5][7bit]]\n" boundary)) - )) - (message "Signing as %s ... Done." (car key)) - t) - nil))) - -(defun tm:mc-pgp-encrypt-region (recipients start end &optional id sign) - (let ((mc-pgp-always-sign (if (eq sign 'maybe) - mc-pgp-always-sign - 'never))) - (mc-pgp-encrypt-region - (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients) - start end id nil) - )) - - -;;; @ end -;;; - -(provide 'tm-edit-mc) - -;;; tm-edit-mc.el ends here
--- a/lisp/tm/tm-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2601 +0,0 @@ -;;; tm-edit.el --- Simple MIME Composer for GNU Emacs - -;; Copyright (C) 1993,1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: UMEDA Masanobu <umerin@mse.kyutech.ac.jp> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1994/08/21 renamed from mime.el -;; Version: $Revision: 1.11 $ -;; Keywords: mail, news, MIME, multimedia, multilingual - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This is an Emacs minor mode for editing Internet multimedia -;; messages formatted in MIME (RFC 2045, 2046, 2047, 2048 and 2049). -;; All messages in this mode are composed in the tagged MIME format, -;; that are described in the following examples. The messages -;; composed in the tagged MIME format are automatically translated -;; into a MIME compliant message when exiting the mode. - -;; Mule (a multilingual extension to Emacs 18 and 19) has a capability -;; of handling multilingual text in limited ISO-2022 manner that is -;; based on early experiences in Japanese Internet community and -;; resulted in RFC 1468 (ISO-2022-JP charset for MIME). In order to -;; enable multilingual capability in single text message in MIME, -;; charset of multilingual text written in Mule is declared as either -;; `ISO-2022-JP-2' [RFC 1554]. Mule is required for reading the such -;; messages. - -;; This MIME composer can work with Mail mode, mh-e letter Mode, and -;; News mode. First of all, you need the following autoload -;; definition to load mime/editor-mode automatically: -;; -;; (autoload 'mime/editor-mode "tm-edit" -;; "Minor mode for editing MIME message." t) -;; -;; In case of Mail mode (includes VM mode), you need the following -;; hook definition: -;; -;; (add-hook 'mail-mode-hook 'mime/editor-mode) -;; (add-hook 'mail-send-hook 'mime-editor/maybe-translate) -;; -;; In case of MH-E, you need the following hook definition: -;; -;; (add-hook 'mh-letter-mode-hook -;; (function -;; (lambda () -;; (mime/editor-mode) -;; (make-local-variable 'mail-header-separator) -;; (setq mail-header-separator "--------") -;; )))) -;; (add-hook 'mh-before-send-letter-hook 'mime-editor/maybe-translate) -;; -;; In case of News mode, you need the following hook definition: -;; -;; (add-hook 'news-reply-mode-hook 'mime/editor-mode) -;; (add-hook 'news-inews-hook 'mime-editor/maybe-translate) -;; -;; In case of Emacs 19, it is possible to emphasize the message tags -;; using font-lock mode as follows: -;; -;; (add-hook 'mime/editor-mode-hook -;; (function -;; (lambda () -;; (font-lock-mode 1) -;; (setq font-lock-keywords (list mime-editor/tag-regexp)) -;; )))) - -;; The message tag looks like: -;; -;; --[[TYPE/SUBTYPE;PARAMETERS][ENCODING]] -;; -;; The tagged MIME message examples: -;; -;; This is a conventional plain text. It should be translated into -;; text/plain. -;; -;;--[[text/plain]] -;; This is also a plain text. But, it is explicitly specified as is. -;;--[[text/plain; charset=ISO-8859-1]] -;; This is also a plain text. But charset is specified as iso-8859-1. -;; -;; ¡Hola! Buenos días. ¿Cómo está usted? -;;--[[text/enriched]] -;; <center>This is a richtext.</center> -;; -;;--[[image/gif][base64]]^M...image encoded in base64 comes here... -;; -;;--[[audio/basic][base64]]^M...audio encoded in base64 comes here... - -;;; Code: - -(require 'sendmail) -(require 'mail-utils) -(require 'mel) -(require 'tl-list) -(require 'tm-view) -(require 'tm-ew-e) -(require 'signature) - - -;;; @ version -;;; - -(defconst mime-editor/RCS-ID - "$Id: tm-edit.el,v 1.11 1997/06/06 00:57:43 steve Exp $") - -(defconst mime-editor/version (get-version-string mime-editor/RCS-ID)) - -(defconst mime-editor/version-name - (concat "tm-edit " mime-editor/version)) - - -;;; @ variables -;;; - -(defvar mime-prefix "\C-c\C-x" - "*Keymap prefix for MIME commands.") - -(defvar mime-ignore-preceding-spaces nil - "*Ignore preceding white spaces if non-nil.") - -(defvar mime-ignore-trailing-spaces nil - "*Ignore trailing white spaces if non-nil.") - -(defvar mime-ignore-same-text-tag t - "*Ignore preceding text content-type tag that is same with new one. -If non-nil, the text tag is not inserted unless something different.") - -(defvar mime-auto-hide-body t - "*Hide non-textual body encoded in base64 after insertion if non-nil.") - -(defvar mime-editor/voice-recorder - (function mime-editor/voice-recorder-for-sun) - "*Function to record a voice message and encode it. [tm-edit.el]") - -(defvar mime/editor-mode-hook nil - "*Hook called when enter MIME mode.") - -(defvar mime-editor/translate-hook nil - "*Hook called before translating into a MIME compliant message. -To insert a signature file automatically, call the function -`mime-editor/insert-signature' from this hook.") - -(defvar mime-editor/exit-hook nil - "*Hook called when exit MIME mode.") - -(defvar mime-content-types - '(("text" - ;; Charset parameter need not to be specified, since it is - ;; defined automatically while translation. - ("plain" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("richtext" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("enriched" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("x-latex" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("html" - ;;("charset" "" "ISO-2022-JP" "US-ASCII" "ISO-8859-1" "ISO-8859-8") - ) - ("x-rot13-47") - ) - ("message" - ("external-body" - ("access-type" - ("anon-ftp" - ("site" "ftp.jaist.ac.jp" "wnoc-fuk.wide.ad.jp" "nic.karrn.ad.jp") - ("directory" "/pub/GNU/elisp/mime") - ("name") - ("mode" "image" "ascii" "local8")) - ("ftp" - ("site") - ("directory") - ("name") - ("mode" "image" "ascii" "local8")) - ("tftp" ("site") ("name")) - ("afs" ("site") ("name")) - ("local-file" ("site") ("name")) - ("mail-server" ("server" "ftpmail@nic.karrn.ad.jp")) - )) - ("rfc822") - ) - ("application" - ("octet-stream" ("type" "" "tar" "shar")) - ("postscript") - ("x-kiss" ("x-cnf"))) - ("image" - ("gif") - ("jpeg") - ("png") - ("tiff") - ("x-pic") - ("x-mag") - ("x-xwd") - ("x-xbm") - ) - ("audio" ("basic")) - ("video" ("mpeg")) - ) - "*Alist of content-type, subtype, parameters and its values.") - -(defvar mime-file-types - '(("\\.rtf$" - "text" "richtext" nil - nil - nil nil) - ("\\.html$" - "text" "html" nil - nil - nil nil) - ("\\.ps$" - "application" "postscript" nil - "quoted-printable" - "attachment" (("filename" . file)) - ) - ("\\.jpg$" - "image" "jpeg" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.gif$" - "image" "gif" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.png$" - "image" "png" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.tiff$" - "image" "tiff" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.pic$" - "image" "x-pic" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.mag$" - "image" "x-mag" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.xbm$" - "image" "x-xbm" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.xwd$" - "image" "x-xwd" nil - "base64" - "inline" (("filename" . file)) - ) - ("\\.au$" - "audio" "basic" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.mpg$" - "video" "mpeg" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.el$" - "application" "octet-stream" (("type" . "emacs-lisp")) - "7bit" - "attachment" (("filename" . file)) - ) - ("\\.lsp$" - "application" "octet-stream" (("type" . "common-lisp")) - "7bit" - "attachment" (("filename" . file)) - ) - ("\\.tar\\.gz$" - "application" "octet-stream" (("type" . "tar+gzip")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.tgz$" - "application" "octet-stream" (("type" . "tar+gzip")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.tar\\.Z$" - "application" "octet-stream" (("type" . "tar+compress")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.taz$" - "application" "octet-stream" (("type" . "tar+compress")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.gz$" - "application" "octet-stream" (("type" . "gzip")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.Z$" - "application" "octet-stream" (("type" . "compress")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.lzh$" - "application" "octet-stream" (("type" . "lha")) - "base64" - "attachment" (("filename" . file)) - ) - ("\\.zip$" - "application" "zip" nil - "base64" - "attachment" (("filename" . file)) - ) - ("\\.diff$" - "application" "octet-stream" (("type" . "patch")) - nil - "attachment" (("filename" . file)) - ) - ("\\.patch$" - "application" "octet-stream" (("type" . "patch")) - nil - "attachment" (("filename" . file)) - ) - ("\\.signature" - "text" "plain" nil nil) - (".*" - "application" "octet-stream" nil - nil - "attachment" (("filename" . file)) - ) - ) - "*Alist of file name, types, parameters, and default encoding. -If encoding is nil, it is determined from its contents.") - -;;; @@ about charset, encoding and transfer-level -;;; - -(defvar mime-editor/transfer-level 7 - "*A number of network transfer level. It should be bigger than 7.") -(make-variable-buffer-local 'mime-editor/transfer-level) - -(defvar mime-editor/transfer-level-string - (mime/encoding-name mime-editor/transfer-level 'not-omit) - "*A string formatted version of mime/defaul-transfer-level") -(make-variable-buffer-local 'mime-editor/transfer-level-string) - -(defun mime-editor/make-charset-default-encoding-alist (transfer-level) - (mapcar (function - (lambda (charset-type) - (let ((charset (car charset-type)) - (type (nth 1 charset-type)) - (encoding (nth 2 charset-type)) - ) - (if (<= type transfer-level) - (cons charset (mime/encoding-name type)) - (cons charset encoding) - )))) - mime-charset-type-list)) - -(defvar mime-editor/charset-default-encoding-alist - (mime-editor/make-charset-default-encoding-alist mime-editor/transfer-level)) -(make-variable-buffer-local 'mime-editor/charset-default-encoding-alist) - -;;; @@ about message inserting -;;; - -(defvar mime-editor/yank-ignored-field-list - '("Received" "Approved" "Path" "Replied" "Status" - "Xref" "X-UIDL" "X-Filter" "X-Gnus-.*" "X-VM-.*") - "Delete these fields from original message when it is inserted -as message/rfc822 part. -Each elements are regexp of field-name. [tm-edit.el]") - -(defvar mime-editor/yank-ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-editor/yank-ignored-field-list) - ":")) - -(defvar mime-editor/message-inserter-alist nil) -(defvar mime-editor/mail-inserter-alist nil) - -;;; @@ about message splitting -;;; - -(defvar mime-editor/split-message t - "*Split large message if it is non-nil. [tm-edit.el]") - -(defvar mime-editor/message-default-max-lines 1000 - "*Default maximum lines of a message. [tm-edit.el]") - -(defvar mime-editor/message-max-lines-alist - '((news-reply-mode . 500)) - "Alist of major-mode vs maximum lines of a message. -If it is not specified for a major-mode, -`mime-editor/message-default-max-lines' is used. [tm-edit.el]") - -(defconst mime-editor/split-ignored-field-regexp - "\\(^Content-\\|^Subject:\\|^Mime-Version:\\)") - -(defvar mime-editor/split-blind-field-regexp - "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)") - -(defvar mime-editor/split-message-sender-alist nil) - -(defvar mime-editor/news-reply-mode-server-running nil) - - -;;; @@ about PGP -;;; - -(defvar mime-editor/signing-type 'pgp-elkins - "*PGP signing type (pgp-elkins, pgp-kazu or nil). [tm-edit.el]") - -(defvar mime-editor/encrypting-type 'pgp-elkins - "*PGP encrypting type (pgp-elkins, pgp-kazu or nil). [tm-edit.el]") - - -;;; @@ about tag -;;; - -(defconst mime-editor/single-part-tag-regexp - "--[[][[]\\([^]]*\\)]\\([[]\\([^]]*\\)]\\|\\)]" - "*Regexp of MIME tag in the form of [[CONTENT-TYPE][ENCODING]].") - -(defconst mime-editor/quoted-single-part-tag-regexp - (concat "- " (substring mime-editor/single-part-tag-regexp 1))) - -(defconst mime-editor/multipart-beginning-regexp "--<<\\([^<>]+\\)>>-{\n") - -(defconst mime-editor/multipart-end-regexp "--}-<<\\([^<>]+\\)>>\n") - -(defconst mime-editor/beginning-tag-regexp - (regexp-or mime-editor/single-part-tag-regexp - mime-editor/multipart-beginning-regexp)) - -(defconst mime-editor/end-tag-regexp - (regexp-or mime-editor/single-part-tag-regexp - mime-editor/multipart-end-regexp)) - -(defconst mime-editor/tag-regexp - (regexp-or mime-editor/single-part-tag-regexp - mime-editor/multipart-beginning-regexp - mime-editor/multipart-end-regexp)) - -(defvar mime-tag-format "--[[%s]]" - "*Control-string making a MIME tag.") - -(defvar mime-tag-format-with-encoding "--[[%s][%s]]" - "*Control-string making a MIME tag with encoding.") - -;;; @@ multipart boundary -;;; - -(defvar mime-multipart-boundary "Multipart" - "*Boundary of a multipart message.") - - -;;; @@ buffer local variables -;;; - -(defvar mime/editor-mode-old-local-map nil) -(defvar mime/editing-buffer nil) - - -;;; @ constants -;;; - -(defconst mime-tspecials-regexp "[][()<>@,;:\\\"/?.= \t]" - "*Specify MIME tspecials. -Tspecials means any character that matches with it in header must be quoted.") - -(defconst mime-editor/mime-version-value - (concat "1.0 (generated by " mime-editor/version-name ")") - "MIME version number.") - -(defconst mime-editor/mime-map (make-sparse-keymap) - "Keymap for MIME commands.") - -;;; @ keymap and menu -;;; - -(defvar mime/editor-mode-flag nil) -(make-variable-buffer-local 'mime/editor-mode-flag) - -(defun mime-editor/define-keymap (keymap) - "Add mime-editor commands to KEYMAP." - (if (not (keymapp keymap)) - nil - (define-key keymap "\C-t" 'mime-editor/insert-text) - (define-key keymap "\C-i" 'mime-editor/insert-file) - (define-key keymap "\C-e" 'mime-editor/insert-external) - (define-key keymap "\C-v" 'mime-editor/insert-voice) - (define-key keymap "\C-y" 'mime-editor/insert-message) - (define-key keymap "\C-m" 'mime-editor/insert-mail) - (define-key keymap "\C-w" 'mime-editor/insert-signature) - (define-key keymap "\C-s" 'mime-editor/insert-signature) - (define-key keymap "\C-k" 'mime-editor/insert-key) - (define-key keymap "t" 'mime-editor/insert-tag) - (define-key keymap "a" 'mime-editor/enclose-alternative-region) - (define-key keymap "p" 'mime-editor/enclose-parallel-region) - (define-key keymap "m" 'mime-editor/enclose-mixed-region) - (define-key keymap "d" 'mime-editor/enclose-digest-region) - (define-key keymap "s" 'mime-editor/enclose-signed-region) - (define-key keymap "e" 'mime-editor/enclose-encrypted-region) - (define-key keymap "q" 'mime-editor/enclose-quote-region) - (define-key keymap "7" 'mime-editor/set-transfer-level-7bit) - (define-key keymap "8" 'mime-editor/set-transfer-level-8bit) - (define-key keymap "/" 'mime-editor/set-split) - (define-key keymap "v" 'mime-editor/set-sign) - (define-key keymap "h" 'mime-editor/set-encrypt) - (define-key keymap "\C-p" 'mime-editor/preview-message) - (define-key keymap "\C-z" 'mime-editor/exit) - (define-key keymap "?" 'mime-editor/help) - )) - -(mime-editor/define-keymap mime-editor/mime-map) - -(defun mime-editor/toggle-mode () - (interactive) - (if mime/editor-mode-flag - (mime-editor/exit 'nomime) - (mime/editor-mode) - )) - -(cond (running-xemacs - (defconst mime-editor/minor-mime-map nil "Keymap for MIME commands.") - (or mime-editor/minor-mime-map - (progn - (setq mime-editor/minor-mime-map - (make-sparse-keymap 'mime-editor/minor-mime-map)) - (define-key - mime-editor/minor-mime-map mime-prefix mime-editor/mime-map) - )) - (add-minor-mode 'mime/editor-mode-flag - '((" MIME-Edit " mime-editor/transfer-level-string)) - mime-editor/minor-mime-map - nil - 'mime-editor/toggle-mode) - ) - (t - (set-alist 'minor-mode-alist - 'mime/editor-mode-flag - '((" MIME-Edit " mime-editor/transfer-level-string)))) - ) - -(defconst mime-editor/menu-title "MIME-Edit") - -(defconst mime-editor/menu-list - '((mime-help "Describe MIME editor mode" mime-editor/help) - (file "Insert File" mime-editor/insert-file) - (external "Insert External" mime-editor/insert-external) - (voice "Insert Voice" mime-editor/insert-voice) - (message "Insert Message" mime-editor/insert-message) - (mail "Insert Mail" mime-editor/insert-mail) - (signature "Insert Signature" mime-editor/insert-signature) - (text "Insert Text" mime-editor/insert-text) - (tag "Insert Tag" mime-editor/insert-tag) - (alternative "Enclose as alternative" - mime-editor/enclose-alternative-region) - (parallel "Enclose as parallel" mime-editor/enclose-parallel-region) - (mixed "Enclose as serial" mime-editor/enclose-mixed-region) - (digest "Enclose as digest" mime-editor/enclose-digest-region) - (signed "Enclose as signed" mime-editor/enclose-signed-region) - (encrypted "Enclose as encrypted" mime-editor/enclose-encrypted-region) - (quote "Verbatim region" mime-editor/enclose-quote-region) - (key "Insert Public Key" mime-editor/insert-key) - (split "About split" mime-editor/set-split) - (sign "About sign" mime-editor/set-sign) - (encrypt "About encryption" mime-editor/set-encrypt) - (preview "Preview Message" mime-editor/preview-message) - (level "Toggle transfer-level" mime-editor/toggle-transfer-level) - ) - "MIME-edit menubar entry.") - -(defun mime-editor/define-menu-for-emacs19 () - "Define menu for Emacs 19." - (define-key (current-local-map) [menu-bar mime-edit] - (cons mime-editor/menu-title - (make-sparse-keymap mime-editor/menu-title))) - (mapcar (function - (lambda (item) - (define-key (current-local-map) - (vector 'menu-bar 'mime-edit (car item)) - (cons (nth 1 item)(nth 2 item)) - ) - )) - (reverse mime-editor/menu-list) - )) - -;;; modified by Pekka Marjola <pema@iki.fi> -;;; 1995/9/5 (c.f. [tm-en:69]) -(defun mime-editor/define-menu-for-xemacs () - "Define menu for Emacs 19." - (cond ((featurep 'menubar) - (make-local-variable 'current-menubar) - (set-buffer-menubar current-menubar) - (add-submenu nil - (cons mime-editor/menu-title - (mapcar (function - (lambda (item) - (vector (nth 1 item)(nth 2 item) - mime/editor-mode-flag) - )) - mime-editor/menu-list))) - ))) - -;;; modified by Steven L. Baur <steve@miranova.com> -;;; 1995/12/6 (c.f. [tm-en:209]) -(if (and running-xemacs (not (boundp 'mime-editor/popup-menu-for-xemacs))) - (setq mime-editor/popup-menu-for-xemacs - (append '("MIME Commands" "---") - (mapcar (function (lambda (item) - (vector (nth 1 item) - (nth 2 item) - t))) - mime-editor/menu-list))) - ) -;;; end - - -;;; @ functions -;;; - -;;;###autoload -(defun mime/editor-mode () - "MIME minor mode for editing the tagged MIME message. - -In this mode, basically, the message is composed in the tagged MIME -format. The message tag looks like: - - --[[text/plain; charset=ISO-2022-JP][7bit]] - -The tag specifies the MIME content type, subtype, optional parameters -and transfer encoding of the message following the tag. Messages -without any tag are treated as `text/plain' by default. Charset and -transfer encoding are automatically defined unless explicitly -specified. Binary messages such as audio and image are usually hidden. -The messages in the tagged MIME format are automatically translated -into a MIME compliant message when exiting this mode. - -Available charsets depend on Emacs version being used. The following -lists the available charsets of each emacs. - -EMACS 18: US-ASCII is only available. -NEmacs: US-ASCII and ISO-2022-JP are available. -EMACS 19: US-ASCII and ISO-8859-1 (or other charset) are available. -XEmacs 19: US-ASCII and ISO-8859-1 (or other charset) are available. -Mule: US-ASCII, ISO-8859-* (except for ISO-8859-5), KOI8-R, - ISO-2022-JP, ISO-2022-JP-2, ISO-2022-KR, BIG5 and - ISO-2022-INT-1 are available. - -ISO-2022-JP-2 and ISO-2022-INT-1 charsets used in mule is expected to -be used to represent multilingual text in intermixed manner. Any -languages that has no registered charset are represented as either -ISO-2022-JP-2 or ISO-2022-INT-1 in mule. - -If you want to use non-ISO-8859-1 charset in EMACS 19 or XEmacs 19, -please set variable `default-mime-charset'. This variable must be -symbol of which name is a MIME charset. - -If you want to add more charsets in mule, please set variable -`charsets-mime-charset-alist'. This variable must be alist of which -key is list of leading-char/charset and value is symbol of MIME -charset. (leading-char is a term of MULE 1.* and 2.*. charset is a -term of XEmacs/mule, mule merged EMACS and MULE 3.*) If name of -coding-system is different as MIME charset, please set variable -`mime-charset-coding-system-alist'. This variable must be alist of -which key is MIME charset and value is coding-system. - -Following commands are available in addition to major mode commands: - -\[make single part\] -\\[mime-editor/insert-text] insert a text message. -\\[mime-editor/insert-file] insert a (binary) file. -\\[mime-editor/insert-external] insert a reference to external body. -\\[mime-editor/insert-voice] insert a voice message. -\\[mime-editor/insert-message] insert a mail or news message. -\\[mime-editor/insert-mail] insert a mail message. -\\[mime-editor/insert-signature] insert a signature file at end. -\\[mime-editor/insert-key] insert PGP public key. -\\[mime-editor/insert-tag] insert a new MIME tag. - -\[make enclosure (maybe multipart)\] -\\[mime-editor/enclose-alternative-region] enclose as multipart/alternative. -\\[mime-editor/enclose-parallel-region] enclose as multipart/parallel. -\\[mime-editor/enclose-mixed-region] enclose as multipart/mixed. -\\[mime-editor/enclose-digest-region] enclose as multipart/digest. -\\[mime-editor/enclose-signed-region] enclose as PGP signed. -\\[mime-editor/enclose-encrypted-region] enclose as PGP encrypted. -\\[mime-editor/enclose-quote-region] enclose as verbose mode (to avoid to expand tags) - -\[other commands\] -\\[mime-editor/set-transfer-level-7bit] set transfer-level as 7. -\\[mime-editor/set-transfer-level-8bit] set transfer-level as 8. -\\[mime-editor/set-split] set message splitting mode. -\\[mime-editor/set-sign] set PGP-sign mode. -\\[mime-editor/set-encrypt] set PGP-encryption mode. -\\[mime-editor/preview-message] preview editing MIME message. -\\[mime-editor/exit] exit and translate into a MIME compliant message. -\\[mime-editor/help] show this help. -\\[mime-editor/maybe-translate] exit and translate if in MIME mode, then split. - -Additional commands are available in some major modes: -C-c C-c exit, translate and run the original command. -C-c C-s exit, translate and run the original command. - -The following is a message example written in the tagged MIME format. -TABs at the beginning of the line are not a part of the message: - - This is a conventional plain text. It should be translated - into text/plain. - --[[text/plain]] - This is also a plain text. But, it is explicitly specified as - is. - --[[text/plain; charset=ISO-8859-1]] - This is also a plain text. But charset is specified as - iso-8859-1. - - ¡Hola! Buenos días. ¿Cómo está usted? - --[[text/enriched]] - This is a <bold>enriched text</bold>. - --[[image/gif][base64]]...image encoded in base64 here... - --[[audio/basic][base64]]...audio encoded in base64 here... - -User customizable variables (not documented all of them): - mime-prefix - Specifies a key prefix for MIME minor mode commands. - - mime-ignore-preceding-spaces - Preceding white spaces in a message body are ignored if non-nil. - - mime-ignore-trailing-spaces - Trailing white spaces in a message body are ignored if non-nil. - - mime-auto-hide-body - Hide a non-textual body message encoded in base64 after insertion - if non-nil. - - mime-editor/transfer-level - A number of network transfer level. It should be bigger than 7. - If you are in 8bit-through environment, please set 8. - - mime-editor/voice-recorder - Specifies a function to record a voice message and encode it. - The function `mime-editor/voice-recorder-for-sun' is for Sun - SparcStations. - - mime/editor-mode-hook - Turning on MIME mode calls the value of mime/editor-mode-hook, if - it is non-nil. - - mime-editor/translate-hook - The value of mime-editor/translate-hook is called just before translating - the tagged MIME format into a MIME compliant message if it is - non-nil. If the hook call the function mime-editor/insert-signature, - the signature file will be inserted automatically. - - mime-editor/exit-hook - Turning off MIME mode calls the value of mime-editor/exit-hook, if it is - non-nil." - (interactive) - (if mime/editor-mode-flag - (error "You are already editing a MIME message.") - (setq mime/editor-mode-flag t) - ;; Remember old key bindings. - (if running-xemacs - (use-local-map (or (current-local-map) (make-sparse-keymap))) - (make-local-variable 'mime/editor-mode-old-local-map) - (setq mime/editor-mode-old-local-map (current-local-map)) - ;; Add MIME commands to current local map. - (use-local-map (copy-keymap (or (current-local-map) - (make-sparse-keymap)))) - ) - (if (not (lookup-key (current-local-map) mime-prefix)) - (define-key (current-local-map) mime-prefix mime-editor/mime-map)) - - ;; Set transfer level into mode line - ;; - (setq mime-editor/transfer-level-string - (mime/encoding-name mime-editor/transfer-level 'not-omit)) - (force-mode-line-update) - - ;; Define menu. Menus for other emacs implementations are - ;; welcome. - (cond (running-xemacs - (mime-editor/define-menu-for-xemacs)) - ((>= emacs-major-version 19) - (mime-editor/define-menu-for-emacs19) - )) - ;; end - - (enable-invisible) - - ;; I don't care about saving these. - (setq paragraph-start - (regexp-or mime-editor/single-part-tag-regexp - paragraph-start)) - (setq paragraph-separate - (regexp-or mime-editor/single-part-tag-regexp - paragraph-separate)) - (run-hooks 'mime/editor-mode-hook) - (message - (substitute-command-keys - "Type \\[mime-editor/exit] to exit MIME mode, and type \\[mime-editor/help] to get help.")) - )) - -;;;###autoload -(defalias 'edit-mime 'mime/editor-mode) ; for convenience -(defalias 'mime-mode 'mime/editor-mode) ; for convenience - -(defun mime-editor/exit (&optional nomime no-error) - "Translate the tagged MIME message into a MIME compliant message. -With no argument encode a message in the buffer into MIME, otherwise -just return to previous mode." - (interactive "P") - (if (not mime/editor-mode-flag) - (if (null no-error) - (error "You aren't editing a MIME message.") - ) - (if (not nomime) - (progn - (run-hooks 'mime-editor/translate-hook) - (mime-editor/translate-buffer))) - ;; Restore previous state. - (setq mime/editor-mode-flag nil) - (cond (running-xemacs - (if (featurep 'menubar) - (delete-menu-item (list mime-editor/menu-title)))) - (t - (use-local-map mime/editor-mode-old-local-map))) - - (end-of-invisible) - (set-buffer-modified-p (buffer-modified-p)) - (run-hooks 'mime-editor/exit-hook) - (message "Exit MIME editor mode.") - )) - -(defun mime-editor/maybe-translate () - (interactive) - (mime-editor/exit nil t) - (call-interactively 'mime-editor/maybe-split-and-send) - ) - -(defun mime-editor/help () - "Show help message about MIME mode." - (interactive) - (with-output-to-temp-buffer "*Help*" - (princ "MIME editor mode:\n") - (princ (documentation 'mime/editor-mode)) - (print-help-return-message))) - -(defun mime-editor/insert-text () - "Insert a text message. -Charset is automatically obtained from the `charsets-mime-charset-alist'." - (interactive) - (let ((ret (mime-editor/insert-tag "text" nil nil))) - (if ret - (progn - (if (looking-at mime-editor/single-part-tag-regexp) - (progn - ;; Make a space between the following message. - (insert "\n") - (forward-char -1) - )) - (if (and (member (second ret) '("enriched" "richtext")) - (fboundp 'enriched-mode) - ) - (enriched-mode t) - (if (boundp 'enriched-mode) - (enriched-mode nil) - )))))) - -(defun mime-editor/insert-file (file &optional verbose) - "Insert a message from a file." - (interactive "fInsert file as MIME message: \nP") - (let* ((guess (mime-find-file-type file)) - (type (nth 0 guess)) - (subtype (nth 1 guess)) - (parameters (nth 2 guess)) - (encoding (nth 3 guess)) - (disposition-type (nth 4 guess)) - (disposition-params (nth 5 guess)) - ) - (if verbose - (setq type (mime-prompt-for-type type) - subtype (mime-prompt-for-subtype type subtype) - )) - (if (or (interactive-p) verbose) - (setq encoding (mime-prompt-for-encoding encoding)) - ) - (if (or (consp parameters) (stringp disposition-type)) - (let ((rest parameters) cell attribute value) - (setq parameters "") - (while rest - (setq cell (car rest)) - (setq attribute (car cell)) - (setq value (cdr cell)) - (if (eq value 'file) - (setq value (std11-wrap-as-quoted-string - (file-name-nondirectory file))) - ) - (setq parameters (concat parameters "; " attribute "=" value)) - (setq rest (cdr rest)) - ) - (if disposition-type - (progn - (setq parameters - (concat parameters "\n" - "Content-Disposition: " disposition-type)) - (setq rest disposition-params) - (while rest - (setq cell (car rest)) - (setq attribute (car cell)) - (setq value (cdr cell)) - (if (eq value 'file) - (setq value (std11-wrap-as-quoted-string - (file-name-nondirectory file))) - ) - (setq parameters - (concat parameters "; " attribute "=" value)) - (setq rest (cdr rest)) - ) - )) - )) - (mime-editor/insert-tag type subtype parameters) - (mime-editor/insert-binary-file file encoding) - )) - -(defun mime-editor/insert-external () - "Insert a reference to external body." - (interactive) - (mime-editor/insert-tag "message" "external-body" nil ";\n\t") - ;;(forward-char -1) - ;;(insert "Content-Description: " (read-string "Content-Description: ") "\n") - ;;(forward-line 1) - (let* ((pritype (mime-prompt-for-type)) - (subtype (mime-prompt-for-subtype pritype)) - (parameters (mime-prompt-for-parameters pritype subtype ";\n\t"))) - (and pritype - subtype - (insert "Content-Type: " - pritype "/" subtype (or parameters "") "\n"))) - (if (and (not (eobp)) - (not (looking-at mime-editor/single-part-tag-regexp))) - (insert (mime-make-text-tag) "\n"))) - -(defun mime-editor/insert-voice () - "Insert a voice message." - (interactive) - (let ((encoding - (completing-read - "What transfer encoding: " - mime-file-encoding-method-alist nil t nil))) - (mime-editor/insert-tag "audio" "basic" nil) - (mime-editor/define-encoding encoding) - (save-restriction - (narrow-to-region (1- (point))(point)) - (unwind-protect - (funcall mime-editor/voice-recorder encoding) - (progn - (insert "\n") - (invisible-region (point-min)(point-max)) - (goto-char (point-max)) - ))))) - -(defun mime-editor/insert-signature (&optional arg) - "Insert a signature file." - (interactive "P") - (let ((signature-insert-hook - (function - (lambda () - (apply (function mime-editor/insert-tag) - (mime-find-file-type signature-file-name)) - ))) - ) - (insert-signature arg) - )) - - -;; Insert a new tag around a point. - -(defun mime-editor/insert-tag (&optional pritype subtype parameters delimiter) - "Insert new MIME tag and return a list of PRITYPE, SUBTYPE, and PARAMETERS. -If nothing is inserted, return nil." - (interactive) - (let ((p (point))) - (mime-editor/goto-tag) - (if (and (re-search-forward mime-editor/tag-regexp nil t) - (< (match-beginning 0) p) - (< p (match-end 0)) - ) - (goto-char (match-beginning 0)) - (goto-char p) - )) - (let ((oldtag nil) - (newtag nil) - (current (point)) - ) - (setq pritype - (or pritype - (mime-prompt-for-type))) - (setq subtype - (or subtype - (mime-prompt-for-subtype pritype))) - (setq parameters - (or parameters - (mime-prompt-for-parameters pritype subtype delimiter))) - ;; Make a new MIME tag. - (setq newtag (mime-make-tag pritype subtype parameters)) - ;; Find an current MIME tag. - (setq oldtag - (save-excursion - (if (mime-editor/goto-tag) - (buffer-substring (match-beginning 0) (match-end 0)) - ;; Assume content type is 'text/plan'. - (mime-make-tag "text" "plain") - ))) - ;; We are only interested in TEXT. - (if (and oldtag - (not (mime-test-content-type - (mime-editor/get-contype oldtag) "text"))) - (setq oldtag nil)) - ;; Make a new tag. - (if (or (not oldtag) ;Not text - (or mime-ignore-same-text-tag - (not (string-equal oldtag newtag)))) - (progn - ;; Mark the beginning of the tag for convenience. - (push-mark (point) 'nomsg) - (insert newtag "\n") - (list pritype subtype parameters) ;New tag is created. - ) - ;; Restore previous point. - (goto-char current) - nil ;Nothing is created. - ) - )) - -(defun mime-editor/insert-binary-file (file &optional encoding) - "Insert binary FILE at point. -Optional argument ENCODING specifies an encoding method such as base64." - (let* ((tagend (1- (point))) ;End of the tag - (hide-p (and mime-auto-hide-body - (stringp encoding) - (not - (let ((en (downcase encoding))) - (or (string-equal en "7bit") - (string-equal en "8bit") - (string-equal en "binary") - ))))) - ) - (save-restriction - (narrow-to-region tagend (point)) - (mime-insert-encoded-file file encoding) - (if hide-p - (progn - (invisible-region (point-min) (point-max)) - (goto-char (point-max)) - ) - (goto-char (point-max)) - )) - (or hide-p - (looking-at mime-editor/tag-regexp) - (= (point)(point-max)) - (mime-editor/insert-tag "text" "plain") - ) - ;; Define encoding even if it is 7bit. - (if (stringp encoding) - (save-excursion - (goto-char tagend) ; Make sure which line the tag is on. - (mime-editor/define-encoding encoding) - )) - )) - - -;; Commands work on a current message flagment. - -(defun mime-editor/goto-tag () - "Search for the beginning of the tagged MIME message." - (let ((current (point)) multipart) - (if (looking-at mime-editor/tag-regexp) - t - ;; At first, go to the end. - (cond ((re-search-forward mime-editor/beginning-tag-regexp nil t) - (goto-char (1- (match-beginning 0))) ;For multiline tag - ) - (t - (goto-char (point-max)) - )) - ;; Then search for the beginning. - (re-search-backward mime-editor/end-tag-regexp nil t) - (or (looking-at mime-editor/beginning-tag-regexp) - ;; Restore previous point. - (progn - (goto-char current) - nil - )) - ))) - -(defun mime-editor/content-beginning () - "Return the point of the beginning of content." - (save-excursion - (let ((beg (save-excursion - (beginning-of-line) (point)))) - (if (mime-editor/goto-tag) - (let ((top (point))) - (goto-char (match-end 0)) - (if (and (= beg top) - (= (following-char) ?\^M)) - (point) - (forward-line 1) - (point))) - ;; Default text/plain tag. - (goto-char (point-min)) - (re-search-forward - (concat "\n" (regexp-quote mail-header-separator) - (if mime-ignore-preceding-spaces - "[ \t\n]*\n" "\n")) nil 'move) - (point)) - ))) - -(defun mime-editor/content-end () - "Return the point of the end of content." - (save-excursion - (let ((beg (point))) - (if (mime-editor/goto-tag) - (let ((top (point))) - (goto-char (match-end 0)) - (if (invisible-p (point)) - (next-visible-point (point)) - ;; Move to the end of this text. - (if (re-search-forward mime-editor/tag-regexp nil 'move) - ;; Don't forget a multiline tag. - (goto-char (match-beginning 0)) - ) - (point) - )) - ;; Assume the message begins with text/plain. - (goto-char (mime-editor/content-beginning)) - (if (re-search-forward mime-editor/tag-regexp nil 'move) - ;; Don't forget a multiline tag. - (goto-char (match-beginning 0))) - (point)) - ))) - -(defun mime-editor/define-charset (charset) - "Set charset of current tag to CHARSET." - (save-excursion - (if (mime-editor/goto-tag) - (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert - (mime-create-tag - (mime-editor/set-parameter - (mime-editor/get-contype tag) - "charset" (upcase (symbol-name charset))) - (mime-editor/get-encoding tag))) - )))) - -(defun mime-editor/define-encoding (encoding) - "Set encoding of current tag to ENCODING." - (save-excursion - (if (mime-editor/goto-tag) - (let ((tag (buffer-substring (match-beginning 0) (match-end 0)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert (mime-create-tag (mime-editor/get-contype tag) encoding))) - ))) - -(defun mime-editor/choose-charset () - "Choose charset of a text following current point." - (detect-mime-charset-region (point) (mime-editor/content-end)) - ) - -(defun mime-make-text-tag (&optional subtype) - "Make a tag for a text after current point. -Subtype of text type can be specified by an optional argument SUBTYPE. -Otherwise, it is obtained from mime-content-types." - (let* ((pritype "text") - (subtype (or subtype - (car (car (cdr (assoc pritype mime-content-types))))))) - ;; Charset should be defined later. - (mime-make-tag pritype subtype))) - - -;; Tag handling functions - -(defun mime-make-tag (pritype subtype &optional parameters encoding) - "Make a tag of MIME message of PRITYPE, SUBTYPE and optional PARAMETERS." - (mime-create-tag (concat (or pritype "") "/" (or subtype "") - (or parameters "")) - encoding)) - -(defun mime-create-tag (contype &optional encoding) - "Make a tag with CONTENT-TYPE and optional ENCODING." - (format (if encoding mime-tag-format-with-encoding mime-tag-format) - contype encoding)) - -(defun mime-editor/get-contype (tag) - "Return Content-Type (including parameters) of TAG." - (and (stringp tag) - (or (string-match mime-editor/single-part-tag-regexp tag) - (string-match mime-editor/multipart-beginning-regexp tag) - (string-match mime-editor/multipart-end-regexp tag) - ) - (substring tag (match-beginning 1) (match-end 1)) - )) - -(defun mime-editor/get-encoding (tag) - "Return encoding of TAG." - (and (stringp tag) - (string-match mime-editor/single-part-tag-regexp tag) - (match-beginning 3) - (not (= (match-beginning 3) (match-end 3))) - (substring tag (match-beginning 3) (match-end 3)))) - -(defun mime-get-parameter (contype parameter) - "For given CONTYPE return value for PARAMETER. -Nil if no such parameter." - (if (string-match - (concat - ";[ \t\n]*" - (regexp-quote parameter) - "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\([ \t\n]*;\\|$\\)") - contype) - (substring contype (match-beginning 1) (match-end 1)) - nil ;No such parameter - )) - -(defun mime-editor/set-parameter (contype parameter value) - "For given CONTYPE set PARAMETER to VALUE." - (let (ctype opt-fields) - (if (string-match "\n[^ \t\n\r]+:" contype) - (setq ctype (substring contype 0 (match-beginning 0)) - opt-fields (substring contype (match-beginning 0))) - (setq ctype contype) - ) - (if (string-match - (concat - ";[ \t\n]*\\(" - (regexp-quote parameter) - "[ \t\n]*=[ \t\n]*\\([^\" \t\n;]*\\|\"[^\"]*\"\\)\\)[ \t\n]*\\(;\\|$\\)") - ctype) - ;; Change value - (concat (substring ctype 0 (match-beginning 1)) - parameter "=" value - (substring contype (match-end 1)) - opt-fields) - (concat ctype "; " parameter "=" value opt-fields) - ))) - -(defun mime-strip-parameters (contype) - "Return primary content-type and subtype without parameters for CONTYPE." - (if (string-match "^[ \t]*\\([^; \t\n]*\\)" contype) - (substring contype (match-beginning 1) (match-end 1)) nil)) - -(defun mime-test-content-type (contype type &optional subtype) - "Test if CONTYPE is a TYPE and an optional SUBTYPE." - (and (stringp contype) - (stringp type) - (string-match - (concat "^[ \t]*" (downcase type) "/" (downcase (or subtype ""))) - (downcase contype)))) - - -;; Basic functions - -(defun mime-find-file-type (file) - "Guess Content-Type, subtype, and parameters from FILE." - (let ((guess nil) - (guesses mime-file-types)) - (while (and (not guess) guesses) - (if (string-match (car (car guesses)) file) - (setq guess (cdr (car guesses)))) - (setq guesses (cdr guesses))) - guess - )) - -(defun mime-prompt-for-type (&optional default) - "Ask for Content-type." - (let ((type "")) - ;; Repeat until primary content type is specified. - (while (string-equal type "") - (setq type - (completing-read "What content type: " - mime-content-types - nil - 'require-match ;Type must be specified. - default - )) - (if (string-equal type "") - (progn - (message "Content type is required.") - (beep) - (sit-for 1) - )) - ) - type)) - -(defun mime-prompt-for-subtype (type &optional default) - "Ask for subtype of media-type TYPE." - (let ((subtypes (cdr (assoc type mime-content-types)))) - (or (and default - (assoc default subtypes)) - (setq default (car (car subtypes))) - )) - (let* ((answer - (completing-read - (if default - (concat - "What content subtype: (default " default ") ") - "What content subtype: ") - (cdr (assoc type mime-content-types)) - nil - 'require-match ;Subtype must be specified. - nil - ))) - (if (string-equal answer "") default answer))) - -(defun mime-prompt-for-parameters (pritype subtype &optional delimiter) - "Ask for Content-type parameters of Content-Type PRITYPE and SUBTYPE. -Optional DELIMITER specifies parameter delimiter (';' by default)." - (let* ((delimiter (or delimiter "; ")) - (parameters - (mapconcat - (function identity) - (delq nil - (mime-prompt-for-parameters-1 - (cdr (assoc subtype - (cdr (assoc pritype mime-content-types)))))) - delimiter - ))) - (if (and (stringp parameters) - (not (string-equal parameters ""))) - (concat delimiter parameters) - "" ;"" if no parameters - ))) - -(defun mime-prompt-for-parameters-1 (optlist) - (apply (function append) - (mapcar (function mime-prompt-for-parameter) optlist))) - -(defun mime-prompt-for-parameter (parameter) - "Ask for PARAMETER. -Parameter must be '(PROMPT CHOICE1 (CHOISE2 ...))." - (let* ((prompt (car parameter)) - (choices (mapcar (function - (lambda (e) - (if (consp e) e (list e)))) - (cdr parameter))) - (default (car (car choices))) - (answer nil)) - (if choices - (progn - (setq answer - (completing-read - (concat "What " prompt - ": (default " - (if (string-equal default "") "\"\"" default) - ") ") - choices nil nil "")) - ;; If nothing is selected, use default. - (if (string-equal answer "") - (setq answer default))) - (setq answer - (read-string (concat "What " prompt ": ")))) - (cons (if (and answer - (not (string-equal answer ""))) - (concat prompt "=" - ;; Note: control characters ignored! - (if (string-match mime-tspecials-regexp answer) - (concat "\"" answer "\"") answer))) - (mime-prompt-for-parameters-1 (cdr (assoc answer (cdr parameter))))) - )) - -(defun mime-prompt-for-encoding (default) - "Ask for Content-Transfer-Encoding. [tm-edit.el]" - (let (encoding) - (while (string= - (setq encoding - (completing-read - "What transfer encoding: " - mime-file-encoding-method-alist nil t default) - ) - "")) - encoding)) - - -;;; @ Translate the tagged MIME messages into a MIME compliant message. -;;; - -(defvar mime-editor/translate-buffer-hook - '(mime-editor/pgp-enclose-buffer - mime-editor/translate-header - mime-editor/translate-body)) - -(defun mime-editor/translate-header () - "Encode the message header into network representation." - (mime/encode-message-header 'code-conversion) - (run-hooks 'mime-editor/translate-header-hook) - ) - -(defun mime-editor/translate-buffer () - "Encode the tagged MIME message in current buffer in MIME compliant message." - (interactive) - (if (catch 'mime-editor/error - (save-excursion - (run-hooks 'mime-editor/translate-buffer-hook) - )) - (progn - (undo) - (error "Translation error!") - ))) - -(defun mime-editor/find-inmost () - (goto-char (point-min)) - (if (re-search-forward mime-editor/multipart-beginning-regexp nil t) - (let ((bb (match-beginning 0)) - (be (match-end 0)) - (type (buffer-substring (match-beginning 1)(match-end 1))) - end-exp eb ee) - (setq end-exp (format "--}-<<%s>>\n" type)) - (widen) - (if (re-search-forward end-exp nil t) - (progn - (setq eb (match-beginning 0)) - (setq ee (match-end 0)) - ) - (setq eb (point-max)) - (setq ee (point-max)) - ) - (narrow-to-region be eb) - (goto-char be) - (if (re-search-forward mime-editor/multipart-beginning-regexp nil t) - (let (ret) - (narrow-to-region (match-beginning 0)(point-max)) - (mime-editor/find-inmost) - ) - (widen) - (list type bb be eb) - )))) - -(defun mime-editor/process-multipart-1 (boundary) - (let ((ret (mime-editor/find-inmost))) - (if ret - (let ((type (car ret)) - (bb (nth 1 ret))(be (nth 2 ret)) - (eb (nth 3 ret)) - ) - (narrow-to-region bb eb) - (delete-region bb be) - (setq bb (point-min)) - (setq eb (point-max)) - (widen) - (goto-char eb) - (if (looking-at mime-editor/multipart-end-regexp) - (let ((beg (match-beginning 0)) - (end (match-end 0)) - ) - (delete-region beg end) - (or (looking-at mime-editor/beginning-tag-regexp) - (eobp) - (insert (concat (mime-make-text-tag) "\n")) - ))) - (cond ((string-equal type "quote") - (mime-editor/enquote-region bb eb) - ) - ((string-equal type "signed") - (cond ((eq mime-editor/signing-type 'pgp-elkins) - (mime-editor/sign-pgp-elkins bb eb boundary) - ) - ((eq mime-editor/signing-type 'pgp-kazu) - (mime-editor/sign-pgp-kazu bb eb boundary) - )) - ) - ((string-equal type "encrypted") - (cond ((eq mime-editor/encrypting-type 'pgp-elkins) - (mime-editor/encrypt-pgp-elkins bb eb boundary) - ) - ((eq mime-editor/encrypting-type 'pgp-kazu) - (mime-editor/encrypt-pgp-kazu bb eb boundary) - ))) - (t - (setq boundary - (nth 2 (mime-editor/translate-region bb eb - boundary t))) - (goto-char bb) - (insert - (format "--[[multipart/%s; - boundary=\"%s\"][7bit]]\n" - type boundary)) - )) - boundary)))) - -(defun mime-editor/enquote-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (while (re-search-forward mime-editor/single-part-tag-regexp nil t) - (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) - (replace-match (concat "- " (substring tag 1))) - ))))) - -(defun mime-editor/dequote-region (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (while (re-search-forward - mime-editor/quoted-single-part-tag-regexp nil t) - (let ((tag (buffer-substring (match-beginning 0)(match-end 0)))) - (replace-match (concat "-" (substring tag 2))) - ))))) - -(defun mime-editor/sign-pgp-elkins (beg end boundary) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let* ((ret - (mime-editor/translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - (pgp-boundary (concat "pgp-sign-" boundary)) - ) - (goto-char beg) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'mime-sign) - (point-min)(point-max) nil nil pgp-boundary)) - (throw 'mime-editor/error 'pgp-error) - ) - )))) - -(defvar mime-editor/encrypt-recipient-fields-list '("To" "cc")) - -(defun mime-editor/make-encrypt-recipient-header () - (let* ((names mime-editor/encrypt-recipient-fields-list) - (values - (std11-field-bodies (cons "From" names) - nil mail-header-separator)) - (from (prog1 - (car values) - (setq values (cdr values)))) - (header (and (stringp from) - (if (string-equal from "") - "" - (format "From: %s\n" from) - ))) - recipients) - (while (and names values) - (let ((name (car names)) - (value (car values)) - ) - (and (stringp value) - (or (string-equal value "") - (progn - (setq header (concat header name ": " value "\n") - recipients (if recipients - (concat recipients " ," value) - value)) - )))) - (setq names (cdr names) - values (cdr values)) - ) - (vector from recipients header) - )) - -(defun mime-editor/encrypt-pgp-elkins (beg end boundary) - (save-excursion - (save-restriction - (let (from recipients header) - (let ((ret (mime-editor/make-encrypt-recipient-header))) - (setq from (aref ret 0) - recipients (aref ret 1) - header (aref ret 2)) - ) - (narrow-to-region beg end) - (let* ((ret - (mime-editor/translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - (pgp-boundary (concat "pgp-" boundary)) - ) - (goto-char beg) - (insert header) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (funcall (pgp-function 'encrypt) - recipients (point-min) (point-max) from) - (throw 'mime-editor/error 'pgp-error) - ) - (goto-char beg) - (insert (format "--[[multipart/encrypted; - boundary=\"%s\"; - protocol=\"application/pgp-encrypted\"][7bit]] ---%s -Content-Type: application/pgp-encrypted - ---%s -Content-Type: application/octet-stream -Content-Transfer-Encoding: 7bit - -" pgp-boundary pgp-boundary pgp-boundary)) - (goto-char (point-max)) - (insert (format "\n--%s--\n" pgp-boundary)) - ))))) - -(defun mime-editor/sign-pgp-kazu (beg end boundary) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let* ((ret - (mime-editor/translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - ) - (goto-char beg) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'traditional-sign) - beg (point-max))) - (throw 'mime-editor/error 'pgp-error) - ) - (goto-char beg) - (insert - "--[[application/pgp; format=mime][7bit]]\n") - )) - )) - -(defun mime-editor/encrypt-pgp-kazu (beg end boundary) - (save-excursion - (let (from recipients header) - (let ((ret (mime-editor/make-encrypt-recipient-header))) - (setq from (aref ret 0) - recipients (aref ret 1) - header (aref ret 2)) - ) - (save-restriction - (narrow-to-region beg end) - (let* ((ret - (mime-editor/translate-region beg end boundary)) - (ctype (car ret)) - (encoding (nth 1 ret)) - (parts (nth 3 ret)) - ) - (goto-char beg) - (insert header) - (insert (format "Content-Type: %s\n" ctype)) - (if encoding - (insert (format "Content-Transfer-Encoding: %s\n" encoding)) - ) - (insert "\n") - (or (as-binary-process - (funcall (pgp-function 'encrypt) - recipients beg (point-max) nil 'maybe) - ) - (throw 'mime-editor/error 'pgp-error) - ) - (goto-char beg) - (insert - "--[[application/pgp; format=mime][7bit]]\n") - )) - ))) - -(defun mime-editor/translate-body () - "Encode the tagged MIME body in current buffer in MIME compliant message." - (interactive) - (save-excursion - (let ((boundary - (concat mime-multipart-boundary "_" - (replace-space-with-underline (current-time-string)) - )) - (i 1) - ret) - (while (mime-editor/process-multipart-1 - (format "%s-%d" boundary i)) - (setq i (1+ i)) - ) - (save-restriction - ;; We are interested in message body. - (let* ((beg - (progn - (goto-char (point-min)) - (re-search-forward - (concat "\n" (regexp-quote mail-header-separator) - (if mime-ignore-preceding-spaces - "[ \t\n]*\n" "\n")) nil 'move) - (point))) - (end - (progn - (goto-char (point-max)) - (and mime-ignore-trailing-spaces - (re-search-backward "[^ \t\n]\n" beg t) - (forward-char 1)) - (point)))) - (setq ret (mime-editor/translate-region - beg end - (format "%s-%d" boundary i))) - )) - (mime-editor/dequote-region (point-min)(point-max)) - (let ((contype (car ret)) ;Content-Type - (encoding (nth 1 ret)) ;Content-Transfer-Encoding - ) - ;; Make primary MIME headers. - (or (mail-position-on-field "Mime-Version") - (insert mime-editor/mime-version-value)) - ;; Remove old Content-Type and other fields. - (save-restriction - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") nil t) - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (mime-delete-field "Content-Type") - (mime-delete-field "Content-Transfer-Encoding")) - ;; Then, insert Content-Type and Content-Transfer-Encoding fields. - (mail-position-on-field "Content-Type") - (insert contype) - (if encoding - (progn - (mail-position-on-field "Content-Transfer-Encoding") - (insert encoding))) - )))) - -(defun mime-editor/translate-single-part-tag (&optional prefix) - (if (re-search-forward mime-editor/single-part-tag-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (tag (buffer-substring beg end)) - ) - (delete-region beg end) - (let ((contype (mime-editor/get-contype tag)) - (encoding (mime-editor/get-encoding tag)) - ) - (insert (concat prefix "--" boundary "\n")) - (save-restriction - (narrow-to-region (point)(point)) - (insert "Content-Type: " contype "\n") - (if encoding - (insert "Content-Transfer-Encoding: " encoding "\n")) - (mime/encode-message-header) - )) - t))) - -(defun mime-editor/translate-region (beg end &optional boundary multipart) - (if (null boundary) - (setq boundary - (concat mime-multipart-boundary "_" - (replace-space-with-underline (current-time-string)))) - ) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (let ((tag nil) ;MIME tag - (contype nil) ;Content-Type - (encoding nil) ;Content-Transfer-Encoding - (nparts 0)) ;Number of body parts - ;; Normalize the body part by inserting appropriate message - ;; tags for every message contents. - (mime-editor/normalize-body) - ;; Counting the number of Content-Type. - (goto-char (point-min)) - (while (re-search-forward mime-editor/single-part-tag-regexp nil t) - (setq nparts (1+ nparts))) - ;; Begin translation. - (cond - ((and (<= nparts 1)(not multipart)) - ;; It's a singular message. - (goto-char (point-min)) - (while (re-search-forward - mime-editor/single-part-tag-regexp nil t) - (setq tag - (buffer-substring (match-beginning 0) (match-end 0))) - (delete-region (match-beginning 0) (1+ (match-end 0))) - (setq contype (mime-editor/get-contype tag)) - (setq encoding (mime-editor/get-encoding tag)) - )) - (t - ;; It's a multipart message. - (goto-char (point-min)) - (and (mime-editor/translate-single-part-tag) - (while (mime-editor/translate-single-part-tag "\n")) - ) - ;; Define Content-Type as "multipart/mixed". - (setq contype - (concat "multipart/mixed;\n boundary=\"" boundary "\"")) - ;; Content-Transfer-Encoding must be "7bit". - ;; The following encoding can be `nil', but is - ;; specified as is since there is no way that a user - ;; specifies it. - (setq encoding "7bit") - ;; Insert the trailer. - (goto-char (point-max)) - (insert "\n--" boundary "--\n") - )) - (list contype encoding boundary nparts) - )))) - -(defun mime-editor/normalize-body () - "Normalize the body part by inserting appropriate message tags." - ;; Insert the first MIME tags if necessary. - (goto-char (point-min)) - (if (not (looking-at mime-editor/single-part-tag-regexp)) - (insert (mime-make-text-tag) "\n")) - ;; Check each tag, and add new tag or correct it if necessary. - (goto-char (point-min)) - (while (re-search-forward mime-editor/single-part-tag-regexp nil t) - (let* ((tag (buffer-substring (match-beginning 0) (match-end 0))) - (contype (mime-editor/get-contype tag)) - (charset (mime-get-parameter contype "charset")) - (encoding (mime-editor/get-encoding tag))) - ;; Remove extra whitespaces after the tag. - (if (looking-at "[ \t]+$") - (delete-region (match-beginning 0) (match-end 0))) - (let ((beg (point)) - (end (mime-editor/content-end)) - ) - (if (= end (point-max)) - nil - (goto-char end) - (or (looking-at mime-editor/beginning-tag-regexp) - (eobp) - (insert (mime-make-text-tag) "\n") - )) - (visible-region beg end) - (goto-char beg) - ) - (cond - ((mime-test-content-type contype "message") - ;; Content-type "message" should be sent as is. - (forward-line 1) - ) - ((mime-test-content-type contype "text") - ;; Define charset for text if necessary. - (setq charset (if charset - (intern (downcase charset)) - (mime-editor/choose-charset))) - (mime-editor/define-charset charset) - (cond ((string-equal contype "text/x-rot13-47") - (save-excursion - (forward-line) - (set-mark (point)) - (goto-char (mime-editor/content-end)) - (tm:caesar-region) - )) - ((string-equal contype "text/enriched") - (save-excursion - (let ((beg (progn - (forward-line) - (point))) - (end (mime-editor/content-end)) - ) - ;; Patch for hard newlines - ;; (save-excursion - ;; (goto-char beg) - ;; (while (search-forward "\n" end t) - ;; (put-text-property (match-beginning 0) - ;; (point) - ;; 'hard t))) - ;; End patch for hard newlines - (enriched-encode beg end) - (goto-char beg) - (if (search-forward "\n\n") - (delete-region beg (match-end 0)) - ) - )))) - ;; Point is now on current tag. - ;; Define encoding and encode text if necessary. - (or encoding ;Encoding is not specified. - (let* ((encoding - (cdr - (assq charset - mime-editor/charset-default-encoding-alist) - )) - (beg (mime-editor/content-beginning)) - ) - (encode-mime-charset-region beg (mime-editor/content-end) - charset) - (mime-encode-region beg (mime-editor/content-end) encoding) - (mime-editor/define-encoding encoding) - )) - (goto-char (mime-editor/content-end)) - ) - ((null encoding) ;Encoding is not specified. - ;; Application, image, audio, video, and any other - ;; unknown content-type without encoding should be - ;; encoded. - (let* ((encoding "base64") ;Encode in BASE64 by default. - (beg (mime-editor/content-beginning)) - (end (mime-editor/content-end)) - (body (buffer-substring beg end)) - ) - (mime-encode-region beg end encoding) - (mime-editor/define-encoding encoding)) - (forward-line 1) - )) - ))) - -(defun mime-delete-field (field) - "Delete header FIELD." - (let ((regexp (format "^%s:[ \t]*" field))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point))) - ))) - - -;;; -;;; Platform dependent functions -;;; - -;; Sun implementations - -(defun mime-editor/voice-recorder-for-sun (encoding) - "Record voice in a buffer using Sun audio device, -and insert data encoded as ENCODING. [tm-edit.el]" - (message "Start the recording on %s. Type C-g to finish the recording..." - (system-name)) - (mime-insert-encoded-file "/dev/audio" encoding) - ) - - -;;; @ Other useful commands. -;;; - -;; Message forwarding commands as content-type "message/rfc822". - -(defun mime-editor/insert-message (&optional message) - (interactive) - (let ((inserter (assoc-value major-mode mime-editor/message-inserter-alist))) - (if (and inserter (fboundp inserter)) - (progn - (mime-editor/insert-tag "message" "rfc822") - (funcall inserter message) - ) - (message "Sorry, I don't have message inserter for your MUA.") - ))) - -(defun mime-editor/insert-mail (&optional message) - (interactive) - (let ((inserter (assoc-value major-mode mime-editor/mail-inserter-alist))) - (if (and inserter (fboundp inserter)) - (progn - (mime-editor/insert-tag "message" "rfc822") - (funcall inserter message) - ) - (message "Sorry, I don't have mail inserter for your MUA.") - ))) - -(defun mime-editor/inserted-message-filter () - (save-excursion - (save-restriction - (let ((header-start (point)) - (case-fold-search t) - beg end) - ;; for Emacs 18 - ;; (if (re-search-forward "^$" (marker-position (mark-marker))) - (if (re-search-forward "^$" (mark t)) - (narrow-to-region header-start (match-beginning 0)) - ) - (goto-char header-start) - (while (and (re-search-forward - mime-editor/yank-ignored-field-regexp nil t) - (setq beg (match-beginning 0)) - (setq end (1+ (std11-field-end))) - ) - (delete-region beg end) - ) - )))) - - -;;; @ multipart enclosure -;;; - -(defun mime-editor/enclose-region (type beg end) - (save-excursion - (goto-char beg) - (let ((current (point))) - (save-restriction - (narrow-to-region beg end) - (insert (format "--<<%s>>-{\n" type)) - (goto-char (point-max)) - (insert (format "--}-<<%s>>\n" type)) - (goto-char (point-max)) - ) - (or (looking-at mime-editor/beginning-tag-regexp) - (eobp) - (insert (mime-make-text-tag) "\n") - ) - ))) - -(defun mime-editor/enclose-quote-region (beg end) - (interactive "*r") - (mime-editor/enclose-region "quote" beg end) - ) - -(defun mime-editor/enclose-mixed-region (beg end) - (interactive "*r") - (mime-editor/enclose-region "mixed" beg end) - ) - -(defun mime-editor/enclose-parallel-region (beg end) - (interactive "*r") - (mime-editor/enclose-region "parallel" beg end) - ) - -(defun mime-editor/enclose-digest-region (beg end) - (interactive "*r") - (mime-editor/enclose-region "digest" beg end) - ) - -(defun mime-editor/enclose-alternative-region (beg end) - (interactive "*r") - (mime-editor/enclose-region "alternative" beg end) - ) - -(defun mime-editor/enclose-signed-region (beg end) - (interactive "*r") - (if mime-editor/signing-type - (mime-editor/enclose-region "signed" beg end) - (message "Please specify signing type.") - )) - -(defun mime-editor/enclose-encrypted-region (beg end) - (interactive "*r") - (if mime-editor/signing-type - (mime-editor/enclose-region "encrypted" beg end) - (message "Please specify encrypting type.") - )) - -(defun mime-editor/insert-key (&optional arg) - "Insert a pgp public key." - (interactive "P") - (mime-editor/insert-tag "application" "pgp-keys") - (mime-editor/define-encoding "7bit") - (funcall (pgp-function 'insert-key)) - ) - - -;;; @ flag setting -;;; - -(defun mime-editor/set-split (arg) - (interactive - (list - (y-or-n-p "Do you want to enable split?") - )) - (setq mime-editor/split-message arg) - (if arg - (message "This message is enabled to split.") - (message "This message is not enabled to split.") - )) - -(defun mime-editor/toggle-transfer-level (&optional transfer-level) - "Toggle transfer-level is 7bit or 8bit through. - -Optional TRANSFER-LEVEL is a number of transfer-level, 7 or 8." - (interactive) - (if (numberp transfer-level) - (setq mime-editor/transfer-level transfer-level) - (if (< mime-editor/transfer-level 8) - (setq mime-editor/transfer-level 8) - (setq mime-editor/transfer-level 7) - )) - (setq mime-editor/charset-default-encoding-alist - (mime-editor/make-charset-default-encoding-alist - mime-editor/transfer-level)) - (message (format "Current transfer-level is %d bit" - mime-editor/transfer-level)) - (setq mime-editor/transfer-level-string - (mime/encoding-name mime-editor/transfer-level 'not-omit)) - (force-mode-line-update) - ) - -(defun mime-editor/set-transfer-level-7bit () - (interactive) - (mime-editor/toggle-transfer-level 7) - ) - -(defun mime-editor/set-transfer-level-8bit () - (interactive) - (mime-editor/toggle-transfer-level 8) - ) - - -;;; @ pgp -;;; - -(defun mime-editor/set-sign (arg) - (interactive - (list - (y-or-n-p "Do you want to sign?") - )) - (if arg - (if mime-editor/signing-type - (progn - (setq mime-editor/pgp-processing 'sign) - (message "This message will be signed.") - ) - (message "Please specify signing type.") - ) - (if (eq mime-editor/pgp-processing 'sign) - (setq mime-editor/pgp-processing nil) - ) - (message "This message will not be signed.") - )) - -(defun mime-editor/set-encrypt (arg) - (interactive - (list - (y-or-n-p "Do you want to encrypt?") - )) - (if arg - (if mime-editor/encrypting-type - (progn - (setq mime-editor/pgp-processing 'encrypt) - (message "This message will be encrypt.") - ) - (message "Please specify encrypting type.") - ) - (if (eq mime-editor/pgp-processing 'encrypt) - (setq mime-editor/pgp-processing nil) - ) - (message "This message will not be encrypt.") - )) - -(defvar mime-editor/pgp-processing nil) -(make-variable-buffer-local 'mime-editor/pgp-processing) - -(defun mime-editor/pgp-enclose-buffer () - (let ((beg (save-excursion - (goto-char (point-min)) - (if (search-forward (concat "\n" mail-header-separator "\n")) - (match-end 0) - ))) - (end (point-max)) - ) - (if beg - (cond ((eq mime-editor/pgp-processing 'sign) - (mime-editor/enclose-signed-region beg end) - ) - ((eq mime-editor/pgp-processing 'encrypt) - (mime-editor/enclose-encrypted-region beg end) - )) - ))) - - -;;; @ split -;;; - -(defun mime-editor/insert-partial-header - (fields subject id number total separator) - (insert fields) - (insert (format "Subject: %s (%d/%d)\n" subject number total)) - (insert (format "Mime-Version: 1.0 (split by %s)\n" - mime-editor/version-name)) - (insert (format "\ -Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" - id number total separator)) - ) - -(defun mime-editor/split-and-send - (&optional cmd lines mime-editor/message-max-length) - (interactive) - (or lines - (setq lines - (count-lines (point-min) (point-max))) - ) - (or mime-editor/message-max-length - (setq mime-editor/message-max-length - (or (cdr (assq major-mode mime-editor/message-max-lines-alist)) - mime-editor/message-default-max-lines)) - ) - (let* ((mime-editor/draft-file-name - (or (buffer-file-name) - (make-temp-name - (expand-file-name "tm-draft" mime/tmp-dir)))) - (separator mail-header-separator) - (id (concat "\"" - (replace-space-with-underline (current-time-string)) - "@" (system-name) "\""))) - (run-hooks 'mime-editor/before-split-hook) - (let ((the-buf (current-buffer)) - (copy-buf (get-buffer-create " *Original Message*")) - (header (std11-header-string-except - mime-editor/split-ignored-field-regexp separator)) - (subject (mail-fetch-field "subject")) - (total (+ (/ lines mime-editor/message-max-length) - (if (> (mod lines mime-editor/message-max-length) 0) - 1))) - (command - (or cmd - (cdr - (assq major-mode - mime-editor/split-message-sender-alist)) - (function - (lambda () - (interactive) - (error "Split sender is not specified for `%s'." major-mode) - )) - )) - (mime-editor/partial-number 1) - data) - (save-excursion - (set-buffer copy-buf) - (erase-buffer) - (insert-buffer the-buf) - (save-restriction - (if (re-search-forward - (concat "^" (regexp-quote separator) "$") nil t) - (let ((he (match-beginning 0))) - (replace-match "") - (narrow-to-region (point-min) he) - )) - (goto-char (point-min)) - (while (re-search-forward mime-editor/split-blind-field-regexp nil t) - (delete-region (match-beginning 0) - (1+ (std11-field-end))) - ))) - (while (< mime-editor/partial-number total) - (erase-buffer) - (save-excursion - (set-buffer copy-buf) - (setq data (buffer-substring - (point-min) - (progn - (goto-line mime-editor/message-max-length) - (point)) - )) - (delete-region (point-min)(point)) - ) - (mime-editor/insert-partial-header - header subject id mime-editor/partial-number total separator) - (insert data) - (save-excursion - (message (format "Sending %d/%d..." - mime-editor/partial-number total)) - (call-interactively command) - (message (format "Sending %d/%d... done" - mime-editor/partial-number total)) - ) - (setq mime-editor/partial-number - (1+ mime-editor/partial-number)) - ) - (erase-buffer) - (save-excursion - (set-buffer copy-buf) - (setq data (buffer-string)) - (erase-buffer) - ) - (mime-editor/insert-partial-header - header subject id mime-editor/partial-number total separator) - (insert data) - (save-excursion - (message (format "Sending %d/%d..." - mime-editor/partial-number total)) - (message (format "Sending %d/%d... done" - mime-editor/partial-number total)) - ) - ))) - -(defun mime-editor/maybe-split-and-send (&optional cmd) - (interactive) - (run-hooks 'mime-editor/before-send-hook) - (let ((mime-editor/message-max-length - (or (cdr (assq major-mode mime-editor/message-max-lines-alist)) - mime-editor/message-default-max-lines)) - (lines (count-lines (point-min) (point-max))) - ) - (if (and (> lines mime-editor/message-max-length) - mime-editor/split-message) - (mime-editor/split-and-send cmd lines mime-editor/message-max-length) - ))) - - -;;; @ preview message -;;; - -(defun mime-editor/preview-message () - "preview editing MIME message. [tm-edit.el]" - (interactive) - (let* ((str (buffer-string)) - (separator mail-header-separator) - (the-buf (current-buffer)) - (buf-name (buffer-name)) - (temp-buf-name (concat "*temp-article:" buf-name "*")) - (buf (get-buffer temp-buf-name)) - ) - (if buf - (progn - (switch-to-buffer buf) - (erase-buffer) - ) - (setq buf (get-buffer-create temp-buf-name)) - (switch-to-buffer buf) - ) - (insert str) - (setq major-mode 'mime/temporary-message-mode) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator separator) - (make-local-variable 'mime/editing-buffer) - (setq mime/editing-buffer the-buf) - - (run-hooks 'mime-editor/translate-hook) - (mime-editor/translate-buffer) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote separator) "$")) - (replace-match "") - ) - (mime/viewer-mode) - )) - -(defun mime-editor/quitting-method () - (let ((temp mime::preview/article-buffer) - buf) - (mime-viewer/kill-buffer) - (set-buffer temp) - (setq buf mime/editing-buffer) - (kill-buffer temp) - (switch-to-buffer buf) - )) - -(set-alist 'mime-viewer/quitting-method-alist - 'mime/temporary-message-mode - (function mime-editor/quitting-method) - ) - - -;;; @ draft preview -;;; -;; by "OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;; Mon, 10 Apr 1995 20:03:07 +0900 - -(defvar mime-editor/draft-header-separator-alist - '((news-reply-mode . mail-header-separator) - (mh-letter-mode . mail-header-separator) - )) - -(defvar mime::article/draft-header-separator nil) - -(defun mime-editor/draft-preview () - (interactive) - (let ((sep (cdr (assq major-mode mime-editor/draft-header-separator-alist)))) - (or (stringp sep) (setq sep (eval sep))) - (make-variable-buffer-local 'mime::article/draft-header-separator) - (goto-char (point-min)) - (re-search-forward - (concat "^\\(" (regexp-quote sep) "\\)?$")) - (setq mime::article/draft-header-separator - (buffer-substring (match-beginning 0) (match-end 0))) - (replace-match "") - (mime/viewer-mode (current-buffer)) - (pop-to-buffer (current-buffer)) - )) - -(defun mime-viewer::quitting-method/draft-preview () - (let ((mother mime::preview/mother-buffer)) - (save-excursion - (switch-to-buffer mother) - (goto-char (point-min)) - (if (and - (re-search-forward - (concat "^\\(" - (regexp-quote mime::article/draft-header-separator) - "\\)?$") nil t) - (bolp)) - (progn - (insert mime::article/draft-header-separator) - (set-buffer-modified-p (buffer-modified-p)) - ))) - (mime-viewer/kill-buffer) - (pop-to-buffer mother) - )) - -(set-alist 'mime-viewer/quitting-method-alist - 'mh-letter-mode - (function mime-viewer::quitting-method/draft-preview) - ) - -(set-alist 'mime-viewer/quitting-method-alist - 'news-reply-mode - (function mime-viewer::quitting-method/draft-preview) - ) - - -;;; @ edit again -;;; - -(defun mime-editor::edit-again (code-conversion) - (save-excursion - (goto-char (point-min)) - (let ((ctl (mime/Content-Type))) - (if ctl - (let ((ctype (car ctl)) - (params (cdr ctl)) - type stype) - (if (string-match "/" ctype) - (progn - (setq type (substring ctype 0 (match-beginning 0))) - (setq stype (substring ctype (match-end 0))) - ) - (setq type ctype) - ) - (cond - ((string= ctype "application/pgp-signature") - (delete-region (point-min)(point-max)) - ) - ((string= type "multipart") - (let* ((boundary (assoc-value "boundary" params)) - (boundary-pat - (concat "\n--" (regexp-quote boundary) "[ \t]*\n")) - ) - (re-search-forward boundary-pat nil t) - (let ((bb (match-beginning 0)) eb tag) - (setq tag (format "\n--<<%s>>-{\n" stype)) - (goto-char bb) - (insert tag) - (setq bb (+ bb (length tag))) - (re-search-forward - (concat "\n--" (regexp-quote boundary) "--[ \t]*\n") - nil t) - (setq eb (match-beginning 0)) - (replace-match (format "--}-<<%s>>\n" stype)) - (save-restriction - (narrow-to-region bb eb) - (goto-char (point-min)) - (while (re-search-forward boundary-pat nil t) - (let ((beg (match-beginning 0)) - end) - (delete-region beg (match-end 0)) - (save-excursion - (if (re-search-forward boundary-pat nil t) - (setq end (match-beginning 0)) - (setq end (point-max)) - ) - (save-restriction - (narrow-to-region beg end) - (mime-editor::edit-again code-conversion) - (goto-char (point-max)) - )))) - )) - (goto-char (point-min)) - (or (= (point-min) 1) - (delete-region (point-min) - (if (search-forward "\n\n" nil t) - (match-end 0) - (point-min) - ))) - )) - (t - (let* (charset - (pstr - (let ((bytes (+ 14 (length ctype)))) - (mapconcat (function - (lambda (attr) - (if (string-equal (car attr) "charset") - (progn - (setq charset (cdr attr)) - "") - (let* ((str - (concat (car attr) - "=" (cdr attr)) - ) - (bs (length str)) - ) - (setq bytes (+ bytes bs 2)) - (if (< bytes 76) - (concat "; " str) - (setq bytes (+ bs 1)) - (concat ";\n " str) - ) - )))) - params ""))) - encoding - encoded) - (save-excursion - (if (re-search-forward - "Content-Transfer-Encoding:" nil t) - (let ((beg (match-beginning 0)) - (hbeg (match-end 0)) - (end (std11-field-end))) - (setq encoding - (eliminate-top-spaces - (std11-unfold-string - (buffer-substring hbeg end)))) - (if (or charset (string-equal type "text")) - (progn - (delete-region beg (1+ end)) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (progn - (mime-decode-region - (match-end 0)(point-max) encoding) - (setq encoded t - encoding nil) - ))))))) - (if (or code-conversion encoded) - (decode-mime-charset-region - (point-min)(point-max) - (or charset default-mime-charset)) - ) - (let ((he - (if (re-search-forward "^$" nil t) - (match-end 0) - (point-min) - ))) - (if (= (point-min) 1) - (progn - (goto-char he) - (insert - (concat "\n" - (mime-create-tag - (concat type "/" stype pstr) encoding))) - ) - (delete-region (point-min) he) - (insert - (mime-create-tag - (concat type "/" stype pstr) encoding)) - )) - )))) - (if code-conversion - (decode-mime-charset-region (point-min) (point-max) - default-mime-charset) - ) - )))) - -(defun mime/edit-again (&optional code-conversion no-separator no-mode) - (interactive) - (mime-editor::edit-again code-conversion) - (goto-char (point-min)) - (save-restriction - (narrow-to-region - (point-min) - (if (re-search-forward - (concat "^\\(" (regexp-quote mail-header-separator) "\\)?$") - nil t) - (match-end 0) - (point-max) - )) - (goto-char (point-min)) - (while (re-search-forward - "^\\(Content-.*\\|Mime-Version\\):" nil t) - (delete-region (match-beginning 0) (1+ (std11-field-end))) - )) - (or no-separator - (and (re-search-forward "^$") - (replace-match mail-header-separator) - )) - (or no-mode - (mime/editor-mode) - )) - - -;;; @ end -;;; - -(provide 'tm-edit) - -(run-hooks 'tm-edit-load-hook) - -;;; tm-edit.el ends here
--- a/lisp/tm/tm-ew-d.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,265 +0,0 @@ -;;; tm-ew-d.el --- RFC 2047 based encoded-word decoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/10/03 -;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'. -;; Renamed: 1993/06/03 to tiny-mime.el. -;; Renamed: 1995/10/03 from tiny-mime.el. (split off encoder) -;; Version: $Revision: 1.4 $ -;; Keywords: encoded-word, MIME, multilingual, header, mail, news - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'emu) -(require 'std11) -(require 'mel) -(require 'tm-def) -(require 'tl-str) - - -;;; @ version -;;; - -(defconst tm-ew-d/RCS-ID - "$Id: tm-ew-d.el,v 1.4 1997/03/16 03:05:46 steve Exp $") -(defconst mime/eword-decoder-version (get-version-string tm-ew-d/RCS-ID)) - - -;;; @ MIME encoded-word definition -;;; - -(defconst mime/encoded-text-regexp "[!->@-~]+") -(defconst mime/encoded-word-regexp (concat (regexp-quote "=?") - "\\(" - mime/charset-regexp - "\\)" - (regexp-quote "?") - "\\(B\\|Q\\)" - (regexp-quote "?") - "\\(" - mime/encoded-text-regexp - "\\)" - (regexp-quote "?="))) - - -;;; @ for string -;;; - -(defun mime-eword/decode-string (string &optional must-unfold) - "Decode MIME encoded-words in STRING. - -STRING is unfolded before decoding. - -If an encoded-word is broken or your emacs implementation can not -decode the charset included in it, it is not decoded. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-words (generated by bad manner MUA -such as a version of Net$cape). [tm-ew-d.el]" - (setq string (std11-unfold-string string)) - (let ((dest "")(ew nil) - beg end) - (while (and (string-match mime/encoded-word-regexp string) - (setq beg (match-beginning 0) - end (match-end 0)) - ) - (if (> beg 0) - (if (not - (and (eq ew t) - (string-match "^[ \t]+$" (substring string 0 beg)) - )) - (setq dest (concat dest (substring string 0 beg))) - ) - ) - (setq dest - (concat dest - (mime/decode-encoded-word - (substring string beg end) must-unfold) - )) - (setq string (substring string end)) - (setq ew t) - ) - (concat dest string) - )) - - -;;; @ for region -;;; - -(defun mime-eword/decode-region (start end &optional unfolding must-unfold) - "Decode MIME encoded-words in region between START and END. - -If UNFOLDING is not nil, it unfolds before decoding. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-words (generated by bad manner MUA -such as a version of Net$cape). [tm-ew-d.el]" - (interactive "*r") - (save-excursion - (save-restriction - (narrow-to-region start end) - (if unfolding - (mime/unfolding) - ) - (goto-char (point-min)) - (while (re-search-forward (concat "\\(" mime/encoded-word-regexp "\\)" - "\\(\n?[ \t]\\)+" - "\\(" mime/encoded-word-regexp "\\)") - nil t) - (replace-match "\\1\\6") - (goto-char (point-min)) - ) - (let (charset encoding text) - (while (re-search-forward mime/encoded-word-regexp nil t) - (insert (mime/decode-encoded-word - (prog1 - (buffer-substring (match-beginning 0) (match-end 0)) - (delete-region (match-beginning 0) (match-end 0)) - ) must-unfold)) - )) - ))) - - -;;; @ for message header -;;; - -(defun mime/decode-message-header () - "Decode MIME encoded-words in message header. [tm-ew-d.el]" - (interactive "*") - (save-excursion - (save-restriction - (narrow-to-region (goto-char (point-min)) - (progn (re-search-forward "^$" nil t) (point))) - (mime-eword/decode-region (point-min) (point-max) t) - ))) - -(defun mime/unfolding () - (goto-char (point-min)) - (let (field beg end) - (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0) - end (std11-field-end)) - (setq field (buffer-substring beg end)) - (if (string-match mime/encoded-word-regexp field) - (save-restriction - (narrow-to-region (goto-char beg) end) - (while (re-search-forward "\n\\([ \t]\\)" nil t) - (replace-match - (match-string 1)) - ) - (goto-char (point-max)) - )) - ))) - - -;;; @ encoded-word decoder -;;; - -(defun mime/decode-encoded-word (word &optional must-unfold) - "Decode WORD if it is an encoded-word. - -If your emacs implementation can not decode the charset of WORD, it -returns WORD. Similarly the encoded-word is broken, it returns WORD. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-word (generated by bad manner MUA such -as a version of Net$cape). [tm-ew-d.el]" - (or (if (string-match mime/encoded-word-regexp word) - (let ((charset - (substring word (match-beginning 1) (match-end 1)) - ) - (encoding - (upcase - (substring word (match-beginning 2) (match-end 2)) - )) - (text - (substring word (match-beginning 3) (match-end 3)) - )) - (condition-case err - (mime/decode-encoded-text charset encoding text must-unfold) - (error - (and (add-text-properties 0 (length word) - (and tm:warning-face - (list 'face tm:warning-face)) - word) - word))) - )) - word)) - - -;;; @ encoded-text decoder -;;; - -(defun mime/decode-encoded-text (charset encoding string &optional must-unfold) - "Decode STRING as an encoded-text. - -If your emacs implementation can not decode CHARSET, it returns nil. - -If ENCODING is not \"B\" or \"Q\", it occurs error. -So you should write error-handling code if you don't want break by errors. - -If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even -if there are in decoded encoded-text (generated by bad manner MUA such -as a version of Net$cape). [tm-ew-d.el]" - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (let ((dest - (cond - ((string-equal "B" encoding) - (if (and (string-match mime/B-encoded-text-regexp string) - (string-equal string (match-string 0 string))) - (base64-decode-string string) - (error "Invalid encoded-text %s" string))) - ((string-equal "Q" encoding) - (if (and (string-match mime/Q-encoded-text-regexp string) - (string-equal string (match-string 0 string))) - (q-encoding-decode-string string) - (error "Invalid encoded-text %s" string))) - (t - (error "Invalid encoding %s" encoding) - ))) - ) - (if dest - (progn - (setq dest (decode-coding-string dest cs)) - (if must-unfold - (mapconcat (function - (lambda (chr) - (cond - ((eq chr ?\n) "") - ((eq chr ?\t) " ") - (t (char-to-string chr))) - )) - (std11-unfold-string dest) - "") - dest) - )))))) - - -;;; @ end -;;; - -(provide 'tm-ew-d) - -;;; tm-ew-d.el ends here
--- a/lisp/tm/tm-ew-e.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,628 +0,0 @@ -;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Revision: 1.5 $ -;; Keywords: encoded-word, MIME, multilingual, header, mail, news - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mel) -(require 'std11) -(require 'tm-def) -(require 'tl-list) - - -;;; @ version -;;; - -(defconst tm-ew-e/RCS-ID - "$Id: tm-ew-e.el,v 1.5 1997/06/29 23:13:28 steve Exp $") -(defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID)) - - -;;; @ variables -;;; - -(defvar mime/field-encoding-method-alist - (if (boundp 'mime/no-encoding-header-fields) - (nconc - (mapcar (function - (lambda (field-name) - (cons field-name 'default-mime-charset) - )) - mime/no-encoding-header-fields) - '((t . mime)) - ) - '(("X-Nsubject" . iso-2022-jp-2) - ("Newsgroups" . nil) - ("Message-ID" . nil) - (t . mime) - )) - "*Alist to specify field encoding method. -Its key is field-name, value is encoding method. - -If method is `mime', this field will be encoded into MIME format. - -If method is a MIME-charset, this field will be encoded as the charset -when it must be convert into network-code. - -If method is `default-mime-charset', this field will be encoded as -variable `default-mime-charset' when it must be convert into -network-code. - -If method is nil, this field will not be encoded. [tm-ew-e.el]") - -(defvar mime/generate-X-Nsubject - (and (boundp 'mime/use-X-Nsubject) - mime/use-X-Nsubject) - "*If it is not nil, X-Nsubject field is generated -when Subject field is encoded by `mime/encode-message-header'. -\[tm-ew-e.el]") - -(defvar mime-eword/charset-encoding-alist - '((us-ascii . nil) - (iso-8859-1 . "Q") - (iso-8859-2 . "Q") - (iso-8859-3 . "Q") - (iso-8859-4 . "Q") - (iso-8859-5 . "Q") - (koi8-r . "Q") - (iso-8859-7 . "Q") - (iso-8859-8 . "Q") - (iso-8859-9 . "Q") - (iso-2022-jp . "B") - (iso-2022-kr . "B") - (gb2312 . "B") - (cn-gb . "B") - (cn-gb-2312 . "B") - (euc-kr . "B") - (iso-2022-jp-2 . "B") - (iso-2022-int-1 . "B") - )) - - -;;; @ encoded-text encoder -;;; - -(defun tm-eword::encode-encoded-text (charset encoding string &optional mode) - (let ((text - (cond ((string= encoding "B") - (base64-encode-string string)) - ((string= encoding "Q") - (q-encoding-encode-string string mode)) - ) - )) - (if text - (concat "=?" (upcase (symbol-name charset)) "?" - encoding "?" text "?=") - ))) - - -;;; @ leading char -;;; - -(defun tm-eword::char-type (chr) - (if (or (= chr ? )(= chr ?\t)) - nil - (char-charset chr) - )) - -(defun tm-eword::parse-lc-word (str) - (let* ((chr (sref str 0)) - (lc (tm-eword::char-type chr)) - (i (char-length chr)) - (len (length str)) - ) - (while (and (< i len) - (setq chr (sref str i)) - (eq lc (tm-eword::char-type chr)) - ) - (setq i (+ i (char-length chr))) - ) - (cons (cons lc (substring str 0 i)) (substring str i)) - )) - -(defun tm-eword::split-to-lc-words (str) - (let (ret dest) - (while (and (not (string= str "")) - (setq ret (tm-eword::parse-lc-word str)) - ) - (setq dest (cons (car ret) dest)) - (setq str (cdr ret)) - ) - (reverse dest) - )) - - -;;; @ word -;;; - -(defun tm-eword::parse-word (lcwl) - (let* ((lcw (car lcwl)) - (lc (car lcw)) - ) - (if (null lc) - lcwl - (let ((lcl (list lc)) - (str (cdr lcw)) - ) - (catch 'tag - (while (setq lcwl (cdr lcwl)) - (setq lcw (car lcwl)) - (setq lc (car lcw)) - (if (null lc) - (throw 'tag nil) - ) - (if (not (memq lc lcl)) - (setq lcl (cons lc lcl)) - ) - (setq str (concat str (cdr lcw))) - )) - (cons (cons lcl str) lcwl) - )))) - -(defun tm-eword::lc-words-to-words (lcwl) - (let (ret dest) - (while (setq ret (tm-eword::parse-word lcwl)) - (setq dest (cons (car ret) dest)) - (setq lcwl (cdr ret)) - ) - (reverse dest) - )) - - -;;; @ rule -;;; - -(defmacro tm-eword::make-rword (text charset encoding type) - (` (list (, text)(, charset)(, encoding)(, type)))) -(defmacro tm-eword::rword-text (rword) - (` (car (, rword)))) -(defmacro tm-eword::rword-charset (rword) - (` (car (cdr (, rword))))) -(defmacro tm-eword::rword-encoding (rword) - (` (car (cdr (cdr (, rword)))))) -(defmacro tm-eword::rword-type (rword) - (` (car (cdr (cdr (cdr (, rword))))))) - -(defun tm-eword::find-charset-rule (charsets) - (if charsets - (let* ((charset (charsets-to-mime-charset charsets)) - (encoding (cdr (assq charset mime-eword/charset-encoding-alist))) - ) - (list charset encoding) - ))) - -(defun tm-eword::words-to-ruled-words (wl &optional mode) - (mapcar (function - (lambda (word) - (let ((ret (tm-eword::find-charset-rule (car word)))) - (tm-eword::make-rword (cdr word) (car ret)(nth 1 ret) mode) - ))) - wl)) - -(defun tm-eword::space-process (seq) - (let (prev a ac b c cc) - (while seq - (setq b (car seq)) - (setq seq (cdr seq)) - (setq c (car seq)) - (setq cc (tm-eword::rword-charset c)) - (if (null (tm-eword::rword-charset b)) - (progn - (setq a (car prev)) - (setq ac (tm-eword::rword-charset a)) - (if (and (tm-eword::rword-encoding a) - (tm-eword::rword-encoding c)) - (cond ((eq ac cc) - (setq prev (cons - (cons (concat (car a)(car b)(car c)) - (cdr a)) - (cdr prev) - )) - (setq seq (cdr seq)) - ) - (t - (setq prev (cons - (cons (concat (car a)(car b)) - (cdr a)) - (cdr prev) - )) - )) - (setq prev (cons b prev)) - )) - (setq prev (cons b prev)) - )) - (reverse prev) - )) - -(defun tm-eword::split-string (str &optional mode) - (tm-eword::space-process - (tm-eword::words-to-ruled-words (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words str)) - mode))) - - -;;; @ length -;;; - -(defun tm-eword::encoded-word-length (rword) - (let ((string (tm-eword::rword-text rword)) - (charset (tm-eword::rword-charset rword)) - (encoding (tm-eword::rword-encoding rword)) - ret) - (setq ret - (cond ((string-equal encoding "B") - (setq string (encode-mime-charset-string string charset)) - (base64-encoded-length string) - ) - ((string-equal encoding "Q") - (setq string (encode-mime-charset-string string charset)) - (q-encoding-encoded-length string - (tm-eword::rword-type rword)) - ))) - (if ret - (cons (+ 7 (length (symbol-name charset)) ret) string) - ))) - - -;;; @ encode-string -;;; - -(defun tm-eword::encode-string-1 (column rwl) - (let* ((rword (car rwl)) - (ret (tm-eword::encoded-word-length rword)) - string len) - (if (null ret) - (cond ((and (setq string (car rword)) - (or (<= (setq len (+ (length string) column)) 76) - (<= column 1)) - ) - (setq rwl (cdr rwl)) - ) - (t - (setq string "\n ") - (setq len 1) - )) - (cond ((and (setq len (car ret)) - (<= (+ column len) 76) - ) - (setq string - (tm-eword::encode-encoded-text - (tm-eword::rword-charset rword) - (tm-eword::rword-encoding rword) - (cdr ret) - (tm-eword::rword-type rword) - )) - (setq len (+ (length string) column)) - (setq rwl (cdr rwl)) - ) - (t - (setq string (car rword)) - (let* ((p 0) np - (str "") nstr) - (while (and (< p len) - (progn - (setq np (+ p (char-length (sref string p)))) - (setq nstr (substring string 0 np)) - (setq ret (tm-eword::encoded-word-length - (cons nstr (cdr rword)) - )) - (setq nstr (cdr ret)) - (setq len (+ (car ret) column)) - (<= len 76) - )) - (setq str nstr - p np)) - (if (string-equal str "") - (setq string "\n " - len 1) - (setq rwl (cons (cons (substring string p) (cdr rword)) - (cdr rwl))) - (setq string - (tm-eword::encode-encoded-text - (tm-eword::rword-charset rword) - (tm-eword::rword-encoding rword) - str - (tm-eword::rword-type rword))) - (setq len (+ (length string) column)) - ) - ))) - ) - (list string len rwl) - )) - -(defun tm-eword::encode-rwl (column rwl) - (let (ret dest ps special str ew-f pew-f) - (while rwl - (setq ew-f (nth 2 (car rwl))) - (if (and pew-f ew-f) - (setq rwl (cons '(" ") rwl) - pew-f nil) - (setq pew-f ew-f) - ) - (setq ret (tm-eword::encode-string-1 column rwl)) - (setq str (car ret)) - (if (eq (elt str 0) ?\n) - (if (eq special ?\() - (progn - (setq dest (concat dest "\n (")) - (setq ret (tm-eword::encode-string-1 2 rwl)) - (setq str (car ret)) - )) - (cond ((eq special ? ) - (if (string= str "(") - (setq ps t) - (setq dest (concat dest " ")) - (setq ps nil) - )) - ((eq special ?\() - (if ps - (progn - (setq dest (concat dest " (")) - (setq ps nil) - ) - (setq dest (concat dest "(")) - ) - ))) - (cond ((string= str " ") - (setq special ? ) - ) - ((string= str "(") - (setq special ?\() - ) - (t - (setq special nil) - (setq dest (concat dest str)) - )) - (setq column (nth 1 ret) - rwl (nth 2 ret)) - ) - (list dest column) - )) - -(defun tm-eword::encode-string (column str &optional mode) - (tm-eword::encode-rwl column (tm-eword::split-string str mode)) - ) - - -;;; @ converter -;;; - -(defun tm-eword::phrase-to-rwl (phrase) - (let (token type dest str) - (while phrase - (setq token (car phrase)) - (setq type (car token)) - (cond ((eq type 'quoted-string) - (setq str (concat "\"" (cdr token) "\"")) - (setq dest - (append dest - (list - (let ((ret (tm-eword::find-charset-rule - (find-non-ascii-charset-string str)))) - (tm-eword::make-rword - str (car ret)(nth 1 ret) 'phrase) - ) - ))) - ) - ((eq type 'comment) - (setq dest - (append dest - '(("(" nil nil)) - (tm-eword::words-to-ruled-words - (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words (cdr token))) - 'comment) - '((")" nil nil)) - )) - ) - (t - (setq dest (append dest - (tm-eword::words-to-ruled-words - (tm-eword::lc-words-to-words - (tm-eword::split-to-lc-words (cdr token)) - ) 'phrase))) - )) - (setq phrase (cdr phrase)) - ) - (tm-eword::space-process dest) - )) - -(defun tm-eword::phrase-route-addr-to-rwl (phrase-route-addr) - (if (eq (car phrase-route-addr) 'phrase-route-addr) - (let ((phrase (nth 1 phrase-route-addr)) - (route (nth 2 phrase-route-addr)) - dest) - (if (eq (car (car phrase)) 'spaces) - (setq phrase (cdr phrase)) - ) - (setq dest (tm-eword::phrase-to-rwl phrase)) - (if dest - (setq dest (append dest '((" " nil nil)))) - ) - (append - dest - (list (list (concat "<" (std11-addr-to-string route) ">") nil nil)) - )))) - -(defun tm-eword::addr-spec-to-rwl (addr-spec) - (if (eq (car addr-spec) 'addr-spec) - (list (list (std11-addr-to-string (cdr addr-spec)) nil nil)) - )) - -(defun tm-eword::mailbox-to-rwl (mbox) - (let ((addr (nth 1 mbox)) - (comment (nth 2 mbox)) - dest) - (setq dest (or (tm-eword::phrase-route-addr-to-rwl addr) - (tm-eword::addr-spec-to-rwl addr) - )) - (if comment - (setq dest - (append dest - '((" " nil nil) - ("(" nil nil)) - (tm-eword::split-string comment 'comment) - '((")" nil nil)) - ))) - dest)) - -(defun tm-eword::addresses-to-rwl (addresses) - (let ((dest (tm-eword::mailbox-to-rwl (car addresses)))) - (if dest - (while (setq addresses (cdr addresses)) - (setq dest (append dest - '(("," nil nil)) - '((" " nil nil)) - (tm-eword::mailbox-to-rwl (car addresses)) - )) - )) - dest)) - -(defun tm-eword::encode-address-list (column str) - (tm-eword::encode-rwl - column - (tm-eword::addresses-to-rwl (std11-parse-addresses-string str)) - )) - - -;;; @ application interfaces -;;; - -(defun mime/encode-field (str) - (setq str (std11-unfold-string str)) - (let ((ret (string-match std11-field-head-regexp str))) - (or (if ret - (let ((field-name (substring str 0 (1- (match-end 0)))) - (field-body (eliminate-top-spaces - (substring str (match-end 0)))) - fname) - (if (setq ret - (cond ((string-equal field-body "") "") - ((member (setq fname (downcase field-name)) - '("reply-to" "from" "sender" - "resent-reply-to" "resent-from" - "resent-sender" "to" "resent-to" - "cc" "resent-cc" - "bcc" "resent-bcc" "dcc") - ) - (car (tm-eword::encode-address-list - (+ (length field-name) 2) field-body)) - ) - (t - (car (tm-eword::encode-string - (+ (length field-name) 1) - field-body 'text)) - )) - ) - (concat field-name ": " ret) - ))) - (car (tm-eword::encode-string 0 str)) - ))) - -(defun mime/exist-encoded-word-in-subject () - (let ((str (std11-field-body "Subject"))) - (if (and str (string-match mime/encoded-word-regexp str)) - str))) - -(defun mime/encode-message-header (&optional code-conversion) - (interactive "*") - (save-excursion - (save-restriction - (std11-narrow-to-header mail-header-separator) - (goto-char (point-min)) - (let ((default-cs (mime-charset-to-coding-system default-mime-charset)) - beg end field-name) - (while (re-search-forward std11-field-head-regexp nil t) - (setq beg (match-beginning 0)) - (setq field-name (buffer-substring beg (1- (match-end 0)))) - (setq end (std11-field-end)) - (and (find-non-ascii-charset-region beg end) - (let ((ret (or (ASSOC (downcase field-name) - mime/field-encoding-method-alist - :test (function - (lambda (str1 str2) - (and (stringp str2) - (string= str1 - (downcase str2)) - )))) - (assq t mime/field-encoding-method-alist) - ))) - (if ret - (let ((method (cdr ret))) - (cond ((eq method 'mime) - (let ((field - (buffer-substring-no-properties beg end) - )) - (delete-region beg end) - (insert (mime/encode-field field)) - )) - (code-conversion - (let ((cs - (or (mime-charset-to-coding-system - method) - default-cs))) - (encode-coding-region beg end cs) - ))) - )) - )) - )) - (and mime/generate-X-Nsubject - (or (std11-field-body "X-Nsubject") - (let ((str (mime/exist-encoded-word-in-subject))) - (if str - (progn - (setq str - (mime-eword/decode-string - (std11-unfold-string str))) - (if code-conversion - (setq str - (encode-mime-charset-string - str - (or (cdr (ASSOC - "x-nsubject" - mime/field-encoding-method-alist - :test - (function - (lambda (str1 str2) - (and (stringp str2) - (string= str1 - (downcase str2)) - ))))) - 'iso-2022-jp-2))) - ) - (insert (concat "\nX-Nsubject: " str)) - ))))) - ))) - -(defun mime-eword/encode-string (str &optional column mode) - (car (tm-eword::encode-rwl (or column 0) (tm-eword::split-string str mode))) - ) - - -;;; @ end -;;; - -(provide 'tm-ew-e) - -;;; tm-ew-e.el ends here
--- a/lisp/tm/tm-file.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,93 +0,0 @@ -;;; tm-file.el --- tm-view internal method for file extraction - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; modified by Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Version: $Id: tm-file.el,v 1.3 1997/03/16 03:05:46 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, file, extract - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tm-view) - -(defun mime-article/extract-file (beg end cal) - (goto-char beg) - (let* ((name - (save-restriction - (narrow-to-region beg end) - (mime-article/get-filename cal) - )) - (encoding (cdr (assq 'encoding cal))) - (filename - (if (and name (not (string-equal name ""))) - (expand-file-name name - (call-interactively - (function - (lambda (dir) - (interactive "DDirectory: ") - dir)))) - (call-interactively - (function - (lambda (file) - (interactive "FFilename: ") - (expand-file-name file)))))) - (the-buf (current-buffer)) - (tmp-buf (generate-new-buffer (file-name-nondirectory filename))) - ) - (if (file-exists-p filename) - (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) - (error ""))) - (re-search-forward "\n\n") - (append-to-buffer tmp-buf (match-end 0) end) - (save-excursion - (set-buffer tmp-buf) - (mime-decode-region (point-min)(point-max) encoding) - (as-binary-output-file (write-file filename)) - (kill-buffer tmp-buf) - ))) - - -;;; @ setup -;;; - -(set-atype 'mime/content-decoding-condition - '((type . "application/octet-stream") - (method . mime-article/extract-file) - ) - 'ignore '(method) - 'replacement) - -(set-atype 'mime/content-decoding-condition - '((mode . "extract") - (method . mime-article/extract-file) - ) - 'remove - '((method "tm-file" nil 'file 'type 'encoding 'mode 'name) - (mode . "extract")) - 'replacement) - - -;;; @ end -;;; - -(provide 'tm-file) - -;;; end of tm-file.el
--- a/lisp/tm/tm-ftp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -;;; tm-ftp.el --- tm-view internal method for anonymous ftp - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1994/11/5 -;; Version: $Id: tm-ftp.el,v 1.3 1997/02/15 22:21:29 steve Exp $ -;; Keywords: anonymous ftp, MIME, multimedia, mail, news - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tm-view) - -(defvar mime-view-ftp-module - (if (< emacs-major-version 19) - 'ange-ftp) - "*Module for ftp file access.") - -(and mime-view-ftp-module - (require mime-view-ftp-module) - ) - -(defvar mime-article/dired-function - (if mime/use-multi-frame - (function dired-other-frame) - (function mime-article/dired-function-for-one-frame) - )) - -(defun mime-article/dired-function-for-one-frame (dir) - (let ((win (or (get-buffer-window mime::article/preview-buffer) - (get-largest-window)))) - (select-window win) - (dired dir) - )) - -(defun mime-article/decode-message/external-ftp (beg end cal) - (let* ((access-type (cdr (assoc "access-type" cal))) - (site (cdr (assoc "site" cal))) - (directory (cdr (assoc "directory" cal))) - (name (cdr (assoc "name" cal))) - (mode (cdr (assoc "mode" cal))) - (pathname (concat "/anonymous@" site ":" directory)) - ) - (message (concat "Accessing " (expand-file-name name pathname) "...")) - (funcall mime-article/dired-function pathname) - (goto-char (point-min)) - (search-forward name) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "message/external-body") - ("access-type" . "anon-ftp") - (method . mime-article/decode-message/external-ftp) - )) - - -;;; @ end -;;; - -(provide 'tm-ftp) - -;;; tm-ftp.el ends here
--- a/lisp/tm/tm-html.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ -;;; -;;; tm-html.el: a tm-view internal decoder for HTML -;;; -;;; Copyright (C) 1995 Free Software Foundation, Inc. -;;; Copyright (C) 1995,1996 MORIOKA Tomohiko -;;; -;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;;; Created: 1995/9/14 -;;; based on tm-latex.el by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;;; Version: -;;; $Id: tm-html.el,v 1.2 1996/12/28 21:03:14 steve Exp $ -;;; Keywords: mail, news, MIME, multimedia, HTML, WWW -;;; -;;; This file is part of tm (Tools for MIME). -;;; -;;; This program 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. -;;; -;;; This program 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 This program. If not, write to the Free Software -;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; Code: - -(require 'tm-view) - -(defun mime-article/decode-html (beg end cal) - (let* ((cur-buf (current-buffer)) - new-buf - (name (or (cdr (assoc "name" cal)) - (cdr (assoc "x-name" cal)) - (concat (make-temp-name "tm") ".html"))) - (encoding (cdr (assq 'encoding cal))) - ;; modified by Shuhei KOBAYASHI <shuhei@cmpt01.phys.tohoku.ac.jp> - ;; 1995/11/17 (cf. [tm-ja:1117]) - (html-helper-build-new-buffer nil) - ) - (switch-to-buffer mime::article/preview-buffer) - (funcall mime/find-file-function (expand-file-name name mime/tmp-dir)) - (if (or (<= (buffer-size) 0) - (y-or-n-p "Replace the existing buffer?")) - (progn - (erase-buffer) - (setq new-buf (current-buffer)) - (save-excursion - (set-buffer cur-buf) - (goto-char beg) - (re-search-forward "^$") - (append-to-buffer new-buf (+ (match-end 0) 1) end) - ))) - (mime-decode-region (point-min)(point-max) encoding) - (run-hooks 'mime-article/decode-html-hook) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "text/html") - (method . mime-article/decode-html) - (mode . "extract") - )) - - -;;; @ end -;;; - -(provide 'tm-html) - -;;; end of tm-html.el
--- a/lisp/tm/tm-image.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,226 +0,0 @@ -;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers - -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko -;; Copyright (C) 1996 Dan Rich - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Dan Rich <drich@morpheus.corp.sgi.com> -;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/12/15 -;; Version: $Id: tm-image.el,v 1.9 1997/09/03 02:55:43 steve Exp $ - -;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news - -;; This file is part of XEmacs. - -;; This program 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. - -;; This program 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 GNU XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; If you use this program with MULE, please install -;; etl8x16-bitmap.bdf font included in tl package. - -;;; Code: - -(require 'tm-view) - -(cond (running-xemacs - (require 'images) - - (defun-maybe image-inline-p (format) - (or (memq format image-native-formats) - (find-if (function - (lambda (native) - (image-converter-chain format native) - )) - image-native-formats) - )) - - (image-register-netpbm-utilities) - (image-register-converter 'pic 'ppm "pictoppm") - (image-register-converter 'mag 'ppm "magtoppm") - - (defun bitmap-insert-xbm-file (file) - (let ((gl (make-glyph (list (cons 'x file)))) - (e (make-extent (point) (point))) - ) - (set-extent-end-glyph e gl) - )) - - ;; - ;; X-Face - ;; - (autoload 'highlight-headers "highlight-headers") - - (defun mime-preview/x-face-function-use-highlight-headers () - (highlight-headers (point-min) (re-search-forward "^$" nil t) t) - ) - - (add-hook 'mime-viewer/content-header-filter-hook - 'mime-preview/x-face-function-use-highlight-headers) - - ) - ((featurep 'mule) - ;; for MULE 2.* or mule merged EMACS - (require 'x-face-mule) - - (defvar image-native-formats '(xbm)) - - (defun-maybe image-inline-p (format) - (memq format image-native-formats) - ) - - (defun-maybe image-normalize (format data) - (and (eq format 'xbm) - (vector 'xbm ':data data) - )) - - ;; - ;; X-Face - ;; - (if (exec-installed-p uncompface-program) - (add-hook 'mime-viewer/content-header-filter-hook - 'x-face-decode-message-header) - ) - )) - -(or (fboundp 'image-invalid-glyph-p) - (defsubst image-invalid-glyph-p (glyph) - (or (null (aref glyph 0)) - (null (aref glyph 2)) - (equal (aref glyph 2) "") - )) - ) - -(defvar mime-viewer/image-converter-alist nil) - -(mapcar (function - (lambda (rule) - (let ((ctype (car rule)) - (format (cdr rule)) - ) - (if (image-inline-p format) - (progn - (set-alist 'mime-viewer/content-filter-alist - ctype - (function mime-preview/filter-for-image)) - (set-alist 'mime-viewer/image-converter-alist - ctype format) - (add-to-list - 'mime-viewer/default-showing-Content-Type-list - ctype) - ) - )))) - '(("image/jpeg" . jpeg) - ("image/gif" . gif) - ("image/tiff" . tiff) - ("image/x-tiff" . tiff) - ("image/xbm" . xbm) - ("image/x-xbm" . xbm) - ("image/x-xpixmap" . xpm) - ("image/x-pic" . pic) - ("image/x-mag" . mag) - ("image/png" . png) - )) - -(defvar mime-viewer/ps-to-gif-command "pstogif") - - -;;; @ content filter for images -;;; -;; (for XEmacs 19.12 or later) - -(defun mime-preview/filter-for-image (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (assoc "charset" params)) - (beg (point-min)) (end (point-max)) - ) - (remove-text-properties beg end '(face nil)) - (message "Decoding image...") - (mime-decode-region beg end encoding) - (let* ((minor (assoc-value ctype mime-viewer/image-converter-alist)) - (gl (image-normalize minor (buffer-string))) - e) - (delete-region (point-min)(point-max)) - (cond ;; ((image-invalid-glyph-p gl) - ;; (setq gl nil) - ;; (message "Invalid glyph!") - ;; ) - ((eq (aref gl 0) 'xbm) - (let ((xbm-file - (make-temp-name (expand-file-name "tm" mime/tmp-dir)))) - (insert (aref gl 2)) - (write-region (point-min)(point-max) xbm-file) - (message "Decoding image...") - (delete-region (point-min)(point-max)) - (bitmap-insert-xbm-file xbm-file) - (delete-file xbm-file) - ) - (message "Decoding image... done") - ) - (t - (setq gl (make-glyph gl)) - (setq e (make-extent (point) (point))) - (set-extent-end-glyph e gl) - (message "Decoding image... done") - )) - ) - (insert "\n") - )) - - -;;; @ content filter for Postscript -;;; -;; (for XEmacs 19.14 or later) - -(defun mime-preview/filter-for-application/postscript (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (beg (point-min)) (end (point-max)) - (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir))) - (ps-file (concat file-base ".ps")) - (gif-file (concat file-base ".gif")) - ) - (remove-text-properties beg end '(face nil)) - (message "Decoding Postscript...") - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) ps-file) - (message "Decoding Postscript...") - (delete-region (point-min)(point-max)) - (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file) - (set-extent-end-glyph (make-extent (point) (point)) - (make-glyph (vector 'gif :file gif-file))) - (message "Decoding Postscript... done") - (delete-file ps-file) - (delete-file gif-file) - )) - -(set-alist 'mime-viewer/content-filter-alist - "application/postscript" - (function mime-preview/filter-for-application/postscript)) - -(if (featurep 'gif) - (add-to-list 'mime-viewer/default-showing-Content-Type-list - "application/postscript") - ) - - -;;; @ end -;;; - -(provide 'tm-image) - -;;; tm-image.el ends here
--- a/lisp/tm/tm-latex.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -;;; -;;; tm-latex: tm-view internal decoder for LaTeX -;;; -;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> (1994/11/11) -;;; -;;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> -;;; -;;; $Id: tm-latex.el,v 1.2 1996/12/28 21:03:14 steve Exp $ -;;; - -(require 'tm-view) - -(defun mime/decode-text/latex (beg end cal) - (let* ((cur-buf (current-buffer)) - new-buf - (name (or (cdr (assoc "name" cal)) - (cdr (assoc "x-name" cal)) - (concat (make-temp-name "tm") ".tex")))) - (switch-to-buffer mime::article/preview-buffer) - (funcall mime/find-file-function (expand-file-name name mime/tmp-dir)) - (if (or (<= (buffer-size) 0) - (y-or-n-p "Replace the existing buffer?")) - (progn - (erase-buffer) - (setq new-buf (current-buffer)) - (save-excursion - (set-buffer cur-buf) - (goto-char beg) - (re-search-forward "^$") - (append-to-buffer new-buf (+ (match-end 0) 1) end) - ))) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "text/x-latex") - (method . mime/decode-text/latex) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/x-latex") - (method . mime/decode-text/latex) - )) - -;(set-atype 'mime/content-decoding-condition -; '((type . "application/octet-stream") -; ("type" . "latex") -; (method . mime/decode-text/latex) -; )) - -(provide 'tm-latex)
--- a/lisp/tm/tm-mail.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -;;; tm-mail.el --- mail-mode extension. - -;; Copyright (C) 1995,1996 KOBAYASHI Shuhei - -;; Author: KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp> -;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; and Neal Becker <neal@neal.ctd.comsat.com> -;; Maintainer: KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp> -;; Created: 1995/11/27 -;; Version: $Id: tm-mail.el,v 1.2 1996/12/28 21:03:15 steve Exp $ -;; Keywords: mail, MIME, multimedia - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tm-edit) - -(defun tm-mail/insert-message (&optional message) - (interactive) - (let* (mail-yank-hooks - (mail-citation-hook '(mime-editor/inserted-message-filter)) - ) - (cond - ((and (boundp 'vm-mail-buffer) vm-mail-buffer) - ;; called from VM. - (let ((mail-reply-buffer vm-mail-buffer)) - (if (null message) - (call-interactively 'vm-yank-message) - (vm-yank-message message))) - ) - ((boundp 'rmail-send-actions-rmail-buffer) - ;; called from RMAIL, emacs-19.29 or later. - (mail-yank-original nil) - ) - ((and (boundp 'gnus-article-buffer) (get-buffer gnus-article-buffer)) - ;; maybe called from Gnus. - (tm-gnus/insert-article) - ) - ((and (boundp 'mail-reply-buffer) mail-reply-buffer) - ;; maybe called from RMAIL. - (mail-yank-original nil) - ) - (t - (message "Sorry, I don't have message inserter for your MUA.") - )) - )) - -(defvar tm-mail/use-xemacs-popup-menu running-xemacs) - -(if (and running-xemacs tm-mail/use-xemacs-popup-menu) - (cond - (running-xemacs-19_14-or-later - (setq mail-menubar-menu - (append mail-menubar-menu - (list "---" - mime-editor/popup-menu-for-xemacs))) - ) - (t - (setq mail-mode-menu - (append mail-mode-menu - (list "---" - mime-editor/popup-menu-for-xemacs))) - ))) - - -;;; @ end -;;; - -(provide 'tm-mail) - -;;; tm-mail.el ends here
--- a/lisp/tm/tm-mh-e.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,418 +0,0 @@ -;;; tm-mh-e.el --- MIME extension for mh-e - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1993/11/21 (obsolete mh-e-mime.el) -;; Version: $Revision: 1.3 $ -;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tl-str) -(require 'tl-misc) -(require 'mh-e) -(or (featurep 'mh-utils) - (require 'tm-mh-e3) - ) -(require 'tm-view) - -(or (fboundp 'mh-get-header-field) - (defalias 'mh-get-header-field 'mh-get-field) - ) -(or (boundp 'mh-temp-buffer) - (defconst mh-temp-buffer " *mh-temp*") - ) - - -;;; @ version -;;; - -(defconst tm-mh-e/RCS-ID - "$Id: tm-mh-e.el,v 1.3 1997/09/27 16:57:47 steve Exp $") - -(defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID)) - - -;;; @ variable -;;; - -(defvar tm-mh-e/automatic-mime-preview t - "*If non-nil, show MIME processed message.") - -(defvar tm-mh-e/decode-encoded-word t - "*If non-nil, decode encoded-word when it is not MIME preview mode.") - - -;;; @ functions -;;; - -(defun mh-display-msg (msg-num folder &optional show-buffer mode) - (or mode - (setq mode tm-mh-e/automatic-mime-preview) - ) - ;; Display message NUMBER of FOLDER. - ;; Sets the current buffer to the show buffer. - (set-buffer folder) - (or show-buffer - (setq show-buffer mh-show-buffer)) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num)) - ) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (set-buffer show-buffer) - (cond ((not (equal msg-filename buffer-file-name)) - ;; Buffer does not yet contain message. - (mh-unvisit-file) - (setq buffer-read-only nil) - (erase-buffer) - ;; Changing contents, so this hook needs to be reinitialized. - ;; pgp.el uses this. - (if (boundp 'write-contents-hooks) ;Emacs 19 - (setq write-contents-hooks nil)) - (if mode - (let* ((aname (concat "article-" folder)) - (abuf (get-buffer aname)) - ) - (if abuf - (progn - (set-buffer abuf) - (setq buffer-read-only nil) - (erase-buffer) - ) - (setq abuf (get-buffer-create aname)) - (set-buffer abuf) - ) - (as-binary-input-file - (insert-file-contents msg-filename) - ;; (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (replace-match "") - ) - ) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (setq buffer-file-name msg-filename) - (mh-show-mode) - (mime/viewer-mode nil nil nil - aname (concat "show-" folder)) - (goto-char (point-min)) - (let ( (buffer-read-only nil) ) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (mh-start-of-uncleaned-message)))) - (goto-char (point-min)) - ) - (progn - (if formfile - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (if (stringp formfile) - (list "-form" formfile)) - msg-filename) - (insert-file-contents msg-filename)) - ;; end - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (mh-start-of-uncleaned-message))) - (if tm-mh-e/decode-encoded-word - (mime/decode-message-header) - ) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (setq buffer-file-name msg-filename) - (mh-show-mode) - )) - (set-buffer-modified-p nil) - (or (eq buffer-undo-list t) ;don't save undo info for prev msgs - (setq buffer-undo-list nil)) - (set-buffer-auto-saved) - ;; the parts of set-visited-file-name we want to do (no locking) - (setq buffer-file-name msg-filename) - (setq buffer-backed-up nil) - (auto-save-mode 1) - (set-mark nil) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder msg-num))) - (set-buffer folder) - (setq mh-showing-with-headers nil))))) - -(defun tm-mh-e/view-message (&optional msg) - "MIME decode and play this message." - (interactive) - (if (or (null tm-mh-e/automatic-mime-preview) - (null (get-buffer mh-show-buffer)) - (save-excursion - (set-buffer mh-show-buffer) - (not (eq major-mode 'mime/viewer-mode)) - )) - (let ((tm-mh-e/automatic-mime-preview t)) - (mh-invalidate-show-buffer) - (mh-show-msg msg) - )) - (pop-to-buffer mh-show-buffer) - ) - -(defun tm-mh-e/toggle-decoding-mode (arg) - "Toggle MIME processing mode. -With arg, turn MIME processing on if arg is positive." - (interactive "P") - (setq tm-mh-e/automatic-mime-preview - (if (null arg) - (not tm-mh-e/automatic-mime-preview) - arg)) - (save-excursion - (set-buffer mh-show-buffer) - (if (null tm-mh-e/automatic-mime-preview) - (if (and mime::preview/article-buffer - (get-buffer mime::preview/article-buffer)) - (kill-buffer mime::preview/article-buffer) - ))) - (mh-invalidate-show-buffer) - (mh-show (mh-get-msg-num t)) - ) - -(defun tm-mh-e/show (&optional message) - (interactive) - (mh-invalidate-show-buffer) - (mh-show message) - ) - -(defun tm-mh-e/header-display () - (interactive) - (mh-invalidate-show-buffer) - (let ((mime-viewer/ignored-field-regexp "^:$") - tm-mh-e/decode-encoded-word) - (mh-header-display) - )) - -(defun tm-mh-e/raw-display () - (interactive) - (mh-invalidate-show-buffer) - (let (tm-mh-e/automatic-mime-preview - tm-mh-e/decode-encoded-word) - (mh-header-display) - )) - -(defun tm-mh-e/burst-multipart/digest () - "Burst apart the current message, which should be a multipart/digest. -The message is replaced by its table of contents and the letters from the -digest are inserted into the folder after that message." - (interactive) - (let ((digest (mh-get-msg-num t))) - (mh-process-or-undo-commands mh-current-folder) - (mh-set-folder-modified-p t) ; lock folder while bursting - (message "Bursting digest...") - (mh-exec-cmd "mhn" "-store" mh-current-folder digest) - (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num)) - (message "Bursting digest...done") - )) - - -;;; @ for tm-view -;;; - -(fset 'tm-mh-e/decode-charset-buffer - (symbol-function 'mime-charset/decode-buffer)) - -(set-alist 'mime-viewer/code-converter-alist - 'mh-show-mode - (function tm-mh-e/decode-charset-buffer)) - -(defun tm-mh-e/content-header-filter () - (goto-char (point-min)) - (mime-preview/cut-header) - (tm-mh-e/decode-charset-buffer default-mime-charset) - (mime/decode-message-header) - ) - -(set-alist 'mime-viewer/content-header-filter-alist - 'mh-show-mode - (function tm-mh-e/content-header-filter)) - -(defun tm-mh-e/quitting-method () - (let ((win (get-buffer-window - mime/output-buffer-name)) - (buf (current-buffer)) - ) - (if win - (delete-window win) - ) - (pop-to-buffer - (let ((name (buffer-name buf))) - (substring name 5) - )) - (if (not tm-mh-e/automatic-mime-preview) - (mh-invalidate-show-buffer) - ) - (mh-show (mh-get-msg-num t)) - )) - -(set-alist 'mime-viewer/quitting-method-alist - 'mh-show-mode - (function tm-mh-e/quitting-method)) -(set-alist 'mime-viewer/show-summary-method - 'mh-show-mode - (function tm-mh-e/quitting-method)) - -(defun tm-mh-e/following-method (buf) - (save-excursion - (set-buffer buf) - (goto-char (point-max)) - (setq mh-show-buffer buf) - (apply (function mh-send) - (std11-field-bodies '("From" "cc" "Subject") "")) - (setq mh-sent-from-folder buf) - (setq mh-sent-from-msg 1) - (let ((last (point))) - (mh-yank-cur-msg) - (goto-char last) - ))) - -(set-alist 'mime-viewer/following-method-alist - 'mh-show-mode - (function tm-mh-e/following-method)) - - -;;; @@ for tm-partial -;;; - -(call-after-loaded - 'tm-partial - (function - (lambda () - (set-atype 'mime/content-decoding-condition - '((type . "message/partial") - (method . mime-article/grab-message/partials) - (major-mode . mh-show-mode) - (summary-buffer-exp - . (and (or (string-match "^article-\\(.+\\)$" article-buffer) - (string-match "^show-\\(.+\\)$" article-buffer)) - (substring article-buffer - (match-beginning 1) (match-end 1)) - )) - )) - (set-alist 'tm-partial/preview-article-method-alist - 'mh-show-mode - (function - (lambda () - (let ((tm-mh-e/automatic-mime-preview t)) - (tm-mh-e/show) - )))) - ))) - - -;;; @ set up -;;; - -(define-key mh-folder-mode-map "v" (function tm-mh-e/view-message)) -(define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode)) -(define-key mh-folder-mode-map "." (function tm-mh-e/show)) -(define-key mh-folder-mode-map "," (function tm-mh-e/header-display)) -(define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display)) -(define-key mh-folder-mode-map "\C-c\C-b" - (function tm-mh-e/burst-multipart/digest)) - -(defun tm-mh-e/summary-before-quit () - (let ((buf (get-buffer mh-show-buffer))) - (if buf - (let ((the-buf (current-buffer))) - (switch-to-buffer buf) - (if (and mime::article/preview-buffer - (setq buf (get-buffer mime::article/preview-buffer)) - ) - (progn - (switch-to-buffer the-buf) - (kill-buffer buf) - ) - (switch-to-buffer the-buf) - ) - )))) - -(add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit)) - - -;;; @@ for tmh-comp.el -;;; - -(autoload 'tm-mh-e/edit-again "tmh-comp" - "Clean-up a draft or a message previously sent and make it resendable." t) -(autoload 'tm-mh-e/extract-rejected-mail "tmh-comp" - "Extract a letter returned by the mail system and make it re-editable." t) -(autoload 'tm-mh-e/forward "tmh-comp" - "Forward a message or message sequence by MIME style." t) - -(call-after-loaded - 'mime-setup - (function - (lambda () - (substitute-key-definition - 'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map) - (substitute-key-definition - 'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail - mh-folder-mode-map) - (substitute-key-definition - 'mh-forward 'tm-mh-e/forward mh-folder-mode-map) - - (call-after-loaded - 'mh-comp - (function - (lambda () - (require 'tmh-comp) - )) - 'mh-letter-mode-hook) - ))) - - -;;; @ for BBDB -;;; - -(call-after-loaded - 'bbdb - (function - (lambda () - (require 'tm-bbdb) - ))) - - -;;; @ end -;;; - -(provide 'tm-mh-e) - -(run-hooks 'tm-mh-e-load-hook) - -;;; tm-mh-e.el ends here
--- a/lisp/tm/tm-parse.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,234 +0,0 @@ -;;; tm-parse.el --- MIME message parser - -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tm-parse.el,v 1.1.1.2 1996/12/21 20:50:42 steve Exp $ -;; Keywords: mail, news, MIME, multimedia - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) -(require 'tl-misc) -(require 'tm-def) - - -;;; @ field parser -;;; - -(defconst rfc822/quoted-pair-regexp "\\\\.") -(defconst rfc822/qtext-regexp - (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]")) -(defconst rfc822/quoted-string-regexp - (concat "\"" - (regexp-* - (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp) - ) - "\"")) - -(defconst mime/content-parameter-value-regexp - (concat "\\(" - rfc822/quoted-string-regexp - "\\|[^; \t\n]*\\)")) - -(defconst mime::parameter-regexp - (concat "^[ \t]*\;[ \t]*\\(" mime/token-regexp "\\)" - "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)")) - -(defun mime/parse-parameter (str) - (if (string-match mime::parameter-regexp str) - (let ((e (match-end 2))) - (cons - (cons (downcase (substring str (match-beginning 1) (match-end 1))) - (std11-strip-quoted-string - (substring str (match-beginning 2) e)) - ) - (substring str e) - )))) - -(defconst mime::ctype-regexp (concat "^" mime/content-type-subtype-regexp)) - -(defun mime/parse-Content-Type (string) - "Parse STRING as field-body of Content-Type field. [tm-parse.el]" - (setq string (std11-unfold-string string)) - (if (string-match mime::ctype-regexp string) - (let* ((e (match-end 0)) - (ctype (downcase (substring string 0 e))) - ret dest) - (setq string (substring string e)) - (while (setq ret (mime/parse-parameter string)) - (setq dest (cons (car ret) dest) - string (cdr ret)) - ) - (cons ctype (nreverse dest)) - ))) - -(defconst mime::dtype-regexp (concat "^" mime/disposition-type-regexp)) - -(defun mime/parse-Content-Disposition (string) - "Parse STRING as field-body of Content-Disposition field. [tm-parse.el]" - (setq string (std11-unfold-string string)) - (if (string-match mime::dtype-regexp string) - (let* ((e (match-end 0)) - (ctype (downcase (substring string 0 e))) - ret dest) - (setq string (substring string e)) - (while (setq ret (mime/parse-parameter string)) - (setq dest (cons (car ret) dest) - string (cdr ret)) - ) - (cons ctype (nreverse dest)) - ))) - - -;;; @ field reader -;;; - -(defun mime/Content-Type () - "Read field-body of Content-Type field from current-buffer, -and return parsed it. [tm-parse.el]" - (let ((str (std11-field-body "Content-Type"))) - (if str - (mime/parse-Content-Type str) - ))) - -(defun mime/Content-Transfer-Encoding (&optional default-encoding) - "Read field-body of Content-Transfer-Encoding field from -current-buffer, and return it. -If is is not found, return DEFAULT-ENCODING. [tm-parse.el]" - (let ((str (std11-field-body "Content-Transfer-Encoding"))) - (if str - (progn - (if (string-match "[ \t\n\r]+$" str) - (setq str (substring str 0 (match-beginning 0))) - ) - (downcase str) - ) - default-encoding) - )) - -(defun mime/Content-Disposition () - "Read field-body of Content-Disposition field from current-buffer, -and return parsed it. [tm-parse.el]" - (let ((str (std11-field-body "Content-Disposition"))) - (if str - (mime/parse-Content-Disposition str) - ))) - - -;;; @ message parser -;;; - -(define-structure mime::content-info - rcnum point-min point-max type parameters encoding children) - - -(defun mime/parse-multipart (boundary ctype params encoding rcnum) - (goto-char (point-min)) - (let* ((dash-boundary (concat "--" boundary)) - (delimiter (concat "\n" (regexp-quote dash-boundary))) - (close-delimiter (concat delimiter "--[ \t]*$")) - (beg (point-min)) - (end (progn - (goto-char (point-max)) - (if (re-search-backward close-delimiter nil t) - (match-beginning 0) - (point-max) - ))) - (rsep (concat delimiter "[ \t]*\n")) - (dc-ctl - (if (string-equal ctype "multipart/digest") - '("message/rfc822") - '("text/plain") - )) - cb ce ct ret ncb children (i 0)) - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (re-search-forward rsep nil t) - (setq cb (match-end 0)) - (while (re-search-forward rsep nil t) - (setq ce (match-beginning 0)) - (setq ncb (match-end 0)) - (save-restriction - (narrow-to-region cb ce) - (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum))) - ) - (setq children (cons ret children)) - (goto-char (mime::content-info/point-max ret)) - (goto-char (setq cb ncb)) - (setq i (1+ i)) - ) - (setq ce (point-max)) - (save-restriction - (narrow-to-region cb ce) - (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum))) - ) - (setq children (cons ret children)) - ) - (mime::content-info/create rcnum beg (point-max) - ctype params encoding - (nreverse children)) - )) - -(defun mime/parse-message (&optional ctl encoding rcnum) - "Parse current-buffer as a MIME message. [tm-parse.el]" - (setq ctl (or (mime/Content-Type) ctl)) - (setq encoding (or (mime/Content-Transfer-Encoding) encoding)) - (let ((ctype (car ctl)) - (params (cdr ctl)) - ) - (let ((boundary (assoc "boundary" params))) - (cond (boundary - (setq boundary (std11-strip-quoted-string (cdr boundary))) - (mime/parse-multipart boundary ctype params encoding rcnum) - ) - ((or (string-equal ctype "message/rfc822") - (string-equal ctype "message/news") - ) - (goto-char (point-min)) - (mime::content-info/create rcnum - (point-min) (point-max) - ctype params encoding - (save-restriction - (narrow-to-region - (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - (point-min) - ) - (point-max)) - (list (mime/parse-message - nil nil (cons 0 rcnum))) - ) - ) - ) - (t - (mime::content-info/create rcnum (point-min) (point-max) - ctype params encoding nil) - )) - ))) - - -;;; @ end -;;; - -(provide 'tm-parse) - -;;; tm-parse.el ends here
--- a/lisp/tm/tm-partial.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,112 +0,0 @@ -;;; tm-partial.el --- Grabbing all MIME "message/partial"s. - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: OKABE Yasuo @ Kyoto University -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: -;; $Id: tm-partial.el,v 1.3 1997/02/15 22:21:29 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, message/partial - -;; This file is a part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tm-view) -(require 'tm-play) - -(defvar tm-partial/preview-article-method-alist nil) - -;; display Article at the cursor in Subject buffer. -(defun tm-partial/preview-article (target) - (save-window-excursion - (let ((f (assq target tm-partial/preview-article-method-alist))) - (if f - (funcall (cdr f)) - (error "Fatal. Unsupported mode") - )))) - -(defun mime-article/grab-message/partials (beg end cal) - (interactive) - (let* ((id (cdr (assoc "id" cal))) - (mother mime::article/preview-buffer) - (target (cdr (assq 'major-mode cal))) - (article-buffer (buffer-name (current-buffer))) - (subject-buf (eval (cdr (assq 'summary-buffer-exp cal)))) - subject-id - (root-dir (expand-file-name - (concat "m-prts-" (user-login-name)) mime/tmp-dir)) - full-file) - (setq root-dir (concat root-dir "/" (replace-as-filename id))) - (setq full-file (concat root-dir "/FULL")) - - (if (null target) - (error "%s is not supported. Sorry." target) - ) - - ;; if you can't parse the subject line, try simple decoding method - (if (or (file-exists-p full-file) - (not (y-or-n-p "Merge partials?")) - ) - (mime-article/decode-message/partial beg end cal) - (let (cinfo the-id parameters) - (setq subject-id (std11-field-body "Subject")) - (if (string-match "[0-9\n]+" subject-id) - (setq subject-id (substring subject-id 0 (match-beginning 0))) - ) - (save-excursion - (set-buffer subject-buf) - (while (search-backward subject-id nil t)) - (catch 'tag - (while t - (tm-partial/preview-article target) - (set-buffer article-buffer) - (set-buffer mime::article/preview-buffer) - (setq cinfo - (mime::preview-content-info/content-info - (car mime::preview/content-list))) - (setq parameters (mime::content-info/parameters cinfo)) - (setq the-id (assoc-value "id" parameters)) - (if (equal the-id id) - (progn - (set-buffer article-buffer) - (mime-article/decode-message/partial - (point-min)(point-max) parameters) - (if (file-exists-p full-file) - (throw 'tag nil) - ) - )) - (if (not (progn - (set-buffer subject-buf) - (end-of-line) - (search-forward subject-id nil t) - )) - (error "not found") - ) - ) - )))))) - - -;;; @ end -;;; - -(provide 'tm-partial) - -(run-hooks 'tm-partial-load-hook) - -;;; tm-partial.el ends here
--- a/lisp/tm/tm-pgp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,315 +0,0 @@ -;;; tm-pgp.el --- tm-view internal methods for PGP. - -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/12/7 -;; Version: $Id: tm-pgp.el,v 1.3 1997/02/15 22:21:29 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, PGP, security - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This module is based on 2 drafts about PGP MIME integration: - -;; - RFC 2015: "MIME Security with Pretty Good Privacy (PGP)" -;; by Michael Elkins <elkins@aero.org> (1996/6) -;; -;; - draft-kazu-pgp-mime-00.txt: "PGP MIME Integration" -;; by Kazuhiko Yamamoto <kazu@is.aist-nara.ac.jp> -;; (1995/10; expired) -;; -;; These drafts may be contrary to each other. You should decide -;; which you support. (Maybe you should use PGP/MIME) - -;;; Code: - -(require 'tm-play) - - -;;; @ internal method for application/pgp -;;; -;;; It is based on draft-kazu-pgp-mime-00.txt - -(defun mime-article/view-application/pgp (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (p-win (or (get-buffer-window mime::article/preview-buffer) - (get-largest-window))) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (mode major-mode) - code-converter - (str (buffer-substring beg end)) - ) - (set-buffer (get-buffer-create new-name)) - (erase-buffer) - (insert str) - (cond ((progn - (goto-char (point-min)) - (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) - ) - (funcall (pgp-function 'verify)) - (goto-char (point-min)) - (delete-region - (point-min) - (and - (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+\n\n") - (match-end 0)) - ) - (delete-region - (and (re-search-forward "^-+BEGIN PGP SIGNATURE-+") - (match-beginning 0)) - (point-max) - ) - (goto-char (point-min)) - (while (re-search-forward "^- -" nil t) - (replace-match "-") - ) - (setq code-converter - (or - (cdr (assq mode mime-viewer/code-converter-alist)) - (function mime-viewer/default-code-convert-region))) - ) - ((progn - (goto-char (point-min)) - (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t) - ) - (as-binary-process (funcall (pgp-function 'decrypt))) - (goto-char (point-min)) - (delete-region (point-min) - (and - (search-forward "\n\n") - (match-end 0))) - (setq code-converter (function mime-charset/decode-buffer)) - )) - (setq major-mode 'mime/show-message-mode) - (setq mime::article/code-converter code-converter) - (save-window-excursion (mime/viewer-mode mother)) - (set-window-buffer p-win mime::article/preview-buffer) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp") - (method . mime-article/view-application/pgp) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "text/x-pgp") - (method . mime-article/view-application/pgp) - )) - - -;;; @ Internal method for application/pgp-signature -;;; -;;; It is based on RFC 2015. - -(defvar tm-pgp::default-language 'en - "*Symbol of language for pgp. -It should be ISO 639 2 letter language code such as en, ja, ...") - -(defvar tm-pgp::good-signature-regexp-alist - '((en . "Good signature from user.*$")) - "Alist of language vs regexp to detect ``Good signature''.") - -(defvar tm-pgp::key-expected-regexp-alist - '((en . "Key matching expected Key ID \\(\\S +\\) not found")) - "Alist of language vs regexp to detect ``Key expected''.") - -(defun mime::article/call-pgp-to-check-signature (output-buffer orig-file) - (save-excursion - (set-buffer output-buffer) - (erase-buffer) - ) - (let* ((lang (or tm-pgp::default-language 'en)) - (status - (call-process-region (point-min)(point-max) - "pgp" nil output-buffer nil orig-file - (format "+language=%s" lang) - )) - (regexp (cdr (assq lang tm-pgp::good-signature-regexp-alist))) - ) - (if (= status 0) - (save-excursion - (set-buffer output-buffer) - (goto-char (point-min)) - (message - (cond ((not (stringp regexp)) - "Please specify right regexp for specified language") - ((re-search-forward regexp nil t) - (buffer-substring (match-beginning 0) (match-end 0)) - ) - (t - "Bad signature" - ))) - )))) - -(defun mime-article/check-pgp-signature (beg end cal) - (let* ((encoding (cdr (assq 'encoding cal))) - (cnum (mime-article/point-content-number beg)) - (rcnum (reverse cnum)) - (rmcnum (cdr rcnum)) - (knum (car rcnum)) - (onum (if (> knum 0) - (1- knum) - (1+ knum))) - (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) - mime::article/content-info)) - status str kbuf - (basename (expand-file-name "tm" mime/tmp-dir)) - (orig-file (make-temp-name basename)) - (sig-file (concat orig-file ".sig")) - ) - (save-excursion - (setq str (buffer-substring - (mime::content-info/point-min oinfo) - (mime::content-info/point-max oinfo) - )) - (set-buffer (get-buffer-create mime/temp-buffer-name)) - (insert str) - (goto-char (point-min)) - (while (re-search-forward "\n" nil t) - (replace-match "\r\n") - ) - (as-binary-output-file (write-file orig-file)) - (kill-buffer (current-buffer)) - ) - (save-excursion - (mime-article/show-output-buffer) - ) - (save-excursion - (setq str (buffer-substring - (save-excursion - (goto-char beg) - (and (search-forward "\n\n") - (match-end 0))) - end)) - (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name))) - (insert str) - (mime-decode-region (point-min)(point-max) encoding) - (as-binary-output-file (write-file sig-file)) - (or (mime::article/call-pgp-to-check-signature - mime/output-buffer-name orig-file) - (let (pgp-id) - (save-excursion - (set-buffer mime/output-buffer-name) - (goto-char (point-min)) - (let ((regexp (cdr (assq (or tm-pgp::default-language 'en) - tm-pgp::key-expected-regexp-alist)))) - (cond ((not (stringp regexp)) - (message - "Please specify right regexp for specified language") - ) - ((re-search-forward regexp nil t) - (setq pgp-id - (concat "0x" (buffer-substring-no-properties - (match-beginning 1) - (match-end 1)))) - )))) - (if (and pgp-id - (y-or-n-p - (format "Key %s not found; attempt to fetch? " pgp-id)) - ) - (progn - (funcall (pgp-function 'fetch-key) (cons nil pgp-id)) - (mime::article/call-pgp-to-check-signature - mime/output-buffer-name orig-file) - )) - )) - (let ((other-window-scroll-buffer mime/output-buffer-name)) - (scroll-other-window 8) - ) - (kill-buffer kbuf) - (delete-file orig-file) - (delete-file sig-file) - ))) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp-signature") - (method . mime-article/check-pgp-signature) - )) - - -;;; @ Internal method for application/pgp-encrypted -;;; -;;; It is based on RFC 2015. - -(defun mime-article/decrypt-pgp (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (rcnum (reverse cnum)) - (rmcnum (cdr rcnum)) - (knum (car rcnum)) - (onum (if (> knum 0) - (1- knum) - (1+ knum))) - (oinfo (mime-article/rcnum-to-cinfo (cons onum rmcnum) - mime::article/content-info)) - (obeg (mime::content-info/point-min oinfo)) - (oend (mime::content-info/point-max oinfo)) - ) - (mime-article/view-application/pgp obeg oend cal) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp-encrypted") - (method . mime-article/decrypt-pgp) - )) - - -;;; @ Internal method for application/pgp-keys -;;; -;;; It is based on RFC 2015. - -(defun mime-article/add-pgp-keys (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (charset (cdr (assoc "charset" cal))) - (encoding (cdr (assq 'encoding cal))) - (mode major-mode) - str) - (setq str (buffer-substring beg end)) - (switch-to-buffer new-name) - (setq buffer-read-only nil) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (mime-decode-region (point-min)(point-max) encoding) - (funcall (pgp-function 'snarf-keys)) - (kill-buffer (current-buffer)) - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/pgp-keys") - (method . mime-article/add-pgp-keys) - )) - - -;;; @ end -;;; - -(provide 'tm-pgp) - -(run-hooks 'tm-pgp-load-hook) - -;;; tm-pgp.el ends here
--- a/lisp/tm/tm-play.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,492 +0,0 @@ -;;; tm-play.el --- decoder for tm-view.el - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1995/9/26 (separated from tm-view.el) -;; Version: $Id: tm-play.el,v 1.6 1997/04/10 05:55:52 steve Exp $ -;; Keywords: mail, news, MIME, multimedia - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tm-view) - - -;;; @ content decoder -;;; - -(defvar mime-preview/after-decoded-position nil) - -(defun mime-preview/decode-content () - (interactive) - (let ((pc (mime-preview/point-pcinfo (point)))) - (if pc - (let ((the-buf (current-buffer))) - (setq mime-preview/after-decoded-position (point)) - (set-buffer (mime::preview-content-info/buffer pc)) - (mime-article/decode-content - (mime::preview-content-info/content-info pc)) - (if (eq (current-buffer) - (mime::preview-content-info/buffer pc)) - (progn - (set-buffer the-buf) - (goto-char mime-preview/after-decoded-position) - )) - )))) - -(defun mime-article/decode-content (cinfo) - (let ((beg (mime::content-info/point-min cinfo)) - (end (mime::content-info/point-max cinfo)) - (ctype (or (mime::content-info/type cinfo) "text/plain")) - (params (mime::content-info/parameters cinfo)) - (encoding (mime::content-info/encoding cinfo)) - ) - ;; Check for VM - (if (< beg (point-min)) - (setq beg (point-min)) - ) - (if (< (point-max) end) - (setq end (point-max)) - ) - (let (method cal ret) - (setq cal (list* (cons 'type ctype) - (cons 'encoding encoding) - (cons 'major-mode major-mode) - params)) - (if mime-viewer/decoding-mode - (setq cal (cons - (cons 'mode mime-viewer/decoding-mode) - cal)) - ) - (setq ret (mime/get-content-decoding-alist cal)) - (setq method (cdr (assq 'method ret))) - (cond ((and (symbolp method) - (fboundp method)) - (funcall method beg end ret) - ) - ((and (listp method)(stringp (car method))) - (mime-article/start-external-method-region beg end ret) - ) - (t - (mime-article/show-output-buffer - "No method are specified for %s\n" ctype) - )) - ) - )) - -(defun field-unifier-for-mode (a b) - (let ((va (cdr a))) - (if (if (consp va) - (member (cdr b) va) - (equal va (cdr b)) - ) - (list nil b nil) - ))) - -(defun mime/get-content-decoding-alist (al) - (get-unified-alist mime/content-decoding-condition al) - ) - - -;;; @ external decoder -;;; - -(defun mime-article/start-external-method-region (beg end cal) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (let ((method (cdr (assoc 'method cal))) - (name (mime-article/get-filename cal)) - ) - (if method - (let ((file (make-temp-name - (expand-file-name "TM" mime/tmp-dir))) - b args) - (if (nth 1 method) - (setq b beg) - (setq b - (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - (point-min) - )) - ) - (goto-char b) - (write-region b end file) - (message "External method is starting...") - (setq cal (put-alist - 'name (replace-as-filename name) cal)) - (setq cal (put-alist 'file file cal)) - (setq args (nconc - (list (car method) - mime/output-buffer-name (car method) - ) - (mime-article/make-method-args cal - (cdr (cdr method))) - )) - (apply (function start-process) args) - (mime-article/show-output-buffer) - )) - )))) - -(defun mime-article/make-method-args (cal format) - (mapcar (function - (lambda (arg) - (if (stringp arg) - arg - (let* ((item (eval arg)) - (ret (cdr (assoc item cal))) - ) - (if ret - ret - (if (eq item 'encoding) - "7bit" - "")) - )) - )) - format)) - -(defun mime-article/show-output-buffer (&rest forms) - (get-buffer-create mime/output-buffer-name) - (let ((the-win (selected-window)) - (win (get-buffer-window mime/output-buffer-name)) - ) - (or win - (if (and mime/output-buffer-window-is-shared-with-bbdb - (boundp 'bbdb-buffer-name) - (setq win (get-buffer-window bbdb-buffer-name)) - ) - (set-window-buffer win mime/output-buffer-name) - (select-window (get-buffer-window mime::article/preview-buffer)) - (setq win (split-window-vertically (/ (* (window-height) 3) 4))) - (set-window-buffer win mime/output-buffer-name) - )) - (select-window win) - (goto-char (point-max)) - (if forms - (insert (apply (function format) forms)) - ) - (select-window the-win) - )) - - -;;; @ file name -;;; - -(defvar mime-viewer/file-name-char-regexp "[A-Za-z0-9+_-]") - -(defvar mime-viewer/file-name-regexp-1 - (concat mime-viewer/file-name-char-regexp "+\\." - mime-viewer/file-name-char-regexp "+")) - -(defvar mime-viewer/file-name-regexp-2 - (concat (regexp-* mime-viewer/file-name-char-regexp) - "\\(\\." mime-viewer/file-name-char-regexp "+\\)*")) - -(defun mime-article/get-original-filename (param &optional encoding) - (or (mime-article/get-uu-filename param encoding) - (let (ret) - (or (if (or (and (setq ret (mime/Content-Disposition)) - (setq ret (assoc "filename" (cdr ret))) - ) - (setq ret (assoc "name" param)) - (setq ret (assoc "x-name" param)) - ) - (std11-strip-quoted-string (cdr ret)) - ) - (if (setq ret - (std11-find-field-body '("Content-Description" - "Subject"))) - (if (or (string-match mime-viewer/file-name-regexp-1 ret) - (string-match mime-viewer/file-name-regexp-2 ret)) - (substring ret (match-beginning 0)(match-end 0)) - )) - )) - )) - -(defun mime-article/get-filename (param) - (replace-as-filename (mime-article/get-original-filename param)) - ) - - -;;; @ mail/news message -;;; - -(defun mime-viewer/quitting-method-for-mime/show-message-mode () - (let ((mother mime::preview/mother-buffer) - (win-conf mime::preview/original-window-configuration) - ) - (kill-buffer - (mime::preview-content-info/buffer (car mime::preview/content-list))) - (mime-viewer/kill-buffer) - (set-window-configuration win-conf) - (pop-to-buffer mother) - ;;(goto-char (point-min)) - ;;(mime-viewer/up-content) - )) - -(defun mime-article/view-message/rfc822 (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (code-converter - (or (cdr (assq major-mode mime-viewer/code-converter-alist)) - 'mime-viewer/default-code-convert-region)) - str) - (setq str (buffer-substring beg end)) - (switch-to-buffer new-name) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (setq major-mode 'mime/show-message-mode) - (setq mime::article/code-converter code-converter) - (mime/viewer-mode mother) - )) - - -;;; @ message/partial -;;; - -(defvar mime-article/coding-system-alist - (list (cons 'mh-show-mode *noconv*) - (cons t (mime-charset-to-coding-system default-mime-charset)) - )) - -(cond ((boundp 'MULE) ; for MULE 2.3 or older - (defun mime-article::write-region (start end file) - (let ((file-coding-system - (cdr - (or (assq major-mode mime-article/coding-system-alist) - (assq t mime-article/coding-system-alist) - )))) - (write-region start end file) - )) - ) - ((featurep 'mule) ; for Emacs/mule and XEmacs/mule - (defun mime-article::write-region (start end file) - (let ((coding-system-for-write - (cdr - (or (assq major-mode mime-article/coding-system-alist) - (assq t mime-article/coding-system-alist) - )))) - (write-region start end file) - )) - ) - ((boundp 'NEMACS) ; for NEmacs - (defun mime-article::write-region (start end file) - (let ((kanji-fileio-code - (cdr - (or (assq major-mode mime-article/kanji-code-alist) - (assq t mime-article/kanji-code-alist) - )))) - (write-region start end file) - )) - ) - (t ; for Emacs 19 or older and XEmacs without mule - (defalias 'mime-article::write-region 'write-region) - )) - -(defun mime-article/decode-message/partial (beg end cal) - (goto-char beg) - (let* ((root-dir (expand-file-name - (concat "m-prts-" (user-login-name)) mime/tmp-dir)) - (id (cdr (assoc "id" cal))) - (number (cdr (assoc "number" cal))) - (total (cdr (assoc "total" cal))) - file - (mother mime::article/preview-buffer) - ) - (or (file-exists-p root-dir) - (make-directory root-dir) - ) - (setq id (replace-as-filename id)) - (setq root-dir (concat root-dir "/" id)) - (or (file-exists-p root-dir) - (make-directory root-dir) - ) - (setq file (concat root-dir "/FULL")) - (if (file-exists-p file) - (let ((full-buf (get-buffer-create "FULL")) - (pwin (or (get-buffer-window mother) - (get-largest-window))) - ) - (save-window-excursion - (set-buffer full-buf) - (erase-buffer) - (as-binary-input-file (insert-file-contents file)) - (setq major-mode 'mime/show-message-mode) - (mime/viewer-mode mother) - ) - (set-window-buffer pwin - (save-excursion - (set-buffer full-buf) - mime::article/preview-buffer)) - (select-window pwin) - ) - (re-search-forward "^$") - (goto-char (1+ (match-end 0))) - (setq file (concat root-dir "/" number)) - (mime-article::write-region (point) (point-max) file) - (let ((total-file (concat root-dir "/CT"))) - (setq total - (if total - (progn - (or (file-exists-p total-file) - (save-excursion - (set-buffer - (get-buffer-create mime/temp-buffer-name)) - (erase-buffer) - (insert total) - (write-file total-file) - (kill-buffer (current-buffer)) - )) - (string-to-number total) - ) - (and (file-exists-p total-file) - (save-excursion - (set-buffer (find-file-noselect total-file)) - (prog1 - (and (re-search-forward "[0-9]+" nil t) - (string-to-number - (buffer-substring (match-beginning 0) - (match-end 0))) - ) - (kill-buffer (current-buffer)) - ))) - ))) - (if (and total (> total 0)) - (catch 'tag - (save-excursion - (set-buffer (get-buffer-create mime/temp-buffer-name)) - (let ((full-buf (current-buffer))) - (erase-buffer) - (let ((i 1)) - (while (<= i total) - (setq file (concat root-dir "/" (int-to-string i))) - (or (file-exists-p file) - (throw 'tag nil) - ) - (as-binary-input-file (insert-file-contents file)) - (goto-char (point-max)) - (setq i (1+ i)) - )) - (as-binary-output-file (write-file (concat root-dir "/FULL"))) - (let ((i 1)) - (while (<= i total) - (let ((file (format "%s/%d" root-dir i))) - (and (file-exists-p file) - (delete-file file) - )) - (setq i (1+ i)) - )) - (let ((file (expand-file-name "CT" root-dir))) - (and (file-exists-p file) - (delete-file file) - )) - (save-window-excursion - (setq major-mode 'mime/show-message-mode) - (mime/viewer-mode mother) - ) - (let ((pwin (or (get-buffer-window mother) - (get-largest-window) - )) - (pbuf (save-excursion - (set-buffer full-buf) - mime::article/preview-buffer))) - (set-window-buffer pwin pbuf) - (select-window pwin) - ))))) - ))) - - -;;; @ rot13-47 -;;; - -(or (boundp 'view-mode-map) - (require 'view) - ) - -(defconst mime-view-text/plain-mode-map (copy-keymap view-mode-map)) -(define-key mime-view-text/plain-mode-map - "q" (function mime-view-text/plain-exit)) - -(defun mime-view-text/plain-mode () - "\\{mime-view-text/plain-mode-map}" - (setq buffer-read-only t) - (setq major-mode 'mime-view-text/plain-mode) - (setq mode-name "MIME-View text/plain") - (use-local-map mime-view-text/plain-mode-map) - ) - -(defun mime-view-text/plain-exit () - (interactive) - (kill-buffer (current-buffer)) - ) - -(defun mime-article/decode-caesar (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) - (cur-buf (current-buffer)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (mother mime::article/preview-buffer) - (charset (cdr (assoc "charset" cal))) - (encoding (cdr (assq 'encoding cal))) - (mode major-mode) - str) - (setq str (buffer-substring beg end)) - (let ((pwin (or (get-buffer-window mother) - (get-largest-window))) - (buf (get-buffer-create new-name)) - ) - (set-window-buffer pwin buf) - (set-buffer buf) - (select-window pwin) - ) - (setq buffer-read-only nil) - (erase-buffer) - (insert str) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (let ((m (cdr (or (assq mode mime-viewer/code-converter-alist) - (assq t mime-viewer/code-converter-alist))))) - (and (functionp m) - (funcall m charset encoding) - )) - (save-excursion - (set-mark (point-min)) - (goto-char (point-max)) - (tm:caesar-region) - ) - (set-buffer-modified-p nil) - (mime-view-text/plain-mode) - )) - - -;;; @ end -;;; - -(provide 'tm-play) - -;;; tm-play.el ends here
--- a/lisp/tm/tm-rmail.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,398 +0,0 @@ -;;; tm-rmail.el --- MIME extension for RMAIL - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; modified by KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp> -;; Created: 1994/8/30 -;; Version: $Revision: 1.2 $ -;; Keywords: mail, MIME, multimedia, multilingual, encoded-word - -;; This file is not part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tl-list) -(require 'tl-misc) -(require 'rmail) - -(autoload 'mime/viewer-mode "tm-view" "View MIME message." t) -(autoload 'mime/Content-Type "tm-view" "parse Content-Type field.") -(autoload 'mime/decode-message-header "tm-ew-d" "Decode MIME encoded-word." t) - - -;;; @ variables -;;; - -(defconst tm-rmail/RCS-ID - "$Id: tm-rmail.el,v 1.2 1997/02/15 22:21:30 steve Exp $") -(defconst tm-rmail/version (get-version-string tm-rmail/RCS-ID)) - -(defvar tm-rmail/decode-all nil) - - -;;; @ message filter -;;; - -(setq rmail-message-filter - (function - (lambda () - (let ((mf (buffer-modified-p)) - (buffer-read-only nil)) - (mime/decode-message-header) - (set-buffer-modified-p mf) - )))) - - -;;; @ MIME preview -;;; - -(defun tm-rmail/show-all-header-p () - (save-restriction - (narrow-to-region (point-min) - (and (re-search-forward "^$" nil t) - (match-beginning 0))) - (goto-char (point-min)) - (re-search-forward rmail-ignored-headers nil t) - )) - -(defun tm-rmail/preview-message () - (interactive) - (setq tm-rmail/decode-all t) - (let ((ret (tm-rmail/get-Content-Type-and-Content-Transfer-Encoding))) - (narrow-to-region (point-min) - (save-excursion - (goto-char (point-max)) - (if (and (re-search-backward "^\n") - (eq (match-end 0)(point-max))) - (match-beginning 0) - (point-max) - ))) - (let ((abuf (current-buffer)) - (buf-name (format "*Preview-%s [%d/%d]*" - (buffer-name) - rmail-current-message rmail-total-messages)) - buf win) - (if (and mime::article/preview-buffer - (setq buf (get-buffer mime::article/preview-buffer)) - ) - (progn - (save-excursion - (set-buffer buf) - (rename-buffer buf-name) - ) - (if (setq win (get-buffer-window buf)) - (progn - (delete-window (get-buffer-window abuf)) - (set-window-buffer win abuf) - (set-buffer abuf) - )) - )) - (setq win (get-buffer-window abuf)) - (save-window-excursion - (mime/viewer-mode nil (car ret)(cdr ret) nil buf-name) - (or buf - (setq buf (current-buffer)) - ) - ) - (set-window-buffer win buf) - ))) - -(defun tm-rmail/preview-message-if-you-need () - (if tm-rmail/decode-all - (tm-rmail/preview-message) - )) - -(add-hook 'rmail-show-message-hook 'tm-rmail/preview-message-if-you-need) - -(load "rmailsum") - -(cond ((fboundp 'rmail-summary-rmail-update) - ;; for Emacs 19 or later - (or (fboundp 'tm:rmail-summary-rmail-update) - (fset 'tm:rmail-summary-rmail-update - (symbol-function 'rmail-summary-rmail-update)) - ) - - (defun rmail-summary-rmail-update () - (tm:rmail-summary-rmail-update) - (if tm-rmail/decode-all - (let ((win (get-buffer-window rmail-buffer))) - (if win - (delete-window win) - ))) - ) - - (defun tm-rmail/get-Content-Type-and-Content-Transfer-Encoding () - (rmail-widen-to-current-msgbeg - (function - (lambda () - (cons (mime/Content-Type) - (mime/Content-Transfer-Encoding "7bit") - ))))) - ) - (t - ;; for Emacs 18 - (defun tm-rmail/get-Content-Type-and-Content-Transfer-Encoding () - (save-restriction - (rmail-widen-to-current-msgbeg - (function - (lambda () - (goto-char (point-min)) - (narrow-to-region (or (and (re-search-forward "^.+:" nil t) - (match-beginning 0)) - (point-min)) - (point-max)) - ))) - (cons (mime/Content-Type) - (mime/Content-Transfer-Encoding "7bit") - ))) - )) - -(define-key rmail-mode-map "v" (function tm-rmail/preview-message)) - -(defun tm-rmail/setup () - (local-set-key "v" (function - (lambda () - (interactive) - (set-buffer rmail-buffer) - (tm-rmail/preview-message) - ))) - ) - -(add-hook 'rmail-summary-mode-hook 'tm-rmail/setup) - - -;;; @ over-to-* and quitting methods -;;; - -(defun tm-rmail/quitting-method-to-summary () - (mime-viewer/kill-buffer) - (rmail-summary) - (delete-other-windows) - ) - -(defun tm-rmail/quitting-method-to-article () - (setq tm-rmail/decode-all nil) - (let ((buffer - (mime::preview-content-info/buffer - (mime-preview/point-pcinfo (point)))) - ) - (mime-viewer/kill-buffer) - - ;; Make sure we return to RMAIL buffer - (if buffer - (switch-to-buffer buffer)) - )) - -(defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article) - - -(defun tm-rmail/over-to-previous-method () - (let (tm-rmail/decode-all) - (mime-viewer/quit) - ) - (if (not (eq (rmail-next-undeleted-message -1) t)) - (tm-rmail/preview-message) - ) - ) - -(defun tm-rmail/over-to-next-method () - (let (tm-rmail/decode-all) - (mime-viewer/quit) - ) - (if (not (eq (rmail-next-undeleted-message 1) t)) - (tm-rmail/preview-message) - ) - ) - -(defun tm-rmail/show-summary-method () - (save-excursion - (set-buffer mime::preview/article-buffer) - (rmail-summary) - )) - -(call-after-loaded - 'tm-view - (function - (lambda () - (set-alist 'mime-viewer/quitting-method-alist - 'rmail-mode - (function tm-rmail/quitting-method)) - - (set-alist 'mime-viewer/over-to-previous-method-alist - 'rmail-mode - (function tm-rmail/over-to-previous-method)) - - (set-alist 'mime-viewer/over-to-next-method-alist - 'rmail-mode - (function tm-rmail/over-to-next-method)) - - (set-alist 'mime-viewer/show-summary-method - 'rmail-mode - (function tm-rmail/show-summary-method)) - ))) - - -;;; @ for tm-partial -;;; - -(call-after-loaded - 'tm-partial - (function - (lambda () - (set-atype 'mime/content-decoding-condition - '((type . "message/partial") - (method . mime-article/grab-message/partials) - (major-mode . rmail-mode) - (summary-buffer-exp - . (progn - (rmail-summary) - (pop-to-buffer rmail-buffer) - rmail-summary-buffer)) - )) - (set-alist 'tm-partial/preview-article-method-alist - 'rmail-mode - (function - (lambda () - (rmail-summary-goto-msg (count-lines 1 (point))) - (pop-to-buffer rmail-buffer) - (tm-rmail/preview-message) - ))) - ))) - - -;;; @ for tm-edit -;;; - -(defun tm-rmail/forward () - "Forward current message in message/rfc822 content-type message -from rmail. The message will be appended if being composed." - (interactive) - ;;>> this gets set even if we abort. Can't do anything about it, though. - (rmail-set-attribute "forwarded" t) - (let ((initialized nil) - (beginning nil) - (msgnum rmail-current-message) - (rmail-buffer (current-buffer)) - (subject (concat "[" - (mail-strip-quoted-names - (mail-fetch-field "From")) - ": " (or (mail-fetch-field "Subject") "") "]"))) - ;; If only one window, use it for the mail buffer. - ;; Otherwise, use another window for the mail buffer - ;; so that the Rmail buffer remains visible - ;; and sending the mail will get back to it. - (setq initialized - (if (one-window-p t) - (mail nil nil subject) - (mail-other-window nil nil subject))) - (save-excursion - ;; following two variables are used in 19.29 or later. - (make-local-variable 'rmail-send-actions-rmail-buffer) - (make-local-variable 'rmail-send-actions-rmail-msg-number) - (make-local-variable 'mail-reply-buffer) - (setq rmail-send-actions-rmail-buffer rmail-buffer) - (setq rmail-send-actions-rmail-msg-number msgnum) - (setq mail-reply-buffer rmail-buffer) - (goto-char (point-max)) - (forward-line 1) - (setq beginning (point)) - (mime-editor/insert-tag "message" "rfc822") -;; (insert-buffer rmail-buffer)) -;; (mime-editor/inserted-message-filter)) - (tm-mail/insert-message)) - (if (not initialized) - (goto-char beginning)) - )) - -(defun gnus-mail-forward-using-mail-mime () - "Forward current article in message/rfc822 content-type message from -GNUS. The message will be appended if being composed." - (let ((initialized nil) - (beginning nil) - (forwarding-buffer (current-buffer)) - (subject - (concat "[" gnus-newsgroup-name "] " - ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": " - (or (gnus-fetch-field "Subject") "")))) - ;; If only one window, use it for the mail buffer. - ;; Otherwise, use another window for the mail buffer - ;; so that the Rmail buffer remains visible - ;; and sending the mail will get back to it. - (setq initialized - (if (one-window-p t) - (mail nil nil subject) - (mail-other-window nil nil subject))) - (save-excursion - (goto-char (point-max)) - (setq beginning (point)) - (mime-editor/insert-tag "message" "rfc822") - (insert-buffer forwarding-buffer) - ;; You have a chance to arrange the message. - (run-hooks 'gnus-mail-forward-hook) - ) - (if (not initialized) - (goto-char beginning)) - )) - -(call-after-loaded - 'mime-setup - (function - (lambda () - (substitute-key-definition - 'rmail-forward 'tm-rmail/forward rmail-mode-map) - - ;; (setq gnus-mail-forward-method 'gnus-mail-forward-using-mail-mime) - - (call-after-loaded - 'tm-edit - (function - (lambda () - (require 'tm-mail) - (set-alist 'mime-editor/message-inserter-alist - 'mail-mode (function tm-mail/insert-message)) - (set-alist 'mime-editor/split-message-sender-alist - 'mail-mode (function - (lambda () - (interactive) - (funcall send-mail-function) - ))) - ))) - ))) - - -;;; @ for BBDB -;;; - -(call-after-loaded - 'bbdb - (function - (lambda () - (require 'tm-bbdb) - ))) - - -;;; @ end -;;; - -(provide 'tm-rmail) - -(run-hooks 'tm-rmail-load-hook) - -;;; tm-rmail.el ends here.
--- a/lisp/tm/tm-setup.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,169 +0,0 @@ -;;; tm-setup.el --- setup file for tm viewer. - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Version: $Id: tm-setup.el,v 1.2 1997/02/15 22:21:30 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tl-misc) - - -;;; @ for tm-view -;;; - -(call-after-loaded - 'tm-view - (function - (lambda () - ;; for message/partial - (require 'tm-partial) - - ;; for anonymous ftp - (set-atype 'mime/content-decoding-condition - '((type . "message/external-body") - ("access-type" . "anon-ftp") - (method . mime-article/decode-message/external-ftp) - )) - (autoload 'mime-article/decode-message/external-ftp "tm-ftp") - - ;; for LaTeX - (set-atype 'mime/content-decoding-condition - '((type . "text/x-latex") - (method . mime/decode-text/latex) - )) - (set-atype 'mime/content-decoding-condition - '((type . "application/x-latex") - (method . mime/decode-text/latex) - )) - ;;(set-atype 'mime/content-decoding-condition - ;; '((type . "application/octet-stream") - ;; ("type" . "latex") - ;; (method . mime/decode-text/latex) - ;; )) - (autoload 'mime/decode-text/latex "tm-latex") - ))) - - -;; for image/* and X-Face -(defvar mime-setup-enable-inline-image - (and window-system - (or running-xemacs - (and (featurep 'mule)(module-installed-p 'bitmap)) - )) - "*If it is non-nil, tm-setup sets up to use tm-image.") - -(if mime-setup-enable-inline-image - (call-after-loaded 'tm-view - (function - (lambda () - (require 'tm-image) - ))) - ) - - -(defvar mime-setup-enable-pgp - (module-installed-p 'mailcrypt) - "*If it is non-nil, tm-setup sets uf to use tm-pgp.") - -;; for PGP -(if mime-setup-enable-pgp - (call-after-loaded 'tm-view - (function - (lambda () - (require 'tm-pgp) - ))) - ) - - -;;; @ for RMAIL -;;; - -(defun tm-setup/load-rmail () - (or (and (boundp 'rmail-support-mime) - rmail-support-mime) - (require 'tm-rmail) - ) - (remove-hook 'rmail-mode-hook 'tm-setup/load-rmail) - ) - -(call-after-loaded 'rmail 'tm-setup/load-rmail 'rmail-mode-hook) - - -;;; @ for mh-e -;;; - -(let ((le (function - (lambda () - (require 'tm-mh-e) - )) - )) - (call-after-loaded 'mh-e le 'mh-folder-mode-hook) - (if (not (featurep 'mh-e)) - (add-hook 'mh-letter-mode-hook le) - )) - - -;;; @ for GNUS and Gnus -;;; - -(if (featurep 'gnus) - (if (boundp 'gnus-load-hook) - (require 'gnus-mime) - (require 'tm-gnus) - ) - ;; for GNUS - (defvar tm-setup/use-gnusutil nil) - - (defun tm-setup/load-GNUS () - (require 'tm-gnus) - ) - - (if (and (boundp 'MULE) tm-setup/use-gnusutil) - (progn - (add-hook 'gnus-Group-mode-hook (function gnusutil-initialize)) - (add-hook 'gnus-group-mode-hook (function gnusutil-initialize)) - (autoload 'gnusutil-initialize "gnusutil") - (autoload 'gnusutil-add-group "gnusutil") - (add-hook 'gnusutil-initialize-hook 'tm-setup/load-GNUS) - ) - (add-hook 'gnus-Startup-hook 'tm-setup/load-GNUS 'append) - (add-hook 'gnus-startup-hook 'tm-setup/load-GNUS 'append) - ) - - ;; for Gnus - (defun tm-setup/load-gnus () - (let (gnus-load-hook) - (remove-hook 'gnus-startup-hook 'tm-setup/load-GNUS) - (require 'gnus-mime) - )) - - (add-hook 'gnus-load-hook 'tm-setup/load-gnus) - ) - - -;;; @ end -;;; - -(provide 'tm-setup) - -;;; tm-setup.el ends here
--- a/lisp/tm/tm-tar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,344 +0,0 @@ -;;; -;;; $Id: tm-tar.el,v 1.2 1996/12/28 21:03:15 steve Exp $ -;;; -;;; tm-tar.el -;;; -;;; Internal viewer for -;;; - application/x-tar -;;; - application/x-gzip, type="tar" -;;; - aplication/octet-stream, type="tar" -;;; - aplication/octet-stream, type="tar+gzip" -;;; -;;; by Hiroshi Ueno <zodiac@ibm.net> -;;; modified by Tomohiko Morioka <morioka@jaist.ac.jp> -;;; - -;;; @ required modules -;;; - -(require 'emu) -(require 'tm-view) - -;;; @ constants -;;; - -(defconst tm-tar/list-buffer "*tm-tar/List*") -(defconst tm-tar/view-buffer "*tm-tar/View*") -(defconst tm-tar/file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+") -(defconst tm-tar/popup-menu-title "Action Menu") - -;;; @ variables -;;; - -(defvar tm-tar/tar-program "gtar") -(defvar tm-tar/tar-decompress-arg '("-z")) -(defvar tm-tar/gzip-program "gzip") -(defvar tm-tar/mmencode-program "mmencode") -(defvar tm-tar/uudecode-program "uudecode") - -(defvar tm-tar/popup-menu-items - '(("View File" . tm-tar/view-file) - ("Key Help" . tm-tar/helpful-message) - ("Quit tm-tar Mode" . exit-recursive-edit) - )) - -(cond ((string-match "XEmacs\\|Lucid" emacs-version) - (defvar tm-tar/popup-menu - (cons tm-tar/popup-menu-title - (mapcar (function - (lambda (item) - (vector (car item)(cdr item) t) - )) - tm-tar/popup-menu-items))) - - (defun tm-tar/mouse-button-2 (event) - (popup-menu tm-tar/popup-menu) - ) - ) - ((>= emacs-major-version 19) - (defun tm-tar/mouse-button-2 (event) - (let ((menu - (cons tm-tar/popup-menu-title - (list (cons "Menu Items" tm-tar/popup-menu-items)) - ))) - (let ((func (x-popup-menu event menu))) - (if func - (funcall func) - )) - )) - )) - -(defvar tm-tar/tar-mode-map nil) -(if tm-tar/tar-mode-map - nil - (setq tm-tar/tar-mode-map (make-keymap)) - (suppress-keymap tm-tar/tar-mode-map) - (define-key tm-tar/tar-mode-map "\C-c" 'exit-recursive-edit) - (define-key tm-tar/tar-mode-map "q" 'exit-recursive-edit) - (define-key tm-tar/tar-mode-map "n" 'tm-tar/next-line) - (define-key tm-tar/tar-mode-map " " 'tm-tar/next-line) - (define-key tm-tar/tar-mode-map "\C-m" 'tm-tar/next-line) - (define-key tm-tar/tar-mode-map "p" 'tm-tar/previous-line) - (define-key tm-tar/tar-mode-map "\177" 'tm-tar/previous-line) - (define-key tm-tar/tar-mode-map "\C-\M-m" 'tm-tar/previous-line) - (define-key tm-tar/tar-mode-map "v" 'tm-tar/view-file) - (define-key tm-tar/tar-mode-map "\C-h" 'Helper-help) - (define-key tm-tar/tar-mode-map "?" 'tm-tar/helpful-message) - (if mouse-button-2 - (define-key tm-tar/tar-mode-map - mouse-button-2 'tm:button-dispatcher) - ) - ) - -;;; @@ tm-tar mode functions -;;; - -(defun tm-tar/tar-mode (&optional prev-buf) - "Major mode for listing the contents of a tar archive file." - (unwind-protect - (let ((buffer-read-only t) - (mode-name "tm-tar") - (mode-line-buffer-identification '("%17b")) - ) - (goto-char (point-min)) - (tm-tar/move-to-filename) - (catch 'tm-tar/tar-mode (tm-tar/command-loop)) - ) - (if prev-buf - (switch-to-buffer prev-buf) - ) - )) - -(defun tm-tar/command-loop () - (let ((old-local-map (current-local-map)) - ) - (unwind-protect - (progn - (use-local-map tm-tar/tar-mode-map) - (tm-tar/helpful-message) - (recursive-edit) - ) - (save-excursion - (use-local-map old-local-map) - )) - )) - -(defun tm-tar/next-line () - (interactive) - (next-line 1) - (tm-tar/move-to-filename) - ) - -(defun tm-tar/previous-line () - (interactive) - (previous-line 1) - (tm-tar/move-to-filename) - ) - -(defun tm-tar/view-file () - (interactive) - (let ((name (tm-tar/get-filename)) - ) - (save-excursion - (switch-to-buffer tm-tar/view-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (message "Reading a file from an archive. Please wait...") - (apply 'call-process tm-tar/tar-program - nil t nil (append tm-tar/view-args (list name))) - (goto-char (point-min)) - ) - (view-buffer tm-tar/view-buffer) - )) - -(defun tm-tar/get-filename () - (let (eol) - (save-excursion - (end-of-line) - (setq eol (point)) - (beginning-of-line) - (save-excursion - (if (re-search-forward "^d" eol t) - (error "Cannot view a directory")) - ) - (if (re-search-forward tm-tar/file-search-regexp eol t) - (progn (let ((beg (point)) - ) - (skip-chars-forward "^ \n") - (buffer-substring beg (point)) - )) - (error "No file on this line") - )) - )) - -(defun tm-tar/move-to-filename () - (let ((eol (progn (end-of-line) (point))) - ) - (beginning-of-line) - (re-search-forward tm-tar/file-search-regexp eol t) - )) - -(defun tm-tar/set-properties () - (if mouse-button-2 - (let ((beg (point-min)) - (end (point-max)) - ) - (goto-char beg) - (save-excursion - (while (re-search-forward tm-tar/file-search-regexp end t) - (tm:add-button (point) - (progn - (end-of-line) - (point)) - 'tm-tar/view-file) - )) - ))) - -(defun tm-tar/helpful-message () - (interactive) - (message "Type %s, %s, %s, %s, %s, %s." - (substitute-command-keys "\\[Helper-help] for help") - (substitute-command-keys "\\[tm-tar/helpful-message] for keys") - (substitute-command-keys "\\[tm-tar/next-line] to next") - (substitute-command-keys "\\[tm-tar/previous-line] to prev") - (substitute-command-keys "\\[tm-tar/view-file] to view") - (substitute-command-keys "\\[exit-recursive-edit] to quit") - )) - -(defun tm-tar/y-or-n-p (prompt) - (prog1 - (y-or-n-p prompt) - (message "") - )) - -;;; @@ tar message decoder -;; - -(defun mime/decode-message/tar (beg end cal) - (if (tm-tar/y-or-n-p "Do you want to enter tm-tar mode? ") - (let ((coding (cdr (assoc 'encoding cal))) - (cur-buf (current-buffer)) - (tm-tar/tar-file-name (expand-file-name (concat (make-temp-name - (expand-file-name "tm" mime/tmp-dir)) ".tar"))) - (tm-tar/tmp-file-name (expand-file-name (make-temp-name - (expand-file-name "tm" mime/tmp-dir)))) - new-buf - ) - (find-file tm-tar/tmp-file-name) - (setq new-buf (current-buffer)) - (setq buffer-read-only nil) - (erase-buffer) - (save-excursion - (set-buffer cur-buf) - (goto-char beg) - (re-search-forward "^$") - (append-to-buffer new-buf (+ (match-end 0) 1) end) - ) - (if (member coding mime-viewer/uuencode-encoding-name-list) - (progn - (goto-char (point-min)) - (if (re-search-forward "^begin [0-9]+ " nil t) - (progn - (kill-line) - (insert tm-tar/tar-file-name) - ) - (progn - (set-buffer-modified-p nil) - (kill-buffer new-buf) - (error "uuencode file signature was not found") - )))) - (save-buffer) - (kill-buffer new-buf) - (message "Listing the contents of an archive. Please wait...") - (cond ((string-equal coding "base64") - (call-process tm-tar/mmencode-program nil nil nil "-u" - "-o" tm-tar/tar-file-name tm-tar/tmp-file-name) - ) - ((string-equal coding "quoted-printable") - (call-process tm-tar/mmencode-program nil nil nil "-u" "-q" - "-o" tm-tar/tar-file-name tm-tar/tmp-file-name) - ) - ((member coding mime-viewer/uuencode-encoding-name-list) - (call-process tm-tar/uudecode-program nil nil nil - tm-tar/tmp-file-name) - ) - (t - (copy-file tm-tar/tmp-file-name tm-tar/tar-file-name t) - )) - (delete-file tm-tar/tmp-file-name) - (setq tm-tar/list-args (list "-tvf" tm-tar/tar-file-name)) - (setq tm-tar/view-args (list "-xOf" tm-tar/tar-file-name)) - (if (eq 0 (call-process tm-tar/gzip-program - nil nil nil "-t" tm-tar/tar-file-name)) - (progn - (setq tm-tar/list-args - (append tm-tar/tar-decompress-arg tm-tar/list-args)) - (setq tm-tar/view-args - (append tm-tar/tar-decompress-arg tm-tar/view-args)) - )) - (switch-to-buffer tm-tar/view-buffer) - (switch-to-buffer tm-tar/list-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (apply 'call-process tm-tar/tar-program - nil t nil tm-tar/list-args) - (if mouse-button-2 - (progn - (make-local-variable 'tm:mother-button-dispatcher) - (setq tm:mother-button-dispatcher 'tm-tar/mouse-button-2) - )) - (tm-tar/set-properties) - (tm-tar/tar-mode mime::article/preview-buffer) - (kill-buffer tm-tar/view-buffer) - (kill-buffer tm-tar/list-buffer) - (delete-file tm-tar/tar-file-name) - ) - )) - -;;; @@ program/buffer coding system -;;; - -(cond ((boundp 'MULE) - (define-program-coding-system tm-tar/view-buffer nil *autoconv*) - ) - ((boundp 'NEMACS) - (define-program-kanji-code tm-tar/view-buffer nil 1) - )) - -;;; @@ message types to use tm-tar -;;; - -(set-atype 'mime/content-decoding-condition - '((type . "application/octet-stream") - (method . mime/decode-message/tar) - (mode . "play") ("type" . "tar") - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/octet-stream") - (method . mime/decode-message/tar) - (mode . "play") ("type" . "tar+gzip") - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/x-gzip") - (method . mime/decode-message/tar) - (mode . "play") ("type" . "tar") - )) - -(set-atype 'mime/content-decoding-condition - '((type . "application/x-tar") - (method . mime/decode-message/tar) - (mode . "play") - )) - -;;; @ end -;;; - -(provide 'tm-tar) - -;;; Local Variables: -;;; mode: emacs-lisp -;;; mode: outline-minor -;;; outline-regexp: ";;; @+\\|(......" -;;; End:
--- a/lisp/tm/tm-text.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,116 +0,0 @@ -;;; -;;; tm-text.el --- a content filter module of tm-view to display -;;; text/plain, text/richtext and text/enriched -;;; in Emacs buffers -;;; -;;; Copyright (C) 1995 Free Software Foundation, Inc. -;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko -;;; -;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;;; Version: -;;; $Id: tm-text.el,v 1.2 1996/12/28 21:03:16 steve Exp $ -;;; Keywords: mail, news, MIME, multimedia, text -;;; -;;; This file is part of tm (Tools for MIME). -;;; -;;; This program 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. -;;; -;;; This program 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 This program. If not, write to the Free Software -;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;; -;;; Code: - -;;; @ code conversion -;;; - -(defvar mime-viewer/code-converter-alist - '((mime/show-message-mode . mime-charset/decode-buffer) - (mime/temporary-message-mode . mime-charset/decode-buffer) - (t . mime-charset/maybe-decode-buffer) - )) - -(defun mime-charset/decode-buffer (charset &optional encoding) - (decode-mime-charset-region (point-min)(point-max) - (or charset default-mime-charset)) - ) - -(defun mime-charset/maybe-decode-buffer (charset &optional encoding) - (or (member encoding '(nil "7bit" "8bit" "binary")) - (mime-charset/decode-buffer charset) - )) - -(defun mime-preview/decode-text-buffer (charset encoding) - (mime-decode-region (point-min) (point-max) encoding) - (let* ((mode mime::preview/original-major-mode) - (m (or (save-excursion - (set-buffer mime::preview/article-buffer) - mime::article/code-converter) - (cdr (or (assq mode mime-viewer/code-converter-alist) - (assq t mime-viewer/code-converter-alist))) - )) - ) - (and (functionp m) - (funcall m charset encoding) - ))) - - -;;; @ content filters for tm-view -;;; - -(defun mime-preview/filter-for-text/plain (ctype params encoding) - (mime-preview/decode-text-buffer (cdr (assoc "charset" params)) encoding) - (goto-char (point-max)) - (if (not (eq (char-after (1- (point))) ?\n)) - (insert "\n") - ) - (if browse-url-browser-function - (progn - (goto-char (point-min)) - (while (re-search-forward tm:URL-regexp nil t) - (let ((beg (match-beginning 0)) - (end (match-end 0))) - (tm:add-button beg end - (function tm:browse-url) - (list (buffer-substring beg end)))) - ))) - (run-hooks 'mime-viewer/plain-text-preview-hook) - ) - -(defun mime-preview/filter-for-text/richtext (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (cdr (assoc "charset" params))) - (beg (point-min)) - ) - (remove-text-properties beg (point-max) '(face nil)) - (mime-preview/decode-text-buffer charset encoding) - (richtext-decode beg (point-max)) - )) - -(defun mime-preview/filter-for-text/enriched (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (cdr (assoc "charset" params))) - (beg (point-min)) - ) - (remove-text-properties beg (point-max) '(face nil)) - (mime-preview/decode-text-buffer charset encoding) - (enriched-decode beg (point-max)) - )) - - -;;; @ end -;;; - -(provide 'tm-text) - -;;; tm-text.el ends here
--- a/lisp/tm/tm-view.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1211 +0,0 @@ -;;; tm-view.el --- interactive MIME viewer for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1994/7/13 (1994/8/31 obsolete tm-body.el) -;; Version: $Revision: 1.6 $ -;; Keywords: mail, news, MIME, multimedia - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'tl-str) -(require 'tl-list) -(require 'tl-atype) -(require 'tl-misc) -(require 'std11) -(require 'mel) -(require 'tm-ew-d) -(require 'tm-def) -(require 'tm-parse) -(require 'tm-text) - - -;;; @ version -;;; - -(defconst mime-viewer/RCS-ID - "$Id: tm-view.el,v 1.6 1997/06/06 00:57:44 steve Exp $") - -(defconst mime-viewer/version (get-version-string mime-viewer/RCS-ID)) -(defconst mime/viewer-version mime-viewer/version) - - -;;; @ variables -;;; - -(defvar mime/content-decoding-condition - '(((type . "text/plain") - (method "tm-plain" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "text/html") - (method "tm-html" nil 'file 'type 'encoding 'mode 'name) - (mode . "play") - ) - ((type . "text/x-rot13-47") - (method . mime-article/decode-caesar) - (mode . "play") - ) - ((type . "audio/basic") - (method "tm-au" nil 'file 'type 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . "image/jpeg") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/gif") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/png") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/tiff") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-tiff") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-xbm") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-pic") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "image/x-mag") - (method "tm-image" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - - ((type . "video/mpeg") - (method "tm-mpeg" nil 'file 'type 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . "application/postscript") - (method "tm-ps" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . "application/octet-stream") - (method "tm-file" nil 'file 'type 'encoding 'mode 'name) - (mode "play" "print") - ) - - ;;((type . "message/external-body") - ;; (method "xterm" nil - ;; "-e" "showexternal" - ;; 'file '"access-type" '"name" '"site" '"directory")) - ((type . "message/rfc822") - (method . mime-article/view-message/rfc822) - (mode . "play") - ) - ((type . "message/partial") - (method . mime-article/decode-message/partial) - (mode . "play") - ) - - ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) - (mode . "play") - ) - ((method "tm-file" nil 'file 'type 'encoding 'mode 'name) - (mode . "extract") - ) - )) - -(defvar mime-viewer/childrens-header-showing-Content-Type-list - '("message/rfc822" "message/news")) - -(defvar mime-viewer/default-showing-Content-Type-list - '("text/plain" nil "text/richtext" "text/enriched" - "text/x-latex" "application/x-latex" - "message/delivery-status" - "application/pgp" "text/x-pgp" - "application/octet-stream" - "application/x-selection" "application/x-comment")) - -(defvar mime-viewer/content-button-ignored-ctype-list - '("application/x-selection")) - -(defvar mime-viewer/content-button-visible-ctype-list - '("application/pgp")) - -(defvar mime-viewer/uuencode-encoding-name-list '("x-uue" "x-uuencode")) - -(defvar mime-viewer/ignored-field-list - '(".*Received" ".*Path" ".*Id" "References" - "Replied" "Errors-To" - "Lines" "Sender" ".*Host" "Xref" - "Content-Type" "Precedence" - "Status" "X-VM-.*") - "All fields that match this list will be hidden in MIME preview buffer. -Each elements are regexp of field-name. [tm-view.el]") - -(defvar mime-viewer/ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-viewer/ignored-field-list) - ":")) - -(defvar mime-viewer/visible-field-list - '("Dnas.*" "Message-Id") - "All fields that match this list will be displayed in MIME preview buffer. -Each elements are regexp of field-name. [tm-view.el]") - -(defvar mime-viewer/visible-field-regexp - (concat "^" - (apply (function regexp-or) mime-viewer/visible-field-list) - ":")) - -(defvar mime-viewer/redisplay nil) - -(defvar mime-viewer/announcement-for-message/partial - (if (and (>= emacs-major-version 19) window-system) - "\ -\[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer ]] -\[[ or click here by mouse button-2. ]]" - "\ -\[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer. ]]" - )) - - -;;; @@ predicate functions -;;; - -(defun mime-viewer/header-visible-p (rcnum cinfo &optional ctype) - (or (null rcnum) - (progn - (setq ctype - (mime::content-info/type - (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo) - )) - (member ctype mime-viewer/childrens-header-showing-Content-Type-list) - ))) - -(defun mime-viewer/body-visible-p (rcnum cinfo &optional ctype) - (let (ccinfo) - (or ctype - (setq ctype - (mime::content-info/type - (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)) - )) - ) - (and (member ctype mime-viewer/default-showing-Content-Type-list) - (if (string-equal ctype "application/octet-stream") - (progn - (or ccinfo - (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo)) - ) - (member (mime::content-info/encoding ccinfo) - '(nil "7bit" "8bit")) - ) - t)) - )) - - -;;; @@ content button -;;; - -(defun mime-preview/insert-content-button - (rcnum cinfo ctype params subj encoding) - (save-restriction - (narrow-to-region (point)(point)) - (let ((access-type (assoc "access-type" params)) - (charset (assoc "charset" params)) - (num (or (assoc-value "x-part-number" params) - (if (consp rcnum) - (mapconcat (function - (lambda (num) - (format "%s" (1+ num)) - )) - (reverse rcnum) ".") - "0")) - )) - (cond (access-type - (let ((server (assoc "server" params))) - (setq access-type (cdr access-type)) - (if server - (insert (format "[%s %s ([%s] %s)]\n" num subj - access-type (cdr server))) - (let ((site (assoc-value "site" params)) - (dir (assoc-value "directory" params)) - ) - (insert (format "[%s %s ([%s] %s:%s)]\n" num subj - access-type site dir)) - ))) - ) - (t - (insert (concat "[" num " " subj)) - (let ((rest - (if (setq charset (cdr charset)) - (if encoding - (format " <%s; %s (%s)>]\n" - ctype charset encoding) - (format " <%s; %s>]\n" ctype charset) - ) - (format " <%s>]\n" ctype) - ))) - (if (>= (+ (current-column)(length rest))(window-width)) - (setq rest (concat "\n\t" rest)) - ) - (insert rest) - )))) - (tm:add-button (point-min)(1- (point-max)) - (function mime-viewer/play-content)) - )) - -(defun mime-preview/default-content-button-function - (rcnum cinfo ctype params subj encoding) - (if (and (consp rcnum) - (not (member - ctype - mime-viewer/content-button-ignored-ctype-list))) - (mime-preview/insert-content-button - rcnum cinfo ctype params subj encoding) - )) - -(defvar mime-preview/content-button-function - (function mime-preview/default-content-button-function)) - - -;;; @@ content header filter -;;; - -(defun mime-preview/cut-header () - (goto-char (point-min)) - (while (and - (re-search-forward mime-viewer/ignored-field-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (name (buffer-substring beg end)) - ) - (if (not (string-match mime-viewer/visible-field-regexp name)) - (delete-region - beg - (save-excursion - (and - (re-search-forward "^\\([^ \t]\\|$\\)" nil t) - (match-beginning 0) - ))) - ) - t))) - ) - -(defun mime-viewer/default-content-header-filter () - (mime-preview/cut-header) - (mime/decode-message-header) - ) - -(defvar mime-viewer/content-header-filter-alist nil) - - -;;; @@ content filter -;;; - -(defvar mime-viewer/content-filter-alist - '(("text/enriched" . mime-preview/filter-for-text/enriched) - ("text/richtext" . mime-preview/filter-for-text/richtext) - (t . mime-preview/filter-for-text/plain) - )) - - -;;; @@ content separator -;;; - -(defun mime-preview/default-content-separator (rcnum cinfo ctype params subj) - (if (and (not (mime-viewer/header-visible-p rcnum cinfo ctype)) - (not (mime-viewer/body-visible-p rcnum cinfo ctype)) - ) - (progn - (goto-char (point-max)) - (insert "\n") - ))) - - -;;; @@ buffer local variables -;;; - -;; for XEmacs -(defvar mime::article/preview-buffer nil) -(defvar mime::article/code-converter nil) -(defvar mime::preview/article-buffer nil) - -(make-variable-buffer-local 'mime::article/content-info) -(make-variable-buffer-local 'mime::article/preview-buffer) -(make-variable-buffer-local 'mime::article/code-converter) - -(make-variable-buffer-local 'mime::preview/mother-buffer) -(make-variable-buffer-local 'mime::preview/content-list) -(make-variable-buffer-local 'mime::preview/article-buffer) -(make-variable-buffer-local 'mime::preview/original-major-mode) -(make-variable-buffer-local 'mime::preview/original-window-configuration) - - -;;; @@ quitting method -;;; - -(defvar mime-viewer/quitting-method-alist - '((mime/show-message-mode - . mime-viewer/quitting-method-for-mime/show-message-mode))) - -(defvar mime-viewer/over-to-previous-method-alist nil) -(defvar mime-viewer/over-to-next-method-alist nil) - -(defvar mime-viewer/show-summary-method nil) - - -;;; @@ following method -;;; - -(defvar mime-viewer/following-method-alist nil) - -(defvar mime-viewer/following-required-fields-list - '("From")) - - -;;; @@ X-Face -;;; - -;; hack from Gnus 5.0.4. - -(defvar mime-viewer/x-face-to-pbm-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm") - -(defvar mime-viewer/x-face-command - (concat mime-viewer/x-face-to-pbm-command - " | xv -quit -") - "String to be executed to display an X-Face field. -The command will be executed in a sub-shell asynchronously. -The compressed face will be piped to this command.") - -(defun mime-viewer/x-face-function () - "Function to display X-Face field. You can redefine to customize." - ;; 1995/10/12 (c.f. tm-eng:130) - ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com> - (save-restriction - (narrow-to-region (point-min) (re-search-forward "^$" nil t)) - ;; end - (goto-char (point-min)) - (if (re-search-forward "^X-Face:[ \t]*" nil t) - (let ((beg (match-end 0)) - (end (std11-field-end)) - ) - (call-process-region beg end "sh" nil 0 nil - "-c" mime-viewer/x-face-command) - )))) - - -;;; @@ utility -;;; - -(defun mime-preview/get-original-major-mode () - (if mime::preview/mother-buffer - (save-excursion - (set-buffer mime::preview/mother-buffer) - (mime-preview/get-original-major-mode) - ) - mime::preview/original-major-mode)) - - -;;; @ data structures -;;; - -;;; @@ preview-content-info -;;; - -(define-structure mime::preview-content-info - point-min point-max buffer content-info) - - -;;; @ buffer setup -;;; - -(defun mime-viewer/setup-buffer (&optional ctl encoding ibuf obuf) - (if ibuf - (progn - (get-buffer ibuf) - (set-buffer ibuf) - )) - (or mime-viewer/redisplay - (setq mime::article/content-info (mime/parse-message ctl encoding)) - ) - (let ((ret (mime-viewer/make-preview-buffer obuf))) - (setq mime::article/preview-buffer (car ret)) - ret)) - -(defun mime-viewer/make-preview-buffer (&optional obuf) - (let* ((cinfo mime::article/content-info) - (pcl (mime/flatten-content-info cinfo)) - (dest (make-list (length pcl) nil)) - (the-buf (current-buffer)) - (mode major-mode) - ) - (or obuf - (setq obuf (concat "*Preview-" (buffer-name the-buf) "*"))) - (set-buffer (get-buffer-create obuf)) - (setq buffer-read-only nil) - (widen) - (erase-buffer) - (setq mime::preview/article-buffer the-buf) - (setq mime::preview/original-major-mode mode) - (setq major-mode 'mime/viewer-mode) - (setq mode-name "MIME-View") - (let ((drest dest)) - (while pcl - (setcar drest - (mime-preview/display-content (car pcl) cinfo the-buf obuf)) - (setq pcl (cdr pcl) - drest (cdr drest)) - )) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (set-buffer the-buf) - (list obuf dest) - )) - -(defun mime-preview/display-content (content cinfo ibuf obuf) - (let* ((beg (mime::content-info/point-min content)) - (end (mime::content-info/point-max content)) - (ctype (mime::content-info/type content)) - (params (mime::content-info/parameters content)) - (encoding (mime::content-info/encoding content)) - (rcnum (mime::content-info/rcnum content)) - he e nb ne subj) - (set-buffer ibuf) - (goto-char beg) - (setq he (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - end)) - (if (> he end) - (setq he end) - ) - (save-restriction - (narrow-to-region beg end) - (setq subj - (mime-eword/decode-string - (mime-article/get-subject params encoding))) - ) - (set-buffer obuf) - (setq nb (point)) - (narrow-to-region nb nb) - (funcall mime-preview/content-button-function - rcnum cinfo ctype params subj encoding) - (if (mime-viewer/header-visible-p rcnum cinfo ctype) - (mime-preview/display-header beg he) - ) - (if (and (null rcnum) - (member - ctype mime-viewer/content-button-visible-ctype-list)) - (save-excursion - (goto-char (point-max)) - (mime-preview/insert-content-button - rcnum cinfo ctype params subj encoding) - )) - (cond ((mime-viewer/body-visible-p rcnum cinfo ctype) - (mime-preview/display-body he end - rcnum cinfo ctype params subj encoding) - ) - ((equal ctype "message/partial") - (mime-preview/display-message/partial) - ) - ((and (null rcnum) - (null (mime::content-info/children cinfo)) - ) - (goto-char (point-max)) - (mime-preview/insert-content-button - rcnum cinfo ctype params subj encoding) - )) - (mime-preview/default-content-separator rcnum cinfo ctype params subj) - (prog1 - (progn - (setq ne (point-max)) - (widen) - (mime::preview-content-info/create nb (1- ne) ibuf content) - ) - (goto-char ne) - ))) - -(defun mime-preview/display-header (beg end) - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer-substring mime::preview/article-buffer beg end) - (let ((f (cdr (assq mime::preview/original-major-mode - mime-viewer/content-header-filter-alist)))) - (if (functionp f) - (funcall f) - (mime-viewer/default-content-header-filter) - )) - (run-hooks 'mime-viewer/content-header-filter-hook) - )) - -(defun mime-preview/display-body (beg end - rcnum cinfo ctype params subj encoding) - (save-restriction - (narrow-to-region (point-max)(point-max)) - (insert-buffer-substring mime::preview/article-buffer beg end) - (let ((f (cdr (or (assoc ctype mime-viewer/content-filter-alist) - (assq t mime-viewer/content-filter-alist))))) - (and (functionp f) - (funcall f ctype params encoding) - ) - ))) - -(defun mime-preview/display-message/partial () - (save-restriction - (goto-char (point-max)) - (if (not (search-backward "\n\n" nil t)) - (insert "\n") - ) - (let ((be (point-max))) - (narrow-to-region be be) - (insert mime-viewer/announcement-for-message/partial) - (tm:add-button (point-min)(point-max) - (function mime-viewer/play-content)) - ))) - -(defun mime-article/get-uu-filename (param &optional encoding) - (if (member (or encoding - (cdr (assq 'encoding param)) - ) - mime-viewer/uuencode-encoding-name-list) - (save-excursion - (or (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0)(match-end 0)) - )) - "")) - )) - -(defun mime-article/get-subject (param &optional encoding) - (or (std11-find-field-body '("Content-Description" "Subject")) - (let (ret) - (if (or (and (setq ret (mime/Content-Disposition)) - (setq ret (assoc "filename" (cdr ret))) - ) - (setq ret (assoc "name" param)) - (setq ret (assoc "x-name" param)) - ) - (std11-strip-quoted-string (cdr ret)) - )) - (mime-article/get-uu-filename param encoding) - "")) - - -;;; @ content information -;;; - -(defun mime-article/point-content-number (p &optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (let ((b (mime::content-info/point-min cinfo)) - (e (mime::content-info/point-max cinfo)) - (c (mime::content-info/children cinfo)) - ) - (if (and (<= b p)(<= p e)) - (or (let (co ret (sn 0)) - (catch 'tag - (while c - (setq co (car c)) - (setq ret (mime-article/point-content-number p co)) - (cond ((eq ret t) (throw 'tag (list sn))) - (ret (throw 'tag (cons sn ret))) - ) - (setq c (cdr c)) - (setq sn (1+ sn)) - ))) - t)))) - -(defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (find-if (function - (lambda (ci) - (equal (mime::content-info/rcnum ci) rcnum) - )) - (mime/flatten-content-info cinfo) - )) - -(defun mime-article/cnum-to-cinfo (cn &optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (if (eq cn t) - cinfo - (let ((sn (car cn))) - (if (null sn) - cinfo - (let ((rc (nth sn (mime::content-info/children cinfo)))) - (if rc - (mime-article/cnum-to-cinfo (cdr cn) rc) - )) - )))) - -(defun mime/flatten-content-info (&optional cinfo) - (or cinfo - (setq cinfo mime::article/content-info) - ) - (let ((dest (list cinfo)) - (rcl (mime::content-info/children cinfo)) - ) - (while rcl - (setq dest (nconc dest (mime/flatten-content-info (car rcl)))) - (setq rcl (cdr rcl)) - ) - dest)) - -(defun mime-preview/point-pcinfo (p &optional pcl) - (or pcl - (setq pcl mime::preview/content-list) - ) - (catch 'tag - (let ((r pcl) cell) - (while r - (setq cell (car r)) - (if (and (<= (mime::preview-content-info/point-min cell) p) - (<= p (mime::preview-content-info/point-max cell)) - ) - (throw 'tag cell) - ) - (setq r (cdr r)) - )) - (car (last pcl)) - )) - - -;;; @ MIME viewer mode -;;; - -(defconst mime-viewer/menu-title "MIME-View") -(defconst mime-viewer/menu-list - '((up "Move to upper content" mime-viewer/up-content) - (previous "Move to previous content" mime-viewer/previous-content) - (next "Move to next content" mime-viewer/next-content) - (scroll-down "Scroll to previous content" mime-viewer/scroll-down-content) - (scroll-up "Scroll to next content" mime-viewer/scroll-up-content) - (play "Play Content" mime-viewer/play-content) - (extract "Extract Content" mime-viewer/extract-content) - (print "Print" mime-viewer/print-content) - (x-face "Show X Face" mime-viewer/display-x-face) - ) - "Menu for MIME Viewer") - -(if running-xemacs - (progn - (defvar mime-viewer/xemacs-popup-menu - (cons mime-viewer/menu-title - (mapcar (function - (lambda (item) - (vector (nth 1 item)(nth 2 item) t) - )) - mime-viewer/menu-list))) - (defun mime-viewer/xemacs-popup-menu (event) - "Popup the menu in the MIME Viewer buffer" - (interactive "e") - (select-window (event-window event)) - (set-buffer (event-buffer event)) - (popup-menu 'mime-viewer/xemacs-popup-menu)) - )) - -(defun mime-viewer/define-keymap (&optional mother) - (let ((mime/viewer-mode-map (if mother - (copy-keymap mother) - (make-keymap) - ))) - (or mother - (suppress-keymap mime/viewer-mode-map)) - (define-key mime/viewer-mode-map - "u" (function mime-viewer/up-content)) - (define-key mime/viewer-mode-map - "p" (function mime-viewer/previous-content)) - (define-key mime/viewer-mode-map - "n" (function mime-viewer/next-content)) - (define-key mime/viewer-mode-map - "\e\t" (function mime-viewer/previous-content)) - (define-key mime/viewer-mode-map - "\t" (function mime-viewer/next-content)) - (define-key mime/viewer-mode-map - " " (function mime-viewer/scroll-up-content)) - (define-key mime/viewer-mode-map - "\M- " (function mime-viewer/scroll-down-content)) - (define-key mime/viewer-mode-map - "\177" (function mime-viewer/scroll-down-content)) - (define-key mime/viewer-mode-map - "\C-m" (function mime-viewer/next-line-content)) - (define-key mime/viewer-mode-map - "\C-\M-m" (function mime-viewer/previous-line-content)) - (define-key mime/viewer-mode-map - "v" (function mime-viewer/play-content)) - (define-key mime/viewer-mode-map - "e" (function mime-viewer/extract-content)) - (define-key mime/viewer-mode-map - "\C-c\C-p" (function mime-viewer/print-content)) - (define-key mime/viewer-mode-map - "x" (function mime-viewer/display-x-face)) - (define-key mime/viewer-mode-map - "a" (function mime-viewer/follow-content)) - (define-key mime/viewer-mode-map - "q" (function mime-viewer/quit)) - (define-key mime/viewer-mode-map - "h" (function mime-viewer/show-summary)) - (define-key mime/viewer-mode-map - "\C-c\C-x" (function mime-viewer/kill-buffer)) - (define-key mime/viewer-mode-map - "<" (function beginning-of-buffer)) - (define-key mime/viewer-mode-map - ">" (function end-of-buffer)) - (define-key mime/viewer-mode-map - "?" (function describe-mode)) - (if mouse-button-2 - (define-key mime/viewer-mode-map - mouse-button-2 (function tm:button-dispatcher)) - ) - (cond (running-xemacs - (define-key mime/viewer-mode-map - mouse-button-3 (function mime-viewer/xemacs-popup-menu)) - ) - ((>= emacs-major-version 19) - (define-key mime/viewer-mode-map [menu-bar mime-view] - (cons mime-viewer/menu-title - (make-sparse-keymap mime-viewer/menu-title))) - (mapcar (function - (lambda (item) - (define-key mime/viewer-mode-map - (vector 'menu-bar 'mime-view (car item)) - (cons (nth 1 item)(nth 2 item)) - ) - )) - (reverse mime-viewer/menu-list) - ) - )) - (use-local-map mime/viewer-mode-map) - (run-hooks 'mime-viewer/define-keymap-hook) - )) - -(defun mime/viewer-mode (&optional mother ctl encoding ibuf obuf - mother-keymap) - "Major mode for viewing MIME message. - -Here is a list of the standard keys for mime/viewer-mode. - -key feature ---- ------- - -u Move to upper content -p or M-TAB Move to previous content -n or TAB Move to next content -SPC Scroll up or move to next content -M-SPC or DEL Scroll down or move to previous content -RET Move to next line -M-RET Move to previous line -v Decode current content as `play mode' -e Decode current content as `extract mode' -C-c C-p Decode current content as `print mode' -a Followup to current content. -x Display X-Face -q Quit -button-2 Move to point under the mouse cursor - and decode current content as `play mode' -" - (interactive) - (let ((buf (get-buffer mime/output-buffer-name))) - (if buf - (save-excursion - (set-buffer buf) - (erase-buffer) - ))) - (let ((ret (mime-viewer/setup-buffer ctl encoding ibuf obuf)) - (win-conf (current-window-configuration)) - ) - (prog1 - (switch-to-buffer (car ret)) - (setq mime::preview/original-window-configuration win-conf) - (if mother - (progn - (setq mime::preview/mother-buffer mother) - )) - (mime-viewer/define-keymap mother-keymap) - (setq mime::preview/content-list (nth 1 ret)) - (goto-char - (let ((ce (mime::preview-content-info/point-max - (car mime::preview/content-list) - )) - e) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (setq e (match-end 0)) - (if (<= e ce) - e - ce))) - (run-hooks 'mime/viewer-mode-hook) - ))) - -(defun mime-preview/point-content-number (point) - (save-window-excursion - (let ((pc (mime-preview/point-pcinfo (point))) - cinfo) - (switch-to-buffer (mime::preview-content-info/buffer pc)) - (setq cinfo (mime::preview-content-info/content-info pc)) - (mime-article/point-content-number (mime::content-info/point-min cinfo)) - ))) - -(defun mime-preview/cinfo-to-pcinfo (cinfo) - (let ((rpcl mime::preview/content-list) cell) - (catch 'tag - (while rpcl - (setq cell (car rpcl)) - (if (eq cinfo (mime::preview-content-info/content-info cell)) - (throw 'tag cell) - ) - (setq rpcl (cdr rpcl)) - )))) - -(autoload 'mime-preview/decode-content "tm-play") - -(defvar mime-viewer/decoding-mode "play" "MIME body decoding mode") - -(defun mime-viewer/play-content () - (interactive) - (let ((mime-viewer/decoding-mode "play")) - (mime-preview/decode-content) - )) - -(defun mime-viewer/extract-content () - (interactive) - (let ((mime-viewer/decoding-mode "extract")) - (mime-preview/decode-content) - )) - -(defun mime-viewer/print-content () - (interactive) - (let ((mime-viewer/decoding-mode "print")) - (mime-preview/decode-content) - )) - -(defun mime-viewer/follow-content () - (interactive) - (let ((root-cinfo - (mime::preview-content-info/content-info - (car mime::preview/content-list))) - pc p-beg p-end cinfo rcnum) - (let ((rest mime::preview/content-list) - b e cell len rc) - (if (catch 'tag - (while (setq cell (car rest)) - (setq b (mime::preview-content-info/point-min cell) - e (mime::preview-content-info/point-max cell)) - (setq rest (cdr rest)) - (if (and (<= b (point))(<= (point) e)) - (throw 'tag cell) - ) - )) - (progn - (setq pc cell - cinfo (mime::preview-content-info/content-info pc) - rcnum (mime::content-info/rcnum cinfo)) - (setq len (length rcnum)) - (setq p-beg (mime::preview-content-info/point-min pc) - p-end (mime::preview-content-info/point-max pc)) - (while (and (setq cell (car rest)) - (progn - (setq rc - (mime::content-info/rcnum - (mime::preview-content-info/content-info - cell))) - (equal rcnum - (nthcdr (- (length rc) len) rc)) - )) - (setq p-end (mime::preview-content-info/point-max cell)) - (setq rest (cdr rest)) - )))) - (if pc - (let* ((mode (mime-preview/get-original-major-mode)) - (new-name (format "%s-%s" (buffer-name) (reverse rcnum))) - new-buf - (the-buf (current-buffer)) - (a-buf mime::preview/article-buffer) - (hb (mime::content-info/point-min cinfo)) - (he (mime::content-info/point-max cinfo)) - fields from to cc reply-to subj mid f) - (save-excursion - (set-buffer (setq new-buf (get-buffer-create new-name))) - (erase-buffer) - (insert-buffer-substring the-buf p-beg p-end) - (goto-char (point-min)) - (if (mime-viewer/header-visible-p rcnum root-cinfo) - (delete-region (goto-char (point-min)) - (if (re-search-forward "^$" nil t) - (match-end 0) - (point-min))) - ) - (goto-char (point-min)) - (insert "\n") - (goto-char (point-min)) - (let ((rcnum (mime::content-info/rcnum cinfo)) ci str) - (while (progn - (setq str - (save-excursion - (set-buffer a-buf) - (setq ci (mime-article/rcnum-to-cinfo rcnum)) - (save-restriction - (narrow-to-region - (mime::content-info/point-min ci) - (mime::content-info/point-max ci) - ) - (std11-header-string-except - (concat "^" - (apply (function regexp-or) fields) - ":") "")))) - (if (string-equal (mime::content-info/type ci) - "message/rfc822") - nil - (if str - (insert str) - ) - rcnum)) - (setq fields (std11-collect-field-names) - rcnum (cdr rcnum)) - ) - ) - (let ((rest mime-viewer/following-required-fields-list)) - (while rest - (let ((field-name (car rest))) - (or (std11-field-body field-name) - (insert - (format - (concat field-name - ": " - (save-excursion - (set-buffer the-buf) - (set-buffer mime::preview/mother-buffer) - (set-buffer mime::preview/article-buffer) - (std11-field-body field-name) - ) - "\n"))) - )) - (setq rest (cdr rest)) - )) - (mime/decode-message-header) - ) - (let ((f (cdr (assq mode mime-viewer/following-method-alist)))) - (if (functionp f) - (funcall f new-buf) - (message - (format - "Sorry, following method for %s is not implemented yet." - mode)) - )) - )))) - -(defun mime-viewer/display-x-face () - (interactive) - (save-window-excursion - (set-buffer mime::preview/article-buffer) - (mime-viewer/x-face-function) - )) - -(defun mime-viewer/up-content () - (interactive) - (let* ((pc (mime-preview/point-pcinfo (point))) - (cinfo (mime::preview-content-info/content-info pc)) - (rcnum (mime::content-info/rcnum cinfo)) - ) - (if rcnum - (let ((r (save-excursion - (set-buffer (mime::preview-content-info/buffer pc)) - (mime-article/rcnum-to-cinfo (cdr rcnum)) - )) - (rpcl mime::preview/content-list) - cell) - (while (and - (setq cell (car rpcl)) - (not (eq r (mime::preview-content-info/content-info cell))) - ) - (setq rpcl (cdr rpcl)) - ) - (goto-char (mime::preview-content-info/point-min cell)) - ) - (mime-viewer/quit) - ))) - -(defun mime-viewer/previous-content () - (interactive) - (let* ((pcl mime::preview/content-list) - (p (point)) - (i (- (length pcl) 1)) - beg) - (catch 'tag - (while (> i 0) - (setq beg (mime::preview-content-info/point-min (nth i pcl))) - (if (> p beg) - (throw 'tag (goto-char beg)) - ) - (setq i (- i 1)) - ) - (let ((f (assq mime::preview/original-major-mode - mime-viewer/over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - ) - )) - -(defun mime-viewer/next-content () - (interactive) - (let ((pcl mime::preview/content-list) - (p (point)) - beg) - (catch 'tag - (while pcl - (setq beg (mime::preview-content-info/point-min (car pcl))) - (if (< p beg) - (throw 'tag (goto-char beg)) - ) - (setq pcl (cdr pcl)) - ) - (let ((f (assq mime::preview/original-major-mode - mime-viewer/over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) - ) - )) - -(defun mime-viewer/scroll-up-content (&optional h) - (interactive) - (or h - (setq h (- (window-height) 1)) - ) - (if (= (point) (point-max)) - (let ((f (assq mime::preview/original-major-mode - mime-viewer/over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) - (let ((pcl mime::preview/content-list) - (p (point)) - np beg) - (setq np - (or (catch 'tag - (while pcl - (setq beg (mime::preview-content-info/point-min (car pcl))) - (if (< p beg) - (throw 'tag beg) - ) - (setq pcl (cdr pcl)) - )) - (point-max))) - (forward-line h) - (if (> (point) np) - (goto-char np) - ) - ;;(show-subtree) - )) - ) - -(defun mime-viewer/scroll-down-content (&optional h) - (interactive) - (or h - (setq h (- (window-height) 1)) - ) - (if (= (point) (point-min)) - (let ((f (assq mime::preview/original-major-mode - mime-viewer/over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - (let ((pcl mime::preview/content-list) - (p (point)) - pp beg) - (setq pp - (or (let ((i (- (length pcl) 1))) - (catch 'tag - (while (> i 0) - (setq beg (mime::preview-content-info/point-min - (nth i pcl))) - (if (> p beg) - (throw 'tag beg) - ) - (setq i (- i 1)) - ))) - (point-min))) - (forward-line (- h)) - (if (< (point) pp) - (goto-char pp) - ))) - ) - -(defun mime-viewer/next-line-content () - (interactive) - (mime-viewer/scroll-up-content 1) - ) - -(defun mime-viewer/previous-line-content () - (interactive) - (mime-viewer/scroll-down-content 1) - ) - -(defun mime-viewer/quit () - (interactive) - (let ((r (save-excursion - (set-buffer (mime::preview-content-info/buffer - (mime-preview/point-pcinfo (point)))) - (assq major-mode mime-viewer/quitting-method-alist) - ))) - (if r - (funcall (cdr r)) - ))) - -(defun mime-viewer/show-summary () - (interactive) - (let ((r (save-excursion - (set-buffer - (mime::preview-content-info/buffer - (mime-preview/point-pcinfo (point))) - ) - (assq major-mode mime-viewer/show-summary-method) - ))) - (if r - (funcall (cdr r)) - ))) - -(defun mime-viewer/kill-buffer () - (interactive) - (kill-buffer (current-buffer)) - ) - - -;;; @ end -;;; - -(provide 'tm-view) - -(run-hooks 'tm-view-load-hook) - -;;; tm-view.el ends here
--- a/lisp/tm/tm-vm.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1523 +0,0 @@ -;;; tm-vm.el --- tm-MUA (MIME Extension module) for VM - -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. - -;; Author: MASUTANI Yasuhiro <masutani@me.es.osaka-u.ac.jp> -;; Kenji Wakamiya <wkenji@flab.fujitsu.co.jp> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> -;; Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> -;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> -;; Created: 1994/10/29 -;; Version: $Revision: 1.7 $ -;; Keywords: mail, MIME, multimedia, multilingual, encoded-word - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Plese insert `(require 'tm-vm)' in your ~/.vm file. - -;;; Code: - -(eval-when-compile - (require 'tm-mail) - (require 'vm) - (require 'vm-window)) - -(require 'tm-edit) -(require 'tm-view) -(require 'vm-reply) -(require 'vm-summary) -(require 'vm-menu) -(require 'vm-toolbar) -(require 'vm-mime) - -;;; @ Variables - -;;; @@ User customization variables - -(defvar tm-vm/use-vm-bindings t - "*If t, use VM compatible keybindings in MIME Preview buffers. -Otherwise TM generic bindings for content extraction/playing are -made available.") - -(defvar tm-vm/attach-to-popup-menus t - "*If t append MIME specific commands to VM's popup menus.") - -(defvar tm-vm/use-original-url-button t - "*If it is t, use original URL button instead of tm's.") - -(defvar tm-vm/automatic-mime-preview (or (and (boundp 'vm-display-using-mime) - vm-display-using-mime) - t) - "*If non-nil, automatically process and show MIME messages.") - -(defvar tm-vm/strict-mime t - "*If nil, do MIME processing even if there is no MIME-Version field.") - -(defvar tm-vm/use-ps-print (not (featurep 'mule)) - "*Use Postscript printing (ps-print) to print MIME messages.") - -(defvar tm-vm-load-hook nil - "*List of functions called after tm-vm is loaded.") - -(defvar tm-vm/select-message-hook nil - "*List of functions called every time a message is selected. -tm-vm uses `vm-select-message-hook', use tm-vm/select-message-hook instead. -When the hooks are run current buffer is either VM folder buffer with -the current message delimited by (point-min) and (point-max) or the MIME -Preview buffer.") - -(defvar tm-vm/forward-message-hook vm-forward-message-hook - "*List of functions called after a Mail mode buffer has been -created to forward a message in message/rfc822 type format. -If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this -hook instead of `vm-forward-message-hook'.") - -(defvar tm-vm/send-digest-hook nil - "*List of functions called after a Mail mode buffer has been -created to send a digest in multipart/digest type format. -If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook -instead of `vm-send-digest-hook'.") - -(defvar tm-vm/build-mime-preview-buffer-hook nil - "*List of functions called each time a MIME Preview buffer is built. -These hooks are run in the MIME-Preview buffer.") - -;;; @@ System/Information variables - -(defconst tm-vm/RCS-ID - "$Id: tm-vm.el,v 1.7 1997/06/21 20:03:15 steve Exp $") -(defconst tm-vm/version (get-version-string tm-vm/RCS-ID)) - -; Ensure vm-menu-mail-menu gets properly defined *before* tm-vm/vm-emulation-map -; since it contains a call to vm-menu-initialize-vm-mode-menu-map -(setq vm-menu-mail-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Mail Commands" - "Mail Commands" - "---" - "---") - (list "Mail Commands")))) - (append - title - (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)] - ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)] - ["Cancel" kill-buffer t] - "----" - "Go to Field:" - "----" - [" To:" mail-to t] - [" Subject:" mail-subject t] - [" CC:" mail-cc t] - [" BCC:" mail-bcc t] - [" Reply-To:" mail-reply-to t] - [" Text" mail-text t] - "----" - ["Yank Original" vm-menu-yank-original vm-reply-list] - ["Fill Yanked Message" mail-fill-yanked-message t] - ["Insert Signature" mail-signature t] - ["Insert File..." insert-file t] - ["Insert Buffer..." insert-buffer t]) - (if tm-vm/attach-to-popup-menus - (list "----" - (cons "MIME Commands" - (mapcar (function (lambda (item) - (vector (nth 1 item) - (nth 2 item) - t))) - mime-editor/menu-list)))) - ))) - -(defvar tm-vm/vm-emulation-map - (let ((map (make-sparse-keymap))) - (define-key map "h" 'vm-summarize) - ;(define-key map "\M-n" 'vm-next-unread-message) - ;(define-key map "\M-p" 'vm-previous-unread-message) - (define-key map "n" 'vm-next-message) - (define-key map "p" 'vm-previous-message) - (define-key map "N" 'vm-next-message-no-skip) - (define-key map "P" 'vm-previous-message-no-skip) - ;(define-key map "\C-\M-n" 'vm-move-message-forward) - ;(define-key map "\C-\M-p" 'vm-move-message-backward) - ;(define-key map "\t" 'vm-goto-message-last-seen) - ;(define-key map "\r" 'vm-goto-message) - (define-key map "^" 'vm-goto-parent-message) - (define-key map "t" 'vm-expose-hidden-headers) - (define-key map " " 'vm-scroll-forward) - (define-key map "b" 'vm-scroll-backward) - (define-key map "\C-?" 'vm-scroll-backward) - (define-key map "d" 'vm-delete-message) - (define-key map "\C-d" 'vm-delete-message-backward) - (define-key map "u" 'vm-undelete-message) - (define-key map "U" 'vm-unread-message) - (define-key map "e" 'vm-edit-message) - ;(define-key map "a" 'vm-set-message-attributes) - ;(define-key map "j" 'vm-discard-cached-data) - ;(define-key map "k" 'vm-kill-subject) - (define-key map "f" 'vm-followup) - (define-key map "F" 'vm-followup-include-text) - (define-key map "r" 'vm-reply) - (define-key map "R" 'vm-reply-include-text) - (define-key map "\M-r" 'vm-resend-bounced-message) - (define-key map "B" 'vm-resend-message) - (define-key map "z" 'vm-forward-message) - ;(define-key map "c" 'vm-continue-composing-message) - (define-key map "@" 'vm-send-digest) - ;(define-key map "*" 'vm-burst-digest) - (define-key map "m" 'vm-mail) - (define-key map "g" 'vm-get-new-mail) - ;(define-key map "G" 'vm-sort-messages) - (define-key map "v" 'vm-visit-folder) - (define-key map "s" 'vm-save-message) - ;(define-key map "w" 'vm-save-message-sans-headers) - ;(define-key map "A" 'vm-auto-archive-messages) - (define-key map "S" 'vm-save-folder) - ;(define-key map "|" 'vm-pipe-message-to-command) - (define-key map "#" 'vm-expunge-folder) - (define-key map "q" 'vm-quit) - (define-key map "x" 'vm-quit-no-change) - (define-key map "i" 'vm-iconify-frame) - (define-key map "?" 'vm-help) - (define-key map "\C-_" 'vm-undo) - (define-key map "\C-xu" 'vm-undo) - (define-key map "!" 'shell-command) - (define-key map "<" 'vm-beginning-of-message) - (define-key map ">" 'vm-end-of-message) - ;(define-key map "\M-s" 'vm-isearch-forward) - (define-key map "=" 'vm-summarize) - (define-key map "L" 'vm-load-init-file) - ;(define-key map "l" (make-sparse-keymap)) - ;(define-key map "la" 'vm-add-message-labels) - ;(define-key map "ld" 'vm-delete-message-labels) - ;(define-key map "V" (make-sparse-keymap)) - ;(define-key map "VV" 'vm-visit-virtual-folder) - ;(define-key map "VC" 'vm-create-virtual-folder) - ;(define-key map "VA" 'vm-apply-virtual-folder) - ;(define-key map "VM" 'vm-toggle-virtual-mirror) - ;(define-key map "V?" 'vm-virtual-help) - ;(define-key map "M" (make-sparse-keymap)) - ;(define-key map "MN" 'vm-next-command-uses-marks) - ;(define-key map "Mn" 'vm-next-command-uses-marks) - ;(define-key map "MM" 'vm-mark-message) - ;(define-key map "MU" 'vm-unmark-message) - ;(define-key map "Mm" 'vm-mark-all-messages) - ;(define-key map "Mu" 'vm-clear-all-marks) - ;(define-key map "MC" 'vm-mark-matching-messages) - ;(define-key map "Mc" 'vm-unmark-matching-messages) - ;(define-key map "MT" 'vm-mark-thread-subtree) - ;(define-key map "Mt" 'vm-unmark-thread-subtree) - ;(define-key map "MS" 'vm-mark-messages-same-subject) - ;(define-key map "Ms" 'vm-unmark-messages-same-subject) - ;(define-key map "MA" 'vm-mark-messages-same-author) - ;(define-key map "Ma" 'vm-unmark-messages-same-author) - ;(define-key map "M?" 'vm-mark-help) - ;(define-key map "W" (make-sparse-keymap)) - ;(define-key map "WW" 'vm-apply-window-configuration) - ;(define-key map "WS" 'vm-save-window-configuration) - ;(define-key map "WD" 'vm-delete-window-configuration) - ;(define-key map "W?" 'vm-window-help) - (define-key map "\C-t" 'vm-toggle-threads-display) - (define-key map "\C-x\C-s" 'vm-save-buffer) - (define-key map "\C-x\C-w" 'vm-write-file) - (define-key map "\C-x\C-q" 'vm-toggle-read-only) - ;(define-key map "%" 'vm-change-folder-type) - (define-key map "\M-C" 'vm-show-copying-restrictions) - (define-key map "\M-W" 'vm-show-no-warranty) - ;; suppress-keymap provides these, but now that we don't use - ;; suppress-keymap anymore... - (define-key map "0" 'digit-argument) - (define-key map "1" 'digit-argument) - (define-key map "2" 'digit-argument) - (define-key map "3" 'digit-argument) - (define-key map "4" 'digit-argument) - (define-key map "5" 'digit-argument) - (define-key map "6" 'digit-argument) - (define-key map "7" 'digit-argument) - (define-key map "8" 'digit-argument) - (define-key map "9" 'digit-argument) - (define-key map "-" 'negative-argument) - (if mouse-button-2 - (define-key map mouse-button-2 (function tm:button-dispatcher))) - (if (vm-menu-fsfemacs-menus-p) - (progn - (vm-menu-initialize-vm-mode-menu-map) - (define-key map [menu-bar] - (lookup-key vm-mode-menu-map [rootmenu vm])))) - map) - "VM emulation keymap for MIME-Preview buffers.") - -(defvar tm-vm/popup-menu - (let (fsfmenu - (dummy (make-sparse-keymap)) - (menu (append vm-menu-dispose-menu - (list "----" - (cons mime-viewer/menu-title - (mapcar (function - (lambda (item) - (vector (nth 1 item)(nth 2 item) t))) - mime-viewer/menu-list)))))) - (if running-xemacs - menu - (vm-easy-menu-define fsfmenu (list dummy) nil menu) - fsfmenu)) - "VM's popup menu + MIME specific commands") - - - -(define-key vm-mode-map "Z" 'tm-vm/view-message) -(define-key vm-mode-map "T" 'tm-vm/decode-message-header) -(define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode) - -; Disable VM 6 built-in MIME handling -(setq vm-display-using-mime nil - vm-send-using-mime nil) - -;;; @ MIME encoded-words - -(defvar tm-vm/use-tm-patch nil - "Does not decode encoded-words in summary buffer if it is t. -If you use tiny-mime patch for VM (by RIKITAKE Kenji -<kenji@reseau.toyonaka.osaka.jp>), please set it t [tm-vm.el]") - -(or tm-vm/use-tm-patch - (progn -(defadvice vm-compile-format (around tm activate) - "MIME decoding support through TM added." - (let ((vm-display-using-mime t)) - ad-do-it)) - -(defadvice vm-tokenized-summary-insert (around tm activate) - "MIME decoding support through TM added." - (let ((vm-display-using-mime t)) - ad-do-it)) - -(fset 'vm-decode-mime-encoded-words-in-string 'mime-eword/decode-string) -(fset 'vm-reencode-mime-encoded-words-in-string 'mime-eword/encode-string) - -)) - -(defun tm-vm/decode-message-header (&optional count) - "Decode MIME header of current message. -Numeric prefix argument COUNT means to decode the current message plus -the next COUNT-1 messages. A negative COUNT means decode the current -message and the previous COUNT-1 messages. -When invoked on marked messages (via vm-next-command-uses-marks), -all marked messages are affected, other messages are ignored." - (interactive "p") - (or count (setq count 1)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-error-if-folder-read-only) - (let ((mlist (vm-select-marked-or-prefixed-messages count)) - (realm nil) - (vlist nil) - (vbufs nil)) - (save-excursion - (while mlist - (setq realm (vm-real-message-of (car mlist))) - ;; Go to real folder of this message. - ;; But maybe this message is already real message... - (set-buffer (vm-buffer-of realm)) - (let ((buffer-read-only nil)) - (vm-save-restriction - (narrow-to-region (vm-headers-of realm) (vm-text-of realm)) - (mime/decode-message-header)) - (let ((vm-message-pointer (list realm)) - (last-command nil)) - (vm-discard-cached-data)) - ;; Mark each virtual and real message for later summary - ;; update. - (setq vlist (cons realm (vm-virtual-messages-of realm))) - (while vlist - (vm-mark-for-summary-update (car vlist)) - ;; Remember virtual and real folders related this message, - ;; for later display update. - (or (memq (vm-buffer-of (car vlist)) vbufs) - (setq vbufs (cons (vm-buffer-of (car vlist)) vbufs))) - (setq vlist (cdr vlist))) - (if (eq vm-flush-interval t) - (vm-stuff-virtual-attributes realm) - (vm-set-modflag-of realm t))) - (setq mlist (cdr mlist))) - ;; Update mail-buffers and summaries. - (while vbufs - (set-buffer (car vbufs)) - (vm-preview-current-message) - (setq vbufs (cdr vbufs)))))) - -(defun tm-vm/header-filter () - "Filter headers in current buffer according to vm-visible-headers and vm-invisible-header-regexp. -Current buffer is assumed to have a message-like structure." - (goto-char (point-min)) - (let ((visible-headers vm-visible-headers)) - (if (or vm-use-lucid-highlighting - vm-display-xfaces) - (setq visible-headers (cons "X-Face:" vm-visible-headers))) - (vm-reorder-message-headers nil - visible-headers - vm-invisible-header-regexp) - (mime/decode-message-header))) - -(setq mime-viewer/content-header-filter-alist - (append '((vm-mode . tm-vm/header-filter) - (vm-virtual-mode . tm-vm/header-filter)) - mime-viewer/content-header-filter-alist)) - - - -;;; @ MIME Viewer - -(setq mime-viewer/code-converter-alist - (append - (list (cons 'vm-mode 'mime-charset/decode-buffer) - (cons 'vm-virtual-mode 'mime-charset/decode-buffer)) - mime-viewer/code-converter-alist)) - -;;; @@ MIME-Preview buffer management - -(defvar tm-vm/system-state nil) - -(defun tm-vm/system-state () - (save-excursion - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer) - (vm-select-folder-buffer)) - tm-vm/system-state)) - -(defun tm-vm/build-preview-buffer () - "Build the MIME Preview buffer for the current VM message. -Current buffer should be VM's folder buffer." - - (set (make-local-variable 'tm-vm/system-state) 'mime-viewing) - (setq vm-system-state 'reading) - - ;; Update message flags and store them in folder buffer before - ;; entering MIME viewer - (tm-vm/update-message-status) - - ;; We need to save window configuration because we may be working - ;; in summary window - (save-window-excursion - (save-restriction - (save-excursion - (widen) - (goto-char (vm-start-of (car vm-message-pointer))) - (forward-line) - (narrow-to-region (point) - (vm-end-of (car vm-message-pointer))) - - (let ((ml vm-message-list) - (mp vm-message-pointer)) - (mime/viewer-mode nil nil nil nil nil nil) - (setq vm-mail-buffer mime::preview/article-buffer) - (setq vm-message-list ml - vm-message-pointer mp)) - ;; Install VM toolbar for MIME-Preview buffer if not installed - (tm-vm/check-for-toolbar) - (if tm-vm/use-vm-bindings - (progn - (define-key tm-vm/vm-emulation-map "\C-c" (current-local-map)) - (use-local-map tm-vm/vm-emulation-map) - (vm-menu-install-menubar) - (if (and vm-use-menus - (vm-menu-support-possible-p)) - (setq mode-popup-menu tm-vm/popup-menu)))) - - ;; Highlight message (and display XFace if supported) - (if (or vm-highlighted-header-regexp - (and running-xemacs vm-use-lucid-highlighting)) - (vm-highlight-headers)) - ;; Display XFaces with VM internal support if appropriate - (if (and vm-display-xfaces - running-xemacs - (vm-multiple-frames-possible-p) - (featurep 'xface)) - (let ((highlight-headers-hack-x-face-p t) - (highlight-headers-regexp nil) - (highlight-headers-citation-regexp nil) - (highlight-headers-citation-header-regexp nil)) - (highlight-headers (point-min) (point-max) t))) - ;; Energize URLs and buttons - (if (and tm-vm/use-original-url-button - vm-use-menus (vm-menu-support-possible-p)) - (progn (vm-energize-headers) - (vm-energize-urls))) - (run-hooks 'tm-vm/build-mime-preview-buffer-hook) - )))) - -(defun tm-vm/sync-preview-buffer () - "Ensure that the MIME preview buffer, if it exists, actually corresponds to the current message. -If no MIME Preview buffer is needed then kill it. If no -MIME Preview buffer exists nothing is done." - ;; Current buffer should be message buffer when calling this function - (let* ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)))) - (if pbuf - ;; A MIME Preview buffer exists then it may need to be synch'ed - (save-excursion - (set-buffer mbuf) - (if (and tm-vm/strict-mime - (not (vm-get-header-contents (car vm-message-pointer) - "MIME-Version:"))) - (progn - (setq mime::article/preview-buffer nil - tm-vm/system-state nil) - (if pbuf (kill-buffer pbuf))) - (tm-vm/build-preview-buffer))) - ;; Return to previous frame - ))) - -(defun tm-vm/toggle-preview-mode () - "Toggle automatic MIME preview on or off. -In automatic MIME Preview mode each newly selected article is MIME processed if -it has MIME content without need for an explicit request from the user. This -behaviour is controlled by the variable tm-vm/automatic-mime-preview." - - (interactive) - (if tm-vm/automatic-mime-preview - (progn - (tm-vm/quit-view-message) - (setq tm-vm/automatic-mime-preview nil) - (message "Automatic MIME Preview is now disabled.")) - ;; Enable Automatic MIME Preview - (tm-vm/view-message) - (setq tm-vm/automatic-mime-preview t) - (message "Automatic MIME Preview is now enabled.") - )) - -;;; @@ Display functions - -(defun tm-vm/update-message-status () - "Update current message display and summary. -Remove 'unread' and 'new' flags. The MIME Preview buffer is not displayed, -tm-vm/display-preview-buffer should be called for that. This function is -display-configuration safe." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer) - (vm-select-folder-buffer)) - (if (or (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer) - (vm-get-visible-buffer-window mime::article/preview-buffer)) - (vm-get-visible-buffer-window (current-buffer))) - (progn - (if (vm-new-flag (car vm-message-pointer)) - (vm-set-new-flag (car vm-message-pointer) nil)) - (if (vm-unread-flag (car vm-message-pointer)) - (vm-set-unread-flag (car vm-message-pointer) nil)) - (vm-update-summary-and-mode-line) - (tm-vm/howl-if-eom)) - (vm-update-summary-and-mode-line))) - -(defun tm-vm/display-preview-buffer () - "Replace the VM message buffer with the MIME-Preview buffer if the VM message buffer is currently displayed or undisplay it if tm-vm/system-state is nil." - (let* ((mbuf (current-buffer)) - (mwin (vm-get-visible-buffer-window mbuf)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) - (if (and pbuf (tm-vm/system-state)) - ;; display preview buffer if preview-buffer exists - (cond - ((and mwin pwin) - (vm-undisplay-buffer mbuf) - (tm-vm/update-message-status)) - ((and mwin (not pwin)) - (set-window-buffer mwin pbuf) - (tm-vm/update-message-status)) - (pwin - (tm-vm/update-message-status)) - (t - ;; don't display if neither mwin nor pwin was displayed before. - )) - ;; display folder buffer - (cond - ((and mwin pwin) - (vm-undisplay-buffer pbuf)) - ((and (not mwin) pwin) - (set-window-buffer pwin mbuf)) - (mwin - ;; folder buffer is already displayed. - ) - (t - ;; don't display if neither mwin nor pwin was displayed before. - ))))) - -(defun tm-vm/preview-current-message () - "Either preview message (view first lines only) or MIME-Preview it. -The message is previewed if message previewing is enabled see vm-preview-lines. -If not, MIME-Preview current message (ie. parse MIME -contents and display appropriately) if it has MIME contents and -tm-vm/automatic-mime-preview is non nil. Installed on vm-visit-folder-hook and -vm-select-message-hook." - ;; assumed current buffer is folder buffer. - (setq tm-vm/system-state nil) - (if (get-buffer mime/output-buffer-name) - (vm-undisplay-buffer mime/output-buffer-name)) - (if (and vm-message-pointer - tm-vm/automatic-mime-preview - (or (null vm-preview-lines) - (not (eq vm-system-state 'previewing)) - (and (not vm-preview-read-messages) - (not (vm-new-flag (car vm-message-pointer))) - (not (vm-unread-flag (car vm-message-pointer)))))) - (if (or (not tm-vm/strict-mime) - (vm-get-header-contents (car vm-message-pointer) - "MIME-Version:")) - ;; do MIME processing. - (progn - (tm-vm/build-preview-buffer) - (save-excursion - (set-buffer mime::article/preview-buffer) - (run-hooks 'tm-vm/select-message-hook))) - ;; don't do MIME processing. decode header only. - (let (buffer-read-only) - (mime/decode-message-header) - (run-hooks 'tm-vm/select-message-hook)) - ) - ;; don't preview; do nothing. - (run-hooks 'tm-vm/select-message-hook)) - (tm-vm/display-preview-buffer)) - -(defun tm-vm/view-message () - "Decode and view the current VM message as a MIME encoded message. -A MIME Preview buffer using mime/viewer-mode is created. -See mime/viewer-mode for more information" - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-display (current-buffer) t '(tm-vm/view-message - tm-vm/toggle-preview-mode) - '(tm-vm/view-message reading-message)) - (let ((tm-vm/automatic-mime-preview t)) - (tm-vm/preview-current-message)) -) - -(defun tm-vm/quit-view-message () - "Quit MIME-Viewer and go back to normal VM. -MIME Preview buffer is killed. This function is called by `mime-viewer/quit' -command via `mime-viewer/quitting-method-alist'." - (if (get-buffer mime/output-buffer-name) - (vm-undisplay-buffer mime/output-buffer-name)) - (vm-select-folder-buffer) - (let* ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) - (if pbuf (kill-buffer pbuf)) - (and pwin - (select-window pwin) - (switch-to-buffer mbuf))) - (setq tm-vm/system-state nil) - (vm-display (current-buffer) t (list this-command) - (list 'reading-message))) - -(add-hook 'vm-select-message-hook 'tm-vm/preview-current-message) -(add-hook 'vm-visit-folder-hook 'tm-vm/preview-current-message) - - - - - -;;; @@ for tm-view - -;;; based on vm-do-reply [vm-reply.el] -(defun tm-vm/do-reply (buf to-all include-text) - (save-excursion - (set-buffer buf) - (let ((dir default-directory) - to cc subject in-reply-to references newsgroups) - (cond ((setq to - (let ((reply-to (std11-field-body "Reply-To"))) - (if (vm-ignored-reply-to reply-to) - nil - reply-to)))) - ((setq to (std11-field-body "From"))) - ;; (t (error "No From: or Reply-To: header in message")) - ) - (if to-all - (setq cc (delq nil (cons cc (std11-field-bodies '("To" "Cc")))) - cc (mapconcat 'identity cc ",")) - ) - (setq subject (std11-field-body "Subject")) - (and subject vm-reply-subject-prefix - (let ((case-fold-search t)) - (not - (equal - (string-match (regexp-quote vm-reply-subject-prefix) - subject) - 0))) - (setq subject (concat vm-reply-subject-prefix subject))) - (setq in-reply-to (std11-field-body "Message-Id") - references (nconc - (std11-field-bodies '("References" "In-Reply-To")) - (list in-reply-to)) - newsgroups (list (or (and to-all - (std11-field-body "Followup-To")) - (std11-field-body "Newsgroups")))) - (setq to (vm-parse-addresses to) - cc (vm-parse-addresses cc)) - (if vm-reply-ignored-addresses - (setq to (vm-strip-ignored-addresses to) - cc (vm-strip-ignored-addresses cc))) - (setq to (vm-delete-duplicates to nil t)) - (setq cc (vm-delete-duplicates - (append (vm-delete-duplicates cc nil t) - to (copy-sequence to)) - t t)) - (and to (setq to (mapconcat 'identity to ",\n "))) - (and cc (setq cc (mapconcat 'identity cc ",\n "))) - (and (null to) (setq to cc cc nil)) - (setq references (delq nil references) - references (mapconcat 'identity references " ") - references (vm-parse references "[^<]*\\(<[^>]+>\\)") - references (vm-delete-duplicates references) - references (if references (mapconcat 'identity references "\n\t"))) - (setq newsgroups (delq nil newsgroups) - newsgroups (mapconcat 'identity newsgroups ",") - newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") - newsgroups (vm-delete-duplicates newsgroups) - newsgroups (if newsgroups (mapconcat 'identity newsgroups ","))) - (vm-mail-internal - (if to - (format "reply to %s%s" - (std11-full-name-string - (car (std11-parse-address-string to))) - (if cc ", ..." ""))) - to subject in-reply-to cc references newsgroups) - (setq mail-reply-buffer buf - ;; vm-system-state 'replying - default-directory dir)) - (if include-text - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") nil 0)) - (forward-char 1) - (tm-vm/yank-content))) - (run-hooks 'vm-reply-hook) - (run-hooks 'vm-mail-mode-hook) - )) - -(defun tm-vm/following-method (buf) - (tm-vm/do-reply buf 'to-all 'include-text) - ) - -(defun tm-vm/yank-content () - (interactive) - (let ((this-command 'vm-yank-message)) - (vm-display nil nil '(vm-yank-message) - '(vm-yank-message composing-message)) - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer mail-reply-buffer) - (goto-char (point-max)) - (push-mark) - (goto-char (point-min))) - (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mail-yank-hooks (run-hooks 'mail-yank-hooks)) - (t (mail-indent-citation))) - )) - -(set-alist 'mime-viewer/following-method-alist - 'vm-mode - (function tm-vm/following-method)) -(set-alist 'mime-viewer/following-method-alist - 'vm-virtual-mode - (function tm-vm/following-method)) - -(set-alist 'mime-viewer/quitting-method-alist - 'vm-mode - 'tm-vm/quit-view-message) -(set-alist 'mime-viewer/quitting-method-alist - 'vm-virtual-mode - 'tm-vm/quit-view-message) - -;;; @@ Motion commands - -(defmacro tm-vm/save-window-excursion (&rest forms) - (list 'let '((tm-vm/selected-window (selected-window))) - (list 'unwind-protect - (cons 'progn forms) - '(if (window-live-p tm-vm/selected-window) - (select-window tm-vm/selected-window))))) - -(defmacro tm-vm/save-frame-excursion (&rest forms) - (list 'let '((tm-vm/selected-frame (vm-selected-frame))) - (list 'unwind-protect - (cons 'progn forms) - '(if (frame-live-p tm-vm/selected-frame) - (vm-select-frame tm-vm/selected-frame))))) - -(defadvice vm-scroll-forward (around tm-aware activate) - "Made TM-aware (handles the MIME-Preview buffer)." - (if (and - (not (save-excursion - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (vm-select-folder-buffer) - (eq vm-system-state 'previewing))) - (not (tm-vm/system-state))) - (progn - ad-do-it - (tm-vm/display-preview-buffer)) - (let* ((mp-changed (vm-follow-summary-cursor)) - (mbuf (or (vm-select-folder-buffer) (current-buffer))) - (mwin (vm-get-buffer-window mbuf)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-buffer-window pbuf))) - ) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (cond - ; A new message was selected - ; => leave it to tm-vm/preview-current-message - (mp-changed - nil) - ((eq vm-system-state 'previewing) - (vm-display (current-buffer) t (list this-command) '(reading-message)) - (vm-show-current-message) - (tm-vm/preview-current-message)) - ; Preview buffer was killed - ((null pbuf) - (tm-vm/preview-current-message)) - ; Preview buffer was undisplayed - ((null pwin) - (if (null mwin) - (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message))) - (tm-vm/display-preview-buffer)) - ; Preview buffer is displayed => scroll - (t - (tm-vm/save-window-excursion - (select-window pwin) - (set-buffer pbuf) - (if (pos-visible-in-window-p (point-max) pwin) - (if vm-auto-next-message - (vm-next-message)) - ;; not at the end of message. scroll preview buffer only. - (scroll-up) - (tm-vm/howl-if-eom)) - )))) - ) -) - -(defadvice vm-scroll-backward (around tm-aware activate) - "Made TM-aware (handles the MIME-Preview buffer)." - (if (and - (not (save-excursion - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (vm-select-folder-buffer) - (eq vm-system-state 'previewing))) - (not (tm-vm/system-state))) - ad-do-it - (let* ((mp-changed (vm-follow-summary-cursor)) - (mbuf (or (vm-select-folder-buffer) (current-buffer))) - (mwin (vm-get-buffer-window mbuf)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-buffer-window pbuf))) - ) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (cond - ; A new message was selected - ; => leave it to tm-vm/preview-current-message - (mp-changed - nil) - ((eq vm-system-state 'previewing) - (tm-vm/update-message-status) - (setq vm-system-state 'reading) - (tm-vm/preview-current-message)) - ; Preview buffer was killed - ((null pbuf) - (tm-vm/preview-current-message)) - ; Preview buffer was undisplayed - ((null pwin) - (if (null mwin) - (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message))) - (tm-vm/display-preview-buffer)) - ; Preview buffer is displayed => scroll - (t - (tm-vm/save-window-excursion - (select-window pwin) - (if (pos-visible-in-window-p (point-min) pwin) - nil - ;; not at the end of message. scroll preview buffer only. - (scroll-down)) - )))) - )) - -(defadvice vm-beginning-of-message (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (if (not (tm-vm/system-state)) - ad-do-it - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)))) - (if (null pbuf) - (progn - (tm-vm/preview-current-message) - (setq pbuf (get-buffer mime::article/preview-buffer)) - )) - (vm-display (current-buffer) t '(vm-beginning-of-message) - '(vm-beginning-of-message reading-message)) - (tm-vm/display-preview-buffer) - (tm-vm/save-window-excursion - (select-window (vm-get-visible-buffer-window pbuf)) - (push-mark) - (goto-char (point-min)) - (vm-display (current-buffer) t '(vm-beginning-of-message) - '(vm-beginning-of-message reading-message)) - )))) - -(defadvice vm-end-of-message (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (interactive) - (if (not (tm-vm/system-state)) - ad-do-it - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)))) - (if (null pbuf) - (progn - (tm-vm/preview-current-message) - (setq pbuf (get-buffer mime::article/preview-buffer)) - )) - (vm-display (current-buffer) t '(vm-end-of-message) - '(vm-end-of-message reading-message)) - (tm-vm/display-preview-buffer) - (tm-vm/save-window-excursion - (select-window (vm-get-buffer-window pbuf)) - (push-mark) - (goto-char (point-max)) - (vm-display (current-buffer) t '(vm-end-of-message) - '(vm-end-of-message reading-message)) - )))) - -;;; based on vm-howl-if-eom [vm-page.el] -(defun tm-vm/howl-if-eom () - (let* ((pbuf (or mime::article/preview-buffer (current-buffer))) - (pwin (and (vm-get-visible-buffer-window pbuf)))) - (and pwin - (save-excursion - (save-window-excursion - (condition-case () - (let ((next-screen-context-lines 0)) - (tm-vm/save-frame-excursion - (vm-select-frame (vm-window-frame pwin)) - (save-selected-window - (select-window pwin) - (save-excursion - (let ((scroll-in-place-replace-original nil)) - (scroll-up))))) - nil) - (error t)))) - (vm-emit-eom-blurb) - ))) - -(defadvice vm-emit-eom-blurb (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (save-excursion - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - ad-do-it)) - -(defadvice vm-next-message (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (tm-vm/save-window-excursion - ad-do-it)) - -(defadvice vm-previous-message (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (tm-vm/save-window-excursion - ad-do-it)) - -(defadvice vm-next-message-no-skip (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (tm-vm/save-window-excursion - ad-do-it)) - -(defadvice vm-previous-message-no-skip (around tm-aware activate) - "TM wrapper for vm-previous-message-no-skip (which see)." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (tm-vm/save-window-excursion - ad-do-it)) - -(defadvice vm-next-unread-message (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (tm-vm/save-window-excursion - ad-do-it)) - -(defadvice vm-previous-unread-message (around tm-aware activate) - "Made TM-aware, works properly in MIME-Preview buffers." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (tm-vm/save-window-excursion - ad-do-it)) - - -(set-alist 'mime-viewer/over-to-previous-method-alist - 'vm-mode 'vm-previous-message) -(set-alist 'mime-viewer/over-to-next-method-alist - 'vm-mode 'vm-next-message) -(set-alist 'mime-viewer/over-to-previous-method-alist - 'vm-virtual-mode 'vm-previous-message) -(set-alist 'mime-viewer/over-to-next-method-alist - 'vm-virtual-mode 'vm-next-message) - - - - - - -;;; @ MIME Editor - -;;; @@ vm-yank-message - - -(defvar tm-vm/yank:message-to-restore nil - "For internal use by tm-vm only.") - -(defun vm-yank-message (&optional message) - "Yank message number N into the current buffer at point. -When called interactively N is always read from the minibuffer. When -called non-interactively the first argument is expected to be a -message struct. - -This function originally provided by vm-reply has been patched for TM -in order to provide better citation of MIME messages : if a MIME -Preview buffer exists for the message then its contents are inserted -instead of the raw message. - -This command is meant to be used in VM created Mail mode buffers; the -yanked message comes from the mail buffer containing the message you -are replying to, forwarding, or invoked VM's mail command from. - -All message headers are yanked along with the text. Point is -left before the inserted text, the mark after. Any hook -functions bound to mail-citation-hook are run, after inserting -the text and setting point and mark. For backward compatibility, -if mail-citation-hook is set to nil, `mail-yank-hooks' is run -instead. - -If mail-citation-hook and mail-yank-hooks are both nil, this -default action is taken: the yanked headers are trimmed as -specified by vm-included-text-headers and -vm-included-text-discard-header-regexp, and the value of -vm-included-text-prefix is prepended to every yanked line." - (interactive - (list - ;; What we really want for the first argument is a message struct, - ;; but if called interactively, we let the user type in a message - ;; number instead. - (let (mp default - (result 0) - prompt - (last-command last-command) - (this-command this-command)) - (if (bufferp vm-mail-buffer) - (save-excursion - (vm-select-folder-buffer) - (setq default (and vm-message-pointer - (vm-number-of (car vm-message-pointer))) - prompt (if default - (format "Yank message number: (default %s) " - default) - "Yank message number: ")) - (while (zerop result) - (setq result (read-string prompt)) - (and (string= result "") default (setq result default)) - (setq result (string-to-int result))) - (if (null (setq mp (nthcdr (1- result) vm-message-list))) - (error "No such message.")) - (setq tm-vm/yank:message-to-restore (string-to-int default)) - (save-selected-window - (vm-goto-message result)) - (car mp)) - nil)))) - (if (null message) - (if mail-reply-buffer - (tm-vm/yank-content) - (error "This is not a VM Mail mode buffer.")) - (if (null (buffer-name vm-mail-buffer)) - (error "The folder buffer containing message %d has been killed." - (vm-number-of message))) - (vm-display nil nil '(vm-yank-message) - '(vm-yank-message composing-message)) - (let ((b (current-buffer)) (start (point)) end) - (save-restriction - (widen) - (save-excursion - (set-buffer (vm-buffer-of message)) - (let (pbuf) - (tm-vm/sync-preview-buffer) - (setq pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (if (and pbuf - (not (eq this-command 'vm-forward-message))) - ;; Yank contents of MIME Preview buffer - (if running-xemacs - (let ((tmp (generate-new-buffer "tm-vm/tmp"))) - (set-buffer pbuf) - (append-to-buffer tmp (point-min) (point-max)) - (set-buffer tmp) - (map-extents - '(lambda (ext maparg) - (set-extent-property ext 'begin-glyph nil))) - (append-to-buffer b (point-min) (point-max)) - (setq end (vm-marker - (+ start (length (buffer-string))) b)) - (kill-buffer tmp)) - (set-buffer pbuf) - (append-to-buffer b (point-min) (point-max)) - (setq end (vm-marker - (+ start (length (buffer-string))) b))) - ;; Yank contents of raw VM message - (save-restriction - (setq message (vm-real-message-of message)) - (set-buffer (vm-buffer-of message)) - (widen) - (append-to-buffer - b (vm-headers-of message) (vm-text-end-of message)) - (setq end - (vm-marker (+ start (- (vm-text-end-of message) - (vm-headers-of message))) b)))))) - (push-mark end) - (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mail-yank-hooks (run-hooks 'mail-yank-hooks)) - (t (vm-mail-yank-default message))) - )) - (if tm-vm/yank:message-to-restore - (save-selected-window - (vm-goto-message tm-vm/yank:message-to-restore) - (setq tm-vm/yank:message-to-restore nil))) - )) - -;;; @@ for tm-partial -;;; - -(call-after-loaded - 'tm-partial - (function - (lambda () - (set-atype 'mime/content-decoding-condition - '((type . "message/partial") - (method . mime-article/grab-message/partials) - (major-mode . vm-mode) - (summary-buffer-exp . vm-summary-buffer) - )) - (set-alist 'tm-partial/preview-article-method-alist - 'vm-mode - (function - (lambda () - (tm-vm/view-message) - ))) - ))) - - -;;; @@ for tm-edit -;;; - -(call-after-loaded - 'mime-setup - (function - (lambda () - (setq vm-forwarding-digest-type "rfc1521") - (setq vm-digest-send-type "rfc1521") - ))) - -;;; @@@ multipart/digest - -(if (not (fboundp 'vm-unsaved-message)) - (fset 'vm-unsaved-message 'message)) - -(defun tm-vm/enclose-messages (mlist &optional preamble) - "Enclose the messages in MLIST as multipart/digest. -The resulting digest is inserted at point in the current buffer. - -MLIST should be a list of message structs (real or virtual). -These are the messages that will be enclosed." - (if mlist - (let ((digest (consp (cdr mlist))) - (mp mlist) - m) - (save-restriction - (narrow-to-region (point) (point)) - (while mlist - (setq m (vm-real-message-of (car mlist))) - (mime-editor/insert-tag "message" "rfc822") - (tm-mail/insert-message m) - (goto-char (point-max)) - (setq mlist (cdr mlist))) - (if preamble - (progn - (goto-char (point-min)) - (mime-editor/insert-tag "text" "plain") - (vm-unsaved-message "Building digest preamble...") - (while mp - (let ((vm-summary-uninteresting-senders nil)) - (insert - (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")) - (if vm-digest-center-preamble - (progn - (forward-char -1) - (center-line) - (forward-char 1))) - (setq mp (cdr mp))))) - (if digest - (mime-editor/enclose-digest-region (point-min) (point-max))) - )))) - -(defadvice vm-forward-message (around tm-aware activate) - "Extended to support rfc1521 digests (roughly equivalent to what -VM does when vm-forwarding-digest-type is 'mime but using message/rfc822 -when appropriate." - (if (not (equal vm-forwarding-digest-type "rfc1521")) - ad-do-it - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (if (eq last-command 'vm-next-command-uses-marks) - (let ((vm-digest-send-type vm-forwarding-digest-type)) - (setq this-command 'vm-next-command-uses-marks) - (command-execute 'tm-vm/send-digest)) - (let ((dir default-directory) - (mp vm-message-pointer)) - (save-restriction - (widen) - (vm-mail-internal - (format "forward of %s's note re: %s" - (vm-su-full-name (car vm-message-pointer)) - (vm-su-subject (car vm-message-pointer))) - nil - (and vm-forwarding-subject-format - (let ((vm-summary-uninteresting-senders nil)) - (vm-sprintf 'vm-forwarding-subject-format (car mp))))) - (make-local-variable 'vm-forward-list) - (setq vm-system-state 'forwarding - vm-forward-list (list (car mp)) - default-directory dir) - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil 0) - (tm-vm/enclose-messages vm-forward-list) - (mail-position-on-field "To")) - (run-hooks 'tm-vm/forward-message-hook) - (run-hooks 'vm-mail-mode-hook))))) - -(defun tm-vm/send-digest (&optional arg) - "Send a digest of all messages in the current folder to recipients. -The type of the digest is specified by the variable vm-digest-send-type. -You will be placed in a Mail mode buffer as is usual with replies, but you -must fill in the To: and Subject: headers manually. - -If invoked on marked messages (via vm-next-command-uses-marks), -only marked messages will be put into the digest." - (interactive "P") - (if (not (equal vm-digest-send-type "rfc1521")) - (vm-send-digest arg) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((dir default-directory) - (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks) - (vm-select-marked-or-prefixed-messages 0) - vm-message-list))) - (save-restriction - (widen) - (vm-mail-internal (format "digest from %s" (buffer-name))) - (setq vm-system-state 'forwarding - default-directory dir) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) - "\n")) - (goto-char (match-end 0)) - (vm-unsaved-message "Building %s digest..." vm-digest-send-type) - (tm-vm/enclose-messages vm-forward-list arg) - (mail-position-on-field "To") - (message "Building %s digest... done" vm-digest-send-type))) - (run-hooks 'tm-vm/send-digest-hook) - (run-hooks 'vm-mail-mode-hook))) - -(substitute-key-definition 'vm-send-digest - 'tm-vm/send-digest vm-mode-map) - -;;; @@@ Menus - - -(call-after-loaded - 'tm-edit - (function - (lambda () - (autoload 'tm-mail/insert-message "tm-mail") - (set-alist 'mime-editor/message-inserter-alist - 'mail-mode (function tm-mail/insert-message)) - (set-alist 'mime-editor/split-message-sender-alist - 'mail-mode (function - (lambda () - (interactive) - (funcall send-mail-function) - ))) - ))) - - - -;;; @ VM Integration - -(add-hook 'vm-quit-hook 'tm-vm/quit-view-message) - -;;; @@ Wrappers for miscellaneous VM functions - -(defadvice vm-summarize (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - ad-do-it - (save-excursion - (set-buffer vm-summary-buffer) - (tm-vm/check-for-toolbar)) - (tm-vm/preview-current-message)) - -(defadvice vm-expose-hidden-headers (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (let ((visible-headers vm-visible-headers)) - (tm-vm/quit-view-message) - ad-do-it - (let ((vm-visible-headers visible-headers)) - (if (= (point-min) (vm-start-of (car vm-message-pointer))) - (setq vm-visible-headers '(".*"))) - (tm-vm/preview-current-message)))) - -(if (vm-mouse-fsfemacs-mouse-p) - (progn - (define-key tm-vm/vm-emulation-map [mouse-3] 'ignore) - (define-key tm-vm/vm-emulation-map [down-mouse-3] 'vm-mouse-button-3) - (defadvice vm-mouse-button-3 (after tm-aware activate) - "Made TM aware. Works in MIME-Preview buffers." - (if (and - vm-use-menus - (eq major-mode 'mime/viewer-mode)) - (vm-menu-popup-mode-menu event)))) -) - -(defadvice vm-save-message (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-expunge-folder (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-save-folder (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-goto-parent-message (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-delete-message (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-delete-message-backward (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-undelete-message (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-unread-message (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - -(defadvice vm-edit-message (around tm-aware activate) - "Made TM aware. Callable from the MIME Preview buffer." - (if mime::preview/article-buffer - (save-excursion - (set-buffer mime::preview/article-buffer) - ad-do-it) - ad-do-it)) - - - -;;; @@ VM Toolbar Integration - -;;; based on vm-toolbar-any-messages-p [vm-toolbar.el] -(defun tm-vm/check-for-toolbar () - "Install VM toolbar if necessary." - (if (and running-xemacs - vm-toolbar-specifier) - (progn - (if (null (specifier-instance vm-toolbar-specifier)) - (vm-toolbar-install-toolbar)) - (vm-toolbar-update-toolbar)))) - -(defun vm-toolbar-any-messages-p () - (save-excursion - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (vm-check-for-killed-folder) - (vm-select-folder-buffer) - vm-message-list)) - - -;;; @ BBDB Integration -;;; - -(call-after-loaded - 'bbdb - (function - (lambda () - (require 'bbdb-vm) - (require 'tm-bbdb) - (defun tm-bbdb/vm-update-record (&optional offer-to-create) - (save-excursion - (vm-select-folder-buffer) - (if (and (tm-vm/system-state) - mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (let ((tm-bbdb/auto-create-p bbdb/mail-auto-create-p)) - (tm-bbdb/update-record offer-to-create)) - (or (bbdb/vm-update-record offer-to-create) - (delete-windows-on (get-buffer "*BBDB*"))) - ))) - (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record) - (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record) - (add-hook 'tm-vm/select-message-hook 'tm-bbdb/vm-update-record) - ))) - -;;; @ ps-print (Suggested by Anders Stenman <stenman@isy.liu.se>) -;;; - -(if tm-vm/use-ps-print - (progn - (autoload 'ps-print-buffer-with-faces "ps-print" "Postscript Print" t) - (add-hook 'vm-mode-hook 'tm-vm/ps-print-setup) - (add-hook 'mime-viewer/define-keymap-hook 'tm-vm/ps-print-setup) - (fset 'vm-toolbar-print-command 'tm-vm/print-message))) - -(defun tm-vm/ps-print-setup () - "Set things up for printing MIME messages with ps-print. Set binding to -the [Print Screen] key." - (local-set-key (if running-xemacs - 'f22 - [f22]) - 'tm-vm/print-message) - (make-local-variable 'ps-header-lines) - (make-local-variable 'ps-left-header) - (setq ps-header-lines 3) - (setq ps-left-header - (list 'ps-article-subject 'ps-article-author 'buffer-name))) - -(defun tm-vm/print-message () - "Print current message with ps-print if it's a MIME message. -Value of tm-vm/strict-mime is also taken into consideration." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (tm-vm/sync-preview-buffer) - (let ((pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)))) - (if pbuf - (save-excursion - (set-buffer pbuf) - (require 'ps-print) - (ps-print-buffer-with-faces)) - (vm-print-message)))) - - -;;; @ end - -(provide 'tm-vm) -(run-hooks 'tm-vm-load-hook) - -;;; tm-vm.el ends here.
--- a/lisp/tm/tmh-comp.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,549 +0,0 @@ -;;; tm-mh-e.el --- tm-mh-e functions for composing messages - -;; Copyright (C) 1993,1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; Created: 1996/2/29 (separated from tm-mh-e.el) -;; Version: $Id: tmh-comp.el,v 1.5 1997/03/22 06:02:46 steve Exp $ -;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual - -;; This file is part of tm (Tools for MIME). - -;; This program 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. - -;; This program 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'mh-comp) -(require 'tm-edit) - - -;;; @ variable -;;; - -(defvar tm-mh-e/forwcomps "forwcomps" - "Name of file to be used as a skeleton for forwarding messages. -Default is \"forwcomps\". If not a complete path name, the file -is searched for first in the user's MH directory, then in the -system MH lib directory.") - -(defvar tm-mh-e/message-yank-function 'mh-yank-cur-msg) - - -;;; @ for tm-edit -;;; - -(defun tm-mh-e::make-message (folder number) - (vector folder number) - ) - -(defun tm-mh-e::message/folder (message) - (elt message 0) - ) - -(defun tm-mh-e::message/number (message) - (elt message 1) - ) - -(defun tm-mh-e::message/file-name (message) - (expand-file-name - (tm-mh-e::message/number message) - (mh-expand-file-name (tm-mh-e::message/folder message)) - )) - -;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;;; 1995/11/14 (cf. [tm-ja:1096]) -(defun tm-mh-e/prompt-for-message (prompt folder &optional default) - (let* ((files - (directory-files (mh-expand-file-name folder) nil "^[0-9]+$") - ) - (folder-buf (get-buffer folder)) - (default - (if folder-buf - (save-excursion - (set-buffer folder-buf) - (let* ((show-buffer (get-buffer mh-show-buffer)) - (show-buffer-file-name - (buffer-file-name show-buffer))) - (if show-buffer-file-name - (file-name-nondirectory show-buffer-file-name))))))) - (if (or (null default) - (not (string-match "^[0-9]+$" default))) - (setq default - (if (and (string= folder mh-sent-from-folder) - mh-sent-from-msg) - (int-to-string mh-sent-from-msg) - (save-excursion - (let (cur-msg) - (if (and - (= 0 (mh-exec-cmd-quiet nil "pick" folder "cur")) - (set-buffer mh-temp-buffer) - (setq cur-msg (buffer-string)) - (string-match "^[0-9]+$" cur-msg)) - (substring cur-msg 0 (match-end 0)) - (car files))))))) - (completing-read prompt - (let ((i 0)) - (mapcar (function - (lambda (file) - (setq i (+ i 1)) - (list file i) - )) - files) - ) nil nil default) - )) - -;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;;; 1995/11/14 (cf. [tm-ja:1096]) -(defun tm-mh-e/query-message (&optional message) - (let (folder number) - (if message - (progn - (setq folder (tm-mh-e::message/folder message)) - (setq number (tm-mh-e::message/number message)) - )) - (or (stringp folder) - (setq folder (mh-prompt-for-folder - "Message from" - (if (and (stringp mh-sent-from-folder) - (string-match "^\\+" mh-sent-from-folder)) - mh-sent-from-folder "+inbox") - nil))) - (setq number - (if (numberp number) - (number-to-string number) - (tm-mh-e/prompt-for-message "Message number: " folder) - )) - (tm-mh-e::make-message folder number) - )) - -(defun tm-mh-e/insert-message (&optional message) - ;; always ignores message - (let ((article-buffer - (if (not (and (stringp mh-sent-from-folder) - (numberp mh-sent-from-msg) - )) - (cond ((and (boundp 'gnus-original-article-buffer) - (bufferp mh-sent-from-folder) - (get-buffer gnus-original-article-buffer) - ) - gnus-original-article-buffer) - ((and (boundp 'gnus-article-buffer) - (get-buffer gnus-article-buffer) - (bufferp mh-sent-from-folder) - ) - (save-excursion - (set-buffer gnus-article-buffer) - (if (eq major-mode 'mime/viewer-mode) - mime::preview/article-buffer - (current-buffer) - ))) - )))) - (if (null article-buffer) - (tm-mh-e/insert-mail - (tm-mh-e::make-message mh-sent-from-folder mh-sent-from-msg) - ) - (insert-buffer article-buffer) - (mime-editor/inserted-message-filter) - ) - )) - -(defun tm-mh-e/insert-mail (&optional message) - (save-excursion - (save-restriction - (let ((message-file - (tm-mh-e::message/file-name (tm-mh-e/query-message message)))) - (narrow-to-region (point) (point)) - (insert-file-contents message-file) - (push-mark (point-max)) - (mime-editor/inserted-message-filter) - )))) - -(set-alist 'mime-editor/message-inserter-alist - 'mh-letter-mode (function tm-mh-e/insert-message)) -(set-alist 'mime-editor/mail-inserter-alist - 'mh-letter-mode (function tm-mh-e/insert-mail)) -(set-alist 'mime-editor/mail-inserter-alist - 'news-reply-mode (function tm-mh-e/insert-mail)) -(set-alist - 'mime-editor/split-message-sender-alist - 'mh-letter-mode - (function - (lambda (&optional arg) - (interactive "P") - (write-region (point-min) (point-max) - mime-editor/draft-file-name nil 'no-message) - (cond (arg - (pop-to-buffer "MH mail delivery") - (erase-buffer) - (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" - "-nodraftfolder" - mh-send-args - mime-editor/draft-file-name) - (goto-char (point-max)) ; show the interesting part - (recenter -1) - (sit-for 1)) - (t - (apply 'mh-exec-cmd-quiet t mh-send-prog - (mh-list-to-string - (list "-nopush" "-nodraftfolder" - "-noverbose" "-nowatch" - mh-send-args mime-editor/draft-file-name))))) - ))) - - -;;; @ commands using tm-edit features -;;; - -(defun tm-mh-e/edit-again (msg) - "Clean-up a draft or a message previously sent and make it resendable. -Default is the current message. -The variable mh-new-draft-cleaned-headers specifies the headers to remove. -See also documentation for `\\[mh-send]' function." - (interactive (list (mh-get-msg-num t))) - (catch 'tag - (let* ((from-folder mh-current-folder) - (config (current-window-configuration)) - code-conversion - (draft - (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) - (let ((name (format "draft-%d" msg))) - (if (get-buffer name) - (throw 'tag (pop-to-buffer name)) - ) - (let ((filename (mh-msg-filename msg mh-draft-folder))) - (set-buffer (get-buffer-create name)) - (as-binary-input-file (insert-file-contents filename)) - (setq buffer-file-name filename) - (setq code-conversion t) - ) - (pop-to-buffer name) - (if (re-search-forward "^-+$" nil t) - (replace-match "") - ) - name)) - (t - (prog1 - (as-binary-input-file - (mh-read-draft "clean-up" (mh-msg-filename msg) nil) - ) - (setq code-conversion t) - )))) - ) - (goto-char (point-min)) - (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) - (if code-conversion - (let ((cs (detect-coding-region (point-min)(point-max)))) - (set-buffer-file-coding-system - (if (listp cs) - (car cs) - cs)) - )) - (save-buffer) - (mime/edit-again code-conversion t t) - (goto-char (point-min)) - (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config) - ))) - -;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;;; 1996/2/29 (cf. [tm-ja:1643]) -(defun tm-mh-e/extract-rejected-mail (msg) - "Extract a letter returned by the mail system and make it re-editable. -Default is the current message. The variable mh-new-draft-cleaned-headers -gives the headers to clean out of the original message." - (interactive (list (mh-get-msg-num t))) - (let ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) - (setq buffer-read-only nil) - (goto-char (point-min)) - (cond - ((and - (re-search-forward - (concat "^\\($\\|[Cc]ontent-[Tt]ype:[ \t]+multipart/\\)") nil t) - (not (bolp)) - (re-search-forward "boundary=\"\\([^\"]+\\)\"" nil t)) - (let ((case-fold-search t) - (boundary (buffer-substring (match-beginning 1) (match-end 1)))) - (cond - ((re-search-forward - (concat "^--" boundary "\n" - "content-type:[ \t]+" - "\\(message/rfc822\\|text/rfc822-headers\\)\n" - "\\(.+\n\\)*\n") nil t) - (delete-region (point-min) (point)) - (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) - (search-forward - (concat "\n--" boundary "--\n") nil t) - (delete-region (match-beginning 0) (point-max))) - (t - (message "Seems no message/rfc822 part."))))) - ((re-search-forward mh-rejected-letter-start nil t) - (skip-chars-forward " \t\n") - (delete-region (point-min) (point)) - (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)) - (t - (message "Does not appear to be a rejected letter."))) - (goto-char (point-min)) - (if (re-search-forward "^-+$" nil t) - (replace-match "") - ) - (mime/edit-again nil t t) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder msg - (mh-get-header-field "To:") - (mh-get-header-field "From:") - (mh-get-header-field "Cc:") - nil nil config))) - -;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp> -;;; 1995/11/14 (cf. [tm-ja:1099]) -(defun tm-mh-e/forward (to cc &optional msg-or-seq) - "Forward a message or message sequence as MIME message/rfc822. -Defaults to displayed message. If optional prefix argument provided, -then prompt for the message sequence. See also documentation for -`\\[mh-send]' function." - (interactive (list (mh-read-address "To: ") - (mh-read-address "Cc: ") - (if current-prefix-arg - (mh-read-seq-default "Forward" t) - (mh-get-msg-num t) - ))) - (or msg-or-seq - (setq msg-or-seq (mh-get-msg-num t))) - (let* ((folder mh-current-folder) - (config (current-window-configuration)) - ;; uses "draft" for compatibility with forw. - ;; forw always leaves file in "draft" since it doesn't have -draft - (draft-name (expand-file-name "draft" mh-user-path)) - (draft (cond ((or (not (file-exists-p draft-name)) - (y-or-n-p "The file `draft' exists. Discard it? ")) - (mh-exec-cmd "comp" - "-noedit" "-nowhatnowproc" - "-form" tm-mh-e/forwcomps - "-nodraftfolder") - (prog1 - (mh-read-draft "" draft-name t) - (mh-insert-fields "To:" to "Cc:" cc) - (set-buffer-modified-p nil))) - (t - (mh-read-draft "" draft-name nil))))) - (let ((msubtype "digest") - orig-from orig-subject multipart-flag - (tag-regexp - (concat "^" - (regexp-quote (mime-make-tag "message" "rfc822")))) - ) - (goto-char (point-min)) - (save-excursion - (save-restriction - (goto-char (point-max)) - (if (not (bolp)) (insert "\n")) - (let ((beg (point))) - (narrow-to-region beg beg) - (mh-exec-cmd-output "pick" nil folder msg-or-seq) - (if (> (count-lines (point) (point-max)) 1) - (setq multipart-flag t) - ) - (while (re-search-forward "^\\([0-9]+\\)\n" nil t) - (let ((forw-msg - (buffer-substring (match-beginning 1) (match-end 1))) - (beg (match-beginning 0)) - (end (match-end 0)) - ) - (save-restriction - (narrow-to-region beg end) - ;; modified for Emacs 18 - (delete-region beg end) - (insert-file-contents - (mh-expand-file-name forw-msg - (mh-expand-file-name folder)) - ) - (save-excursion - (push-mark (point-max)) - (mime-editor/inserted-message-filter)) - (goto-char (point-max)) - ) - (save-excursion - (goto-char beg) - (mime-editor/insert-tag "message" "rfc822") - ))) - (delete-region (point) (point-max)) - (if multipart-flag - (mime-editor/enclose-region "digest" beg (point)) - )))) - (re-search-forward tag-regexp) - (forward-line 1) - (save-restriction - (narrow-to-region (point) (point-max)) - (setq orig-from (mime-eword/decode-string - (mh-get-header-field "From:"))) - (setq orig-subject (mime-eword/decode-string - (mh-get-header-field "Subject:"))) - ) - (let ((forw-subject - (mh-forwarded-letter-subject orig-from orig-subject))) - (mh-insert-fields "Subject:" forw-subject) - (goto-char (point-min)) - (re-search-forward tag-regexp) - (forward-line -1) - (delete-other-windows) - (if (numberp msg-or-seq) - (mh-add-msgs-to-seq msg-or-seq 'forwarded t) - (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)) - (mh-compose-and-send-mail draft "" folder msg-or-seq - to forw-subject cc - mh-note-forw "Forwarded:" - config))))) - -(cond ((not (featurep 'mh-utils)) - (defun tm-mh-e::insert-letter (folder number verbatim) - (mh-insert-letter verbatim folder number) - ) - ) - ((and (boundp 'mh-e-version) - (string-lessp mh-e-version "5")) - (defun tm-mh-e::insert-letter (folder number verbatim) - (mh-insert-letter number folder verbatim) - ) - ) - (t - (defalias 'tm-mh-e::insert-letter 'mh-insert-letter) - )) - -(defun tm-mh-e/insert-letter (verbatim) - "Interface to mh-insert-letter." - (interactive "P") - (let* - ((folder (mh-prompt-for-folder - "Message from" - (if (and (stringp mh-sent-from-folder) - (string-match "^\\+" mh-sent-from-folder)) - mh-sent-from-folder "+inbox") - nil)) - (number (tm-mh-e/prompt-for-message "Message number: " folder))) - (tm-mh-e::insert-letter folder number verbatim))) - -(defun tm-mh-e/yank-cur-msg-with-no-filter () - "Insert the current message into the draft buffer. -This function makes new show-buffer from article-buffer to disable -variable `mime-viewer/plain-text-preview-hook'. If you don't want to -use text filters for replying message, please set it to -`tm-mh-e/message-yank-function'. -Prefix each non-blank line in the message with the string in -`mh-ins-buf-prefix'. The entire message will be inserted if -`mh-yank-from-start-of-msg' is non-nil. If this variable is nil, the -portion of the message following the point will be yanked. If -`mh-delete-yanked-msg-window' is non-nil, any window displaying the -yanked message will be deleted." - (interactive) - (if (and mh-sent-from-folder mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let ((mh-ins-str - (if mime::preview/article-buffer - (let (mime-viewer/plain-text-preview-hook buf) - (prog1 - (save-window-excursion - (set-buffer mime::preview/article-buffer) - (setq buf (mime/viewer-mode)) - (buffer-string) - ) - (kill-buffer buf) - )) - (buffer-string) - ))) - (set-buffer to-buffer) - (save-restriction - (narrow-to-region to-point to-point) - (push-mark) - (insert mh-ins-str) - (mh-insert-prefix-string mh-ins-buf-prefix) - (insert "\n")))) - (error "There is no current message"))) - -(defun tm-mh-e/yank-current-message () - "Insert the current message into the draft buffer. -It uses variable `tm-mh-e/message-yank-function' -to select message yanking function." - (interactive) - (let ((mh-sent-from-folder mh-sent-from-folder) - (mh-sent-from-msg mh-sent-from-msg)) - (if (and (not (stringp mh-sent-from-folder)) - (boundp 'gnus-article-buffer) - (get-buffer gnus-article-buffer) - (bufferp mh-sent-from-folder) - ) ; might be called from GNUS - (if (boundp 'gnus-article-copy) ; might be sgnus - (save-excursion - (gnus-copy-article-buffer) - (setq mh-sent-from-folder gnus-article-copy) - (set-buffer mh-sent-from-folder) - (setq mh-show-buffer gnus-article-copy) - ) - (save-excursion - (setq mh-sent-from-folder gnus-article-buffer) - (set-buffer gnus-article-buffer) - (setq mh-show-buffer (current-buffer)) - ))) - (funcall tm-mh-e/message-yank-function) - )) - -(substitute-key-definition - 'mh-yank-cur-msg 'tm-mh-e/yank-current-message mh-letter-mode-map) -(substitute-key-definition - 'mh-insert-letter 'tm-mh-e/insert-letter mh-letter-mode-map) - - -;;; @ for mu-cite -;;; - -(call-after-loaded - 'mu-cite - (function - (lambda () - (set-alist 'mu-cite/get-field-value-method-alist - 'mh-letter-mode - (function - (lambda (name) - (if (and (stringp mh-sent-from-folder) - (numberp mh-sent-from-msg)) - (save-excursion - (set-buffer mh-sent-from-folder) - (set-buffer mh-show-buffer) - (and (boundp 'mime::preview/article-buffer) - (bufferp mime::preview/article-buffer) - (set-buffer mime::preview/article-buffer)) - (std11-field-body name) - )) - ))) - ))) - - -;;; @ end -;;; - -(provide 'tmh-comp) -(require 'tm-mh-e) - -;;; tmh-comp.el ends here
--- a/lisp/utils/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/utils/auto-autoloads.el Mon Aug 13 10:03:52 2007 +0200 @@ -333,7 +333,9 @@ ;;;*** -;;;### (autoloads (list-colors-display facemenu-read-color list-text-properties-at facemenu-remove-special facemenu-remove-props facemenu-set-read-only facemenu-set-intangible facemenu-set-invisible facemenu-make-much-smaller facemenu-make-much-larger facemenu-make-smaller facemenu-make-larger facemenu-set-size-default facemenu-set-face-from-menu facemenu-set-background facemenu-set-foreground facemenu-set-face) "facemenu" "utils/facemenu.el") +;;;### (autoloads (list-colors-display list-text-properties-at facemenu-remove-special facemenu-remove-props facemenu-set-read-only facemenu-set-intangible facemenu-set-invisible facemenu-make-much-smaller facemenu-make-much-larger facemenu-make-smaller facemenu-make-larger facemenu-set-size-default facemenu-set-face-from-menu facemenu-set-background facemenu-set-foreground facemenu-set-face) "facemenu" "utils/facemenu.el") + +(autoload 'facemenu-keymap "facemenu" nil t 'keymap) (define-key ctl-x-map "F" 'facemenu-keymap) @@ -345,6 +347,8 @@ `Facemenu-update' fills in the keymap according to the bindings requested in `facemenu-keybindings'.") +(defalias 'facemenu-keymap facemenu-keymap) + (autoload 'facemenu-set-face "facemenu" "\ Add FACE to the region or next character typed. It will be added to the top of the face list; any faces lower on the list that @@ -424,8 +428,7 @@ (autoload 'list-text-properties-at "facemenu" "\ Pop up a buffer listing text-properties at LOCATION." t nil) -(autoload 'facemenu-read-color "facemenu" "\ -Read a color using the minibuffer." nil nil) +(defalias 'facemenu-read-color 'read-color) (autoload 'list-colors-display "facemenu" "\ Display names of defined colors, and show what they look like. @@ -462,28 +465,6 @@ ;;;*** -;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl" "utils/flow-ctrl.el") - -(autoload 'enable-flow-control "flow-ctrl" "\ -Toggle flow control handling. -When handling is enabled, user can type C-s as C-\\, and C-q as C-^. -With arg, enable flow control mode if arg is positive, otherwise disable." t nil) - -(autoload 'enable-flow-control-on "flow-ctrl" "\ -Enable flow control if using one of a specified set of terminal types. -Use `(enable-flow-control-on \"vt100\" \"h19\")' to enable flow control -on VT-100 and H19 terminals. When flow control is enabled, -you must type C-\\ to get the effect of a C-s, and type C-^ -to get the effect of a C-q. - -This function has no effect unless the current device is a tty. - -The tty terminal type is determined from the TERM environment variable. -Trailing hyphens and everything following is stripped, so a TERM -value of \"vt100-nam\" is treated the same as \"vt100\"." nil nil) - -;;;*** - ;;;### (autoloads (x-font-build-cache font-default-size-for-device font-default-encoding-for-device font-default-registry-for-device font-default-family-for-device font-default-object-for-device font-default-font-for-device font-create-object) "font" "utils/font.el") (autoload 'font-create-object "font" nil nil nil) @@ -534,17 +515,6 @@ ;;;*** -;;;### (autoloads (unhide-copyleft-region hide-copyleft-region) "hide-copyleft" "utils/hide-copyleft.el") - -(autoload 'hide-copyleft-region "hide-copyleft" "\ -Make the legal drivel at the front of this file invisible. Unhide it again -with C-u \\[hide-copyleft-region]." t nil) - -(autoload 'unhide-copyleft-region "hide-copyleft" "\ -If the legal nonsense at the top of this file is elided, make it visible again." nil nil) - -;;;*** - ;;;### (autoloads (highlight-headers-follow-url highlight-headers-follow-url-mosaic highlight-headers-follow-url-netscape highlight-headers) "highlight-headers" "utils/highlight-headers.el") (autoload 'highlight-headers "highlight-headers" "\
--- a/lisp/utils/browse-cltl2.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,406 +0,0 @@ -; -*- Mode: Emacs-Lisp -*- -;;; browse-cltl2.el --- browse the hypertext-version of -;;; "Common Lisp the Language, 2nd. Edition" - -;; Revision 1.1.2 -;; last edited on 18.2.1997 - -;; Copyright (C) 1997 Holger Schauer - -;; Author: Holger Schauer <Holger.Schauer@gmd.de> -;; Keywords: utils lisp ilisp www - -;; This file is not part of Emacs. - -;; Developed under XEmacs 19.14. Also tested on Emacs 19.32 and -;; XEmacs 19.11. Should work with newer versions, too. -;; Required: browse-url.el -;; Recommended: url.el - -;; This program 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 of the License, or -;; (at your option) any later version. -;; -;; This program 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 this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: -;; This gives you two top-level-functions useful when programming lisp: -;; cltl2-view-function-definition and cltl2-view-index -;; cltl2-view-function-definition asks you for a name of a lisp -;; function (or variable) and will open up your favourite browser -;; (as specified by `browse-url-browser-function') loading the page -;; which documents it. - -;;; Installation: (as usual) -;; Put browse-cltl2.el somewhere where emacs can find it. -;; browse-cltl2.el requires a working browse-url, url and cl. -;; Insert the following lines in your .emacs: -;; -;; (autoload 'cltl2-view-function-definition "browse-cltl2") -;; (autoload 'cltl2-view-index "browse-cltl2") -;; (autoload 'cltl2-lisp-mode-install "browse-cltl2") -;; (add-hook 'lisp-mode-hook 'cltl2-lisp-mode-install) -;; (add-hook 'ilisp-mode-hook 'cltl2-lisp-mode-install) -;; -;; This should also add the needed hooks to lisp-mode (and ilisp-mode). - -;; Gnu Emacs: -;; For Gnu Emacs there doesn't seem to be a lisp-mode-hook so you're -;; on your own with the key-settings. -;; No url.el: -;; If you don't have url.el set *cltl2-use-url* to nil -;; and set *cltl2-fetch-method* to 'local or 'local-index-only. -;; This implies that you need a local copy of the index page of -;; CLtL2 (which you can get from the normal hypertext-version at CMU), -;; so you need to point *cltl2-local-file-pos* and *cltl2-index-file-name* -;; to the place where you put it. -;; Old versions of Emacs (XEmacs 19.11 for example): -;; When you want to use a local copy (or a local copy of the index file) -;; check the documentation on find-file-noselect. If it doesn't mention -;; an option called RAWFILE set *cltl2-old-find-file-noselect* to 't. - - -;;; Customization: -;; By default, browse-cltl2 will use a local copy of CLtL2, looking -;; for it in /usr/doc/html/cltl. This can be modified with the help -;; of the following variables: -;; *cltl2-fetch-method*, *cltl2-url*, *cltl-local-file-pos* -;; See the documentation on this variables for more info. -;; -;;; TODO: -;; In this version we can't separate between functions, variables, -;; constants and loop clauses. This is not that hard to change, -;; but it is more difficult to distinguish what the user is -;; looking for. Until I receive several requests for it, I won't -;; implement it, because there are not that much constructs like * and + -;; which have two (or more) semantics. - -;;; Changes: -;; 28-01-97: HS: now we're using cl-puthash all over the place because -;; this is common on XEmacs 19.11 and upwards and Gnu Emacs. -;; Added information on how to install without url.el -;; -;; 29-01-97 HS: included conditionalized versions of the required -;; functions match-string and buffer-live-p. -;; Suggested by Simon Marshall <Simon.Marshall@esrin.esa.it>. -;; Included new variable *cltl2-use-url* with which one can -;; specify if he has url.el or not. Introduced variable -;; *cltl2-old-find-file-noselect*. -;; -;; 05-02-97 HS: added two variables for the key-bindings, -;; *cltl2-vfd-key* *cltl2-vi-key*. -;; -;; 18-02-97 HS: use compatible keybindings that work on Gnu Emacs and XEmacs. -;; Made cltl2-lisp-mode-install an interactive function. -(defvar *cltl2-use-url* 'nil - "Enables or disables retrieval of the index-file via WWW (or more - exactly by the use of the function url-retrieve from url.el). - Default is 't.") - -;; needed things -(require 'cl) -(require 'browse-url) - -(when (not *cltl2-use-url*) - (require 'url)) - -;;; ****************************** -;;; Some variable and constant definitions -;;; ****************************** -(defvar *cltl2-fetch-method* 'local - "This sets the method by which the index-file will be fetched. Three - methods are possible: 'local assumes that all files are local. - 'local-index-only assumes that just the index-file is locally but - all other files will be fetched via www. 'www means that the index-file - will be fetched via WWW, too. Don't change the value of this variable - after loading.") - -(defvar *cltl2-url* - "http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/" - "The url where the hypertext-version of Common Lisp the Language - can be found. Note that this assumes to be the top-level of the - directory structure which should be the same as in the hypertext - version as provided by the CMU AI Repository. Defaults to - http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/ - Note the / at the end.") - -(defvar *cltl2-local-file-pos* "/usr/doc/html/cltl/" - "A directory where the CLtl2 can be found. Note that this assumes - to be the top-level of the directory structure which should be the - same as in the hypertext version as provided by the CMU AI Repository. - Defaults to /usr/doc/html/cltl/ Note the / at the end.") - -(defconst *cltl2-index-file-name* "clm/index.html" - "The name of the index-file, typically with directory on front. - Defaults to clm/index.html, as this is the momentary position from - the top-level directory of the CLtL2-home. Defaults to clm/index.html. - Note that there is no leading /.") - -(defvar *cltl2-index-home* - (concatenate 'string - (case *cltl2-fetch-method* - ('local *cltl2-local-file-pos*) - ('local-index-only *cltl2-local-file-pos*) - ('www *cltl2-url*)) - *cltl2-index-file-name*) - "The absolute path which will be used to fetch the index.") - -(defvar *cltl2-home* - (concatenate - 'string - (case *cltl2-fetch-method* - ('local *cltl2-local-file-pos*) - ('local-index-only *cltl2-url*) - ('www *cltl2-url*)) - "clm/") - "This specifies the home-position of the CLtL2. The value of this variable - will be concatenated with the name of the nodes of the CLtL2.") - -(defvar *cltl2-index-buffer-name* "*cltl2-index*" - "The name of the buffer which holds the index for CLtL2.") - -(defvar *cltl2-old-find-file-noselect* 'nil - "Older versions of Emacs (at least XEmacs 19.11) don't support the - option RAWFILE with the function FIND-FILE-NO-SELECT. Set this variable - to 't if you have such an old version. It will cause fontification and - other useless stuff on the buffer in which the index is fetched. If - you don't use a local copy (of the index) this won't bother you.") - -(defvar *cltl2-vfd-key* - (if (featurep 'ilisp) - '[(control z) h] - '[(control c) b]) - "Shortcut for accessing cltl2-view-function-definition. Use meaningful - setting with Ilisp.") - -(defvar *cltl2-vi-key* - (if (featurep 'ilisp) - '[(control z) H] - '[(control c) B]) - "Shortcut for accessing cltl2-view-index. Use meaningful - setting with Ilisp.") - -(defvar *browse-cltl2-ht* (make-hash-table 0)) -(defconst *cltl2-search-regexpr* - "<a href=\"\\(.+\\)\"><code>\\(.+\\)</code></a>" - "A regular expression how to check for entries in the index-file - of CLtL2. Note that you have to modify this and the - prepare-get-entry*-functions if you want to change the search.") - -;;; ****************************** -;;; First of all: Compatibility stuff -;;; ****************************** -; no match-string in old versions -(if (not (fboundp (function match-string))) - (defun match-string (num &optional string) - "Return string of text matched by last search. - NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. - Zero means the entire text matched by the whole regexp or whole string. - STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring - (match-beginning num) (match-end num)))))) - -; no buffer-live-p in old versions - (if (not (fboundp (function buffer-live-p))) - (defun buffer-live-p (buf-or-name) - "Checks if BUF-OR-NAME is a live buffer. Returns non-nil - if BOF-OR-NAME is an editor buffer which has not been deleted. - Imitating a built-in function from newer Emacs versions." - (let ((object (if (bufferp buf-or-name) - buf-or-name - (get-buffer buf-or-name)))) - (and (bufferp object) (buffer-name object))))) - -; no add-submenu in old versions of XEmacs -(if (and (string-match "XEmacs\\|Lucid" emacs-version) - (not (fboundp 'add-submenu))) - (defun add-submenu (menu-path submenu &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -SUBMENU is the new menu to add. - See the documentation of `current-menubar' for the syntax. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (add-menu menu-path (car submenu) (cdr submenu) before))) - -; old find-file-noselect has no RAWFILE argument -(if *cltl2-old-find-file-noselect* - (unless (boundp 'cltl2-old-find-file-noselect-func) - (setf (symbol-value 'cltl2-old-find-file-noselect-func) - (symbol-function 'find-file-noselect)) - (setf (symbol-function 'find-file-noselect) - #'(lambda (file &optional nowarn rawfile) - (funcall cltl2-old-find-file-noselect-func file nowarn))))) - -;;; ****************************** -;;; Functions for fetching the index file -;;; ****************************** -(defun cltl2-fetch-index () - "Fetches the index page of the CLtl2 and puts it in its own - buffer called *cltl2-index*." - ;; if the index isn't here load it into a buffer - (when (or (not (get-buffer *cltl2-index-buffer-name*)) - (not (buffer-live-p *cltl2-index-buffer-name*))) - (message "Fetching the CLtL2 index file ...") - (case *cltl2-fetch-method* - ('local - (cltl2-fetch-index-by-file)) - ('local-index-only - (cltl2-fetch-index-by-file)) - ('www - (cltl2-fetch-index-by-www)))) - - (cltl2-prepare-index) -) - -;; fetch methods -(defun cltl2-fetch-index-by-file () - "Fetch the index from disk." - (setf *cltl2-index-buffer-name* - (find-file-noselect *cltl2-index-home* 'nil 't)) -) - -(defun cltl2-fetch-index-by-www () - "Fetch the index via WWW." - (save-excursion - (let ((old-url-working-buffer url-working-buffer)) - (setf url-working-buffer *cltl2-index-buffer-name*) - (url-retrieve *cltl2-index-home*) - (setf url-working-buffer old-url-working-buffer)))) - - -;;; ****************************** -;;; Main functions for viewing -;;; ****************************** -(defun cltl2-view-function-definition (entry) - "First checks if function can be found in the CLtL2-index-file. - If it can be found, uses the function browse-url to have a look - at the corresponding documentation from CLtL2." - (interactive "sCLtL2-Entry to lookup:") - (when (cltl2-index-unprepared-p) - (cltl2-fetch-index)) - - (let ((entry-url (cltl2-find-url-for-function (intern entry)))) - (when entry-url - (message "Loading found entry for %s into browser.." entry) - (browse-url - (concatenate 'string *cltl2-home* entry-url))))) - -(defun cltl2-find-url-for-function (entry) - "Checks if we can find a page for function ENTRY and - constructs an URL from it." - (let ((entry-url (gethash entry *browse-cltl2-ht*))) - (when (not entry-url) - (error "No entry in CLtL2 for %s" entry)) - entry-url)) - -(defun cltl2-view-index () - "Browse-urls the index file." - (interactive) - (browse-url *cltl2-index-home*)) - -;;; ****************************** -;;; Preparing the index (the hashtable) -;;; ****************************** -(defun cltl2-prepare-index () - "Jumps to the *cltl2-index* buffer and scans it, creating a hashtable - for all entries." - (message "Preparing CLtL2 index.") - (save-excursion - (set-buffer *cltl2-index-buffer-name*) - (goto-char (point-min)) - - ; search for entry - (do ((point (re-search-forward - *cltl2-search-regexpr* - nil t) - (re-search-forward - *cltl2-search-regexpr* - nil t))) - ; until we can't find anymore - ((null point)); (format "Index-preparation done.")) - ; put found entry in hash-table - (cl-puthash - (cltl2-prepare-get-entry-name) - (cltl2-prepare-get-entry-url) - *browse-cltl2-ht*)))) - -(defun cltl2-prepare-get-entry-name () - "Get the enrty name from the last match of regexp-search for entries." - (let ((name-string (intern (match-string 2)))) - (format "%s" name-string) - name-string)) - -(defun cltl2-prepare-get-entry-url () - "Get the enrty url from the last match of regexp-search for entries." - (let ((url (match-string 1))) - (format "%s" url) - url)) - -(defun cltl2-index-unprepared-p () - "Check if the index is already prepared." - ; If the hashtable has entries the index is prepared. - (not (and (hash-table-p *browse-cltl2-ht*) - (>= (hash-table-count *browse-cltl2-ht*) 1)))) - -;;; ****************************** -;;; Hooking into lisp mode and ilisp-mode -;;; ****************************** -(defun cltl2-lisp-mode-install () - "Adds browse-cltl2 to lisp-mode. If you use ilisp (installed via a hook - on lisp-mode) add browse-cltl2 to ilisp. Check the variables *cltl2-vfd-key* - and *cltl2-vi-key* for the keybindings. Under XEmacs we will add ourself to - the corresponding menus if there exists one." - (interactive) - ; set key bindings - (local-set-key *cltl2-vfd-key* 'cltl2-view-function-definition) - (local-set-key *cltl2-vi-key* 'cltl2-view-index) - ; under XEmacs hook ourself into the menu if there is one - (when (string-match "XEmacs\\|Lucid" emacs-version) - (cond ((and (featurep 'ilisp-easy-menu) - ; this is for the menu as provided by ilisp-easy-menu - (not (null (car (find-menu-item current-menubar '("ILisp")))))) - (add-submenu - '("ILisp" "Documentation") - '("Browse CLtL2" - [ "View entry" cltl2-view-function-definition t] - [ "View index" cltl2-view-index t] ))) - ; perhaps an other Ilisp-Menu is there ? - ((not (null (car (find-menu-item current-menubar '("ILisp"))))) - (add-submenu - '("Lisp") - '("Browse CLtL2" - [ "View entry" cltl2-view-function-definition t] - [ "View index" cltl2-view-index t] ))) - ; or at least a Lisp-Menu ? - ((not (null (car (find-menu-item current-menubar '("Lisp"))))) - (add-submenu - '("Lisp") - '("Browse CLtL2" - [ "View entry" cltl2-view-function-definition t] - [ "View index" cltl2-view-index t] ))))) -) - -(add-hook 'lisp-mode-hook 'cltl2-lisp-mode-install) -(add-hook 'ilisp-mode-hook 'cltl2-lisp-mode-install) - -;;; Providing ourself. -(provide 'ilisp-browse-cltl2) -;;; browse-cltl2.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/build-report.el Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,243 @@ +;;; xemacs-build-report.el --- Automatically formatted build reports for XEmacs + +;; Copyright (C) 1997 Adrian Aichner + +;; Author: Adrian Aichner, Teradyne GmbH Munich <aichner@ecf.teradyne.com> +;; Date: Sun., Apr. 20, 1997. +;; Version: 1.28 +;; Keywords: internal + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 synched. + +;;; Commentary: + +;; The Idea: +;; Let XEmacs report interesting aspects of how it was built. + +;; The Concept: +;; User creates an XEmacs Build Report by just calling +;; M-x xemacs-create-build-report +;; which will initialize a mail buffer with relevant information +;; derived from the XEmacs build process. Point is left at the +;; beginning of the report for user to input some personal notes and +;; send the report. + +;; The Status: +;; This is the first `Proof of Concept'. + +;; The Author: +;; Adrian Aichner, Teradyne GmbH Munich, Sun., Apr. 20, 1997. + +;;; Code: + +(require 'config) +(provide 'xemacs-build-report) + +;; Due to recommandation by developers on xemacs-beta@xemacs.org, +;; release versions are to be checked out using `co -u -kv ...'. +(defconst xemacs-build-report-version + "1.28" + "Version number of xemacs-build-report.") + +(defgroup xemacs-build-report nil + "Package automating the process of sending Xemacs Build Reports.") + +(defcustom xemacs-build-report-destination + "xemacs-beta@xemacs.org" + "The mail address XEmacs Build Reports should go to." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-keep-regexp + "make\\[\\|error\\|warn\\|pure.*\\(space\\|size\\)\\|hides\\b\\|strange\\|shadowings" + "Regexp of make process output lines to keep in the report." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-delete-regexp + "confl.*with.*auto-inlining" + "Regexp of make process output lines to delete from the report." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-make-output-file + (concat (gethash 'blddir (config-value-hash-table)) "/beta.err") + "Filename where stdout and stderr of XEmacs make process have been stored. +mk.err will not be created automatically. You'll have to run make with +output redirection. I use an alias +alias mk 'make \!* >>&\! \!$.err &' +for that, so that I get beta.err went I run `mk beta'." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-installation-file + (concat (gethash 'blddir (config-value-hash-table)) "/Installation") + "Installation file produced by XEmacs configure process." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-subject + (concat "[%s] " emacs-version " on " system-configuration) + "XEmacs Build Report Subject Line. %s-sequences will be substituted +with user input through `xemacs-create-build-report' according to +`xemacs-build-report-prompts' using `format'." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-prompts + '(("Status?: " "Success" "Failure")) + "XEmacs Build Report Prompt(s). This is a list of prompt-string +lists used by `xemacs-create-build-report' in conjunction with +`xemacs-build-report-subject'. Each list consists of a prompt string +followed by any number of strings which can be chosen via the history +mechanism." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-file-encoding + "7bit" + "XEmacs Build Report File Encoding to be used when MIME support is +available." +:group 'xemacs-build-report) + +;; Symbol Name mappings from TM to SEMI serving as +;; Compatibility Bandaid +;; If 'mime-editor/version-name is bound, we must be using TM(-edit). +(if (featurep 'mime-setup) + (if (locate-library "tm-edit") + (progn + ;; No (defvaralias ...) so far. T + ;; Thanks to "Didier Verna" verna@inf.enst.fr for reporting my + ;; incorrect defvaraliasing of `mime-editor/insert-tag'. + (defalias + 'mime-edit-insert-tag + 'mime-editor/insert-tag + ) + (defalias + 'mime-edit-insert-binary-file + 'mime-editor/insert-binary-file + )))) + +(defun xemacs-create-build-report (&rest args) + "Initializes a fresh mail-mode buffer with the contents of XEmacs +Installation file and excerpts from XEmacs make output and errors and +leaves point at the beginning of the mail text. See also +`xemacs-build-report-destination', +`xemacs-build-report-keep-regexp', +`xemacs-build-report-delete-regexp', +`xemacs-build-report-make-output-file' and +`xemacs-build-report-installation-file'." + (interactive + (let (prompt + hist + arg + (prompts xemacs-build-report-prompts)) + (progn + (while prompts + (setq prompt (caar prompts)) + (setq hist (cdar prompts)) + (setq prompts (cdr prompts)) + (setq arg (cons (read-string prompt "" 'hist) arg))) + arg))) + (save-excursion + (compose-mail + xemacs-build-report-destination + (apply 'format xemacs-build-report-subject args) + nil + nil + nil + nil + nil) + (let ((report-begin (mail-text))) + (xemacs-build-report-insert-make-output report-begin) + (xemacs-build-report-insert-installation-file report-begin) + (xemacs-build-report-insert-header report-begin) + ))) + +(defun xemacs-build-report-insert-header (where) + "Inserts the xemacs-build-report-header at the point specified by `where'." + (goto-char where) + (insert "\n> XEmacs Build Report as generated\n> by " + "xemacs-build-report-version " + xemacs-build-report-version + " follows:\n\n")) + +(defun xemacs-build-report-insert-make-output (where) + "Inserts the output of the XEmacs Beta make run. +The make process output must have been saved in +`xemacs-build-report-make-output-file' during the XEmacs Beta building." + (goto-char where) + (if (file-exists-p xemacs-build-report-make-output-file) + (progn + (if (featurep 'mime-setup) + (progn + (setq xemacs-build-report-keep-regexp + (concat "^--\\[\\[\\|\\]\\]$\\|" + xemacs-build-report-keep-regexp)) + (mime-edit-insert-tag + "application" + "octet-stream" + (concat + "\nContent-Disposition: attachment;" + " filename=\"" + (file-name-nondirectory + xemacs-build-report-make-output-file) + "\"")) + (mime-edit-insert-binary-file + xemacs-build-report-make-output-file + xemacs-build-report-file-encoding)) + (insert-file-contents xemacs-build-report-make-output-file)) + (goto-char where) + (delete-non-matching-lines + xemacs-build-report-keep-regexp) + (goto-char where) + (delete-matching-lines xemacs-build-report-delete-regexp) + (goto-char where) + (insert "> Contents of " + xemacs-build-report-make-output-file + "\n> keeping lines matching\n> \"" + xemacs-build-report-keep-regexp + "\"\n> and then deleting lines matching\n> \"" + xemacs-build-report-delete-regexp + "\"\n\n")) + (insert "> " xemacs-build-report-make-output-file + " does not exist!\n\n"))) + +(defun xemacs-build-report-insert-installation-file (where) + "Inserts the contents of the `xemacs-build-report-installation-file' +created by the XEmacs Beta configure process." + (goto-char where) + (if (file-exists-p xemacs-build-report-installation-file) + (progn + (insert "> Contents of " + xemacs-build-report-installation-file + ":\n\n") + (if (featurep 'mime-setup) + (progn + (mime-edit-insert-tag + "application" + "octet-stream" + (concat + "\nContent-Disposition: attachment;" + " filename=\"" + (file-name-nondirectory + xemacs-build-report-installation-file) + "\"")) + (mime-edit-insert-binary-file + xemacs-build-report-installation-file + xemacs-build-report-file-encoding)) + (insert-file-contents xemacs-build-report-installation-file))) + (insert "> " xemacs-build-report-installation-file + " does not exist!\n\n"))) + +;;; xemacs-build-report.el ends here
--- a/lisp/utils/crontab.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -;; #(@) crontab.el - An Emacs function to assist in editing crontab entries -;; Last edited: Fri Aug 18 12:19:22 1989 by chris (Christopher D. Orr) on lxn -;; -;; Version: 1.00 - Initial Creation of mode -;; 1.01 - Added crontab-use-local-file variable -;; 1.02 - Reworked most of the library to be cleaner. -;; 1.03 - Now deletes blank lines in crontab entry - -;; Copyright (C) 1989 Christopher D. Orr (chris@lxn.eds.com) - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;; -;; TODO: -;; - -;; Place the following line in your ~/.emacs file: -;; (autoload 'crontab-edit "crontab" -;; "Function to allow the easy editing of crontab files." t) -;; - -(provide 'crontab-edit) - -;;; Local Variables. Define these to your liking. - -(defgroup crontab nil - "Assist in editing crontab files." - :group 'languages) - - -(defcustom crontab-filename "~/.crontab" - "*The name of the file to store the User's Crontab." - :type 'file - :group 'crontab) - -(defcustom crontab-directory "/usr/spool/cron/crontabs" - "*The name of the directory in which crontab stores it's entries." - :type 'file - :group 'crontab) - -(defcustom crontab-use-local-file nil - "*Non-nil means use file stored in User's Home directory, if it exists. -Otherwise, always ask crontab for the current entry (maybe)." - :type 'boolean - :group 'crontab) - - -;;; Interactive Function called to edit a Crontab Entry. It is called -;;; instead of crontab-edit to allow for future automatic entries. - -(defun crontab-edit () - "Function to allow the easy editing of crontab files." - - (interactive) - (crontab-get)) - - -;;; Function to retrieve the crontab entry. The Function will -;;; retrieve the file (crontab-filename) first. If the file does not -;;; exists, a crontab -l command will be executed. - -(defun crontab-get () - "Retrieve a crontab file either using crontab -l or from the variable -crontab-filename" - (message "Retrieving Crontab ... ") - (switch-to-buffer (create-file-buffer crontab-filename)) - (erase-buffer) - - (if (file-exists-p crontab-filename) - (if (file-newer-than-file-p (concat crontab-directory "/" (user-login-name)) (expand-file-name crontab-filename)) - (if (yes-or-no-p "Cron has a more recent copy of your crontab. Use it ? ") - (call-process "crontab" nil t t "-l") - (insert-file crontab-filename)) - (if crontab-use-local-file - (insert-file crontab-filename) - (call-process "crontab" nil t t "-l"))) - (if crontab-use-local-file - (insert-file crontab-filename) - (call-process "crontab" nil t t "-l"))) - -;; What if crontab returns a fatal ?????? Can't we check the errorlevel ???? - (goto-char (point-min)) - (if (search-forward-regexp "crontab:\\|no crontab for" nil t nil) - (erase-buffer)) - (if (eobp) - (crontab-initialize)) - (goto-line 6) - (setq buffer-file-name crontab-filename) - (set-buffer-modified-p nil) - (make-variable-buffer-local 'write-file-hooks) - (or (memq 'crontab-save write-file-hooks) - (setq write-file-hooks - (reverse (cons 'crontab-save (reverse write-file-hooks))))) - (message "Save file normally when finished to update cron.")) - - -;;; This function is called whenever a save-file operation is -;;; performed in the crontab buffer. It saves the crontab to the file -;;; name (crontab-filename) and then removes the crontab buffer. - -(defun crontab-save () - "Submit the edited crontab to the cron deamon for processing" - - (goto-char (point-min)) - (while (not (eobp)) - (delete-blank-lines) - (forward-line 1)) - (redraw-display) - - (setq write-file-hooks nil) - (let ((crontab-buffer (buffer-name))) - (basic-save-buffer) - -;; What if the call-process to crontab fails ??? Can we check for a fatal ??? -;; (call-process "crontab" nil nil nil (expand-file-name crontab-filename)) - (shell-command (concat "crontab " (expand-file-name crontab-filename))) - - (switch-to-buffer (other-buffer)) - (kill-buffer crontab-buffer)) - (message (concat "Crontab saved as " crontab-filename " and submitted to cron.")) -;; fixed by Lynn D. Newton - 03/17/95 - "") -;; OLD -;; nil) - -(defun crontab-initialize () - "Create a default Crontab file if one does not exist or is empty. -If the function (time-stamp) is available, the last modification time will -be stamped to the file." - - (insert "# Cron Table Entry for ") - (insert (user-login-name)) - (insert " (") - (insert (user-full-name)) - (insert ")\n# Last Edited: \n") - (insert "#\n") - (insert "# min hr day mon wday(0=sun) cmd\n") - (insert "#\n")) - -;;; Watch out for the signature :-)
--- a/lisp/utils/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/utils/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,39 +1,35 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:30 1997 ;;; Code: -(custom-put 'extensions 'custom-loads '("eldoc")) -(custom-put 'eldoc 'custom-loads '("eldoc")) -(custom-put 'mouse 'custom-loads '("id-select")) -(custom-put 'minibuffer 'custom-loads '("detached-minibuf" "savehist")) -(custom-put 'mail 'custom-loads '("highlight-headers" "mail-extr" "ph" "smtpmail")) -(custom-put 'uniquify 'custom-loads '("uniquify")) -(custom-put 'xemacs-build-report 'custom-loads '("xemacs-build-report")) -(custom-put 'hypermedia 'custom-loads '("browse-url")) -(custom-put 'lisp 'custom-loads '("elp")) -(custom-put 'elp 'custom-loads '("elp")) -(custom-put 'applications 'custom-loads '("uniquify")) -(custom-put 'keyboard 'custom-loads '("edmacro")) -(custom-put 'highlight-headers-faces 'custom-loads '("highlight-headers")) -(custom-put 'crontab 'custom-loads '("crontab")) -(custom-put 'comm 'custom-loads '("ph")) -(custom-put 'id-select 'custom-loads '("id-select")) -(custom-put 'frames 'custom-loads '("detached-minibuf")) -(custom-put 'smtpmail 'custom-loads '("smtpmail")) -(custom-put 'detached-minibuf 'custom-loads '("detached-minibuf")) -(custom-put 'languages 'custom-loads '("crontab")) -(custom-put 'edmacro 'custom-loads '("edmacro")) -(custom-put 'faces 'custom-loads '("font" "highlight-headers")) -(custom-put 'passwd 'custom-loads '("passwd")) -(custom-put 'browse-url 'custom-loads '("browse-url")) -(custom-put 'processes 'custom-loads '("passwd")) -(custom-put 'news 'custom-loads '("highlight-headers")) -(custom-put 'highlight-headers 'custom-loads '("highlight-headers")) -(custom-put 'savehist 'custom-loads '("savehist")) -(custom-put 'ph 'custom-loads '("ph")) -(custom-put 'mail-extr 'custom-loads '("mail-extr")) -(custom-put 'matching 'custom-loads '("id-select")) +(custom-add-loads 'extensions '("eldoc")) +(custom-add-loads 'eldoc '("eldoc")) +(custom-add-loads 'mouse '("id-select")) +(custom-add-loads 'minibuffer '("savehist")) +(custom-add-loads 'mail '("highlight-headers" "mail-extr" "ph" "smtpmail")) +(custom-add-loads 'uniquify '("uniquify")) +(custom-add-loads 'xemacs-build-report '("build-report")) +(custom-add-loads 'hypermedia '("browse-url")) +(custom-add-loads 'lisp '("elp")) +(custom-add-loads 'elp '("elp")) +(custom-add-loads 'applications '("uniquify")) +(custom-add-loads 'keyboard '("edmacro")) +(custom-add-loads 'highlight-headers-faces '("highlight-headers")) +(custom-add-loads 'comm '("ph")) +(custom-add-loads 'id-select '("id-select")) +(custom-add-loads 'smtpmail '("smtpmail")) +(custom-add-loads 'edmacro '("edmacro")) +(custom-add-loads 'faces '("facemenu" "font" "highlight-headers")) +(custom-add-loads 'passwd '("passwd")) +(custom-add-loads 'browse-url '("browse-url")) +(custom-add-loads 'processes '("passwd")) +(custom-add-loads 'news '("highlight-headers")) +(custom-add-loads 'highlight-headers '("highlight-headers")) +(custom-add-loads 'savehist '("savehist")) +(custom-add-loads 'ph '("ph")) +(custom-add-loads 'mail-extr '("mail-extr")) +(custom-add-loads 'matching '("id-select")) +(custom-add-loads 'facemenu '("facemenu")) ;;; custom-load.el ends here
--- a/lisp/utils/detached-minibuf.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,162 +0,0 @@ -;;; detached-minibuf.el -- Support a detached minibuffer for XEmacs. - -;; Copyright (C) 1997 Alvin C. Shelton - -;; Author: Alvin Shelton <acs@acm.org> -;; Keywords: extensions - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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; 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: - -;; WARNING. DANGER. This file reportedly crashes 19.14, use it only with a -;; recent XEmacs. - -;; Version: 1.1 - -;;; Code: - -;; -;; Variable definitions - -(defgroup detached-minibuf nil - "Support a detached minibuffer in XEmacs" - :group 'minibuffer - :prefix "minibuf-frame-" - :group 'frames) - - -(defcustom add-minibuf-options t - "*If nil, prevent minibuffer options from being added to the Options menu.\ -This must be set before detached-minibuf is loaded." - :type 'boolean - :group 'detached-minibuf) -(defcustom minibuf-frame-height 1 - "*The height in lines of the minibuffer frame created by make-detached-minibuf" - :type 'integer - :group 'detached-minibuf) -(defcustom minibuf-frame-width (frame-width (selected-frame)) - "*The width in chars of the minibuffer frame created by make-detached-minibuf" - :type 'integer - :group 'detached-minibuf) -(defcustom minibuf-frame-pos-y -2 - "*The y position of the minibuffer frame as created by make-detached-minibuf" - :type 'integer - :group 'detached-minibuf) -(defcustom minibuf-frame-pos-x -2 - "*The x position of the minibuffer frame as created by make-detached-minibuf" - :type 'integer - :group 'detached-minibuf) - -;; -;; Add minibuffer options to the Options menu -(if add-minibuf-options - (progn - (defun toggle-minibuf () - (interactive) - (if (equal (frame-property (selected-frame) 'minibuffer) t) - - ;; This frame already has a minibuffer, so remove the minibuffer. - ;; Unfortunately, we must delete and redraw the frame - (let ((fp (frame-properties (selected-frame))) - (buf (current-buffer)) - (orig (selected-frame))) - - ;; Create and select the new frame; - ;; we have to do this before we delete the old frame. - (setq fp (plist-remprop fp 'window-id) - fp (plist-remprop fp 'minibuffer)) - (select-frame - (make-frame (plist-put fp 'minibuffer nil))) - (switch-to-buffer buf) - - (set-frame-properties - orig (list 'minibuffer default-minibuffer-frame)) - (delete-frame orig t)) - - ;; This frame does not have a minibuffer, so add one - (set-frame-property (selected-frame) 'minibuffer t))) - - (add-menu-button '("Options" "Frame Appearance") - ["------" nil nil] - nil) - (add-menu-button '("Options" "Frame Appearance") - ["Toggle minibuffer" - (toggle-minibuf) - :style toggle - :active (not (equal (selected-frame) - default-minibuffer-frame)) - :selected (equal - (frame-property (selected-frame) 'minibuffer) - t)] - nil) - (add-menu-button '("Options" "Frame Appearance") - ["Default minibuffer here" - (setq default-minibuffer-frame (selected-frame)) - :style toggle - :active (let ((mbf (frame-property - (selected-frame) 'minibuffer))) - (or (equal mbf (selected-frame)) - (equal mbf t))) - :selected (equal (selected-frame) - default-minibuffer-frame)] - nil) - (add-menu-button '("Options" "Frame Appearance") - ["Make a detached minibuffer" - (make-detached-minibuf) - :style nil] - nil))) - -;; -;; Create a minibuffer-only frame. -;; -;; This function creates a frame named "minibuffer". -;; You will likely want this frame not to have a titlebar. -;; In order to do this for gwm, uncomment the following line -;; and add it to your .profile.gwm: -;; (set-window Emacs.minibuffer no-frame) -;; -(defun make-detached-minibuf () - "Create a standalone minibuffer" - (interactive) - (if (console-on-window-system-p) - (progn - (setq initial-frame-plist - (list 'minibuffer nil - 'width (frame-width (selected-frame)) - 'height (frame-height (selected-frame)))) - (setq default-minibuffer-frame - (make-frame - (list 'minibuffer 'only - 'width minibuf-frame-width - 'height minibuf-frame-height - 'menubar-visible-p nil - 'default-toolbar-visible-p nil - 'name "minibuffer" - 'top minibuf-frame-pos-y - 'left minibuf-frame-pos-x - 'has-modeline-p nil))) - - ;; Bogus! But it avoids annoying screen flash at startup - (if (not command-line-args-left) - (frame-notice-user-settings))))) - -(provide 'detached-minibuf) - -;;; detached-minibuf.el ends here
--- a/lisp/utils/facemenu.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/utils/facemenu.el Mon Aug 13 10:03:52 2007 +0200 @@ -22,7 +22,7 @@ ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;;; Synched up with: FSF 19.34. +;;; Synched up with: FSF 20.2 (but not literally) ;;; Commentary: @@ -47,8 +47,11 @@ ;; modifications before inserting or typing anything. ;; ;; Faces can be selected from the keyboard as well. -;; The standard keybindings are M-g (or ESC g) + letter: -;; M-g i = "set italic", M-g b = "set bold", etc. +;; The standard keybindings are C-x M-f + letter: +;; C-x M-f i = "set italic", C-x M-f b = "set bold", etc. +;; +;; Feel free to bind it to something more accessible, for instance: +;; (global-set-key [f5] 'facemenu-keymap) ;;; Customization: ;; An alternative set of keybindings that may be easier to type can be set up @@ -67,11 +70,10 @@ ;; (italic . [?\H-i]) ;; (bold-italic . [?\H-l]) ;; (underline . [?\H-u]))) +;; (facemenu-update) ;; (setq facemenu-keymap global-map) -;; (setq facemenu-key nil) ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color -;; (require 'facemenu) ;; ;; The order of the faces that appear in the menu and their keybindings can be ;; controlled by setting the variables `facemenu-keybindings' and @@ -101,10 +103,16 @@ (require 'easymenu) ;;; Provide some binding for startup: +;;;###autoload(autoload 'facemenu-keymap "facemenu" nil t 'keymap) ;;;###autoload (define-key ctl-x-map "F" 'facemenu-keymap) -(defvar facemenu-keybindings +(defgroup facemenu nil + "Create a face menu for interactively adding fonts to text." + :group 'faces + :prefix "facemenu-") + +(defcustom facemenu-keybindings '((default . "d") (bold . "b") (italic . "i") @@ -113,7 +121,7 @@ "Alist of interesting faces and keybindings. Each element is itself a list: the car is the name of the face, the next element is the key to use as a keyboard equivalent of the menu item; -the binding is made in facemenu-keymap. +the binding is made in `facemenu-keymap'. The faces specifically mentioned in this list are put at the top of the menu, in the order specified. All other faces which are defined, @@ -121,22 +129,32 @@ but get no keyboard equivalents. If you change this variable after loading facemenu.el, you will need to call -`facemenu-update' to make it take effect.") +`facemenu-update' to make it take effect." + :type '(repeat (cons face string)) + :group 'facemenu) -(defvar facemenu-new-faces-at-end t - "Where in the menu to insert newly-created faces. +(defcustom facemenu-new-faces-at-end t + "*Where in the menu to insert newly-created faces. This should be nil to put them at the top of the menu, or t to put them -just before \"Other\" at the end.") +just before \"Other\" at the end." + :type 'boolean + :group 'facemenu) ;; XEmacs -- additional faces -(defvar facemenu-unlisted-faces +(defcustom facemenu-unlisted-faces '(modeline region secondary-selection highlight scratch-face gui-button-face isearch hyperlink modeline modeline-buffer-id modeline-mousable modeline-mousable-minor-mode pointer primary-selection secondary-selection list-mode-item-selected text-cursor zmacs-region - left-margin right-margin) - "List of faces not to include in the Face menu. + left-margin right-margin + "^font-lock-" "^gnus-" "^message-" "^ediff-" "^term-" "^vc-" + "^widget-" "^custom-" "^vm-") + "*List of faces not to include in the Face menu. +Each element may be either a symbol, which is the name of a face, or a string, +which is a regular expression to be matched against face names. Matching +faces will not be added to the menu. + You can set this list before loading facemenu.el, or add a face to it before creating that face if you do not want it to be listed. If you change the variable so as to eliminate faces that have already been added to the menu, @@ -144,12 +162,43 @@ If this variable is t, no faces will be added to the menu. This is useful for temporarily turning off the feature that automatically adds faces to the menu -when they are created.") +when they are created." + :type '(choice (const :tag "Don't add" t) + (const :tag "None" nil) + (repeat (choice symbol regexp))) + :group 'facemenu) + +(defcustom facemenu-relevant-face-attributes + '(foreground background font underline highlight dim blinking reverse) + "*List of face attributes that facemenu fiddles with." + :type '(repeat (symbol :tag "Attribute")) + :group 'facemenu) -(defvar facemenu-relevant-face-attributes - '(foreground background font underline highlight dim blinking reverse) - "List of face attributes that facemenu fiddles with. -This is only relevant for XEmacs.") +(defcustom facemenu-add-face-function nil + "Function called at beginning of text to change or `nil'. +This function is passed the FACE to set and END of text to change, and must +return a string which is inserted. It may set `facemenu-end-add-face'." + :type '(choice (const :tag "None" nil) + function) + :group 'facemenu) + +(defcustom facemenu-end-add-face nil + "String to insert or function called at end of text to change or `nil'. +This function is passed the FACE to set, and must return a string which is +inserted." + :type '(choice (const :tag "None" nil) + string + function) + :group 'facemenu) + +(defcustom facemenu-remove-face-function nil + "When non-`nil' function called to remove faces. +This function is passed the START and END of text to change. +May also be `t' meaning to use `facemenu-add-face-function'." + :type '(choice (const :tag "None" nil) + (const :tag "Use add-face" t) + function) + :group 'facemenu) (easy-menu-define facemenu-face-menu () "Menu for faces" @@ -230,24 +279,10 @@ "Keymap for face-changing commands. `Facemenu-update' fills in the keymap according to the bindings requested in `facemenu-keybindings'.") +;;;###autoload (defalias 'facemenu-keymap facemenu-keymap) -(defvar facemenu-add-face-function nil - "Function called at beginning of text to change or `nil'. -This function is passed the FACE to set and END of text to change, and must -return a string which is inserted. It may set `facemenu-end-add-face'.") - -(defvar facemenu-end-add-face nil - "String to insert or function called at end of text to change or `nil'. -This function is passed the FACE to set, and must return a string which is -inserted.") - -(defvar facemenu-remove-face-function nil - "When non-`nil' function called to remove faces. -This function is passed the START and END of text to change. -May also be `t' meaning to use `facemenu-add-face-function'.") - ;;; Internal Variables (defvar facemenu-color-alist nil @@ -271,12 +306,6 @@ (easy-menu-change '("Edit") (car facemenu-menu) (cdr facemenu-menu)) (define-key global-map [C-down-mouse-2] 'facemenu-menu))) -(fset 'facemenu-region-active-p - (if (string-match "XEmacs" emacs-version) - 'region-active-p - #'(lambda () - mark-active))) - ;;;###autoload (defun facemenu-set-face (face &optional start end) "Add FACE to the region or next character typed. @@ -296,7 +325,7 @@ (barf-if-buffer-read-only) (facemenu-add-new-face face) (facemenu-update-facemenu-menu) ; XEmacs - (if (and (facemenu-region-active-p) + (if (and (region-active-p) (not current-prefix-arg)) (let ((start (or start (region-beginning))) (end (or end (region-end)))) @@ -348,10 +377,10 @@ inserted. Moving point or switching buffers before typing a character to insert cancels the specification." (interactive (list last-command-event - (if (and (facemenu-region-active-p) + (if (and (region-active-p) (not current-prefix-arg)) (region-beginning)) - (if (and (facemenu-region-active-p) + (if (and (region-active-p) (not current-prefix-arg)) (region-end)))) (barf-if-buffer-read-only) @@ -399,6 +428,10 @@ ((consp face) (mapcar 'facemenu-face-strip-size face)) (t (facemenu-face-strip-size face)))) +;; This file uses `put-text-property' all over. All of these calls +;; have been changed to `add-text-properties' in FSF, but I don't see +;; any reason to copy that change. + ;;;###autoload (defun facemenu-set-size-default (start end) (interactive "_r") @@ -422,7 +455,8 @@ face (let ((name (symbol-name face)) (measure size) - (change-face 'make-face-larger)) + (change-face 'make-face-larger) + prefix) (if (> measure 0) (setq prefix "larger-") @@ -504,6 +538,8 @@ This sets the `intangible' text property; it can be undone with `facemenu-remove-special'." (interactive "_r") + ;; #### This does nothing in XEmacs. Should use atomic-extents, but + ;; why bother, when that's broken, too? (put-text-property start end 'intangible t)) ;;;###autoload @@ -567,19 +603,7 @@ (setq props (cdr (cdr props))))))))))) ;;;###autoload -(defun facemenu-read-color (&optional prompt) - "Read a color using the minibuffer." - (if (string-match "XEmacs" emacs-version) - (read-color prompt) - (let ((col (completing-read - (or prompt "Color: ") - (or facemenu-color-alist - (if (or (eq window-system 'x) (eq window-system 'win32)) - (mapcar 'list (x-defined-colors)))) - nil t))) - (if (equal "" col) - nil - col)))) +(defalias 'facemenu-read-color 'read-color) (defun facemenu-canonicalize-color (c) (downcase (replace-in-string c " " ""))) @@ -599,20 +623,10 @@ colors to display. Otherwise, this command computes a list of colors that the current display can handle." (interactive) - (if (string-match "XEmacs" emacs-version) - (setq list - (facemenu-unique - (mapcar 'facemenu-canonicalize-color - (mapcar 'car (read-color-completion-table))))) - (if (and (null list) (or (eq window-system 'x) (eq window-system 'win32))) - (progn - (setq list (x-defined-colors)) - ;; Delete duplicate colors. - (let ((l list)) - (while (cdr l) - (if (facemenu-color-equal (car l) (car (cdr l))) - (setcdr l (cdr (cdr l))) - (setq l (cdr l)))))))) + (setq list + (facemenu-unique + (mapcar 'facemenu-canonicalize-color + (mapcar 'car (read-color-completion-table))))) (with-output-to-temp-buffer "*Colors*" (save-excursion (set-buffer standard-output) @@ -705,11 +719,9 @@ ;; XEmacs (defun facemenu-face-attributes (face) "Create a vector of the relevant face attributes of face FACE." - (if (string-match "XEmacs" emacs-version) - (apply 'vector (mapcar #'(lambda (prop) - (face-property-instance face prop)) - facemenu-relevant-face-attributes)) - (internal-get-face (car face-list)))) + (mapvector #'(lambda (prop) + (face-property-instance face prop)) + facemenu-relevant-face-attributes)) (defun facemenu-active-faces (face-list) "Return from FACE-LIST those faces that would be used for display. @@ -735,41 +747,28 @@ (setq face-list (cdr face-list))) (nreverse active-list))) -(fset 'facemenu-find-face - (if (string-match "XEmacs" emacs-version) - 'find-face - 'internal-find-face)) - -(fset 'facemenu-color-defined-p - (if (string-match "XEmacs" emacs-version) - #'(lambda (c) - (color-instance-p (make-color-instance c nil t))) - #'(lambda (c) - (and (or (eq window-system 'x) (eq window-system 'win32)) - (x-color-defined-p color))))) - (defun facemenu-get-face (symbol) "Make sure FACE exists. -If not, it is created. If it is created and is of the form `fg:color', then -set the foreground to that color. If of the form `bg:color', set the -background. In any case, add it to the appropriate menu. Returns the face, -or nil if given a bad color." - (if (or (facemenu-find-face symbol) - (let* ((face (make-face symbol)) - (name (symbol-name symbol)) - (color-name (substring name 3)) - (color (if (string-match "XEmacs" emacs-version) - (make-color-specifier color-name) - color-name))) - (facemenu-add-new-face symbol) - (cond ((string-match "^fg:" name) - (set-face-foreground face color) - (facemenu-color-defined-p color-name)) - ((string-match "^bg:" name) - (set-face-background face color) - (facemenu-color-defined-p color-name)) - (t)))) - symbol)) +If not, create it and add it to the appropriate menu. Return the symbol. + +If this function creates a face named `fg:color', then it sets the +foreground to that color. Likewise, `bg:color' means to set the +background. In either case, if the color is undefined, no color is +set and a warning is issued." + (let ((name (symbol-name symbol)) + foreground) + (cond ((find-face symbol)) + ((or (setq foreground (string-match "^fg:" name)) + (string-match "^bg:" name)) + (let* ((face (make-face symbol)) + (color (substring name 3))) + (if (color-instance-p (make-color-instance color)) + (if foreground + (set-face-foreground face color) + (set-face-background face color)) + (warn "Color `%s' undefined" color)))) + (t (make-face symbol)))) + symbol) (defun facemenu-menu-has-face (menu face-name) "Check if menu MENU has an entry for face named by string FACE-NAME. @@ -792,31 +791,52 @@ "Add a FACE to the appropriate Face menu. Automatically called when a new face is created." (let* ((name (symbol-name face)) - (menu (cond ((string-match "^fg:" name) - (setq name (substring name 3)) - 'facemenu-foreground-menu) - ((string-match "^bg:" name) - (setq name (substring name 3)) - 'facemenu-background-menu) - (t 'facemenu-face-menu))) - (menu-value (symbol-value menu)) + menu menu-value (key (cdr (assoc face facemenu-keybindings)))) (cond ((eq t facemenu-unlisted-faces)) + ((string-match "^fg:" name) + (setq name (substring name 3) + docstring (format + "Select foreground color %s for subsequent insertion." + name) + menu 'facemenu-foreground-menu)) + ((string-match "^bg:" name) + (setq name (substring name 3) + docstring (format + "Select background color %s for subsequent insertion." + name) + menu 'facemenu-background-menu)) + (t + (setq docstring (format "Select face `%s' for subsequent insertion." + name) + menu 'facemenu-face-menu))) + (setq menu-value (symbol-value menu)) + (cond ((eq t facemenu-unlisted-faces)) + ((memq face facemenu-unlisted-faces)) ((string-match "^larger-" name)) ((string-match "^smaller-" name)) - ((memq face facemenu-unlisted-faces)) + ;; Test against regexps in facemenu-unlisted-faces + ((let ((unlisted facemenu-unlisted-faces) + (matched nil)) + (while (and unlisted (not matched)) + (if (and (stringp (car unlisted)) + (string-match (car unlisted) name)) + (setq matched t) + (setq unlisted (cdr unlisted)))) + matched)) (key ; has a keyboard equivalent. These go at the front. (let ((function (intern (concat "facemenu-set-" name)))) (fset function - (` (lambda () - (interactive "_") - (facemenu-set-face (quote (, face)))))) + `(lambda () + ,docstring + (interactive "_") + (facemenu-set-face (quote ,face)))) (define-key 'facemenu-keymap key function) - (if (not (facemenu-menu-has-face menu-value name)) - (set menu - (cons (car menu-value) - (cons (vector name function t) - (cdr menu-value))))))) + (unless (facemenu-menu-has-face menu-value name) + (set menu + (cons (car menu-value) + (cons (vector name function t) + (cdr menu-value))))))) ((facemenu-menu-has-face menu-value name)) (t ; No keyboard equivalent. Figure out where to put it: (let ((before-entry
--- a/lisp/utils/find-gc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,169 +0,0 @@ -;;; find-gc.el --- detect functions that call the garbage collector - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: maint - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.30. - -;;; #### before this is really usable, it should be rewritten to call -;;; Makefile to compile the files. - -;;; Commentary: - -;;; Produce in unsafe-list the set of all functions that may invoke GC. -;;; This expects the Emacs sources to live in emacs-source-directory. -;;; It creates a temporary working directory /tmp/esrc. - -;;; Code: - -;; Set this to point to your XEmacs source directory. -(setq emacs-source-directory "/net/prosper/opt/xemacs/editor/src") - -;; Set this to the include directories neeed for compilation. -(setq include-directives "-I/net/prosper/opt/xemacs/editor/src -I/usr/dt/include -I/net/prosper/opt/SUNWmotif/include -I/net/prosper/opt/xemacs/editor/import/xpm/include -I/net/prosper/opt/xemacs/editor/import/include -I/usr/demo/SOUND/include -I/usr/openwin/include -I/usr/openwin/include/desktop -I/usr/openwin/include/desktop -I/net/prosper/opt/xemacs/editor/src/../lwlib -g -v -DNeedFunctionPrototypes -xildoff -I/usr/dt/include -I/net/prosper/opt/SUNWmotif/include -I/net/prosper/opt/xemacs/editor/import/xpm/include -I/net/prosper/opt/xemacs/editor/import/include -I/usr/demo/SOUND/include -I/usr/demo/SOUND/include") - -;; Set this to the source files you want to check. -(setq source-files - '( -"EmacsFrame.c" "EmacsManager.c" "EmacsShell.c" "abbrev.c" "alloc.c" -"blocktype.c" "buffer.c" "bytecode.c" "callint.c" "callproc.c" "casefiddle.c" -"casetab.c" "cm.c" "cmds.c" "data.c" "debug.c" "device-stream.c" -"device-tty.c" "device-x.c" "device.c" "dired.c" "doc.c" "doprnt.c" -"dynarr.c""editfns.c" "elhash.c" "emacs.c" "eval.c" "event-Xt.c" -"event-stream.c" "event-tty.c" "events.c" "extents.c" "faces.c" "fileio.c" -"filelock.c" "filemode.c" "floatfns.c" "fns.c" "font-lock.c" "frame-tty.c" -"frame-x.c" "frame.c" "getloadavg.c" "glyphs.c" "gmalloc.c" "hash.c" -"indent.c" "insdel.c" "intl.c" "keyboard.c" "keymap.c" "lastfile.c" "lread.c" -"lstream.c" "macros.c" "marker.c" "md5.c" "menubar-x.c" "menubar.c" -"minibuf.c" "objects-x.c" "objects.c" "opaque.c" "print.c" "process.c" -"pure.c" "redisplay-output.c" "redisplay-tty.c" "redisplay-x.c" "redisplay.c" -"regex.c" "scrollbar.c" "search.c" "sound.c" "specifier.c" "sunplay.c" -"sunpro.c" "symbols.c" "syntax.c" "sysdep.c" "terminfo.c" "toolbar-x.c" -"toolbar.c" "tooltalk.c" "undo.c" "unexsol2.c" "vm-limit.c" "window.c" -"xgccache.c" "xselect.c")) - -;;; - -(defun find-gc-unsafe () - (trace-call-tree nil) - (trace-use-tree) - (find-unsafe-funcs 'Fgarbage_collect) - (setq unsafe-list (sort unsafe-list - (function (lambda (x y) - (string-lessp (car x) (car y)))))) - (princ (format "%s\n" unsafe-list)) - (setq unsafe-list nil) - (find-unsafe-funcs 'Fgarbage_collect_1) - (setq unsafe-list (sort unsafe-list - (function (lambda (x y) - (string-lessp (car x) (car y)))))) - (princ (format "%s\n" unsafe-list))) - - -;;; This does a depth-first search to find all functions that can -;;; ultimately call the function "target". The result is an a-list -;;; in unsafe-list; the cars are the unsafe functions, and the cdrs -;;; are (one of) the unsafe functions that these functions directly -;;; call. - -(defun find-unsafe-funcs (target) - (setq unsafe-list (list (list target))) - (trace-unsafe target)) - -(defun trace-unsafe (func) - (let ((used (assq func subrs-used))) - (or used - (error "No subrs-used for %s" (car unsafe-list))) - (while (setq used (cdr used)) - (or (assq (car used) unsafe-list) - (memq (car used) noreturn-list) - (progn - (setq unsafe-list (cons (cons (car used) func) unsafe-list)) - (trace-unsafe (car used))))))) - - -;;; Functions on this list are safe, even if they appear to be able -;;; to call the target. - -(setq noreturn-list '( signal_error error Fthrow wrong_type_argument )) - - -;;; This produces an a-list of functions in subrs-called. The cdr of -;;; each entry is a list of functions which the function in car calls. - -(defun trace-call-tree (&optional already-setup) - (or already-setup - (progn - (princ (format "Setting up directories...\n")) - ;; Gee, wouldn't a built-in "system" function be handy here. - (call-process "sh" nil nil nil "-c" "rm -rf /tmp/esrc") - (call-process "sh" nil nil nil "-c" "mkdir /tmp/esrc") - (call-process "sh" nil nil nil "-c" - (format "ln -s %s/*.[ch] /tmp/esrc" - emacs-source-directory)))) - (save-excursion - (set-buffer (get-buffer-create "*Trace Call Tree*")) - (setq subrs-called nil) - (let ((case-fold-search nil) - (files source-files) - name entry) - (while files - (princ (format "Compiling %s...\n" (car files))) - (call-process "sh" nil nil nil "-c" - (format "cd /tmp/esrc; gcc -dr -c %s /tmp/esrc/%s -o /dev/null" - include-directives (car files))) - (erase-buffer) - (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl")) - (while (re-search-forward ";; Function \\|(call_insn " nil t) - (if (= (char-after (- (point) 3)) ?o) - (progn - (looking-at "[a-zA-Z0-9_]+") - (setq name (intern (buffer-substring (match-beginning 0) - (match-end 0)))) - (princ (format "%s : %s\n" (car files) name)) - (setq entry (list name) - subrs-called (cons entry subrs-called))) - (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"") - (progn - (setq name (intern (buffer-substring (match-beginning 1) - (match-end 1)))) - (or (memq name (cdr entry)) - (setcdr entry (cons name (cdr entry)))))))) - ;;(delete-file (concat "/tmp/esrc/" (car files) ".rtl")) - (setq files (cdr files)))))) - - -;;; This produces an inverted a-list in subrs-used. The cdr of each -;;; entry is a list of functions that call the function in car. - -(defun trace-use-tree () - (setq subrs-used (mapcar 'list (mapcar 'car subrs-called))) - (let ((ptr subrs-called) - p2 found) - (while ptr - (setq p2 (car ptr)) - (while (setq p2 (cdr p2)) - (if (setq found (assq (car p2) subrs-used)) - (setcdr found (cons (car (car ptr)) (cdr found))))) - (setq ptr (cdr ptr))))) - -;;; find-gc.el ends here
--- a/lisp/utils/floating-toolbar.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/utils/floating-toolbar.el Mon Aug 13 10:03:52 2007 +0200 @@ -83,7 +83,7 @@ (provide 'floating-toolbar) -(require 'toolbar) +;; (require 'toolbar) (require 'x) (defvar floating-toolbar-version "1.02" @@ -145,6 +145,8 @@ that only extent local toolbars should be used; this means the `floating-toolbar' variable will not be consulted." (interactive "_e") + (unless (featurep 'toolbar) + (error "Floating toolbar requires built in toolbar support.")) (if (not (mouse-event-p event)) nil (let* ((buffer (event-buffer event)) @@ -375,7 +377,8 @@ frame ))) ;; first popup should be faster if we go ahead and make the frame now. -(or floating-toolbar-frame +(or (not (featurep 'toolbar)) + floating-toolbar-frame (not (eq (device-type) 'x)) (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame 0 0)))
--- a/lisp/utils/flow-ctrl.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -;;; flow-ctrl.el --- help for lusers on cu(1) or ttys with wired-in ^S/^Q flow control - -;;; Copyright (C) 1990, 1991, 1994 Free Software Foundation, Inc. - -;; Author Kevin Gallagher -;; Maintainer: FSF -;; Adapted-By: ESR -;; Keywords: hardware - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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: FSF 19.34. - -;;; Commentary: - -;; Terminals that use XON/XOFF flow control can cause problems with -;; GNU Emacs users. This file contains Emacs Lisp code that makes it -;; easy for a user to deal with this problem, when using such a -;; terminal. -;; -;; To invoke these adjustments, a user need only invoke the function -;; enable-flow-control-on with a list of terminal types in his/her own -;; .emacs file. As arguments, give it the names of one or more terminal -;; types in use by that user which require flow control adjustments. -;; Here's an example: -;; -;; (enable-flow-control-on "vt200" "vt300" "vt101" "vt131") - -;; Portability note: This uses (getenv "TERM"), and therefore probably -;; won't work outside of UNIX-like environments. - -;;; Code: - -(defvar flow-control-c-s-replacement ?\034 - "Character that replaces C-s, when flow control handling is enabled.") -(defvar flow-control-c-q-replacement ?\036 - "Character that replaces C-q, when flow control handling is enabled.") - -;(put 'keyboard-translate-table 'char-table-extra-slots 0) - -;;;###autoload -(defun enable-flow-control (&optional argument) - "Toggle flow control handling. -When handling is enabled, user can type C-s as C-\\, and C-q as C-^. -With arg, enable flow control mode if arg is positive, otherwise disable." - (interactive "P") - (if (if argument - ;; Argument means enable if arg is positive. - (<= (prefix-numeric-value argument) 0) - ;; No arg means toggle. - (nth 1 (current-input-mode))) - (progn - ;; Turn flow control off, and stop exchanging chars. - (set-input-mode t nil (nth 2 (current-input-mode))) - ;; XEmacs - (keyboard-translate flow-control-c-s-replacement nil) - (keyboard-translate ?\^s nil) - (keyboard-translate flow-control-c-q-replacement nil) - (keyboard-translate ?\^q nil)) - ;; Turn flow control on. - ;; Tell emacs to pass C-s and C-q to OS. - (set-input-mode nil t (nth 2 (current-input-mode))) - ;; Initialize translate table, saving previous mappings, if any. - ;; Swap C-s and C-\ - ;; XEmacs - (keyboard-translate flow-control-c-s-replacement ?\^s) - (keyboard-translate ?\^s flow-control-c-s-replacement) - ;; Swap C-q and C-^ - (keyboard-translate flow-control-c-q-replacement ?\^q) - (keyboard-translate ?\^q flow-control-c-q-replacement) - (message (concat - "XON/XOFF adjustment for " - (getenv "TERM") - ": use C-\\ for C-s and use C-^ for C-q.")) - (sleep-for 2))) ; Give user a chance to see message. - -;;;###autoload -(defun enable-flow-control-on (&rest losing-terminal-types) - "Enable flow control if using one of a specified set of terminal types. -Use `(enable-flow-control-on \"vt100\" \"h19\")' to enable flow control -on VT-100 and H19 terminals. When flow control is enabled, -you must type C-\\ to get the effect of a C-s, and type C-^ -to get the effect of a C-q. - -This function has no effect unless the current device is a tty. - -The tty terminal type is determined from the TERM environment variable. -Trailing hyphens and everything following is stripped, so a TERM -value of \"vt100-nam\" is treated the same as \"vt100\"." - (let ((term (getenv "TERM")) - hyphend) - ;; Look for TERM in LOSING-TERMINAL-TYPES. - ;; If we don't find it literally, try stripping off words - ;; from the end, one by one. - (while (and term (not (member term losing-terminal-types))) - ;; Strip off last hyphen and what follows, then try again. - (if (setq hyphend (string-match "[-_][^-_]+$" term)) - (setq term (substring term 0 hyphend)) - (setq term nil))) - (if term - (enable-flow-control)))) - -(provide 'flow-ctrl) - -;;; flow-ctrl.el ends here
--- a/lisp/utils/hide-copyleft.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -;;; hide-copyleft.el --- hide obnoxious copyright prologs - -;; Copyright (C) 1997 Sun Microsystems. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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. - -;;; Commentary: - -;; Written by Jamie Zawinski <jwz@netscape.com>, 19-jan-91. -;; Minor fixes by Martin Buchholz, 14-may-97. -;; Last modified 14-may-97. -;; -;; I sometimes find it tiresome to have fifteen lines of copyright notice at -;; the beginning of each file. Meta-< does not take you to the beginning of -;; the code, it takes you a windowfull or two away, which can be tedious on -;; slow terminal lines. -;; -;; I know what the copyright notice says; so this code makes all but the first -;; line of it be invisible, by using Emacs's selective-display feature. The -;; text is still present and unmodified, but it is invisible. -;; -;; Elide the copyright notice with "Meta-X hide-copyleft-region". Make it -;; visible again with "Control-U Meta-X hide-copyleft-region". Or, if you're -;; sure you're not gonna get sued, you can do something like this in your -;; .emacs file: -;; -;; (autoload 'hide-copyleft-region "hide-copyleft" nil t) -;; (autoload 'unhide-copyleft-region "hide-copyleft" nil t) -;; (add-hook 'emacs-lisp-mode-hook 'hide-copyleft-region) -;; (add-hook 'c-mode-hook 'hide-copyleft-region) -;; -;; This code (obviously) has quite specific knowledge of the wording of the -;; various copyrights I've run across. Let me know if you find one on which -;; it fails. - -(defvar copylefts-to-hide - ;; There are some extra backslashes in these strings to prevent this code - ;; from matching the definition of this list as the copyright notice! - '(;; GNU - ("free software\; you can redistribute it" . - "notice must be\ preserved on all") - ("free software\; you can redistribute it" . - "copy of the GNU General Public License.*\n?.*\n?.*\n?.*\n?.*\\(02139,\\|02111-1307\\)") - ("distributed in the hope that it will be useful\," . - "notice must be\ preserved on all") - ("free software\; you can redistribute it" . - "General Public License for more details\\.") - ;; X11 - ("Permission to use\, copy, modify," . - "WITH THE USE OR PERFORMANCE") - ("Permission to use\, copy, modify," . - "without express or implied warranty") - ;; Motif - ("Copyright.*OPEN\ SOFTWARE FOUNDATION" . - "X Window System is a trademark of the") - ("THIS SOFTWARE\ IS FURNISHED UNDER A LICENSE" . - "X Window System is a trademark of the") - ;; UPenn - ("Permission to use\, copy, and distribute" . - " provided \"as is\" without") - ;; Evans & Sutherland, Solbourne. - ("Copyright 19[0-9][0-9] by " . - "OR PERFORMANCE OF THIS SOFTWARE\\.") - ;; TI Explorer - ("RESTRICTED RIGHTS LEGEND" . "All rights reserved\\.\\(\n;;; ?$\\)?") - ("^%%BeginDocumentation" . "^%%EndDocumentation") - ) - "An alist of pairs of regexps which delimit copyright notices to hide. -The first one found is hidden, so order is significant.") - - -;;;###autoload -(defun hide-copyleft-region (&optional arg) - "Make the legal drivel at the front of this file invisible. Unhide it again -with C-u \\[hide-copyleft-region]." - (interactive "P") - (if arg - (unhide-copyleft-region) - (save-excursion - (save-restriction - (if selective-display (error "selective-display is already on.")) - (catch 'Abort - (let ((mod-p (buffer-modified-p)) - (buffer-read-only nil) - (rest copylefts-to-hide) - pair start end) - (widen) - (goto-char (point-min)) - (while (and rest (not pair)) - (save-excursion - (and (re-search-forward (car (car rest)) nil t) - (setq start (point)) - (re-search-forward (cdr (car rest)) nil t) - (setq end (point) - pair (car rest)))) - (setq rest (cdr rest))) - (setq x pair) - (or pair - (if (interactive-p) - (error "Couldn't find a CopyLeft to hide.") - (throw 'Abort nil))) - (goto-char end) - (forward-line 1) - ;; If the last line of the notice closes a C comment, don't - ;; hide that line (to avoid confusion...) - (if (save-excursion (forward-char -3) (looking-at "\\*/")) - (forward-line -1)) - (setq end (point)) - (goto-char start) - (forward-line 1) - (while (< (point) end) - (delete-char -1) - (insert "\^M") - (forward-line 1)) - (setq selective-display t) - (set-buffer-modified-p mod-p))))))) - -;;;###autoload -(defun unhide-copyleft-region () - "If the legal nonsense at the top of this file is elided, make it visible again." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((mod-p (buffer-modified-p)) - (buffer-read-only nil) - end) - (or (search-forward "\^M" nil t) (error "Nothing hidden here, dude.")) - (end-of-line) - (setq end (point)) - (beginning-of-line) - (while (search-forward "\^M" end t) - (delete-char -1) - (insert "\^J")) - (set-buffer-modified-p mod-p) - (setq selective-display nil))))) -
--- a/lisp/utils/xemacs-build-report.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,222 +0,0 @@ -;;; xemacs-build-report.el --- Automatically formatted build reports for XEmacs - -;; Copyright (C) 1997 Adrian Aichner - -;; Author: Adrian Aichner, Teradyne GmbH Munich <aichner@ecf.teradyne.com> -;; Date: Sun., Apr. 20, 1997. -;; Version: 1.25 -;; Keywords: internal - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 synched. - -;;; Commentary: - -;; The Idea: -;; Let XEmacs report interesting aspects of how it was built. - -;; The Concept: -;; User creates an XEmacs Build Report by just calling -;; M-x xemacs-create-build-report -;; which will initialize a mail buffer with relevant information -;; derived from the XEmacs build process. Point is left at the -;; beginning of the report for user to input some personal notes and -;; send the report. - -;; The Status: -;; This is the first `Proof of Concept'. - -;; The Author: -;; Adrian Aichner, Teradyne GmbH Munich, Sun., Apr. 20, 1997. - -;;; Code: - -(require 'config) -(provide 'xemacs-build-report) - -;; Building the version from the RCS Revision keyword was lifted from -;; lisp/packages/auto-save.el. -;; This was later taken out due to recommandation by developers on -;; xemacs-beta@xemacs.org. Release versions are to be checked out -;; using `co -u -kv ...'. -(defconst xemacs-build-report-version - "Revision: 1.25" - "Version number of xemacs-build-report.") - -(defgroup xemacs-build-report nil - "Package automating the process of sending XEmacs Build Reports.") - -(defcustom xemacs-build-report-destination - "xemacs-beta@xemacs.org" - "The mail address XEmacs Build Reports should go to." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-keep-regexp - "make\\[\\|warn\\|pure.*\\(space\\|size\\)\\|hides\\|shadowings" - "Regexp of make process output lines to keep in the report." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-delete-regexp - "confl.*with.*auto-inlining" - "Regexp of make process output lines to delete from the report." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-make-output-file - (concat (gethash 'blddir (config-value-hash-table)) "/mk.err") - "Filename where stdout and stderr of XEmacs make process have been stored. -mk.err will not be created automatically. You'll have to run make with -output redirection. I use an alias -alias mk 'make \!* >>&\! \!$.err &' -for that, so that I get mk.err went I run mk." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-installation-file - (concat (gethash 'blddir (config-value-hash-table)) "/Installation") - "Installation file produced by XEmacs configure process." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-subject - (concat "Build %s: " emacs-version " on " system-configuration) - "XEmacs Build Report Subject Line. %s-sequences will be substituted -with user input through `xemacs-create-build-report' according to -`xemacs-build-report-prompts' using `format'." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-prompts - '(("Status?: " "Success" "Failure")) - "XEmacs Build Report Prompt(s). This is a list of prompt-string -lists used by `xemacs-create-build-report' in conjunction with -`xemacs-build-report-subject'. Each list consists of a prompt string -followed by any number of strings which can be chosen via the history -mechanism." - :group 'xemacs-build-report) - -(defcustom xemacs-build-report-file-encoding - "7bit" - "XEmacs Build Report File Encoding to be used when MIME support is -available." -:group 'xemacs-build-report) - -;; Symbol Name mappings from TM to SEMI serving as -;; Compatibility Bandaid -;; If 'mime-editor/version-name is bound, we must be using TM(-edit). -(if (boundp 'mime-editor/version-name) - (progn - ;; No (defvaralias ...) so far. T - ;; Thanks to "Didier Verna" verna@inf.enst.fr for reporting my - ;; incorrect defvaraliasing of `mime-editor/insert-tag'. - (defalias - 'mime-edit-insert-tag - 'mime-editor/insert-tag) - (defalias - 'mime-edit-insert-binary-file - 'mime-editor/insert-binary-file))) - -(defun xemacs-create-build-report (&rest args) - "Initializes a fresh mail-mode buffer with the contents of XEmacs -Installation file and excerpts from XEmacs make output and errors and -leaves point at the beginning of the mail text. See also -`xemacs-build-report-destination', -`xemacs-build-report-keep-regexp', -`xemacs-build-report-delete-regexp', -`xemacs-build-report-make-output-file' and -`xemacs-build-report-installation-file'." - (interactive - (let (prompt - hist - arg - (prompts xemacs-build-report-prompts)) - (progn - (while prompts - (setq prompt (caar prompts)) - (setq hist (cdar prompts)) - (setq prompts (cdr prompts)) - (setq arg (cons (read-string prompt "" 'hist) arg))) - arg))) - (save-excursion - (mail - t - xemacs-build-report-destination - (apply 'format xemacs-build-report-subject args)) - (let ((report-begin (mail-text))) - (if (file-exists-p xemacs-build-report-make-output-file) - (progn - (if (featurep 'mime-setup) - (progn - (setq xemacs-build-report-keep-regexp - (concat "^--\\[\\[\\|\\]\\]$\\|" - xemacs-build-report-keep-regexp)) - (mime-edit-insert-tag - "application" - "octet-stream" - (concat - "\nContent-Disposition: attachment;" - " filename=\"" - (file-name-nondirectory - xemacs-build-report-make-output-file) - "\"")) - (mime-edit-insert-binary-file - xemacs-build-report-make-output-file - xemacs-build-report-file-encoding)) - (insert-file-contents xemacs-build-report-make-output-file)) - (goto-char report-begin) - (delete-non-matching-lines - xemacs-build-report-keep-regexp) - (goto-char report-begin) - (delete-matching-lines xemacs-build-report-delete-regexp) - (goto-char report-begin) - (insert "> Contents of " - xemacs-build-report-make-output-file - "\n> keeping lines matching\n> \"" - xemacs-build-report-keep-regexp - "\"\n> and then deleting lines matching\n> \"" - xemacs-build-report-delete-regexp - "\"\n\n")) - (insert "> " xemacs-build-report-make-output-file - " does not exist!\n\n")) - (goto-char report-begin) - (insert "\n> XEmacs Build Report as generated\n> by " - "xemacs-build-report-version " - xemacs-build-report-version - " follows:\n\n") - (if (file-exists-p xemacs-build-report-installation-file) - (progn - (insert "> Contents of " - xemacs-build-report-installation-file - ":\n\n") - (if (featurep 'mime-setup) - (progn - (mime-edit-insert-tag - "application" - "octet-stream" - (concat - "\nContent-Disposition: attachment;" - " filename=\"" - (file-name-nondirectory - xemacs-build-report-installation-file) - "\"")) - (mime-edit-insert-binary-file - xemacs-build-report-installation-file - xemacs-build-report-file-encoding)) - (insert-file-contents xemacs-build-report-installation-file))) - (insert "> " xemacs-build-report-installation-file - " does not exist!\n\n")) - (goto-char report-begin)))) - -;;; xemacs-build-report.el ends here
--- a/lisp/viper/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -# -# Makefile for compiling and installing Viper -# - -# -------- USER MAY NEED TO CHANGE THESE --------------------- -# To compile under XEmacs, uncomment XEmacs-specific versions of the -# variables VERSION, EMACS, DATADIR and comment out the Emacs-specific -# versions. - -VERSION = 20.0 -EMACS = emacs-$(VERSION) -#VERSION = 20.3 -#EMACS = xemacs-$(VERSION) -PREFIX = /usr/local -DATADIR = $(PREFIX)/share -#DATADIR = $(PREFIX)/lib -LISPDIR = $(DATADIR)/emacs/site-lisp -INFODIR = $(PREFIX)/info -ETCDIR = $(DATADIR)/emacs/$(VERSION)/etc -COMPDIR = - -# --------- YOU PROBABLY DON'T WANT TO CHANGE THESE ---------------- -TeX = tex -TEXINDEX = texindex -MAKEINFO = makeinfo -INSTALL = install - -# --------- ONLY AUTHORIZED PERSONNEL BEYOND THIS POINT!!! ------------ -VIPER = viper.el viper-cmd.el viper-util.el viper-mous.el viper-ex.el \ - viper-macs.el viper-keym.el viper-init.el -VIPERelc = $(COMPDIR)viper-util.elc \ - $(COMPDIR)viper-mous.elc \ - $(COMPDIR)viper-ex.elc \ - $(COMPDIR)viper-macs.elc \ - $(COMPDIR)viper-keym.elc \ - $(COMPDIR)viper.elc \ - $(COMPDIR)viper-cmd.elc \ - $(COMPDIR)viper-init.elc - -COMPILE_ARGS = -batch -f batch-byte-compile - -all: dvi info hello elc goodbye - -elc: $(VIPERelc) - -goodbye: - @echo "" - @echo "" - @echo "" - @echo " The above compiler warnings were normal -- don't panic!" - @echo "" - @echo " Please report bugs via the command :submitReport" - @echo "" - @echo "" - @echo "" - -hello: - @echo "" - @echo "" - @echo "Byte compiling using Emacs" - @echo "Use make EMACS=xemacs to compile under XEmacs" - @echo "" - @echo "" - @echo " The following compiler warnings are normal -- don't panic!" - @echo "" - @echo "" - @echo "" - -viper.dvi: viper.texi - @echo "" - @echo "" - @echo "Making viper.dvi --- a Printable Version of the Viper Manual"; - @echo "" - $(TeX) viper.texi - @echo "" - @echo "Indexing " - $(TEXINDEX) viper.cp - $(TEXINDEX) viper.fn - $(TEXINDEX) viper.ky - $(TEXINDEX) viper.pg -# $(TEXINDEX) viper.tp - $(TEXINDEX) viper.vr - @echo "" - @echo "Texing Again"; - $(TeX) viper.texi - -viper: viper.texi - @echo "" - @echo "" - @echo "Making Info Files for the Viper Manual" - @echo "" - $(MAKEINFO) viper.texi - -viperCard.dvi: viperCard.tex - @echo "" - @echo "" - @echo "Making the Viper Reference Card" - @echo "" - $(TeX) viperCard.tex - -${COMPDIR}viper-init.elc: viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-init.el - -$(COMPDIR)viper-util.elc: viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-util.el - -$(COMPDIR)viper-ex.elc: viper-ex.el viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-ex.el - -$(COMPDIR)viper-mous.elc: viper-mous.el viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-mous.el - -$(COMPDIR)viper-macs.elc: viper-macs.el viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-macs.el - -$(COMPDIR)viper-keym.elc: viper-keym.el viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-keym.el - -$(COMPDIR)viper.elc: viper.el viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper.el - -$(COMPDIR)viper-cmd.elc: viper-cmd.el viper.el viper-util.el viper-init.el - @echo "" - $(EMACS) $(COMPILE_ARGS) viper-cmd.el - - -dvi: viper.dvi viperCard.dvi - -info: viper - -install: all - $(INSTALL) -m444 $(VIPER) $(LISPDIR) - $(INSTALL) -m644 viper*.elc $(LISPDIR) - $(INSTALL) -m444 viper viper-? $(INFODIR) - $(INSTALL) -m644 viper.dvi viperCard.dvi $(ETCDIR) - @echo "" - @echo "Please move viper.texi to emacs-distribution-directory/man/" - @echo "" - -clean: - rm -f *.elc *~ core - -distclean: clean - -realclean: clean - rm -f *.dvi ../info/viper ../info/viper-? - rm -f viper.aux viper.cp viper.cps viper.fn viper.fns viper.ky \ - viper.kys viper.log viper.pg viper.pgs viper.toc viper.tp \ - viper.tps viper.vr viper.vrs
--- a/lisp/viper/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -**** Viper requires Emacs 19.23 or later. - -This directory: - -README -- This file -Makefile -- Automated installation file - -viper.el -- Viper Emacs Lisp code -viper-cmd.el -- Viper Emacs Lisp code -viper-macs.el -- Viper Emacs Lisp code -viper-ex.el -- Viper Emacs Lisp code -viper-init.el -- Viper Emacs Lisp code -viper-util.el -- Viper Emacs Lisp code -viper-mous.el -- Viper Emacs Lisp code -viper-keym.el -- Viper Emacs Lisp code - -viper.texi -- Manual in Texinfo format - -viperCard.tex -- Reference card in TeX format - -viper, viper-? -- The Info files - -viper.dvi -- Dvi version of the Viper manual -viperCard.dvi -- Dvi version of the quick reference card - -To install Viper, do: - - uncompress viper.tar.Z - tar xf viper.tar - - -Then do the following: - -1. To compile Lisp: - - make elc - - Since the DVI and Info files are bundled with the distribution, this is - the only make command you need. - -2. To recompile the DVI files (if you have to), type: - - make dvi - -3. To re-make the info files (if needed), type: - - make info - -4. To redo everything: - - make all - - "make all" is useful if you made your own changes to the *.texi or - *.el files. This way, this single command will recompile exactly what's - needed. - -5. You can also run - - make install - - to do what "make all" does plus to copy viper*.elc into - a suitable Lisp directory and Viper Info files into the Info - directory; DVI files containing printable version of Viper - Manual and Reference Card will be copied into the 'etc' directory. - - You will still have to edit the 'dir' file manually (see below), if - you haven't done so during a previous installation. - - To make all this happen, you will most likely have to change the PREFIX - variable in Makefile and, possibly, one or more of these variables: - - DATADIR, LISPDIR, INFODIR, ETCDIR, and VERSION - - if they don't point to the right directories in your installation. - You also need to have a write permission for all directories - mentioned in LISPDIR, INFODIR, and ETCDIR. - -6. XEmacs users must invoke make with the parameter EMACS=xemacs - or whatever name is used to invoke XEmacs (some backward sites - still use xemacs for Emacs 18). An even better thing would be to - edit Makefile directly as indicated in the comments there. -
--- a/lisp/viper/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'viper-autoloads) (error "Already loaded")) - -(provide 'viper-autoloads) - -;;;### (autoloads (viper-mode toggle-viper-mode) "viper" "viper/viper.el") - -(autoload 'toggle-viper-mode "viper" nil t nil) - -(autoload 'viper-mode "viper" "\ -Turn on Viper emulation of Vi." t nil) - -;;;***
--- a/lisp/viper/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - -;; Created by SL Baur on Sat Oct 4 18:11:54 1997 - -;;; Code: - -(custom-put 'viper-mouse 'custom-loads '("viper-mous")) -(custom-put 'viper-ex 'custom-loads '("viper-ex")) -(custom-put 'viper-highlighting 'custom-loads '("viper-init")) -(custom-put 'emulations 'custom-loads '("viper")) -(custom-put 'viper-misc 'custom-loads '("viper-cmd" "viper-init" "viper")) -(custom-put 'viper 'custom-loads '("viper-ex" "viper-init" "viper-keym" "viper-macs" "viper-mous" "viper")) - -;;; custom-load.el ends here
--- a/lisp/viper/viper-cmd.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4747 +0,0 @@ -;;; viper-cmd.el --- Vi command support for Viper -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Code - -(provide 'viper-cmd) -(require 'advice) - -;; Compiler pacifier -(defvar viper-minibuffer-current-face) -(defvar viper-minibuffer-insert-face) -(defvar viper-minibuffer-vi-face) -(defvar viper-minibuffer-emacs-face) -(defvar viper-always) -(defvar viper-mode-string) -(defvar viper-custom-file-name) -(defvar iso-accents-mode) -(defvar quail-mode) -(defvar quail-current-str) -(defvar zmacs-region-stays) -(defvar mark-even-if-inactive) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-keym) - (load "viper-keym.el" nil nil 'nosuffix)) - (or (featurep 'viper-mous) - (load "viper-mous.el" nil nil 'nosuffix)) - (or (featurep 'viper-macs) - (load "viper-macs.el" nil nil 'nosuffix)) - (or (featurep 'viper-ex) - (load "viper-ex.el" nil nil 'nosuffix)) - ))) -;; end pacifier - - -(require 'viper-util) -(require 'viper-keym) -(require 'viper-mous) -(require 'viper-macs) -(require 'viper-ex) - - - -;; Generic predicates - -;; These test functions are shamelessly lifted from vip 4.4.2 by Aamod Sane - -;; generate test functions -;; given symbol foo, foo-p is the test function, foos is the set of -;; Viper command keys -;; (macroexpand '(viper-test-com-defun foo)) -;; (defun foo-p (com) (consp (memq (if (< com 0) (- com) com) foos))) - -(defmacro viper-test-com-defun (name) - (let* ((snm (symbol-name name)) - (nm-p (intern (concat snm "-p"))) - (nms (intern (concat snm "s")))) - (` (defun (, nm-p) (com) - (consp (memq (if (and (viper-characterp com) (< com 0)) - (- com) com) (, nms))))))) - -;; Variables for defining VI commands - -;; Modifying commands that can be prefixes to movement commands -(defconst viper-prefix-commands '(?c ?d ?y ?! ?= ?# ?< ?> ?\")) -;; define viper-prefix-command-p -(viper-test-com-defun viper-prefix-command) - -;; Commands that are pairs eg. dd. r and R here are a hack -(defconst viper-charpair-commands '(?c ?d ?y ?! ?= ?< ?> ?r ?R)) -;; define viper-charpair-command-p -(viper-test-com-defun viper-charpair-command) - -(defconst viper-movement-commands '(?b ?B ?e ?E ?f ?F ?G ?h ?H ?j ?k ?l - ?H ?M ?L ?n ?t ?T ?w ?W ?$ ?% - ?^ ?( ?) ?- ?+ ?| ?{ ?} ?[ ?] ?' ?` - ?; ?, ?0 ?? ?/ ?\C-m ?\ - space return - delete backspace - ) - "Movement commands") -;; define viper-movement-command-p -(viper-test-com-defun viper-movement-command) - -;; Vi digit commands -(defconst viper-digit-commands '(?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - -;; define viper-digit-command-p -(viper-test-com-defun viper-digit-command) - -;; Commands that can be repeated by . (dotted) -(defconst viper-dotable-commands '(?c ?d ?C ?s ?S ?D ?> ?<)) -;; define viper-dotable-command-p -(viper-test-com-defun viper-dotable-command) - -;; Commands that can follow a # -(defconst viper-hash-commands '(?c ?C ?g ?q ?s)) -;; define viper-hash-command-p -(viper-test-com-defun viper-hash-command) - -;; Commands that may have registers as prefix -(defconst viper-regsuffix-commands '(?d ?y ?Y ?D ?p ?P ?x ?X)) -;; define viper-regsuffix-command-p -(viper-test-com-defun viper-regsuffix-command) - -(defconst viper-vi-commands (append viper-movement-commands - viper-digit-commands - viper-dotable-commands - viper-charpair-commands - viper-hash-commands - viper-prefix-commands - viper-regsuffix-commands) - "The list of all commands in Vi-state.") -;; define viper-vi-command-p -(viper-test-com-defun viper-vi-command) - - -;;; CODE - -;; sentinels - -;; Runs viper-after-change-functions inside after-change-functions -(defun viper-after-change-sentinel (beg end len) - (let ((list viper-after-change-functions)) - (while list - (funcall (car list) beg end len) - (setq list (cdr list))))) - -;; Runs viper-before-change-functions inside before-change-functions -(defun viper-before-change-sentinel (beg end) - (let ((list viper-before-change-functions)) - (while list - (funcall (car list) beg end) - (setq list (cdr list))))) - -(defsubst viper-post-command-sentinel () - (run-hooks 'viper-post-command-hooks)) - -(defsubst viper-pre-command-sentinel () - (run-hooks 'viper-pre-command-hooks)) - -;; Needed so that Viper will be able to figure the last inserted -;; chunk of text with reasonable accuracy. -(defsubst viper-insert-state-post-command-sentinel () - (if (and (memq viper-current-state '(insert-state replace-state)) - viper-insert-point - (>= (point) viper-insert-point)) - (setq viper-last-posn-while-in-insert-state (point-marker))) - (if (eq viper-current-state 'insert-state) - (progn - (or (stringp viper-saved-cursor-color) - (string= (viper-get-cursor-color) viper-insert-state-cursor-color) - (setq viper-saved-cursor-color (viper-get-cursor-color))) - (if (stringp viper-saved-cursor-color) - (viper-change-cursor-color viper-insert-state-cursor-color)) - )) - (if (and (eq this-command 'dabbrev-expand) - (integerp viper-pre-command-point) - (markerp viper-insert-point) - (marker-position viper-insert-point) - (> viper-insert-point viper-pre-command-point)) - (viper-move-marker-locally viper-insert-point viper-pre-command-point)) - ) - -(defsubst viper-insert-state-pre-command-sentinel () - (or (memq this-command '(self-insert-command)) - (memq (viper-event-key last-command-event) - '(up down left right (meta f) (meta b) - (control n) (control p) (control f) (control b))) - (viper-restore-cursor-color-after-insert)) - (if (and (eq this-command 'dabbrev-expand) - (markerp viper-insert-point) - (marker-position viper-insert-point)) - (setq viper-pre-command-point (marker-position viper-insert-point)))) - -(defsubst viper-R-state-post-command-sentinel () - ;; Restoring cursor color is needed despite - ;; viper-replace-state-pre-command-sentinel: When you jump to another buffer - ;; in another frame, the pre-command hook won't change cursor color to - ;; default in that other frame. So, if the second frame cursor was red and - ;; we set the point outside the replacement region, then the cursor color - ;; will remain red. Restoring the default, below, prevents this. - (if (and (<= (viper-replace-start) (point)) - (<= (point) (viper-replace-end))) - (viper-change-cursor-color viper-replace-overlay-cursor-color) - (viper-restore-cursor-color-after-replace) - )) - -;; to speed up, don't change cursor color before self-insert -;; and common move commands -(defsubst viper-replace-state-pre-command-sentinel () - (or (memq this-command '(self-insert-command)) - (memq (viper-event-key last-command-event) - '(up down left right (meta f) (meta b) - (control n) (control p) (control f) (control b))) - (viper-restore-cursor-color-after-replace))) - -(defun viper-replace-state-post-command-sentinel () - ;; Restoring cursor color is needed despite - ;; viper-replace-state-pre-command-sentinel: When one jumps to another buffer - ;; in another frame, the pre-command hook won't change cursor color to - ;; default in that other frame. So, if the second frame cursor was red and - ;; we set the point outside the replacement region, then the cursor color - ;; will remain red. Restoring the default, below, fixes this problem. - ;; - ;; We optimize for self-insert-command's here, since they either don't change - ;; cursor color or, if they terminate replace mode, the color will be changed - ;; in viper-finish-change - (or (memq this-command '(self-insert-command)) - (viper-restore-cursor-color-after-replace)) - (cond - ((eq viper-current-state 'replace-state) - ;; delete characters to compensate for inserted chars. - (let ((replace-boundary (viper-replace-end))) - (save-excursion - (goto-char viper-last-posn-in-replace-region) - (viper-trim-replace-chars-to-delete-if-necessary) - (delete-char viper-replace-chars-to-delete) - (setq viper-replace-chars-to-delete 0) - ;; terminate replace mode if reached replace limit - (if (= viper-last-posn-in-replace-region (viper-replace-end)) - (viper-finish-change))) - - (if (viper-pos-within-region - (point) (viper-replace-start) replace-boundary) - (progn - ;; the state may have changed in viper-finish-change above - (if (eq viper-current-state 'replace-state) - (viper-change-cursor-color viper-replace-overlay-cursor-color)) - (setq viper-last-posn-in-replace-region (point-marker)))) - )) - ;; terminate replace mode if changed Viper states. - (t (viper-finish-change)))) - - -;; changing mode - -;; Change state to NEW-STATE---either emacs-state, vi-state, or insert-state. -(defun viper-change-state (new-state) - ;; Keep viper-post/pre-command-hooks fresh. - ;; We remove then add viper-post/pre-command-sentinel since it is very - ;; desirable that viper-pre-command-sentinel is the last hook and - ;; viper-post-command-sentinel is the first hook. - (remove-hook 'post-command-hook 'viper-post-command-sentinel) - (add-hook 'post-command-hook 'viper-post-command-sentinel) - (remove-hook 'pre-command-hook 'viper-pre-command-sentinel) - (add-hook 'pre-command-hook 'viper-pre-command-sentinel t) - ;; These hooks will be added back if switching to insert/replace mode - (viper-remove-hook 'viper-post-command-hooks - 'viper-insert-state-post-command-sentinel) - (viper-remove-hook 'viper-pre-command-hooks - 'viper-insert-state-pre-command-sentinel) - (setq viper-intermediate-command nil) - (cond ((eq new-state 'vi-state) - (cond ((member viper-current-state '(insert-state replace-state)) - - ;; move viper-last-posn-while-in-insert-state - ;; This is a normal hook that is executed in insert/replace - ;; states after each command. In Vi/Emacs state, it does - ;; nothing. We need to execute it here to make sure that - ;; the last posn was recorded when we hit ESC. - ;; It may be left unrecorded if the last thing done in - ;; insert/repl state was dabbrev-expansion or abbrev - ;; expansion caused by hitting ESC - (viper-insert-state-post-command-sentinel) - - (condition-case conds - (progn - (viper-save-last-insertion - viper-insert-point - viper-last-posn-while-in-insert-state) - (if viper-began-as-replace - (setq viper-began-as-replace nil) - ;; repeat insert commands if numerical arg > 1 - (save-excursion - (viper-repeat-insert-command)))) - (error - (viper-message-conditions conds))) - - (if (> (length viper-last-insertion) 0) - (viper-push-onto-ring viper-last-insertion - 'viper-insertion-ring)) - - (if viper-ex-style-editing - (or (bolp) (backward-char 1)))) - )) - - ;; insert or replace - ((memq new-state '(insert-state replace-state)) - (if (memq viper-current-state '(emacs-state vi-state)) - (viper-move-marker-locally 'viper-insert-point (point))) - (viper-move-marker-locally - 'viper-last-posn-while-in-insert-state (point)) - (viper-add-hook 'viper-post-command-hooks - 'viper-insert-state-post-command-sentinel t) - (viper-add-hook 'viper-pre-command-hooks - 'viper-insert-state-pre-command-sentinel t)) - ) ; outermost cond - - ;; Nothing needs to be done to switch to emacs mode! Just set some - ;; variables, which is already done in viper-change-state-to-emacs! - - ;; ISO accents - ;; always turn off iso-accents-mode in vi-state, or else we won't be able to - ;; use the keys `,',^ , as they will do accents instead of Vi actions. - (cond ((eq new-state 'vi-state) (viper-set-iso-accents-mode nil));accents off - (viper-automatic-iso-accents (viper-set-iso-accents-mode t));accents on - (t (viper-set-iso-accents-mode nil))) - ;; Always turn off quail mode in vi state - (cond ((eq new-state 'vi-state) (viper-set-input-method nil)) ;intl input off - (viper-special-input-method (viper-set-input-method t)) ;intl input on - (t (viper-set-input-method nil))) - - (setq viper-current-state new-state) - - (viper-update-syntax-classes) - (viper-normalize-minor-mode-map-alist) - (viper-adjust-keys-for new-state) - (viper-set-mode-vars-for new-state) - (viper-refresh-mode-line) - ) - - - -(defun viper-adjust-keys-for (state) - "Make necessary adjustments to keymaps before entering STATE." - (cond ((memq state '(insert-state replace-state)) - (if viper-auto-indent - (progn - (define-key viper-insert-basic-map "\C-m" 'viper-autoindent) - (if viper-want-emacs-keys-in-insert - ;; expert - (define-key viper-insert-basic-map "\C-j" nil) - ;; novice - (define-key viper-insert-basic-map "\C-j" 'viper-autoindent))) - (define-key viper-insert-basic-map "\C-m" nil) - (define-key viper-insert-basic-map "\C-j" nil)) - - (setq viper-insert-diehard-minor-mode - (not viper-want-emacs-keys-in-insert)) - - (if viper-want-ctl-h-help - (progn - (define-key viper-insert-basic-map "\C-h" 'help-command) - (define-key viper-replace-map "\C-h" 'help-command)) - (define-key viper-insert-basic-map - "\C-h" 'viper-del-backward-char-in-insert) - (define-key viper-replace-map - "\C-h" 'viper-del-backward-char-in-replace)) - ;; In XEmacs, C-h overrides backspace, so we make sure it doesn't. - (define-key viper-insert-basic-map - [backspace] 'viper-del-backward-char-in-insert) - (define-key viper-replace-map - [backspace] 'viper-del-backward-char-in-replace) - ) ; end insert/replace case - (t ; Vi state - (setq viper-vi-diehard-minor-mode (not viper-want-emacs-keys-in-vi)) - (if viper-want-ctl-h-help - (define-key viper-vi-basic-map "\C-h" 'help-command) - (define-key viper-vi-basic-map "\C-h" 'viper-backward-char)) - ;; In XEmacs, C-h overrides backspace, so we make sure it doesn't. - (define-key viper-vi-basic-map [backspace] 'viper-backward-char)) - )) - - -;; Normalizes minor-mode-map-alist by putting Viper keymaps first. -;; This ensures that Viper bindings are in effect, regardless of which minor -;; modes were turned on by the user or by other packages. -(defun viper-normalize-minor-mode-map-alist () - (setq minor-mode-map-alist - (viper-append-filter-alist - (list - (cons 'viper-vi-intercept-minor-mode viper-vi-intercept-map) - (cons 'viper-vi-minibuffer-minor-mode viper-minibuffer-map) - (cons 'viper-vi-local-user-minor-mode viper-vi-local-user-map) - (cons 'viper-vi-kbd-minor-mode viper-vi-kbd-map) - (cons 'viper-vi-global-user-minor-mode viper-vi-global-user-map) - (cons 'viper-vi-state-modifier-minor-mode - (if (keymapp - (cdr (assoc major-mode - viper-vi-state-modifier-alist))) - (cdr (assoc major-mode viper-vi-state-modifier-alist)) - viper-empty-keymap)) - (cons 'viper-vi-diehard-minor-mode viper-vi-diehard-map) - (cons 'viper-vi-basic-minor-mode viper-vi-basic-map) - (cons 'viper-insert-intercept-minor-mode - viper-insert-intercept-map) - (cons 'viper-replace-minor-mode viper-replace-map) - ;; viper-insert-minibuffer-minor-mode must come after - ;; viper-replace-minor-mode - (cons 'viper-insert-minibuffer-minor-mode - viper-minibuffer-map) - (cons 'viper-insert-local-user-minor-mode - viper-insert-local-user-map) - (cons 'viper-insert-kbd-minor-mode viper-insert-kbd-map) - (cons 'viper-insert-global-user-minor-mode - viper-insert-global-user-map) - (cons 'viper-insert-state-modifier-minor-mode - (if (keymapp - (cdr (assoc major-mode - viper-insert-state-modifier-alist))) - (cdr (assoc major-mode - viper-insert-state-modifier-alist)) - viper-empty-keymap)) - (cons 'viper-insert-diehard-minor-mode viper-insert-diehard-map) - (cons 'viper-insert-basic-minor-mode viper-insert-basic-map) - (cons 'viper-emacs-intercept-minor-mode - viper-emacs-intercept-map) - (cons 'viper-emacs-local-user-minor-mode - viper-emacs-local-user-map) - (cons 'viper-emacs-kbd-minor-mode viper-emacs-kbd-map) - (cons 'viper-emacs-global-user-minor-mode - viper-emacs-global-user-map) - (cons 'viper-emacs-state-modifier-minor-mode - (if (keymapp - (cdr - (assoc major-mode viper-emacs-state-modifier-alist))) - (cdr - (assoc major-mode viper-emacs-state-modifier-alist)) - viper-empty-keymap)) - ) - minor-mode-map-alist))) - - - - - -;; Viper mode-changing commands and utilities - -;; Modifies mode-line-buffer-identification. -(defun viper-refresh-mode-line () - (setq viper-mode-string - (cond ((eq viper-current-state 'emacs-state) viper-emacs-state-id) - ((eq viper-current-state 'vi-state) viper-vi-state-id) - ((eq viper-current-state 'replace-state) viper-replace-state-id) - ((eq viper-current-state 'insert-state) viper-insert-state-id))) - - ;; Sets Viper mode string in global-mode-string - (force-mode-line-update)) - - -;; Switch from Insert state to Vi state. -(defun viper-exit-insert-state () - (interactive) - (viper-change-state-to-vi)) - -(defun viper-set-mode-vars-for (state) - "Sets Viper minor mode variables to put Viper's state STATE in effect." - - ;; Emacs state - (setq viper-vi-minibuffer-minor-mode nil - viper-insert-minibuffer-minor-mode nil - viper-vi-intercept-minor-mode nil - viper-insert-intercept-minor-mode nil - - viper-vi-local-user-minor-mode nil - viper-vi-kbd-minor-mode nil - viper-vi-global-user-minor-mode nil - viper-vi-state-modifier-minor-mode nil - viper-vi-diehard-minor-mode nil - viper-vi-basic-minor-mode nil - - viper-replace-minor-mode nil - - viper-insert-local-user-minor-mode nil - viper-insert-kbd-minor-mode nil - viper-insert-global-user-minor-mode nil - viper-insert-state-modifier-minor-mode nil - viper-insert-diehard-minor-mode nil - viper-insert-basic-minor-mode nil - viper-emacs-intercept-minor-mode t - viper-emacs-local-user-minor-mode t - viper-emacs-kbd-minor-mode (not (viper-is-in-minibuffer)) - viper-emacs-global-user-minor-mode t - viper-emacs-state-modifier-minor-mode t - ) - - ;; Vi state - (if (eq state 'vi-state) ; adjust for vi-state - (setq - viper-vi-intercept-minor-mode t - viper-vi-minibuffer-minor-mode (viper-is-in-minibuffer) - viper-vi-local-user-minor-mode t - viper-vi-kbd-minor-mode (not (viper-is-in-minibuffer)) - viper-vi-global-user-minor-mode t - viper-vi-state-modifier-minor-mode t - ;; don't let the diehard keymap block command completion - ;; and other things in the minibuffer - viper-vi-diehard-minor-mode (not - (or viper-want-emacs-keys-in-vi - (viper-is-in-minibuffer))) - viper-vi-basic-minor-mode t - viper-emacs-intercept-minor-mode nil - viper-emacs-local-user-minor-mode nil - viper-emacs-kbd-minor-mode nil - viper-emacs-global-user-minor-mode nil - viper-emacs-state-modifier-minor-mode nil - )) - - ;; Insert and Replace states - (if (member state '(insert-state replace-state)) - (setq - viper-insert-intercept-minor-mode t - viper-replace-minor-mode (eq state 'replace-state) - viper-insert-minibuffer-minor-mode (viper-is-in-minibuffer) - viper-insert-local-user-minor-mode t - viper-insert-kbd-minor-mode (not (viper-is-in-minibuffer)) - viper-insert-global-user-minor-mode t - viper-insert-state-modifier-minor-mode t - ;; don't let the diehard keymap block command completion - ;; and other things in the minibuffer - viper-insert-diehard-minor-mode (not - (or - viper-want-emacs-keys-in-insert - (viper-is-in-minibuffer))) - viper-insert-basic-minor-mode t - viper-emacs-intercept-minor-mode nil - viper-emacs-local-user-minor-mode nil - viper-emacs-kbd-minor-mode nil - viper-emacs-global-user-minor-mode nil - viper-emacs-state-modifier-minor-mode nil - )) - - ;; minibuffer faces - (if (viper-has-face-support-p) - (setq viper-minibuffer-current-face - (cond ((eq state 'emacs-state) viper-minibuffer-emacs-face) - ((eq state 'vi-state) viper-minibuffer-vi-face) - ((memq state '(insert-state replace-state)) - viper-minibuffer-insert-face)))) - - (if (viper-is-in-minibuffer) - (viper-set-minibuffer-overlay)) - ) - -;; This also takes care of the annoying incomplete lines in files. -;; Also, this fixes `undo' to work vi-style for complex commands. -(defun viper-change-state-to-vi () - "Change Viper state to Vi." - (interactive) - (if (and viper-first-time (not (viper-is-in-minibuffer))) - (viper-mode) - (if overwrite-mode (overwrite-mode nil)) - (if abbrev-mode (expand-abbrev)) - (if (and auto-fill-function (> (current-column) fill-column)) - (funcall auto-fill-function)) - ;; don't leave whitespace lines around - (if (and (memq last-command - '(viper-autoindent - viper-open-line viper-Open-line - viper-replace-state-exit-cmd)) - (viper-over-whitespace-line)) - (indent-to-left-margin)) - (viper-add-newline-at-eob-if-necessary) - (viper-adjust-undo) - (viper-change-state 'vi-state) - - (viper-restore-cursor-color-after-insert) - - ;; Protect against user errors in hooks - (condition-case conds - (run-hooks 'viper-vi-state-hook) - (error - (viper-message-conditions conds))))) - -(defun viper-change-state-to-insert () - "Change Viper state to Insert." - (interactive) - (viper-change-state 'insert-state) - - (or (stringp viper-saved-cursor-color) - (string= (viper-get-cursor-color) viper-insert-state-cursor-color) - (setq viper-saved-cursor-color (viper-get-cursor-color))) - ;; Commented out, because if viper-change-state-to-insert is executed - ;; non-interactively then the old cursor color may get lost. Same old Emacs - ;; bug related to local variables? -;;;(if (stringp viper-saved-cursor-color) -;;; (viper-change-cursor-color viper-insert-state-cursor-color)) - - ;; Protect against user errors in hooks - (condition-case conds - (run-hooks 'viper-insert-state-hook) - (error - (viper-message-conditions conds)))) - -(defsubst viper-downgrade-to-insert () - (setq viper-current-state 'insert-state - viper-replace-minor-mode nil)) - - - -;; Change to replace state. When the end of replacement region is reached, -;; replace state changes to insert state. -(defun viper-change-state-to-replace (&optional non-R-cmd) - (viper-change-state 'replace-state) - ;; Run insert-state-hook - (condition-case conds - (run-hooks 'viper-insert-state-hook 'viper-replace-state-hook) - (error - (viper-message-conditions conds))) - - (if non-R-cmd - (viper-start-replace) - ;; 'R' is implemented using Emacs's overwrite-mode - (viper-start-R-mode)) - ) - - -(defun viper-change-state-to-emacs () - "Change Viper state to Emacs." - (interactive) - (viper-change-state 'emacs-state) - - ;; Protect agains user errors in hooks - (condition-case conds - (run-hooks 'viper-emacs-state-hook) - (error - (viper-message-conditions conds)))) - -;; escape to emacs mode termporarily -(defun viper-escape-to-emacs (arg &optional events) - "Escape to Emacs state from Vi state for one Emacs command. -ARG is used as the prefix value for the executed command. If -EVENTS is a list of events, which become the beginning of the command." - (interactive "P") - (if (= last-command-char ?\\) - (message "Switched to EMACS state for the next command...")) - (viper-escape-to-state arg events 'emacs-state)) - -;; escape to Vi mode termporarily -(defun viper-escape-to-vi (arg) - "Escape from Emacs state to Vi state for one Vi 1-character command. -If the Vi command that the user types has a prefix argument, e.g., `d2w', then -Vi's prefix argument will be used. Otherwise, the prefix argument passed to -`viper-escape-to-vi' is used." - (interactive "P") - (message "Switched to VI state for the next command...") - (viper-escape-to-state arg nil 'vi-state)) - -;; Escape to STATE mode for one Emacs command. -(defun viper-escape-to-state (arg events state) - ;;(let (com key prefix-arg) - (let (com key) - ;; this temporarily turns off Viper's minor mode keymaps - (viper-set-mode-vars-for state) - (viper-normalize-minor-mode-map-alist) - (if events (viper-set-unread-command-events events)) - - ;; protect against keyboard quit and other errors - (condition-case nil - (let (viper-vi-kbd-minor-mode - viper-insert-kbd-minor-mode - viper-emacs-kbd-minor-mode) - (unwind-protect - (progn - (setq com (key-binding (setq key - (if viper-xemacs-p - (read-key-sequence nil) - (read-key-sequence nil t))))) - ;; In case of binding indirection--chase definitions. - ;; Have to do it here because we execute this command under - ;; different keymaps, so command-execute may not do the - ;; right thing there - (while (vectorp com) (setq com (key-binding com)))) - nil) - ;; Execute command com in the original Viper state, not in state - ;; `state'. Otherwise, if we switch buffers while executing the - ;; escaped to command, Viper's mode vars will remain those of - ;; `state'. When we return to the orig buffer, the bindings will be - ;; screwed up. - (viper-set-mode-vars-for viper-current-state) - - ;; this-command, last-command-char, last-command-event - (setq this-command com) - (if viper-xemacs-p ; XEmacs represents key sequences as vectors - (setq last-command-event - (viper-copy-event (viper-seq-last-elt key)) - last-command-char (event-to-character last-command-event)) - ;; Emacs represents them as sequences (str or vec) - (setq last-command-event - (viper-copy-event (viper-seq-last-elt key)) - last-command-char last-command-event)) - - (if (commandp com) - (progn - (setq prefix-arg (or prefix-arg arg)) - (command-execute com))) - ) - (quit (ding)) - (error (beep 1)))) - ;; set state in the new buffer - (viper-set-mode-vars-for viper-current-state)) - -(defun viper-exec-form-in-vi (form) - "Execute FORM in Vi state, regardless of the Ccurrent Vi state." - (let ((buff (current-buffer)) - result) - (viper-set-mode-vars-for 'vi-state) - - (condition-case nil - (let (viper-vi-kbd-minor-mode) ; execute without kbd macros - (setq result (eval form)) - ) - (error - (signal 'quit nil))) - - (if (not (equal buff (current-buffer))) ; cmd switched buffer - (save-excursion - (set-buffer buff) - (viper-set-mode-vars-for viper-current-state))) - (viper-set-mode-vars-for viper-current-state) - result)) - -(defun viper-exec-form-in-emacs (form) - "Execute FORM in Emacs, temporarily disabling Viper's minor modes. -Similar to viper-escape-to-emacs, but accepts forms rather than keystrokes." - (let ((buff (current-buffer)) - result) - (viper-set-mode-vars-for 'emacs-state) - (setq result (eval form)) - (if (not (equal buff (current-buffer))) ; cmd switched buffer - (save-excursion - (set-buffer buff) - (viper-set-mode-vars-for viper-current-state))) - (viper-set-mode-vars-for viper-current-state) - result)) - - -;; This is needed because minor modes sometimes override essential Viper -;; bindings. By letting Viper know which files these modes are in, it will -;; arrange to reorganize minor-mode-map-alist so that things will work right. -(defun viper-harness-minor-mode (load-file) - "Familiarize Viper with a minor mode defined in LOAD_FILE. -Minor modes that have their own keymaps may overshadow Viper keymaps. -This function is designed to make Viper aware of the packages that define -such minor modes. -Usage: - (viper-harness-minor-mode load-file) - -LOAD-FILE is a name of the file where the specific minor mode is defined. -Suffixes such as .el or .elc should be stripped." - - (interactive "sEnter name of the load file: ") - - (eval-after-load load-file '(viper-normalize-minor-mode-map-alist)) - - ;; Change the default for minor-mode-map-alist each time a harnessed minor - ;; mode adds its own keymap to the a-list. - (eval-after-load - load-file '(setq-default minor-mode-map-alist minor-mode-map-alist)) - ) - - -(defun viper-ESC (arg) - "Emulate ESC key in Emacs. -Prevents multiple escape keystrokes if viper-no-multiple-ESC is true. -If viper-no-multiple-ESC is 'twice double ESC would ding in vi-state. -Other ESC sequences are emulated via the current Emacs's major mode -keymap. This is more convenient on TTYs, since this won't block -function keys such as up,down, etc. ESC will also will also work as -a Meta key in this case. When viper-no-multiple-ESC is nil, ESC functions -as a Meta key and any number of multiple escapes is allowed." - (interactive "P") - (let (char) - (cond ((and (not viper-no-multiple-ESC) (eq viper-current-state 'vi-state)) - (setq char (viper-read-char-exclusive)) - (viper-escape-to-emacs arg (list ?\e char) )) - ((and (eq viper-no-multiple-ESC 'twice) - (eq viper-current-state 'vi-state)) - (setq char (viper-read-char-exclusive)) - (if (= char (string-to-char viper-ESC-key)) - (ding) - (viper-escape-to-emacs arg (list ?\e char) ))) - (t (ding))) - )) - -(defun viper-alternate-Meta-key (arg) - "Simulate Emacs Meta key." - (interactive "P") - (sit-for 1) (message "ESC-") - (viper-escape-to-emacs arg '(?\e))) - -(defun viper-toggle-key-action () - "Action bound to `viper-toggle-key'." - (interactive) - (if (and (< viper-expert-level 2) (equal viper-toggle-key "\C-z")) - (if (viper-window-display-p) - (viper-iconify) - (suspend-emacs)) - (viper-change-state-to-emacs))) - - -;; Intercept ESC sequences on dumb terminals. -;; Based on the idea contributed by Marcelino Veiga Tuimil <mveiga@dit.upm.es> - -;; Check if last key was ESC and if so try to reread it as a function key. -;; But only if there are characters to read during a very short time. -;; Returns the last event, if any. -(defun viper-envelop-ESC-key () - (let ((event last-input-event) - (keyseq [nil]) - inhibit-quit) - (if (viper-ESC-event-p event) - (progn - (if (viper-fast-keysequence-p) - (progn - (let (minor-mode-map-alist) - (viper-set-unread-command-events event) - (setq keyseq - (funcall - (ad-get-orig-definition 'read-key-sequence) nil)) - ) ; let - ;; If keyseq translates into something that still has ESC - ;; at the beginning, separate ESC from the rest of the seq. - ;; In XEmacs we check for events that are keypress meta-key - ;; and convert them into [escape key] - ;; - ;; This is needed for the following reason: - ;; If ESC is the first symbol, we interpret it as if the - ;; user typed ESC and then quickly some other symbols. - ;; If ESC is not the first one, then the key sequence - ;; entered was apparently translated into a function key or - ;; something (e.g., one may have - ;; (define-key function-key-map "\e[192z" [f11]) - ;; which would translate the escape-sequence generated by - ;; f11 in an xterm window into the symbolic key f11. - ;; - ;; If `first-key' is not an ESC event, we make it into the - ;; last-command-event in order to pretend that this key was - ;; pressed. This is needed to allow arrow keys to be bound to - ;; macros. Otherwise, viper-exec-mapped-kbd-macro will think - ;; that the last event was ESC and so it'll execute whatever is - ;; bound to ESC. (Viper macros can't be bound to - ;; ESC-sequences). - (let* ((first-key (elt keyseq 0)) - (key-mod (event-modifiers first-key))) - (cond ((viper-ESC-event-p first-key) - ;; put keys following ESC on the unread list - ;; and return ESC as the key-sequence - (viper-set-unread-command-events (subseq keyseq 1)) - (setq last-input-event event - keyseq (if viper-emacs-p - "\e" - (vector (character-to-event ?\e))))) - ((and viper-xemacs-p - (key-press-event-p first-key) - (equal '(meta) key-mod)) - (viper-set-unread-command-events - (vconcat (vector - (character-to-event (event-key first-key))) - (subseq keyseq 1))) - (setq last-input-event event - keyseq (vector (character-to-event ?\e)))) - ((eventp first-key) - (setq last-command-event - (viper-copy-event first-key))) - )) - ) ; end progn - - ;; this is escape event with nothing after it - ;; put in unread-command-event and then re-read - (viper-set-unread-command-events event) - (setq keyseq - (funcall (ad-get-orig-definition 'read-key-sequence) nil)) - )) - ;; not an escape event - (setq keyseq (vector event))) - keyseq)) - - - -;; Listen to ESC key. -;; If a sequence of keys starting with ESC is issued with very short delays, -;; interpret these keys in Emacs mode, so ESC won't be interpreted as a Vi key. -(defun viper-intercept-ESC-key () - "Function that implements ESC key in Viper emulation of Vi." - (interactive) - (let ((cmd (or (key-binding (viper-envelop-ESC-key)) - '(lambda () (interactive) (error ""))))) - - ;; call the actual function to execute ESC (if no other symbols followed) - ;; or the key bound to the ESC sequence (if the sequence was issued - ;; with very short delay between characters. - (if (eq cmd 'viper-intercept-ESC-key) - (setq cmd - (cond ((eq viper-current-state 'vi-state) - 'viper-ESC) - ((eq viper-current-state 'insert-state) - 'viper-exit-insert-state) - ((eq viper-current-state 'replace-state) - 'viper-replace-state-exit-cmd) - (t 'viper-change-state-to-vi) - ))) - (call-interactively cmd))) - - - - -;; prefix argument for Vi mode - -;; In Vi mode, prefix argument is a dotted pair (NUM . COM) where NUM -;; represents the numeric value of the prefix argument and COM represents -;; command prefix such as "c", "d", "m" and "y". - -;; Get value part of prefix-argument ARG. -(defsubst viper-p-val (arg) - (cond ((null arg) 1) - ((consp arg) - (if (or (null (car arg)) (equal (car arg) '(nil))) - 1 (car arg))) - (t arg))) - -;; Get raw value part of prefix-argument ARG. -(defsubst viper-P-val (arg) - (cond ((consp arg) (car arg)) - (t arg))) - -;; Get com part of prefix-argument ARG. -(defsubst viper-getcom (arg) - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - (t nil))) - -;; Get com part of prefix-argument ARG and modify it. -(defun viper-getCom (arg) - (let ((com (viper-getcom arg))) - (cond ((equal com ?c) ?c) - ;; Previously, ?c was being converted to ?C, but this prevented - ;; multiline replace regions. - ;;((equal com ?c) ?C) - ((equal com ?d) ?D) - ((equal com ?y) ?Y) - (t com)))) - - -;; Compute numeric prefix arg value. -;; Invoked by EVENT. COM is the command part obtained so far. -(defun viper-prefix-arg-value (event com) - (let ((viper-intermediate-command 'viper-digit-argument) - value func) - ;; read while number - (while (and (viper-characterp event) (>= event ?0) (<= event ?9)) - (setq value (+ (* (if (integerp value) value 0) 10) (- event ?0))) - (setq event (viper-read-event-convert-to-char))) - - (setq prefix-arg value) - (if com (setq prefix-arg (cons prefix-arg com))) - (while (eq event ?U) - (viper-describe-arg prefix-arg) - (setq event (viper-read-event-convert-to-char))) - - (if (or com (and (not (eq viper-current-state 'vi-state)) - ;; make sure it is a Vi command - (viper-characterp event) (viper-vi-command-p event) - )) - ;; If appears to be one of the vi commands, - ;; then execute it with funcall and clear prefix-arg in order to not - ;; confuse subsequent commands - (progn - ;; last-command-char is the char we want emacs to think was typed - ;; last. If com is not nil, the viper-digit-argument command was - ;; called from within viper-prefix-arg command, such as `d', `w', - ;; etc., i.e., the user typed, say, d2. In this case, `com' would be - ;; `d', `w', etc. If viper-digit-argument was invoked by - ;; viper-escape-to-vi (which is indicated by the fact that the - ;; current state is not vi-state), then `event' represents the vi - ;; command to be executed (e.g., `d', `w', etc). Again, - ;; last-command-char must make emacs believe that this is the command - ;; we typed. - (cond ((eq event 'return) (setq event ?\C-m)) - ((eq event 'delete) (setq event ?\C-?)) - ((eq event 'backspace) (setq event ?\C-h)) - ((eq event 'space) (setq event ?\ ))) - (setq last-command-char (or com event)) - (setq func (viper-exec-form-in-vi - (` (key-binding (char-to-string (, event)))))) - (funcall func prefix-arg) - (setq prefix-arg nil)) - ;; some other command -- let emacs do it in its own way - (viper-set-unread-command-events event)) - )) - - -;; Vi operator as prefix argument." -(defun viper-prefix-arg-com (char value com) - (let ((cont t) - cmd-info - cmd-to-exec-at-end) - (while (and cont - (memq char - (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\" - viper-buffer-search-char))) - (if com - ;; this means that we already have a command character, so we - ;; construct a com list and exit while. however, if char is " - ;; it is an error. - (progn - ;; new com is (CHAR . OLDCOM) - (if (memq char '(?# ?\")) (error "")) - (setq com (cons char com)) - (setq cont nil)) - ;; If com is nil we set com as char, and read more. Again, if char is - ;; ", we read the name of register and store it in viper-use-register. - ;; if char is !, =, or #, a complete com is formed so we exit the while - ;; loop. - (cond ((memq char '(?! ?=)) - (setq com char) - (setq char (read-char)) - (setq cont nil)) - ((= char ?#) - ;; read a char and encode it as com - (setq com (+ 128 (read-char))) - (setq char (read-char))) - ((= char ?\") - (let ((reg (read-char))) - (if (viper-valid-register reg) - (setq viper-use-register reg) - (error "")) - (setq char (read-char)))) - (t - (setq com char) - (setq char (read-char)))))) - - (if (atom com) - ;; `com' is a single char, so we construct the command argument - ;; and if `char' is `?', we describe the arg; otherwise - ;; we prepare the command that will be executed at the end. - (progn - (setq cmd-info (cons value com)) - (while (= char ?U) - (viper-describe-arg cmd-info) - (setq char (read-char))) - ;; `char' is a movement cmd, a digit arg cmd, or a register cmd---so we - ;; execute it at the very end - (or (viper-movement-command-p char) - (viper-digit-command-p char) - (viper-regsuffix-command-p char) - (= char ?!) ; bang command - (error "")) - (setq cmd-to-exec-at-end - (viper-exec-form-in-vi - (` (key-binding (char-to-string (, char))))))) - - ;; as com is non-nil, this means that we have a command to execute - (if (memq (car com) '(?r ?R)) - ;; execute apropriate region command. - (let ((char (car com)) (com (cdr com))) - (setq prefix-arg (cons value com)) - (if (= char ?r) (viper-region prefix-arg) - (viper-Region prefix-arg)) - ;; reset prefix-arg - (setq prefix-arg nil)) - ;; otherwise, reset prefix arg and call appropriate command - (setq value (if (null value) 1 value)) - (setq prefix-arg nil) - (cond - ;; If we change ?C to ?c here, then cc will enter replacement mode - ;; rather than deleting lines. However, it will affect 1 less line than - ;; normal. We decided to not use replacement mode here and follow Vi, - ;; since replacement mode on n full lines can be achieved with nC. - ((equal com '(?c . ?c)) (viper-line (cons value ?C))) - ((equal com '(?d . ?d)) (viper-line (cons value ?D))) - ((equal com '(?d . ?y)) (viper-yank-defun)) - ((equal com '(?y . ?y)) (viper-line (cons value ?Y))) - ((equal com '(?< . ?<)) (viper-line (cons value ?<))) - ((equal com '(?> . ?>)) (viper-line (cons value ?>))) - ((equal com '(?! . ?!)) (viper-line (cons value ?!))) - ((equal com '(?= . ?=)) (viper-line (cons value ?=))) - (t (error ""))))) - - (if cmd-to-exec-at-end - (progn - (setq last-command-char char) - (setq last-command-event - (viper-copy-event - (if viper-xemacs-p (character-to-event char) char))) - (condition-case nil - (funcall cmd-to-exec-at-end cmd-info) - (error - (error ""))))) - )) - -(defun viper-describe-arg (arg) - (let (val com) - (setq val (viper-P-val arg) - com (viper-getcom arg)) - (if (null val) - (if (null com) - (message "Value is nil, and command is nil") - (message "Value is nil, and command is `%c'" com)) - (if (null com) - (message "Value is `%d', and command is nil" val) - (message "Value is `%d', and command is `%c'" val com))))) - -(defun viper-digit-argument (arg) - "Begin numeric argument for the next command." - (interactive "P") - (viper-leave-region-active) - (viper-prefix-arg-value - last-command-char (if (consp arg) (cdr arg) nil))) - -(defun viper-command-argument (arg) - "Accept a motion command as an argument." - (interactive "P") - (let ((viper-intermediate-command 'viper-command-argument)) - (condition-case nil - (viper-prefix-arg-com - last-command-char - (cond ((null arg) nil) - ((consp arg) (car arg)) - ((integerp arg) arg) - (t (error viper-InvalidCommandArgument))) - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - ((integerp arg) nil) - (t (error viper-InvalidCommandArgument)))) - (quit (setq viper-use-register nil) - (signal 'quit nil))) - (viper-deactivate-mark))) - - -;; repeat last destructive command - -;; Append region to text in register REG. -;; START and END are buffer positions indicating what to append. -(defsubst viper-append-to-register (reg start end) - (set-register reg (concat (if (stringp (get-register reg)) - (get-register reg) "") - (buffer-substring start end)))) - -;; Saves last inserted text for possible use by viper-repeat command. -(defun viper-save-last-insertion (beg end) - (condition-case nil - (setq viper-last-insertion (buffer-substring beg end)) - (error - ;; beg or end marker are somehow screwed up - (setq viper-last-insertion nil))) - (setq viper-last-insertion (buffer-substring beg end)) - (or (< (length viper-d-com) 5) - (setcar (nthcdr 4 viper-d-com) viper-last-insertion)) - (or (null viper-command-ring) - (ring-empty-p viper-command-ring) - (progn - (setcar (nthcdr 4 (viper-current-ring-item viper-command-ring)) - viper-last-insertion) - ;; del most recent elt, if identical to the second most-recent - (viper-cleanup-ring viper-command-ring))) - ) - -(defsubst viper-yank-last-insertion () - "Inserts the text saved by the previous viper-save-last-insertion command." - (condition-case nil - (insert viper-last-insertion) - (error nil))) - - -;; define functions to be executed - -;; invoked by the `C' command -(defun viper-exec-change (m-com com) - (or (and (markerp viper-com-point) (marker-position viper-com-point)) - (set-marker viper-com-point (point) (current-buffer))) - ;; handle C cmd at the eol and at eob. - (if (or (and (eolp) (= viper-com-point (point))) - (= viper-com-point (point-max))) - (progn - (insert " ")(backward-char 1))) - (if (= viper-com-point (point)) - (viper-forward-char-carefully)) - (set-mark viper-com-point) - (if (eq m-com 'viper-next-line-at-bol) - (viper-enlarge-region (mark t) (point))) - (if (< (point) (mark t)) - (exchange-point-and-mark)) - (if (eq (preceding-char) ?\n) - (viper-backward-char-carefully)) ; give back the newline - (if (= com ?c) - (viper-change (mark t) (point)) - (viper-change-subr (mark t) (point)))) - -;; this is invoked by viper-substitute-line -(defun viper-exec-Change (m-com com) - (save-excursion - (set-mark viper-com-point) - (viper-enlarge-region (mark t) (point)) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '(letter digit)) - (copy-to-register - viper-use-register (mark t) (point) nil)) - ((viper-valid-register viper-use-register '(Letter)) - (viper-append-to-register - (downcase viper-use-register) (mark t) (point))) - (t (setq viper-use-register nil) - (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - (delete-region (mark t) (point))) - (open-line 1) - (if (= com ?C) - (viper-change-state-to-insert) - (viper-yank-last-insertion))) - -(defun viper-exec-delete (m-com com) - (or (and (markerp viper-com-point) (marker-position viper-com-point)) - (set-marker viper-com-point (point) (current-buffer))) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '(letter digit)) - (copy-to-register - viper-use-register viper-com-point (point) nil)) - ((viper-valid-register viper-use-register '(Letter)) - (viper-append-to-register - (downcase viper-use-register) viper-com-point (point))) - (t (setq viper-use-register nil) - (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - (setq last-command - (if (eq last-command 'd-command) 'kill-region nil)) - (kill-region viper-com-point (point)) - (setq this-command 'd-command) - (if viper-ex-style-motion - (if (and (eolp) (not (bolp))) (backward-char 1)))) - -(defun viper-exec-Delete (m-com com) - (save-excursion - (set-mark viper-com-point) - (viper-enlarge-region (mark t) (point)) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '(letter digit)) - (copy-to-register - viper-use-register (mark t) (point) nil)) - ((viper-valid-register viper-use-register '(Letter)) - (viper-append-to-register - (downcase viper-use-register) (mark t) (point))) - (t (setq viper-use-register nil) - (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - (setq last-command - (if (eq last-command 'D-command) 'kill-region nil)) - (kill-region (mark t) (point)) - (if (eq m-com 'viper-line) (setq this-command 'D-command))) - (back-to-indentation)) - -(defun viper-exec-yank (m-com com) - (or (and (markerp viper-com-point) (marker-position viper-com-point)) - (set-marker viper-com-point (point) (current-buffer))) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '(letter digit)) - (copy-to-register - viper-use-register viper-com-point (point) nil)) - ((viper-valid-register viper-use-register '(Letter)) - (viper-append-to-register - (downcase viper-use-register) viper-com-point (point))) - (t (setq viper-use-register nil) - (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - (setq last-command nil) - (copy-region-as-kill viper-com-point (point)) - (goto-char viper-com-point)) - -(defun viper-exec-Yank (m-com com) - (save-excursion - (set-mark viper-com-point) - (viper-enlarge-region (mark t) (point)) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '(letter digit)) - (copy-to-register - viper-use-register (mark t) (point) nil)) - ((viper-valid-register viper-use-register '(Letter)) - (viper-append-to-register - (downcase viper-use-register) (mark t) (point))) - (t (setq viper-use-register nil) - (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - (setq last-command nil) - (copy-region-as-kill (mark t) (point))) - (viper-deactivate-mark) - (goto-char viper-com-point)) - -(defun viper-exec-bang (m-com com) - (save-excursion - (set-mark viper-com-point) - (viper-enlarge-region (mark t) (point)) - (exchange-point-and-mark) - (shell-command-on-region - (mark t) (point) - (if (= com ?!) - (setq viper-last-shell-com - (viper-read-string-with-history - "!" - nil - 'viper-shell-history - (car viper-shell-history) - )) - viper-last-shell-com) - t))) - -(defun viper-exec-equals (m-com com) - (save-excursion - (set-mark viper-com-point) - (viper-enlarge-region (mark t) (point)) - (if (> (mark t) (point)) (exchange-point-and-mark)) - (indent-region (mark t) (point) nil))) - -(defun viper-exec-shift (m-com com) - (save-excursion - (set-mark viper-com-point) - (viper-enlarge-region (mark t) (point)) - (if (> (mark t) (point)) (exchange-point-and-mark)) - (indent-rigidly (mark t) (point) - (if (= com ?>) - viper-shift-width - (- viper-shift-width)))) - ;; return point to where it was before shift - (goto-char viper-com-point)) - -;; this is needed because some commands fake com by setting it to ?r, which -;; denotes repeated insert command. -(defsubst viper-exec-dummy (m-com com) - nil) - -(defun viper-exec-buffer-search (m-com com) - (setq viper-s-string (buffer-substring (point) viper-com-point)) - (setq viper-s-forward t) - (setq viper-search-history (cons viper-s-string viper-search-history)) - (viper-search viper-s-string viper-s-forward 1)) - -(defvar viper-exec-array (make-vector 128 nil)) - -;; Using a dispatch array allows adding functions like buffer search -;; without affecting other functions. Buffer search can now be bound -;; to any character. - -(aset viper-exec-array ?c 'viper-exec-change) -(aset viper-exec-array ?C 'viper-exec-Change) -(aset viper-exec-array ?d 'viper-exec-delete) -(aset viper-exec-array ?D 'viper-exec-Delete) -(aset viper-exec-array ?y 'viper-exec-yank) -(aset viper-exec-array ?Y 'viper-exec-Yank) -(aset viper-exec-array ?r 'viper-exec-dummy) -(aset viper-exec-array ?! 'viper-exec-bang) -(aset viper-exec-array ?< 'viper-exec-shift) -(aset viper-exec-array ?> 'viper-exec-shift) -(aset viper-exec-array ?= 'viper-exec-equals) - - - -;; This function is called by various movement commands to execute a -;; destructive command on the region specified by the movement command. For -;; instance, if the user types cw, then the command viper-forward-word will -;; call viper-execute-com to execute viper-exec-change, which eventually will -;; call viper-change to invoke the replace mode on the region. -;; -;; The var viper-d-com is set to (M-COM VAL COM REG INSETED-TEXT COMMAND-KEYS) -;; via a call to viper-set-destructive-command, for later use by viper-repeat. -(defun viper-execute-com (m-com val com) - (let ((reg viper-use-register)) - ;; this is the special command `#' - (if (> com 128) - (viper-special-prefix-com (- com 128)) - (let ((fn (aref viper-exec-array (if (< com 0) (- com) com)))) - (if (null fn) - (error "%c: %s" com viper-InvalidViCommand) - (funcall fn m-com com)))) - (if (viper-dotable-command-p com) - (viper-set-destructive-command - (list m-com val - (if (memq com (list ?c ?C ?!)) (- com) com) - reg nil nil))) - )) - - -(defun viper-repeat (arg) - "Re-execute last destructive command. -Use the info in viper-d-com, which has the form -\(com val ch reg inserted-text command-keys\), -where `com' is the command to be re-executed, `val' is the -argument to `com', `ch' is a flag for repeat, and `reg' is optional; -if it exists, it is the name of the register for `com'. -If the prefix argument, ARG, is non-nil, it is used instead of `val'." - (interactive "P") - (let ((save-point (point)) ; save point before repeating prev cmd - ;; Pass along that we are repeating a destructive command - ;; This tells viper-set-destructive-command not to update - ;; viper-command-ring - (viper-intermediate-command 'viper-repeat)) - (if (eq last-command 'viper-undo) - ;; if the last command was viper-undo, then undo-more - (viper-undo-more) - ;; otherwise execute the command stored in viper-d-com. if arg is - ;; non-nil its prefix value is used as new prefix value for the command. - (let ((m-com (car viper-d-com)) - (val (viper-P-val arg)) - (com (nth 2 viper-d-com)) - (reg (nth 3 viper-d-com))) - (if (null val) (setq val (nth 1 viper-d-com))) - (if (null m-com) (error "No previous command to repeat.")) - (setq viper-use-register reg) - (if (nth 4 viper-d-com) ; text inserted by command - (setq viper-last-insertion (nth 4 viper-d-com) - viper-d-char (nth 4 viper-d-com))) - (funcall m-com (cons val com)) - (cond ((and (< save-point (point)) viper-keep-point-on-repeat) - (goto-char save-point)) ; go back to before repeat. - ((and (< save-point (point)) viper-ex-style-editing) - (or (bolp) (backward-char 1)))) - (if (and (eolp) (not (bolp))) - (backward-char 1)) - )) - (viper-adjust-undo) ; take care of undo - ;; If the prev cmd was rotating the command ring, this means that `.' has - ;; just executed a command from that ring. So, push it on the ring again. - ;; If we are just executing previous command , then don't push viper-d-com - ;; because viper-d-com is not fully constructed in this case (its keys and - ;; the inserted text may be nil). Besides, in this case, the command - ;; executed by `.' is already on the ring. - (if (eq last-command 'viper-display-current-destructive-command) - (viper-push-onto-ring viper-d-com 'viper-command-ring)) - (viper-deactivate-mark) - )) - -(defun viper-repeat-from-history () - "Repeat a destructive command from history. -Doesn't change viper-command-ring in any way, so `.' will work as before -executing this command. -This command is supposed to be bound to a two-character Vi macro where -the second character is a digit 0 to 9. The digit indicates which -history command to execute. `<char>0' is equivalent to `.', `<char>1' -invokes the command before that, etc." - (interactive) - (let* ((viper-intermediate-command 'repeating-display-destructive-command) - (idx (cond (viper-this-kbd-macro - (string-to-number - (symbol-name (elt viper-this-kbd-macro 1)))) - (t 0))) - (num idx) - (viper-d-com viper-d-com)) - - (or (and (numberp num) (<= 0 num) (<= num 9)) - (progn - (setq idx 0 - num 0) - (message - "`viper-repeat-from-history' must be invoked as a Vi macro bound to `<key><digit>'"))) - (while (< 0 num) - (setq viper-d-com (viper-special-ring-rotate1 viper-command-ring -1)) - (setq num (1- num))) - (viper-repeat nil) - (while (> idx num) - (viper-special-ring-rotate1 viper-command-ring 1) - (setq num (1+ num))) - )) - - -;; The hash-command. It is invoked interactively by the key sequence #<char>. -;; The chars that can follow `#' are determined by viper-hash-command-p -(defun viper-special-prefix-com (char) - (cond ((= char ?c) - (downcase-region (min viper-com-point (point)) - (max viper-com-point (point)))) - ((= char ?C) - (upcase-region (min viper-com-point (point)) - (max viper-com-point (point)))) - ((= char ?g) - (push-mark viper-com-point t) - (viper-global-execute)) - ((= char ?q) - (push-mark viper-com-point t) - (viper-quote-region)) - ((= char ?s) (funcall viper-spell-function viper-com-point (point))) - (t (error "#%c: %s" char viper-InvalidViCommand)))) - - -;; undoing - -(defun viper-undo () - "Undo previous change." - (interactive) - (message "undo!") - (let ((modified (buffer-modified-p)) - (before-undo-pt (point-marker)) - (after-change-functions after-change-functions) - undo-beg-posn undo-end-posn) - - ;; no need to remove this hook, since this var has scope inside a let. - (add-hook 'after-change-functions - '(lambda (beg end len) - (setq undo-beg-posn beg - undo-end-posn (or end beg)))) - - (undo-start) - (undo-more 2) - (setq undo-beg-posn (or undo-beg-posn before-undo-pt) - undo-end-posn (or undo-end-posn undo-beg-posn)) - - (goto-char undo-beg-posn) - (sit-for 0) - (if (and viper-keep-point-on-undo - (pos-visible-in-window-p before-undo-pt)) - (progn - (push-mark (point-marker) t) - (viper-sit-for-short 300) - (goto-char undo-end-posn) - (viper-sit-for-short 300) - (if (and (> (viper-chars-in-region undo-beg-posn before-undo-pt) 1) - (> (viper-chars-in-region undo-end-posn before-undo-pt) 1)) - (goto-char before-undo-pt) - (goto-char undo-beg-posn))) - (push-mark before-undo-pt t)) - (if (and (eolp) (not (bolp))) (backward-char 1)) - (if (not modified) (set-buffer-modified-p t))) - (setq this-command 'viper-undo)) - -;; Continue undoing previous changes. -(defun viper-undo-more () - (message "undo more!") - (condition-case nil - (undo-more 1) - (error (beep) - (message "No further undo information in this buffer"))) - (if (and (eolp) (not (bolp))) (backward-char 1)) - (setq this-command 'viper-undo)) - -;; The following two functions are used to set up undo properly. -;; In VI, unlike Emacs, if you open a line, say, and add a bunch of lines, -;; they are undone all at once. -(defun viper-adjust-undo () - (if viper-undo-needs-adjustment - (let ((inhibit-quit t) - tmp tmp2) - (setq viper-undo-needs-adjustment nil) - (if (listp buffer-undo-list) - (if (setq tmp (memq viper-buffer-undo-list-mark buffer-undo-list)) - (progn - (setq tmp2 (cdr tmp)) ; the part after mark - - ;; cut tail from buffer-undo-list temporarily by direct - ;; manipulation with pointers in buffer-undo-list - (setcdr tmp nil) - - (setq buffer-undo-list (delq nil buffer-undo-list)) - (setq buffer-undo-list - (delq viper-buffer-undo-list-mark buffer-undo-list)) - ;; restore tail of buffer-undo-list - (setq buffer-undo-list (nconc buffer-undo-list tmp2))) - (setq buffer-undo-list (delq nil buffer-undo-list))))) - )) - - -(defun viper-set-complex-command-for-undo () - (if (listp buffer-undo-list) - (if (not viper-undo-needs-adjustment) - (let ((inhibit-quit t)) - (setq buffer-undo-list - (cons viper-buffer-undo-list-mark buffer-undo-list)) - (setq viper-undo-needs-adjustment t))))) - - - - -(defun viper-display-current-destructive-command () - (let ((text (nth 4 viper-d-com)) - (keys (nth 5 viper-d-com)) - (max-text-len 30)) - - (setq this-command 'viper-display-current-destructive-command) - - (message " `.' runs %s%s" - (concat "`" (viper-array-to-string keys) "'") - (viper-abbreviate-string - (if viper-xemacs-p - (replace-in-string - (cond ((characterp text) (char-to-string text)) - ((stringp text) text) - (t "")) - "\n" "^J") - text) - max-text-len - " inserting `" "'" " .......")) - )) - - -;; don't change viper-d-com if it was viper-repeat command invoked with `.' -;; or in some other way (non-interactively). -(defun viper-set-destructive-command (list) - (or (eq viper-intermediate-command 'viper-repeat) - (progn - (setq viper-d-com list) - (setcar (nthcdr 5 viper-d-com) - (viper-array-to-string (if (arrayp viper-this-command-keys) - viper-this-command-keys - (this-command-keys)))) - (viper-push-onto-ring viper-d-com 'viper-command-ring))) - (setq viper-this-command-keys nil)) - -(defun viper-prev-destructive-command (next) - "Find previous destructive command in the history of destructive commands. -With prefix argument, find next destructive command." - (interactive "P") - (let (cmd viper-intermediate-command) - (if (eq last-command 'viper-display-current-destructive-command) - ;; repeated search through command history - (setq viper-intermediate-command - 'repeating-display-destructive-command) - ;; first search through command history--set temp ring - (setq viper-temp-command-ring (copy-list viper-command-ring))) - (setq cmd (if next - (viper-special-ring-rotate1 viper-temp-command-ring 1) - (viper-special-ring-rotate1 viper-temp-command-ring -1))) - (if (null cmd) - () - (setq viper-d-com cmd)) - (viper-display-current-destructive-command))) - -(defun viper-next-destructive-command () - "Find next destructive command in the history of destructive commands." - (interactive) - (viper-prev-destructive-command 'next)) - -(defun viper-insert-prev-from-insertion-ring (arg) - "Cycle through insertion ring in the direction of older insertions. -Undoes previous insertion and inserts new. -With prefix argument, cycles in the direction of newer elements. -In minibuffer, this command executes whatever the invocation key is bound -to in the global map, instead of cycling through the insertion ring." - (interactive "P") - (let (viper-intermediate-command) - (if (eq last-command 'viper-insert-from-insertion-ring) - (progn ; repeated search through insertion history - (setq viper-intermediate-command 'repeating-insertion-from-ring) - (if (eq viper-current-state 'replace-state) - (undo 1) - (if viper-last-inserted-string-from-insertion-ring - (backward-delete-char - (length viper-last-inserted-string-from-insertion-ring)))) - ) - ;;first search through insertion history - (setq viper-temp-insertion-ring (copy-list viper-insertion-ring))) - (setq this-command 'viper-insert-from-insertion-ring) - ;; so that things will be undone properly - (setq buffer-undo-list (cons nil buffer-undo-list)) - (setq viper-last-inserted-string-from-insertion-ring - (viper-special-ring-rotate1 viper-temp-insertion-ring (if arg 1 -1))) - - ;; this change of viper-intermediate-command must come after - ;; viper-special-ring-rotate1, so that the ring will rotate, but before the - ;; insertion. - (setq viper-intermediate-command nil) - (if viper-last-inserted-string-from-insertion-ring - (insert viper-last-inserted-string-from-insertion-ring)) - )) - -(defun viper-insert-next-from-insertion-ring () - "Cycle through insertion ring in the direction of older insertions. -Undo previous insertion and inserts new." - (interactive) - (viper-insert-prev-from-insertion-ring 'next)) - - -;; some region utilities - -;; If at the last line of buffer, add \\n before eob, if newline is missing. -(defun viper-add-newline-at-eob-if-necessary () - (save-excursion - (end-of-line) - ;; make sure all lines end with newline, unless in the minibuffer or - ;; when requested otherwise (require-final-newline is nil) - (if (and (eobp) - (not (bolp)) - require-final-newline - (not (viper-is-in-minibuffer)) - (not buffer-read-only)) - (insert "\n")))) - -(defun viper-yank-defun () - (mark-defun) - (copy-region-as-kill (point) (mark t))) - -;; Enlarge region between BEG and END. -(defun viper-enlarge-region (beg end) - (or beg (setq beg end)) ; if beg is nil, set to end - (or end (setq end beg)) ; if end is nil, set to beg - - (if (< beg end) - (progn (goto-char beg) (set-mark end)) - (goto-char end) - (set-mark beg)) - (beginning-of-line) - (exchange-point-and-mark) - (if (or (not (eobp)) (not (bolp))) (forward-line 1)) - (if (not (eobp)) (beginning-of-line)) - (if (> beg end) (exchange-point-and-mark))) - - -;; Quote region by each line with a user supplied string. -(defun viper-quote-region () - (setq viper-quote-string - (viper-read-string-with-history - "Quote string: " - nil - 'viper-quote-region-history - viper-quote-string)) - (viper-enlarge-region (point) (mark t)) - (if (> (point) (mark t)) (exchange-point-and-mark)) - (insert viper-quote-string) - (beginning-of-line) - (forward-line 1) - (while (and (< (point) (mark t)) (bolp)) - (insert viper-quote-string) - (beginning-of-line) - (forward-line 1))) - -;; Tells whether BEG is on the same line as END. -;; If one of the args is nil, it'll return nil. -(defun viper-same-line (beg end) - (let ((selective-display nil) - (incr 0) - temp) - (if (and beg end (> beg end)) - (setq temp beg - beg end - end temp)) - (if (and beg end) - (cond ((or (> beg (point-max)) (> end (point-max))) ; out of range - nil) - (t - ;; This 'if' is needed because Emacs treats the next empty line - ;; as part of the previous line. - (if (= (viper-line-pos 'start) end) - (setq incr 1)) - (<= (+ incr (count-lines beg end)) 1)))) - )) - - -;; Check if the string ends with a newline. -(defun viper-end-with-a-newline-p (string) - (or (string= string "") - (= (viper-seq-last-elt string) ?\n))) - -(defun viper-tmp-insert-at-eob (msg) - (let ((savemax (point-max))) - (goto-char savemax) - (insert msg) - (sit-for 2) - (goto-char savemax) (delete-region (point) (point-max)) - )) - - - -;;; Minibuffer business - -(defsubst viper-set-minibuffer-style () - (add-hook 'minibuffer-setup-hook 'viper-minibuffer-setup-sentinel)) - - -(defun viper-minibuffer-setup-sentinel () - (let ((hook (if viper-vi-style-in-minibuffer - 'viper-change-state-to-insert - 'viper-change-state-to-emacs))) - (funcall hook) - )) - -;; Interpret last event in the local map first; if fails, use exit-minibuffer. -;; Run viper-minibuffer-exit-hook before exiting. -(defun viper-exit-minibuffer () - "Exit minibuffer Viper way." - (interactive) - (let (command) - (setq command (local-key-binding (char-to-string last-command-char))) - (run-hooks 'viper-minibuffer-exit-hook) - (if command - (command-execute command) - (exit-minibuffer)))) - - -(defcustom viper-smart-suffix-list - '("" "tex" "c" "cc" "C" "el" "java" "html" "htm" "pl" "P" "p") - "*List of suffixes that Viper tries to append to filenames ending with a `.'. -This is useful when you the current directory contains files with the same -prefix and many different suffixes. Usually, only one of the suffixes -represents an editable file. However, file completion will stop at the `.' -The smart suffix feature lets you hit RET in such a case, and Viper will -select the appropriate suffix. - -Suffixes are tried in the order given and the first suffix for which a -corresponding file exists is selected. If no file exists for any of the -suffixes, the user is asked to confirm. - -To turn this feature off, set this variable to nil." - :type '(repeat string) - :group 'viper-misc) - - -;; Try to add a suitable suffix to files whose name ends with a `.' -;; Useful when the user hits RET on a non-completed file name. -;; Used as a minibuffer exit hook in read-file-name -(defun viper-file-add-suffix () - (let ((count 0) - (len (length viper-smart-suffix-list)) - (file (buffer-string)) - found key cmd suff) - (goto-char (point-max)) - (if (and viper-smart-suffix-list (string-match "\\.$" file)) - (progn - (while (and (not found) (< count len)) - (setq suff (nth count viper-smart-suffix-list) - count (1+ count)) - (if (file-exists-p - (format "%s%s" (substitute-in-file-name file) suff)) - (progn - (setq found t) - (insert suff)))) - - (if found - () - (viper-tmp-insert-at-eob " [Please complete file name]") - (unwind-protect - (while (not (memq cmd - '(exit-minibuffer viper-exit-minibuffer))) - (setq cmd - (key-binding (setq key (read-key-sequence nil)))) - (cond ((eq cmd 'self-insert-command) - (if viper-xemacs-p - (insert (events-to-keys key)) - (insert key))) - ((memq cmd '(exit-minibuffer viper-exit-minibuffer)) - nil) - (t (command-execute cmd))) - ))) - )))) - - -(defun viper-minibuffer-trim-tail () - "Delete junk at the end of the first line of the minibuffer input. -Remove this function from `viper-minibuffer-exit-hook', if this causes -problems." - (if (viper-is-in-minibuffer) - (progn - (goto-char (point-min)) - (end-of-line) - (delete-region (point) (point-max))))) - - -;;; Reading string with history - -(defun viper-read-string-with-history (prompt &optional initial - history-var default keymap) - ;; Read string, prompting with PROMPT and inserting the INITIAL - ;; value. Uses HISTORY-VAR. DEFAULT is the default value to accept if the - ;; input is an empty string. Use KEYMAP, if given, or the - ;; minibuffer-local-map. - ;; Default value is displayed until the user types something in the - ;; minibuffer. - (let ((minibuffer-setup-hook - '(lambda () - (if (stringp initial) - (progn - ;; don't wait if we have unread events or in kbd macro - (or unread-command-events - executing-kbd-macro - (sit-for 840)) - (erase-buffer) - (insert initial))) - (viper-minibuffer-setup-sentinel))) - (val "") - (padding "") - temp-msg) - - (setq keymap (or keymap minibuffer-local-map) - initial (or initial "") - temp-msg (if default - (format "(default: %s) " default) - "")) - - (setq viper-incomplete-ex-cmd nil) - (setq val (read-from-minibuffer prompt - (concat temp-msg initial val padding) - keymap nil history-var)) - (setq minibuffer-setup-hook nil - padding (viper-array-to-string (this-command-keys)) - temp-msg "") - ;; the following tries to be smart about what to put in history - (if (not (string= val (car (eval history-var)))) - (set history-var (cons val (eval history-var)))) - (if (or (string= (nth 0 (eval history-var)) (nth 1 (eval history-var))) - (string= (nth 0 (eval history-var)) "")) - (set history-var (cdr (eval history-var)))) - ;; If the user enters nothing but the prev cmd wasn't viper-ex, - ;; viper-command-argument, or `! shell-command', this probably means - ;; that the user typed something then erased. Return "" in this case, not - ;; the default---the default is too confusing in this case. - (cond ((and (string= val "") - (not (string= prompt "!")) ; was a `! shell-command' - (not (memq last-command - '(viper-ex - viper-command-argument - t) - ))) - "") - ((string= val "") (or default "")) - (t val)) - )) - - - -;; insertion commands - -;; Called when state changes from Insert Vi command mode. -;; Repeats the insertion command if Insert state was entered with prefix -;; argument > 1. -(defun viper-repeat-insert-command () - (let ((i-com (car viper-d-com)) - (val (nth 1 viper-d-com)) - (char (nth 2 viper-d-com))) - (if (and val (> val 1)) ; first check that val is non-nil - (progn - (setq viper-d-com (list i-com (1- val) ?r nil nil nil)) - (viper-repeat nil) - (setq viper-d-com (list i-com val char nil nil nil)) - )))) - -(defun viper-insert (arg) - "Insert before point." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command (list 'viper-insert val ?r nil nil nil)) - (if com - (viper-loop val (viper-yank-last-insertion)) - (viper-change-state-to-insert)))) - -(defun viper-append (arg) - "Append after point." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command (list 'viper-append val ?r nil nil nil)) - (if (not (eolp)) (forward-char)) - (if (equal com ?r) - (viper-loop val (viper-yank-last-insertion)) - (viper-change-state-to-insert)))) - -(defun viper-Append (arg) - "Append at end of line." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command (list 'viper-Append val ?r nil nil nil)) - (end-of-line) - (if (equal com ?r) - (viper-loop val (viper-yank-last-insertion)) - (viper-change-state-to-insert)))) - -(defun viper-Insert (arg) - "Insert before first non-white." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command (list 'viper-Insert val ?r nil nil nil)) - (back-to-indentation) - (if (equal com ?r) - (viper-loop val (viper-yank-last-insertion)) - (viper-change-state-to-insert)))) - -(defun viper-open-line (arg) - "Open line below." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command (list 'viper-open-line val ?r nil nil nil)) - (let ((col (current-indentation))) - (if (equal com ?r) - (viper-loop val - (end-of-line) - (newline 1) - (if viper-auto-indent - (progn - (setq viper-cted t) - (if viper-electric-mode - (indent-according-to-mode) - (indent-to col)) - )) - (viper-yank-last-insertion)) - (end-of-line) - (newline 1) - (if viper-auto-indent - (progn - (setq viper-cted t) - (if viper-electric-mode - (indent-according-to-mode) - (indent-to col)))) - (viper-change-state-to-insert))))) - -(defun viper-Open-line (arg) - "Open line above." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command (list 'viper-Open-line val ?r nil nil nil)) - (let ((col (current-indentation))) - (if (equal com ?r) - (viper-loop val - (beginning-of-line) - (open-line 1) - (if viper-auto-indent - (progn - (setq viper-cted t) - (if viper-electric-mode - (indent-according-to-mode) - (indent-to col)) - )) - (viper-yank-last-insertion)) - (beginning-of-line) - (open-line 1) - (if viper-auto-indent - (progn - (setq viper-cted t) - (if viper-electric-mode - (indent-according-to-mode) - (indent-to col)) - )) - (viper-change-state-to-insert))))) - -(defun viper-open-line-at-point (arg) - "Open line at point." - (interactive "P") - (viper-set-complex-command-for-undo) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-set-destructive-command - (list 'viper-open-line-at-point val ?r nil nil nil)) - (if (equal com ?r) - (viper-loop val - (open-line 1) - (viper-yank-last-insertion)) - (open-line 1) - (viper-change-state-to-insert)))) - -(defun viper-substitute (arg) - "Substitute characters." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (push-mark nil t) - (forward-char val) - (if (equal com ?r) - (viper-change-subr (mark t) (point)) - (viper-change (mark t) (point))) - (viper-set-destructive-command (list 'viper-substitute val ?r nil nil nil)) - )) - -;; Command bound to S -(defun viper-substitute-line (arg) - "Substitute lines." - (interactive "p") - (viper-set-complex-command-for-undo) - (viper-line (cons arg ?C))) - -;; Prepare for replace -(defun viper-start-replace () - (setq viper-began-as-replace t - viper-sitting-in-replace t - viper-replace-chars-to-delete 0) - (viper-add-hook - 'viper-after-change-functions 'viper-replace-mode-spy-after t) - (viper-add-hook - 'viper-before-change-functions 'viper-replace-mode-spy-before t) - ;; this will get added repeatedly, but no harm - (add-hook 'after-change-functions 'viper-after-change-sentinel t) - (add-hook 'before-change-functions 'viper-before-change-sentinel t) - (viper-move-marker-locally 'viper-last-posn-in-replace-region - (viper-replace-start)) - (viper-add-hook - 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel t) - (viper-add-hook - 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel t) - ;; guard against a smartie who switched from R-replace to normal replace - (viper-remove-hook - 'viper-post-command-hooks 'viper-R-state-post-command-sentinel) - (if overwrite-mode (overwrite-mode nil)) - ) - - -(defun viper-replace-mode-spy-before (beg end) - (setq viper-replace-region-chars-deleted (viper-chars-in-region beg end)) - ) - -;; Invoked as an after-change-function to calculate how many chars have to be -;; deleted. This function may be called several times within a single command, -;; if this command performs several separate buffer changes. Therefore, if adds -;; up the number of chars inserted and subtracts the number of chars deleted. -(defun viper-replace-mode-spy-after (beg end length) - (if (memq viper-intermediate-command - '(dabbrev-expand repeating-insertion-from-ring)) - ;; Take special care of text insertion from insertion ring inside - ;; replacement overlays. - (progn - (setq viper-replace-chars-to-delete 0) - (viper-move-marker-locally - 'viper-last-posn-in-replace-region (point))) - - (let* ((real-end (min end (viper-replace-end))) - (column-shift (- (save-excursion (goto-char real-end) - (current-column)) - (save-excursion (goto-char beg) - (current-column)))) - (chars-deleted 0)) - - (if (> length 0) - (setq chars-deleted viper-replace-region-chars-deleted)) - (setq viper-replace-region-chars-deleted 0) - (setq viper-replace-chars-to-delete - (+ viper-replace-chars-to-delete - (- - ;; if column shift is bigger, due to a TAB insertion, take - ;; column-shift instead of the number of inserted chars - (max (viper-chars-in-region beg real-end) - ;; This test accounts for Chinese/Japanese/... chars, - ;; which occupy 2 columns instead of one. If we use - ;; column-shift here, we may delete two chars instead of - ;; one when the user types one Chinese character. Deleting - ;; two would be OK, if they were European chars, but it is - ;; not OK if they are Chinese chars. Since it is hard to - ;; figure out which characters are being deleted in any - ;; given region, we decided to treat Eastern and European - ;; characters equally, even though Eastern chars may - ;; occupy more columns. - (if (memq this-command '(self-insert-command - quoted-insert viper-insert-tab)) - column-shift - 0)) - ;; the number of deleted chars - chars-deleted))) - - (viper-move-marker-locally - 'viper-last-posn-in-replace-region - (max (if (> end (viper-replace-end)) (viper-replace-end) end) - (or (marker-position viper-last-posn-in-replace-region) - (viper-replace-start)) - )) - - ))) - -;; Make sure we don't delete more than needed. -;; This is executed at viper-last-posn-in-replace-region -(defsubst viper-trim-replace-chars-to-delete-if-necessary () - (setq viper-replace-chars-to-delete - (max 0 - (min viper-replace-chars-to-delete - ;; Don't delete more than to the end of repl overlay - (viper-chars-in-region - (viper-replace-end) viper-last-posn-in-replace-region) - ;; point is viper-last-posn-in-replace-region now - ;; So, this limits deletion to the end of line - (viper-chars-in-region (point) (viper-line-pos 'end)) - )))) - - -;; Delete stuff between viper-last-posn-in-replace-region and the end of -;; viper-replace-overlay-marker, if viper-last-posn-in-replace-region is within -;; the overlay and current point is before the end of the overlay. -;; Don't delete anything if current point is past the end of the overlay. -(defun viper-finish-change () - (viper-remove-hook - 'viper-after-change-functions 'viper-replace-mode-spy-after) - (viper-remove-hook - 'viper-before-change-functions 'viper-replace-mode-spy-before) - (viper-remove-hook - 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel) - (viper-remove-hook - 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel) - (viper-restore-cursor-color-after-replace) - (setq viper-sitting-in-replace nil) ; just in case we'll need to know it - (save-excursion - (if (and viper-replace-overlay - (viper-pos-within-region viper-last-posn-in-replace-region - (viper-replace-start) - (viper-replace-end)) - (< (point) (viper-replace-end))) - (delete-region - viper-last-posn-in-replace-region (viper-replace-end)))) - - (if (eq viper-current-state 'replace-state) - (viper-downgrade-to-insert)) - ;; replace mode ended => nullify viper-last-posn-in-replace-region - (viper-move-marker-locally 'viper-last-posn-in-replace-region nil) - (viper-hide-replace-overlay) - (viper-refresh-mode-line) - (viper-put-string-on-kill-ring viper-last-replace-region) - ) - -;; Make STRING be the first element of the kill ring. -(defun viper-put-string-on-kill-ring (string) - (setq kill-ring (cons string kill-ring)) - (if (> (length kill-ring) kill-ring-max) - (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) - (setq kill-ring-yank-pointer kill-ring)) - -(defun viper-finish-R-mode () - (viper-remove-hook - 'viper-post-command-hooks 'viper-R-state-post-command-sentinel) - (viper-remove-hook - 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel) - (viper-downgrade-to-insert)) - -(defun viper-start-R-mode () - ;; Leave arg as 1, not t: XEmacs insists that it must be a pos number - (overwrite-mode 1) - (viper-add-hook - 'viper-post-command-hooks 'viper-R-state-post-command-sentinel t) - (viper-add-hook - 'viper-pre-command-hooks 'viper-replace-state-pre-command-sentinel t) - ;; guard against a smartie who switched from R-replace to normal replace - (viper-remove-hook - 'viper-post-command-hooks 'viper-replace-state-post-command-sentinel) - ) - - - -(defun viper-replace-state-exit-cmd () - "Binding for keys that cause Replace state to switch to Vi or to Insert. -These keys are ESC, RET, and LineFeed" - (interactive) - (if overwrite-mode ; if in replace mode invoked via 'R' - (viper-finish-R-mode) - (viper-finish-change)) - (let (com) - (if (eq this-command 'viper-intercept-ESC-key) - (setq com 'viper-exit-insert-state) - (viper-set-unread-command-events last-input-char) - (setq com (key-binding (read-key-sequence nil)))) - - (condition-case conds - (command-execute com) - (error - (viper-message-conditions conds))) - ) - (viper-hide-replace-overlay)) - - -(defun viper-replace-state-carriage-return () - "Carriage return in Viper replace state." - (interactive) - ;; If Emacs start supporting overlay maps, as it currently supports - ;; text-property maps, we could do away with viper-replace-minor-mode and - ;; just have keymap attached to replace overlay. Then the "if part" of this - ;; statement can be deleted. - (if (or (< (point) (viper-replace-start)) - (> (point) (viper-replace-end))) - (let (viper-replace-minor-mode com) - (viper-set-unread-command-events last-input-char) - (setq com (key-binding (read-key-sequence nil))) - (condition-case conds - (command-execute com) - (error - (viper-message-conditions conds)))) - (if (not viper-allow-multiline-replace-regions) - (viper-replace-state-exit-cmd) - (if (viper-same-line (point) (viper-replace-end)) - (viper-replace-state-exit-cmd) - ;; delete the rest of line - (delete-region (point) (viper-line-pos 'end)) - (save-excursion - (end-of-line) - (if (eobp) (error "Last line in buffer"))) - ;; skip to the next line - (forward-line 1) - (back-to-indentation) - )))) - - -;; This is the function bound to 'R'---unlimited replace. -;; Similar to Emacs's own overwrite-mode. -(defun viper-overwrite (arg) - "Begin overwrite mode." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) (len)) - (viper-set-destructive-command (list 'viper-overwrite val ?r nil nil nil)) - (if com - (progn - ;; Viper saves inserted text in viper-last-insertion - (setq len (length viper-last-insertion)) - (delete-char len) - (viper-loop val (viper-yank-last-insertion))) - (setq last-command 'viper-overwrite) - (viper-set-complex-command-for-undo) - (viper-set-replace-overlay (point) (viper-line-pos 'end)) - (viper-change-state-to-replace) - ))) - - -;; line commands - -(defun viper-line (arg) - (let ((val (car arg)) - (com (cdr arg))) - (viper-move-marker-locally 'viper-com-point (point)) - (if (not (eobp)) - (viper-next-line-carefully (1- val))) - ;; this ensures that dd, cc, D, yy will do the right thing on the last - ;; line of buffer when this line has no \n. - (viper-add-newline-at-eob-if-necessary) - (viper-execute-com 'viper-line val com)) - (if (and (eobp) (not (bobp))) (forward-line -1)) - ) - -(defun viper-yank-line (arg) - "Yank ARG lines (in Vi's sense)." - (interactive "P") - (let ((val (viper-p-val arg))) - (viper-line (cons val ?Y)))) - - -;; region commands - -(defun viper-region (arg) - "Execute command on a region." - (interactive "P") - (let ((val (viper-P-val arg)) - (com (viper-getcom arg))) - (viper-move-marker-locally 'viper-com-point (point)) - (exchange-point-and-mark) - (viper-execute-com 'viper-region val com))) - -(defun viper-Region (arg) - "Execute command on a Region." - (interactive "P") - (let ((val (viper-P-val arg)) - (com (viper-getCom arg))) - (viper-move-marker-locally 'viper-com-point (point)) - (exchange-point-and-mark) - (viper-execute-com 'viper-Region val com))) - -(defun viper-replace-char (arg) - "Replace the following ARG chars by the character read." - (interactive "P") - (if (and (eolp) (bolp)) (error "No character to replace here")) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-replace-char-subr com val) - (if (and (eolp) (not (bolp))) (forward-char 1)) - (setq viper-this-command-keys - (format "%sr" (if (integerp arg) arg ""))) - (viper-set-destructive-command - (list 'viper-replace-char val ?r nil viper-d-char nil)) - )) - -(defun viper-replace-char-subr (com arg) - (let (char) - (setq char (if (equal com ?r) - viper-d-char - (read-char))) - (let (inhibit-quit) ; preserve consistency of undo-list and iso-accents - (if (and viper-automatic-iso-accents (memq char '(?' ?\" ?^ ?~))) - ;; get European characters - (progn - (viper-set-iso-accents-mode t) - (viper-set-unread-command-events char) - (setq char (aref (read-key-sequence nil) 0)) - (viper-set-iso-accents-mode nil))) - (viper-set-complex-command-for-undo) - (if (eq char ?\C-m) (setq char ?\n)) - (if (and viper-special-input-method (fboundp 'quail-start-translation)) - ;; get Intl. characters - (progn - (viper-set-input-method t) - (setq last-command-event - (viper-copy-event - (if viper-xemacs-p (character-to-event char) char))) - (delete-char 1 t) - (condition-case nil - (if com - (insert char) - (if viper-emacs-p - (quail-start-translation 1) - (quail-start-translation))) - (error)) - ;; quail translation failed - (if (and (not (stringp quail-current-str)) - (not (viper-characterp quail-current-str))) - (progn - (viper-adjust-undo) - (undo-start) - (undo-more 1) - (viper-set-input-method nil) - (error "Composing character failed, changes undone"))) - ;; quail translation seems ok - (or com - ;;(setq char quail-current-str)) - (setq char (viper-char-at-pos 'backward))) - (setq viper-d-char char) - (viper-loop (1- (if (> arg 0) arg (- arg))) - (delete-char 1 t) - (insert char)) - (viper-set-input-method nil)) - (delete-char arg t) - (setq viper-d-char char) - (viper-loop (if (> arg 0) arg (- arg)) - (insert char))) - (viper-adjust-undo) - (backward-char arg)))) - - -;; basic cursor movement. j, k, l, h commands. - -(defun viper-forward-char (arg) - "Move point right ARG characters (left if ARG negative). -On reaching end of line, stop and signal error." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (if viper-ex-style-motion - (progn - ;; the boundary condition check gets weird here because - ;; forward-char may be the parameter of a delete, and 'dl' works - ;; just like 'x' for the last char on a line, so we have to allow - ;; the forward motion before the 'viper-execute-com', but, of - ;; course, 'dl' doesn't work on an empty line, so we have to - ;; catch that condition before 'viper-execute-com' - (if (and (eolp) (bolp)) (error "") (forward-char val)) - (if com (viper-execute-com 'viper-forward-char val com)) - (if (eolp) (progn (backward-char 1) (error "")))) - (forward-char val) - (if com (viper-execute-com 'viper-forward-char val com))))) - -(defun viper-backward-char (arg) - "Move point left ARG characters (right if ARG negative). -On reaching beginning of line, stop and signal error." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (if viper-ex-style-motion - (progn - (if (bolp) (error "") (backward-char val)) - (if com (viper-execute-com 'viper-backward-char val com))) - (backward-char val) - (if com (viper-execute-com 'viper-backward-char val com))))) - -;; Like forward-char, but doesn't move at end of buffer. -;; Returns distance traveled -;; (positive or 0, if arg positive; negative if arg negative). -(defun viper-forward-char-carefully (&optional arg) - (setq arg (or arg 1)) - (let ((pt (point))) - (condition-case nil - (forward-char arg) - (error)) - (if (< (point) pt) ; arg was negative - (- (viper-chars-in-region pt (point))) - (viper-chars-in-region pt (point))))) - -;; Like backward-char, but doesn't move at beg of buffer. -;; Returns distance traveled -;; (negative or 0, if arg positive; positive if arg negative). -(defun viper-backward-char-carefully (&optional arg) - (setq arg (or arg 1)) - (let ((pt (point))) - (condition-case nil - (backward-char arg) - (error)) - (if (> (point) pt) ; arg was negative - (viper-chars-in-region pt (point)) - (- (viper-chars-in-region pt (point)))))) - -(defun viper-next-line-carefully (arg) - (condition-case nil - (next-line arg) - (error nil))) - - - -;;; Word command - -;; Words are formed from alpha's and nonalphas - <sp>,\t\n are separators for -;; word movement. When executed with a destructive command, \n is usually left -;; untouched for the last word. Viper uses syntax table to determine what is a -;; word and what is a separator. However, \n is always a separator. Also, if -;; viper-syntax-preference is 'vi, then `_' is part of the word. - -;; skip only one \n -(defun viper-skip-separators (forward) - (if forward - (progn - (viper-skip-all-separators-forward 'within-line) - (if (looking-at "\n") - (progn - (forward-char) - (viper-skip-all-separators-forward 'within-line)))) - (viper-skip-all-separators-backward 'within-line) - (viper-backward-char-carefully) - (if (looking-at "\n") - (viper-skip-all-separators-backward 'within-line) - (forward-char)))) - -(defun viper-forward-word-kernel (val) - (while (> val 0) - (cond ((viper-looking-at-alpha) - (viper-skip-alpha-forward "_") - (viper-skip-separators t)) - ((viper-looking-at-separator) - (viper-skip-separators t)) - ((not (viper-looking-at-alphasep)) - (viper-skip-nonalphasep-forward) - (viper-skip-separators t))) - (setq val (1- val)))) - -;; first skip non-newline separators backward, then skip \n. Then, if TWICE is -;; non-nil, skip non-\n back again, but don't overshoot the limit LIM. -(defun viper-separator-skipback-special (twice lim) - (let ((prev-char (viper-char-at-pos 'backward)) - (saved-point (point))) - ;; skip non-newline separators backward - (while (and (not (memq prev-char '(nil \n))) - (< lim (point)) - ;; must be non-newline separator - (if (eq viper-syntax-preference 'strict-vi) - (memq prev-char '(?\ ?\t)) - (memq (char-syntax prev-char) '(?\ ?-)))) - (viper-backward-char-carefully) - (setq prev-char (viper-char-at-pos 'backward))) - - (if (and (< lim (point)) (eq prev-char ?\n)) - (backward-char) - ;; If we skipped to the next word and the prefix of this line doesn't - ;; consist of separators preceded by a newline, then don't skip backwards - ;; at all. - (goto-char saved-point)) - (setq prev-char (viper-char-at-pos 'backward)) - - ;; skip again, but make sure we don't overshoot the limit - (if twice - (while (and (not (memq prev-char '(nil \n))) - (< lim (point)) - ;; must be non-newline separator - (if (eq viper-syntax-preference 'strict-vi) - (memq prev-char '(?\ ?\t)) - (memq (char-syntax prev-char) '(?\ ?-)))) - (viper-backward-char-carefully) - (setq prev-char (viper-char-at-pos 'backward)))) - - (if (= (point) lim) - (viper-forward-char-carefully)) - )) - - -(defun viper-forward-word (arg) - "Forward word." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-forward-word-kernel val) - (if com (progn - (cond ((memq com (list ?c (- ?c))) - (viper-separator-skipback-special 'twice viper-com-point)) - ;; Yank words including the whitespace, but not newline - ((memq com (list ?y (- ?y))) - (viper-separator-skipback-special nil viper-com-point)) - ((viper-dotable-command-p com) - (viper-separator-skipback-special nil viper-com-point))) - (viper-execute-com 'viper-forward-word val com))))) - - -(defun viper-forward-Word (arg) - "Forward word delimited by white characters." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-loop val - (viper-skip-nonseparators 'forward) - (viper-skip-separators t)) - (if com (progn - (cond ((memq com (list ?c (- ?c))) - (viper-separator-skipback-special 'twice viper-com-point)) - ;; Yank words including the whitespace, but not newline - ((memq com (list ?y (- ?y))) - (viper-separator-skipback-special nil viper-com-point)) - ((viper-dotable-command-p com) - (viper-separator-skipback-special nil viper-com-point))) - (viper-execute-com 'viper-forward-Word val com))))) - - -;; this is a bit different from Vi, but Vi's end of word -;; makes no sense whatsoever -(defun viper-end-of-word-kernel () - (if (viper-end-of-word-p) (forward-char)) - (if (viper-looking-at-separator) - (viper-skip-all-separators-forward)) - - (cond ((viper-looking-at-alpha) (viper-skip-alpha-forward "_")) - ((not (viper-looking-at-alphasep)) (viper-skip-nonalphasep-forward))) - (viper-backward-char-carefully)) - -(defun viper-end-of-word-p () - (or (eobp) - (save-excursion - (cond ((viper-looking-at-alpha) - (forward-char) - (not (viper-looking-at-alpha))) - ((not (viper-looking-at-alphasep)) - (forward-char) - (viper-looking-at-alphasep)))))) - - -(defun viper-end-of-word (arg &optional careful) - "Move point to end of current word." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-loop val (viper-end-of-word-kernel)) - (if com - (progn - (forward-char) - (viper-execute-com 'viper-end-of-word val com))))) - -(defun viper-end-of-Word (arg) - "Forward to end of word delimited by white character." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-loop val - (viper-end-of-word-kernel) - (viper-skip-nonseparators 'forward) - (backward-char)) - (if com - (progn - (forward-char) - (viper-execute-com 'viper-end-of-Word val com))))) - -(defun viper-backward-word-kernel (val) - (while (> val 0) - (viper-backward-char-carefully) - (cond ((viper-looking-at-alpha) - (viper-skip-alpha-backward "_")) - ((viper-looking-at-separator) - (forward-char) - (viper-skip-separators nil) - (viper-backward-char-carefully) - (cond ((viper-looking-at-alpha) - (viper-skip-alpha-backward "_")) - ((not (viper-looking-at-alphasep)) - (viper-skip-nonalphasep-backward)) - ((bobp)) ; could still be at separator, but at beg of buffer - (t (forward-char)))) - ((not (viper-looking-at-alphasep)) - (viper-skip-nonalphasep-backward))) - (setq val (1- val)))) - -(defun viper-backward-word (arg) - "Backward word." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com - (let (i) - (if (setq i (save-excursion (backward-char) (looking-at "\n"))) - (backward-char)) - (viper-move-marker-locally 'viper-com-point (point)) - (if i (forward-char)))) - (viper-backward-word-kernel val) - (if com (viper-execute-com 'viper-backward-word val com)))) - -(defun viper-backward-Word (arg) - "Backward word delimited by white character." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com - (let (i) - (if (setq i (save-excursion (backward-char) (looking-at "\n"))) - (backward-char)) - (viper-move-marker-locally 'viper-com-point (point)) - (if i (forward-char)))) - (viper-loop val - (viper-skip-separators nil) ; nil means backward here - (viper-skip-nonseparators 'backward)) - (if com (viper-execute-com 'viper-backward-Word val com)))) - - - -;; line commands - -(defun viper-beginning-of-line (arg) - "Go to beginning of line." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (beginning-of-line val) - (if com (viper-execute-com 'viper-beginning-of-line val com)))) - -(defun viper-bol-and-skip-white (arg) - "Beginning of line at first non-white character." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (forward-to-indentation (1- val)) - (if com (viper-execute-com 'viper-bol-and-skip-white val com)))) - -(defun viper-goto-eol (arg) - "Go to end of line." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (end-of-line val) - (if com (viper-execute-com 'viper-goto-eol val com)) - (if viper-ex-style-motion - (if (and (eolp) (not (bolp)) - ;; a fix for viper-change-to-eol - (not (equal viper-current-state 'insert-state))) - (backward-char 1) - )))) - - -(defun viper-goto-col (arg) - "Go to ARG's column." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) - line-len) - (setq line-len - (viper-chars-in-region - (viper-line-pos 'start) (viper-line-pos 'end))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (beginning-of-line) - (forward-char (1- (min line-len val))) - (while (> (current-column) (1- val)) - (backward-char 1)) - (if com (viper-execute-com 'viper-goto-col val com)) - (save-excursion - (end-of-line) - (if (> val (current-column)) (error ""))) - )) - - -(defun viper-next-line (arg) - "Go to next line." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (next-line val) - (if viper-ex-style-motion - (if (and (eolp) (not (bolp))) (backward-char 1))) - (setq this-command 'next-line) - (if com (viper-execute-com 'viper-next-line val com)))) - -(defun viper-next-line-at-bol (arg) - "Next line at beginning of line." - (interactive "P") - (viper-leave-region-active) - (save-excursion - (end-of-line) - (if (eobp) (error "Last line in buffer"))) - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (forward-line val) - (back-to-indentation) - (if com (viper-execute-com 'viper-next-line-at-bol val com)))) - -(defun viper-previous-line (arg) - "Go to previous line." - (interactive "P") - (viper-leave-region-active) - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (previous-line val) - (if viper-ex-style-motion - (if (and (eolp) (not (bolp))) (backward-char 1))) - (setq this-command 'previous-line) - (if com (viper-execute-com 'viper-previous-line val com)))) - - -(defun viper-previous-line-at-bol (arg) - "Previous line at beginning of line." - (interactive "P") - (viper-leave-region-active) - (save-excursion - (beginning-of-line) - (if (bobp) (error "First line in buffer"))) - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (forward-line (- val)) - (back-to-indentation) - (if com (viper-execute-com 'viper-previous-line val com)))) - -(defun viper-change-to-eol (arg) - "Change to end of line." - (interactive "P") - (viper-goto-eol (cons arg ?c))) - -(defun viper-kill-line (arg) - "Delete line." - (interactive "P") - (viper-goto-eol (cons arg ?d))) - -(defun viper-erase-line (arg) - "Erase line." - (interactive "P") - (viper-beginning-of-line (cons arg ?d))) - - -;;; Moving around - -(defun viper-goto-line (arg) - "Go to ARG's line. Without ARG go to end of buffer." - (interactive "P") - (let ((val (viper-P-val arg)) - (com (viper-getCom arg))) - (viper-move-marker-locally 'viper-com-point (point)) - (viper-deactivate-mark) - (push-mark nil t) - (if (null val) - (goto-char (point-max)) - (goto-char (point-min)) - (forward-line (1- val))) - - ;; positioning is done twice: before and after command execution - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - - (if com (viper-execute-com 'viper-goto-line val com)) - - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - )) - -;; Find ARG's occurrence of CHAR on the current line. -;; If FORWARD then search is forward, otherwise backward. OFFSET is used to -;; adjust point after search. -(defun viper-find-char (arg char forward offset) - (or (char-or-string-p char) (error "")) - (let ((arg (if forward arg (- arg))) - (cmd (if (eq viper-intermediate-command 'viper-repeat) - (nth 5 viper-d-com) - (viper-array-to-string (this-command-keys)))) - point) - (save-excursion - (save-restriction - (if (> arg 0) - (narrow-to-region - ;; forward search begins here - (if (eolp) (error "Command `%s': At end of line" cmd) (point)) - ;; forward search ends here - (progn (end-of-line) (point))) - (narrow-to-region - ;; backward search begins from here - (if (bolp) - (error "Command `%s': At beginning of line" cmd) (point)) - ;; backward search ends here - (progn (beginning-of-line) (point)))) - ;; if arg > 0, point is forwarded before search. - (if (> arg 0) (goto-char (1+ (point-min))) - (goto-char (point-max))) - (if (let ((case-fold-search nil)) - (search-forward (char-to-string char) nil 0 arg)) - (setq point (point)) - (error "Command `%s': `%c' not found" cmd char)))) - (goto-char point) - (if (> arg 0) - (backward-char (if offset 2 1)) - (forward-char (if offset 1 0))))) - -(defun viper-find-char-forward (arg) - "Find char on the line. -If called interactively read the char to find from the terminal, and if -called from viper-repeat, the char last used is used. This behaviour is -controlled by the sign of prefix numeric value." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) - (cmd-representation (nth 5 viper-d-com))) - (if (> val 0) - ;; this means that the function was called interactively - (setq viper-f-char (read-char) - viper-f-forward t - viper-f-offset nil) - ;; viper-repeat --- set viper-F-char from command-keys - (setq viper-F-char (if (stringp cmd-representation) - (viper-seq-last-elt cmd-representation) - viper-F-char) - viper-f-char viper-F-char) - (setq val (- val))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-find-char - val (if (> (viper-p-val arg) 0) viper-f-char viper-F-char) t nil) - (setq val (- val)) - (if com - (progn - (setq viper-F-char viper-f-char) ; set new viper-F-char - (forward-char) - (viper-execute-com 'viper-find-char-forward val com))))) - -(defun viper-goto-char-forward (arg) - "Go up to char ARG forward on line." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) - (cmd-representation (nth 5 viper-d-com))) - (if (> val 0) - ;; this means that the function was called interactively - (setq viper-f-char (read-char) - viper-f-forward t - viper-f-offset t) - ;; viper-repeat --- set viper-F-char from command-keys - (setq viper-F-char (if (stringp cmd-representation) - (viper-seq-last-elt cmd-representation) - viper-F-char) - viper-f-char viper-F-char) - (setq val (- val))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-find-char - val (if (> (viper-p-val arg) 0) viper-f-char viper-F-char) t t) - (setq val (- val)) - (if com - (progn - (setq viper-F-char viper-f-char) ; set new viper-F-char - (forward-char) - (viper-execute-com 'viper-goto-char-forward val com))))) - -(defun viper-find-char-backward (arg) - "Find char ARG on line backward." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) - (cmd-representation (nth 5 viper-d-com))) - (if (> val 0) - ;; this means that the function was called interactively - (setq viper-f-char (read-char) - viper-f-forward nil - viper-f-offset nil) - ;; viper-repeat --- set viper-F-char from command-keys - (setq viper-F-char (if (stringp cmd-representation) - (viper-seq-last-elt cmd-representation) - viper-F-char) - viper-f-char viper-F-char) - (setq val (- val))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-find-char - val (if (> (viper-p-val arg) 0) viper-f-char viper-F-char) nil nil) - (setq val (- val)) - (if com - (progn - (setq viper-F-char viper-f-char) ; set new viper-F-char - (viper-execute-com 'viper-find-char-backward val com))))) - -(defun viper-goto-char-backward (arg) - "Go up to char ARG backward on line." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) - (cmd-representation (nth 5 viper-d-com))) - (if (> val 0) - ;; this means that the function was called interactively - (setq viper-f-char (read-char) - viper-f-forward nil - viper-f-offset t) - ;; viper-repeat --- set viper-F-char from command-keys - (setq viper-F-char (if (stringp cmd-representation) - (viper-seq-last-elt cmd-representation) - viper-F-char) - viper-f-char viper-F-char) - (setq val (- val))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-find-char - val (if (> (viper-p-val arg) 0) viper-f-char viper-F-char) nil t) - (setq val (- val)) - (if com - (progn - (setq viper-F-char viper-f-char) ; set new viper-F-char - (viper-execute-com 'viper-goto-char-backward val com))))) - -(defun viper-repeat-find (arg) - "Repeat previous find command." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-deactivate-mark) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-find-char val viper-f-char viper-f-forward viper-f-offset) - (if com - (progn - (if viper-f-forward (forward-char)) - (viper-execute-com 'viper-repeat-find val com))))) - -(defun viper-repeat-find-opposite (arg) - "Repeat previous find command in the opposite direction." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (viper-deactivate-mark) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (viper-find-char val viper-f-char (not viper-f-forward) viper-f-offset) - (if com - (progn - (if viper-f-forward (forward-char)) - (viper-execute-com 'viper-repeat-find-opposite val com))))) - - -;; window scrolling etc. - -(defun viper-window-top (arg) - "Go to home window line." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (push-mark nil t) - (move-to-window-line (1- val)) - - ;; positioning is done twice: before and after command execution - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - - (if com (viper-execute-com 'viper-window-top val com)) - - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - )) - -(defun viper-window-middle (arg) - "Go to middle window line." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getCom arg)) - lines) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (push-mark nil t) - (if (not (pos-visible-in-window-p (point-max))) - (move-to-window-line (+ (/ (1- (window-height)) 2) (1- val))) - (setq lines (count-lines (window-start) (point-max))) - (move-to-window-line (+ (/ lines 2) (1- val)))) - - ;; positioning is done twice: before and after command execution - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - - (if com (viper-execute-com 'viper-window-middle val com)) - - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - )) - -(defun viper-window-bottom (arg) - "Go to last window line." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (push-mark nil t) - (move-to-window-line (- val)) - - ;; positioning is done twice: before and after command execution - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - - (if com (viper-execute-com 'viper-window-bottom val com)) - - (if (and (eobp) (bolp) (not (bobp))) (forward-line -1)) - (back-to-indentation) - )) - -(defun viper-line-to-top (arg) - "Put current line on the home line." - (interactive "p") - (recenter (1- arg))) - -(defun viper-line-to-middle (arg) - "Put current line on the middle line." - (interactive "p") - (recenter (+ (1- arg) (/ (1- (window-height)) 2)))) - -(defun viper-line-to-bottom (arg) - "Put current line on the last line." - (interactive "p") - (recenter (- (window-height) (1+ arg)))) - -;; If point is within viper-search-scroll-threshold of window top or bottom, -;; scroll up or down 1/7 of window height, depending on whether we are at the -;; bottom or at the top of the window. This function is called by viper-search -;; (which is called from viper-search-forward/backward/next). If the value of -;; viper-search-scroll-threshold is negative - don't scroll. -(defun viper-adjust-window () - (let ((win-height (if viper-emacs-p - (1- (window-height)) ; adjust for modeline - (window-displayed-height))) - (pt (point)) - at-top-p at-bottom-p - min-scroll direction) - (save-excursion - (move-to-window-line 0) ; top - (setq at-top-p - (<= (count-lines pt (point)) - viper-search-scroll-threshold)) - (move-to-window-line -1) ; bottom - (setq at-bottom-p - (<= (count-lines pt (point)) viper-search-scroll-threshold)) - ) - (cond (at-top-p (setq min-scroll (1- viper-search-scroll-threshold) - direction 1)) - (at-bottom-p (setq min-scroll (1+ viper-search-scroll-threshold) - direction -1))) - (if min-scroll - (recenter - (* (max min-scroll (/ win-height 7)) direction))) - )) - - -;; paren match -;; must correct this to only match ( to ) etc. On the other hand -;; it is good that paren match gets confused, because that way you -;; catch _all_ imbalances. - -(defun viper-paren-match (arg) - "Go to the matching parenthesis." - (interactive "P") - (viper-leave-region-active) - (let ((com (viper-getcom arg)) - (parse-sexp-ignore-comments viper-parse-sexp-ignore-comments) - anchor-point) - (if (integerp arg) - (if (or (> arg 99) (< arg 1)) - (error "Prefix must be between 1 and 99") - (goto-char - (if (> (point-max) 80000) - (* (/ (point-max) 100) arg) - (/ (* (point-max) arg) 100))) - (back-to-indentation)) - (let (beg-lim end-lim) - (if (and (eolp) (not (bolp))) (forward-char -1)) - (if (not (looking-at "[][(){}]")) - (setq anchor-point (point))) - (save-excursion - (beginning-of-line) - (setq beg-lim (point)) - (end-of-line) - (setq end-lim (point))) - (cond ((re-search-forward "[][(){}]" end-lim t) - (backward-char) ) - ((re-search-backward "[][(){}]" beg-lim t)) - (t - (error "No matching character on line")))) - (cond ((looking-at "[\(\[{]") - (if com (viper-move-marker-locally 'viper-com-point (point))) - (forward-sexp 1) - (if com - (viper-execute-com 'viper-paren-match nil com) - (backward-char))) - (anchor-point - (if com - (progn - (viper-move-marker-locally 'viper-com-point anchor-point) - (forward-char 1) - (viper-execute-com 'viper-paren-match nil com) - ))) - ((looking-at "[])}]") - (forward-char) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (backward-sexp 1) - (if com (viper-execute-com 'viper-paren-match nil com))) - (t (error "")))))) - -(defun viper-toggle-parse-sexp-ignore-comments () - (interactive) - (setq viper-parse-sexp-ignore-comments - (not viper-parse-sexp-ignore-comments)) - (princ (format - "From now on, `%%' will %signore parentheses inside comment fields" - (if viper-parse-sexp-ignore-comments "" "NOT ")))) - - -;; sentence ,paragraph and heading - -(defun viper-forward-sentence (arg) - "Forward sentence." - (interactive "P") - (or (eq last-command this-command) - (push-mark nil t)) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (forward-sentence val) - (if com (viper-execute-com 'viper-forward-sentence nil com)))) - -(defun viper-backward-sentence (arg) - "Backward sentence." - (interactive "P") - (or (eq last-command this-command) - (push-mark nil t)) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (backward-sentence val) - (if com (viper-execute-com 'viper-backward-sentence nil com)))) - -(defun viper-forward-paragraph (arg) - "Forward paragraph." - (interactive "P") - (or (eq last-command this-command) - (push-mark nil t)) - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (forward-paragraph val) - (if com - (progn - (backward-char 1) - (viper-execute-com 'viper-forward-paragraph nil com))))) - -(defun viper-backward-paragraph (arg) - "Backward paragraph." - (interactive "P") - (or (eq last-command this-command) - (push-mark nil t)) - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (backward-paragraph val) - (if com - (progn - (forward-char 1) - (viper-execute-com 'viper-backward-paragraph nil com) - (backward-char 1))))) - -;; should be mode-specific -(defun viper-prev-heading (arg) - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (re-search-backward viper-heading-start nil t val) - (goto-char (match-beginning 0)) - (if com (viper-execute-com 'viper-prev-heading nil com)))) - -(defun viper-heading-end (arg) - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (re-search-forward viper-heading-end nil t val) - (goto-char (match-beginning 0)) - (if com (viper-execute-com 'viper-heading-end nil com)))) - -(defun viper-next-heading (arg) - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getCom arg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (end-of-line) - (re-search-forward viper-heading-start nil t val) - (goto-char (match-beginning 0)) - (if com (viper-execute-com 'viper-next-heading nil com)))) - - -;; scrolling - -(defun viper-scroll-screen (arg) - "Scroll to next screen." - (interactive "p") - (condition-case nil - (if (> arg 0) - (while (> arg 0) - (scroll-up) - (setq arg (1- arg))) - (while (> 0 arg) - (scroll-down) - (setq arg (1+ arg)))) - (error (beep 1) - (if (> arg 0) - (progn - (message "End of buffer") - (goto-char (point-max))) - (message "Beginning of buffer") - (goto-char (point-min)))) - )) - -(defun viper-scroll-screen-back (arg) - "Scroll to previous screen." - (interactive "p") - (viper-scroll-screen (- arg))) - -(defun viper-scroll-down (arg) - "Pull down half screen." - (interactive "P") - (condition-case nil - (if (null arg) - (scroll-down (/ (window-height) 2)) - (scroll-down arg)) - (error (beep 1) - (message "Beginning of buffer") - (goto-char (point-min))))) - -(defun viper-scroll-down-one (arg) - "Scroll up one line." - (interactive "p") - (scroll-down arg)) - -(defun viper-scroll-up (arg) - "Pull up half screen." - (interactive "P") - (condition-case nil - (if (null arg) - (scroll-up (/ (window-height) 2)) - (scroll-up arg)) - (error (beep 1) - (message "End of buffer") - (goto-char (point-max))))) - -(defun viper-scroll-up-one (arg) - "Scroll down one line." - (interactive "p") - (scroll-up arg)) - - -;; searching - -(defun viper-if-string (prompt) - (if (memq viper-intermediate-command - '(viper-command-argument viper-digit-argument viper-repeat)) - (setq viper-this-command-keys (this-command-keys))) - (let ((s (viper-read-string-with-history - prompt - nil ; no initial - 'viper-search-history - (car viper-search-history)))) - (if (not (string= s "")) - (setq viper-s-string s)))) - - -(defun viper-toggle-search-style (arg) - "Toggle the value of viper-case-fold-search/viper-re-search. -Without prefix argument, will ask which search style to toggle. With prefix -arg 1,toggles viper-case-fold-search; with arg 2 toggles viper-re-search. - -Although this function is bound to \\[viper-toggle-search-style], the most -convenient way to use it is to bind `//' to the macro -`1 M-x viper-toggle-search-style' and `///' to -`2 M-x viper-toggle-search-style'. In this way, hitting `//' quickly will -toggle case-fold-search and hitting `/' three times witth toggle regexp -search. Macros are more convenient in this case because they don't affect -the Emacs binding of `/'." - (interactive "P") - (let (msg) - (cond ((or (eq arg 1) - (and (null arg) - (y-or-n-p (format "Search style: '%s'. Want '%s'? " - (if viper-case-fold-search - "case-insensitive" "case-sensitive") - (if viper-case-fold-search - "case-sensitive" - "case-insensitive"))))) - (setq viper-case-fold-search (null viper-case-fold-search)) - (if viper-case-fold-search - (setq msg "Search becomes case-insensitive") - (setq msg "Search becomes case-sensitive"))) - ((or (eq arg 2) - (and (null arg) - (y-or-n-p (format "Search style: '%s'. Want '%s'? " - (if viper-re-search - "regexp-search" "vanilla-search") - (if viper-re-search - "vanilla-search" - "regexp-search"))))) - (setq viper-re-search (null viper-re-search)) - (if viper-re-search - (setq msg "Search becomes regexp-style") - (setq msg "Search becomes vanilla-style"))) - (t - (setq msg "Search style remains unchanged"))) - (princ msg t))) - -(defun viper-set-searchstyle-toggling-macros (unset) - "Set the macros for toggling the search style in Viper's vi-state. -The macro that toggles case sensitivity is bound to `//', and the one that -toggles regexp search is bound to `///'. -With a prefix argument, this function unsets the macros. " - (interactive "P") - (or noninteractive - (if (not unset) - (progn - ;; toggle case sensitivity in search - (viper-record-kbd-macro - "//" 'vi-state - [1 (meta x) v i p e r - t o g g l e - s e a r c h - s t y l e return] - 't) - ;; toggle regexp/vanila search - (viper-record-kbd-macro - "///" 'vi-state - [2 (meta x) v i p e r - t o g g l e - s e a r c h - s t y l e return] - 't) - (if (interactive-p) - (message - "// and /// now toggle case-sensitivity and regexp search"))) - (viper-unrecord-kbd-macro "//" 'vi-state) - (sit-for 2) - (viper-unrecord-kbd-macro "///" 'vi-state)))) - - -(defun viper-set-parsing-style-toggling-macro (unset) - "Set `%%%' to be a macro that toggles whether comment fields should be parsed for matching parentheses. -This is used in conjunction with the `%' command. - -With a prefix argument, unsets the macro." - (interactive "P") - (or noninteractive - (if (not unset) - (progn - ;; Make %%% toggle parsing comments for matching parentheses - (viper-record-kbd-macro - "%%%" 'vi-state - [(meta x) v i p e r - t o g g l e - p a r s e - s e x p - i g n o r e - c o m m e n t s return] - 't) - (if (interactive-p) - (message - "%%%%%% now toggles whether comments should be parsed for matching parentheses"))) - (viper-unrecord-kbd-macro "%%%" 'vi-state)))) - - -(defun viper-set-emacs-state-searchstyle-macros (unset &optional arg-majormode) - "Set the macros for toggling the search style in Viper's emacs-state. -The macro that toggles case sensitivity is bound to `//', and the one that -toggles regexp search is bound to `///'. -With a prefix argument, this function unsets the macros. -If the optional prefix argument is non-nil and specifies a valid major mode, -this sets the macros only in the macros in that major mode. Otherwise, -the macros are set in the current major mode. -\(When unsetting the macros, the second argument has no effect.\)" - (interactive "P") - (or noninteractive - (if (not unset) - (progn - ;; toggle case sensitivity in search - (viper-record-kbd-macro - "//" 'emacs-state - [1 (meta x) v i p e r - t o g g l e - s e a r c h - s t y l e return] - (or arg-majormode major-mode)) - ;; toggle regexp/vanila search - (viper-record-kbd-macro - "///" 'emacs-state - [2 (meta x) v i p e r - t o g g l e - s e a r c h - s t y l e return] - (or arg-majormode major-mode)) - (if (interactive-p) - (message - "// and /// now toggle case-sensitivity and regexp search."))) - (viper-unrecord-kbd-macro "//" 'emacs-state) - (sit-for 2) - (viper-unrecord-kbd-macro "///" 'emacs-state)))) - - -(defun viper-search-forward (arg) - "Search a string forward. -ARG is used to find the ARG's occurrence of the string. -Null string will repeat previous search." - (interactive "P") - (let ((val (viper-P-val arg)) - (com (viper-getcom arg)) - (old-str viper-s-string)) - (setq viper-s-forward t) - (viper-if-string "/") - ;; this is not used at present, but may be used later - (if (or (not (equal old-str viper-s-string)) - (not (markerp viper-local-search-start-marker)) - (not (marker-buffer viper-local-search-start-marker))) - (setq viper-local-search-start-marker (point-marker))) - (viper-search viper-s-string t val) - (if com - (progn - (viper-move-marker-locally 'viper-com-point (mark t)) - (viper-execute-com 'viper-search-next val com))))) - -(defun viper-search-backward (arg) - "Search a string backward. -ARG is used to find the ARG's occurrence of the string. -Null string will repeat previous search." - (interactive "P") - (let ((val (viper-P-val arg)) - (com (viper-getcom arg)) - (old-str viper-s-string)) - (setq viper-s-forward nil) - (viper-if-string "?") - ;; this is not used at present, but may be used later - (if (or (not (equal old-str viper-s-string)) - (not (markerp viper-local-search-start-marker)) - (not (marker-buffer viper-local-search-start-marker))) - (setq viper-local-search-start-marker (point-marker))) - (viper-search viper-s-string nil val) - (if com - (progn - (viper-move-marker-locally 'viper-com-point (mark t)) - (viper-execute-com 'viper-search-next val com))))) - - -;; Search for COUNT's occurrence of STRING. -;; Search is forward if FORWARD is non-nil, otherwise backward. -;; INIT-POINT is the position where search is to start. -;; Arguments: -;; (STRING FORW COUNT &optional NO-OFFSET INIT-POINT LIMIT FAIL-IF-NOT-FOUND) -(defun viper-search (string forward arg - &optional no-offset init-point fail-if-not-found) - (if (not (equal string "")) - (let ((val (viper-p-val arg)) - (com (viper-getcom arg)) - (offset (not no-offset)) - (case-fold-search viper-case-fold-search) - (start-point (or init-point (point)))) - (viper-deactivate-mark) - (if forward - (condition-case nil - (progn - (if offset (viper-forward-char-carefully)) - (if viper-re-search - (progn - (re-search-forward string nil nil val) - (re-search-backward string)) - (search-forward string nil nil val) - (search-backward string)) - (if (not (equal start-point (point))) - (push-mark start-point t))) - (search-failed - (if (and (not fail-if-not-found) viper-search-wrap-around-t) - (progn - (message "Search wrapped around BOTTOM of buffer") - (goto-char (point-min)) - (viper-search string forward (cons 1 com) t start-point 'fail) - ;; don't wait in macros - (or executing-kbd-macro - (memq viper-intermediate-command - '(viper-repeat - viper-digit-argument - viper-command-argument)) - (sit-for 2)) - ;; delete the wrap-around message - (message "") - ) - (goto-char start-point) - (error "`%s': %s not found" - string - (if viper-re-search "Pattern" "String")) - ))) - ;; backward - (condition-case nil - (progn - (if viper-re-search - (re-search-backward string nil nil val) - (search-backward string nil nil val)) - (if (not (equal start-point (point))) - (push-mark start-point t))) - (search-failed - (if (and (not fail-if-not-found) viper-search-wrap-around-t) - (progn - (message "Search wrapped around TOP of buffer") - (goto-char (point-max)) - (viper-search string forward (cons 1 com) t start-point 'fail) - ;; don't wait in macros - (or executing-kbd-macro - (memq viper-intermediate-command - '(viper-repeat - viper-digit-argument - viper-command-argument)) - (sit-for 2)) - ;; delete the wrap-around message - (message "") - ) - (goto-char start-point) - (error "`%s': %s not found" - string - (if viper-re-search "Pattern" "String")) - )))) - ;; pull up or down if at top/bottom of window - (viper-adjust-window) - ;; highlight the result of search - ;; don't wait and don't highlight in macros - (or executing-kbd-macro - (memq viper-intermediate-command - '(viper-repeat viper-digit-argument viper-command-argument)) - (viper-flash-search-pattern)) - ))) - -(defun viper-search-next (arg) - "Repeat previous search." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if (null viper-s-string) (error viper-NoPrevSearch)) - (viper-search viper-s-string viper-s-forward arg) - (if com - (progn - (viper-move-marker-locally 'viper-com-point (mark t)) - (viper-execute-com 'viper-search-next val com))))) - -(defun viper-search-Next (arg) - "Repeat previous search in the reverse direction." - (interactive "P") - (let ((val (viper-p-val arg)) - (com (viper-getcom arg))) - (if (null viper-s-string) (error viper-NoPrevSearch)) - (viper-search viper-s-string (not viper-s-forward) arg) - (if com - (progn - (viper-move-marker-locally 'viper-com-point (mark t)) - (viper-execute-com 'viper-search-Next val com))))) - - -;; Search contents of buffer defined by one of Viper's motion commands. -;; Repeatable via `n' and `N'. -(defun viper-buffer-search-enable (&optional c) - (cond (c (setq viper-buffer-search-char c)) - ((null viper-buffer-search-char) - (setq viper-buffer-search-char ?g))) - (define-key viper-vi-basic-map - (char-to-string viper-buffer-search-char) 'viper-command-argument) - (aset viper-exec-array viper-buffer-search-char 'viper-exec-buffer-search) - (setq viper-prefix-commands - (cons viper-buffer-search-char viper-prefix-commands))) - -;; This is a Viper wraper for isearch-forward. -(defun viper-isearch-forward (arg) - "Do incremental search forward." - (interactive "P") - ;; emacs bug workaround - (if (listp arg) (setq arg (car arg))) - (viper-exec-form-in-emacs (list 'isearch-forward arg))) - -;; This is a Viper wraper for isearch-backward." -(defun viper-isearch-backward (arg) - "Do incremental search backward." - (interactive "P") - ;; emacs bug workaround - (if (listp arg) (setq arg (car arg))) - (viper-exec-form-in-emacs (list 'isearch-backward arg))) - - -;; visiting and killing files, buffers - -(defun viper-switch-to-buffer () - "Switch to buffer in the current window." - (interactive) - (let (buffer) - (setq buffer - (read-buffer - (format "Switch to buffer in this window \(%s\): " - (buffer-name (other-buffer (current-buffer)))))) - (switch-to-buffer buffer) - )) - -(defun viper-switch-to-buffer-other-window () - "Switch to buffer in another window." - (interactive) - (let (buffer) - (setq buffer - (read-buffer - (format "Switch to buffer in another window \(%s\): " - (buffer-name (other-buffer (current-buffer)))))) - (switch-to-buffer-other-window buffer) - )) - -(defun viper-kill-buffer () - "Kill a buffer." - (interactive) - (let (buffer buffer-name) - (setq buffer-name - (read-buffer - (format "Kill buffer \(%s\): " - (buffer-name (current-buffer))))) - (setq buffer - (if (null buffer-name) - (current-buffer) - (get-buffer buffer-name))) - (if (null buffer) (error "`%s': No such buffer" buffer-name)) - (if (or (not (buffer-modified-p buffer)) - (y-or-n-p - (format - "Buffer `%s' is modified, are you sure you want to kill it? " - buffer-name))) - (kill-buffer buffer) - (error "Buffer not killed")))) - - - -;; yank and pop - -(defsubst viper-yank (text) - "Yank TEXT silently. This works correctly with Emacs's yank-pop command." - (insert text) - (setq this-command 'yank)) - -(defun viper-put-back (arg) - "Put back after point/below line." - (interactive "P") - (let ((val (viper-p-val arg)) - (text (if viper-use-register - (cond ((viper-valid-register viper-use-register '(digit)) - (current-kill - (- viper-use-register ?1) 'do-not-rotate)) - ((viper-valid-register viper-use-register) - (get-register (downcase viper-use-register))) - (t (error viper-InvalidRegister viper-use-register))) - (current-kill 0)))) - (if (null text) - (if viper-use-register - (let ((reg viper-use-register)) - (setq viper-use-register nil) - (error viper-EmptyRegister reg)) - (error ""))) - (setq viper-use-register nil) - (if (viper-end-with-a-newline-p text) - (progn - (end-of-line) - (if (eobp) - (insert "\n") - (forward-line 1)) - (beginning-of-line)) - (if (not (eolp)) (viper-forward-char-carefully))) - (set-marker (viper-mark-marker) (point) (current-buffer)) - (viper-set-destructive-command - (list 'viper-put-back val nil viper-use-register nil nil)) - (viper-loop val (viper-yank text))) - ;; Vi puts cursor on the last char when the yanked text doesn't contain a - ;; newline; it leaves the cursor at the beginning when the text contains - ;; a newline - (if (viper-same-line (point) (mark)) - (or (= (point) (mark)) (viper-backward-char-carefully)) - (exchange-point-and-mark) - (if (bolp) - (back-to-indentation))) - (viper-deactivate-mark)) - -(defun viper-Put-back (arg) - "Put back at point/above line." - (interactive "P") - (let ((val (viper-p-val arg)) - (text (if viper-use-register - (cond ((viper-valid-register viper-use-register '(digit)) - (current-kill - (- viper-use-register ?1) 'do-not-rotate)) - ((viper-valid-register viper-use-register) - (get-register (downcase viper-use-register))) - (t (error viper-InvalidRegister viper-use-register))) - (current-kill 0)))) - (if (null text) - (if viper-use-register - (let ((reg viper-use-register)) - (setq viper-use-register nil) - (error viper-EmptyRegister reg)) - (error ""))) - (setq viper-use-register nil) - (if (viper-end-with-a-newline-p text) (beginning-of-line)) - (viper-set-destructive-command - (list 'viper-Put-back val nil viper-use-register nil nil)) - (set-marker (viper-mark-marker) (point) (current-buffer)) - (viper-loop val (viper-yank text))) - ;; Vi puts cursor on the last char when the yanked text doesn't contain a - ;; newline; it leaves the cursor at the beginning when the text contains - ;; a newline - (if (viper-same-line (point) (mark)) - (or (= (point) (mark)) (viper-backward-char-carefully)) - (exchange-point-and-mark) - (if (bolp) - (back-to-indentation))) - (viper-deactivate-mark)) - - -;; Copy region to kill-ring. -;; If BEG and END do not belong to the same buffer, copy empty region. -(defun viper-copy-region-as-kill (beg end) - (condition-case nil - (copy-region-as-kill beg end) - (error (copy-region-as-kill beg beg)))) - - -(defun viper-delete-char (arg) - "Delete next character." - (interactive "P") - (let ((val (viper-p-val arg)) - end-del-pos) - (viper-set-destructive-command - (list 'viper-delete-char val nil nil nil nil)) - (if (and viper-ex-style-editing - (> val (viper-chars-in-region (point) (viper-line-pos 'end)))) - (setq val (viper-chars-in-region (point) (viper-line-pos 'end)))) - (if (and viper-ex-style-motion (eolp)) - (if (bolp) (error "") (setq val 0))) ; not bol---simply back 1 ch - (save-excursion - (viper-forward-char-carefully val) - (setq end-del-pos (point))) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '((Letter))) - (viper-append-to-register - (downcase viper-use-register) (point) end-del-pos)) - ((viper-valid-register viper-use-register) - (copy-to-register - viper-use-register (point) end-del-pos nil)) - (t (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - - (delete-char val t) - (if viper-ex-style-motion - (if (and (eolp) (not (bolp))) (backward-char 1))) - )) - -(defun viper-delete-backward-char (arg) - "Delete previous character. On reaching beginning of line, stop and beep." - (interactive "P") - (let ((val (viper-p-val arg)) - end-del-pos) - (viper-set-destructive-command - (list 'viper-delete-backward-char val nil nil nil nil)) - (if (and - viper-ex-style-editing - (> val (viper-chars-in-region (viper-line-pos 'start) (point)))) - (setq val (viper-chars-in-region (viper-line-pos 'start) (point)))) - (save-excursion - (viper-backward-char-carefully val) - (setq end-del-pos (point))) - (if viper-use-register - (progn - (cond ((viper-valid-register viper-use-register '(Letter)) - (viper-append-to-register - (downcase viper-use-register) end-del-pos (point))) - ((viper-valid-register viper-use-register) - (copy-to-register - viper-use-register end-del-pos (point) nil)) - (t (error viper-InvalidRegister viper-use-register))) - (setq viper-use-register nil))) - (if (and (bolp) viper-ex-style-editing) - (ding)) - (delete-backward-char val t))) - -(defun viper-del-backward-char-in-insert () - "Delete 1 char backwards while in insert mode." - (interactive) - (if (and viper-ex-style-editing (bolp)) - (beep 1) - (delete-backward-char 1 t))) - -(defun viper-del-backward-char-in-replace () - "Delete one character in replace mode. -If `viper-delete-backwards-in-replace' is t, then DEL key actually deletes -charecters. If it is nil, then the cursor just moves backwards, similarly -to Vi. The variable `viper-ex-style-editing', if t, doesn't let the -cursor move past the beginning of line." - (interactive) - (cond (viper-delete-backwards-in-replace - (cond ((not (bolp)) - (delete-backward-char 1 t)) - (viper-ex-style-editing - (beep 1)) - ((bobp) - (beep 1)) - (t - (delete-backward-char 1 t)))) - (viper-ex-style-editing - (if (bolp) - (beep 1) - (backward-char 1))) - (t - (backward-char 1)))) - - - -;; join lines. - -(defun viper-join-lines (arg) - "Join this line to next, if ARG is nil. Otherwise, join ARG lines." - (interactive "*P") - (let ((val (viper-P-val arg))) - (viper-set-destructive-command - (list 'viper-join-lines val nil nil nil nil)) - (viper-loop (if (null val) 1 (1- val)) - (end-of-line) - (if (not (eobp)) - (progn - (forward-line 1) - (delete-region (point) (1- (point))) - (fixup-whitespace) - ;; fixup-whitespace sometimes does not leave space - ;; between objects, so we insert it as in Vi - (or (looking-at " ") - (insert " ") - (backward-char 1)) - ))))) - - -;; Replace state - -(defun viper-change (beg end) - (if (markerp beg) (setq beg (marker-position beg))) - (if (markerp end) (setq end (marker-position end))) - ;; beg is sometimes (mark t), which may be nil - (or beg (setq beg end)) - - (viper-set-complex-command-for-undo) - (if viper-use-register - (progn - (copy-to-register viper-use-register beg end nil) - (setq viper-use-register nil))) - (viper-set-replace-overlay beg end) - (setq last-command nil) ; separate repl text from prev kills - - (if (= (viper-replace-start) (point-max)) - (error "End of buffer")) - - (setq viper-last-replace-region - (buffer-substring (viper-replace-start) - (viper-replace-end))) - - ;; protect against error while inserting "@" and other disasters - ;; (e.g., read-only buff) - (condition-case conds - (if (or viper-allow-multiline-replace-regions - (viper-same-line (viper-replace-start) - (viper-replace-end))) - (progn - ;; tabs cause problems in replace, so untabify - (goto-char (viper-replace-end)) - (insert-before-markers "@") ; put placeholder after the TAB - (untabify (viper-replace-start) (point)) - ;; del @, don't put on kill ring - (delete-backward-char 1) - - (viper-set-replace-overlay-glyphs - viper-replace-region-start-delimiter - viper-replace-region-end-delimiter) - ;; this move takes care of the last posn in the overlay, which - ;; has to be shifted because of insert. We can't simply insert - ;; "$" before-markers because then overlay-start will shift the - ;; beginning of the overlay in case we are replacing a single - ;; character. This fixes the bug with `s' and `cl' commands. - (viper-move-replace-overlay (viper-replace-start) (point)) - (goto-char (viper-replace-start)) - (viper-change-state-to-replace t)) - (kill-region (viper-replace-start) - (viper-replace-end)) - (viper-hide-replace-overlay) - (viper-change-state-to-insert)) - (error ;; make sure that the overlay doesn't stay. - ;; go back to the original point - (goto-char (viper-replace-start)) - (viper-hide-replace-overlay) - (viper-message-conditions conds)))) - - -(defun viper-change-subr (beg end) - ;; beg is sometimes (mark t), which may be nil - (or beg (setq beg end)) - (if viper-use-register - (progn - (copy-to-register viper-use-register beg end nil) - (setq viper-use-register nil))) - (kill-region beg end) - (setq this-command 'viper-change) - (viper-yank-last-insertion)) - -(defun viper-toggle-case (arg) - "Toggle character case." - (interactive "P") - (let ((val (viper-p-val arg)) (c)) - (viper-set-destructive-command - (list 'viper-toggle-case val nil nil nil nil)) - (while (> val 0) - (setq c (following-char)) - (delete-char 1 nil) - (if (eq c (upcase c)) - (insert-char (downcase c) 1) - (insert-char (upcase c) 1)) - (if (eolp) (backward-char 1)) - (setq val (1- val))))) - - -;; query replace - -(defun viper-query-replace () - "Query replace. -If a null string is suplied as the string to be replaced, -the query replace mode will toggle between string replace -and regexp replace." - (interactive) - (let (str) - (setq str (viper-read-string-with-history - (if viper-re-query-replace "Query replace regexp: " - "Query replace: ") - nil ; no initial - 'viper-replace1-history - (car viper-replace1-history) ; default - )) - (if (string= str "") - (progn - (setq viper-re-query-replace (not viper-re-query-replace)) - (message "Query replace mode changed to %s" - (if viper-re-query-replace "regexp replace" - "string replace"))) - (if viper-re-query-replace - (query-replace-regexp - str - (viper-read-string-with-history - (format "Query replace regexp `%s' with: " str) - nil ; no initial - 'viper-replace1-history - (car viper-replace1-history) ; default - )) - (query-replace - str - (viper-read-string-with-history - (format "Query replace `%s' with: " str) - nil ; no initial - 'viper-replace1-history - (car viper-replace1-history) ; default - )))))) - - -;; marking - -(defun viper-mark-beginning-of-buffer () - "Mark beginning of buffer." - (interactive) - (push-mark (point)) - (goto-char (point-min)) - (exchange-point-and-mark) - (message "Mark set at the beginning of buffer")) - -(defun viper-mark-end-of-buffer () - "Mark end of buffer." - (interactive) - (push-mark (point)) - (goto-char (point-max)) - (exchange-point-and-mark) - (message "Mark set at the end of buffer")) - -(defun viper-mark-point () - "Set mark at point of buffer." - (interactive) - (let ((char (read-char))) - (cond ((and (<= ?a char) (<= char ?z)) - (point-to-register (1+ (- char ?a)))) - ((= char ?<) (viper-mark-beginning-of-buffer)) - ((= char ?>) (viper-mark-end-of-buffer)) - ((= char ?.) (viper-set-mark-if-necessary)) - ((= char ?,) (viper-cycle-through-mark-ring)) - ((= char ?D) (mark-defun)) - (t (error "")) - ))) - -;; Algorithm: If first invocation of this command save mark on ring, goto -;; mark, M0, and pop the most recent elt from the mark ring into mark, -;; making it into the new mark, M1. -;; Push this mark back and set mark to the original point position, p1. -;; So, if you hit '' or `` then you can return to p1. -;; -;; If repeated command, pop top elt from the ring into mark and -;; jump there. This forgets the position, p1, and puts M1 back into mark. -;; Then we save the current pos, which is M0, jump to M1 and pop M2 from -;; the ring into mark. Push M2 back on the ring and set mark to M0. -;; etc. -(defun viper-cycle-through-mark-ring () - "Visit previous locations on the mark ring. -One can use `` and '' to temporarily jump 1 step back." - (let* ((sv-pt (point))) - ;; if repeated `m,' command, pop the previously saved mark. - ;; Prev saved mark is actually prev saved point. It is used if the - ;; user types `` or '' and is discarded - ;; from the mark ring by the next `m,' command. - ;; In any case, go to the previous or previously saved mark. - ;; Then push the current mark (popped off the ring) and set current - ;; point to be the mark. Current pt as mark is discarded by the next - ;; m, command. - (if (eq last-command 'viper-cycle-through-mark-ring) - () - ;; save current mark if the first iteration - (setq mark-ring (delete (viper-mark-marker) mark-ring)) - (if (mark t) - (push-mark (mark t) t)) ) - (pop-mark) - (set-mark-command 1) - ;; don't duplicate mark on the ring - (setq mark-ring (delete (viper-mark-marker) mark-ring)) - (push-mark sv-pt t) - (viper-deactivate-mark) - (setq this-command 'viper-cycle-through-mark-ring) - )) - - -(defun viper-goto-mark (arg) - "Go to mark." - (interactive "P") - (let ((char (read-char)) - (com (viper-getcom arg))) - (viper-goto-mark-subr char com nil))) - -(defun viper-goto-mark-and-skip-white (arg) - "Go to mark and skip to first non-white character on line." - (interactive "P") - (let ((char (read-char)) - (com (viper-getCom arg))) - (viper-goto-mark-subr char com t))) - -(defun viper-goto-mark-subr (char com skip-white) - (if (eobp) - (if (bobp) - (error "Empty buffer") - (backward-char 1))) - (cond ((viper-valid-register char '(letter)) - (let* ((buff (current-buffer)) - (reg (1+ (- char ?a))) - (text-marker (get-register reg))) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (if (not (viper-valid-marker text-marker)) - (error viper-EmptyTextmarker char)) - (if (and (viper-same-line (point) viper-last-jump) - (= (point) viper-last-jump-ignore)) - (push-mark viper-last-jump t) - (push-mark nil t)) ; no msg - (viper-register-to-point reg) - (setq viper-last-jump (point-marker)) - (cond (skip-white - (back-to-indentation) - (setq viper-last-jump-ignore (point)))) - (if com - (if (equal buff (current-buffer)) - (viper-execute-com (if skip-white - 'viper-goto-mark-and-skip-white - 'viper-goto-mark) - nil com) - (switch-to-buffer buff) - (goto-char viper-com-point) - (viper-change-state-to-vi) - (error ""))))) - ((and (not skip-white) (= char ?`)) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (if (and (viper-same-line (point) viper-last-jump) - (= (point) viper-last-jump-ignore)) - (goto-char viper-last-jump)) - (if (null (mark t)) (error "Mark is not set in this buffer")) - (if (= (point) (mark t)) (pop-mark)) - (exchange-point-and-mark) - (setq viper-last-jump (point-marker) - viper-last-jump-ignore 0) - (if com (viper-execute-com 'viper-goto-mark nil com))) - ((and skip-white (= char ?')) - (if com (viper-move-marker-locally 'viper-com-point (point))) - (if (and (viper-same-line (point) viper-last-jump) - (= (point) viper-last-jump-ignore)) - (goto-char viper-last-jump)) - (if (= (point) (mark t)) (pop-mark)) - (exchange-point-and-mark) - (setq viper-last-jump (point)) - (back-to-indentation) - (setq viper-last-jump-ignore (point)) - (if com (viper-execute-com 'viper-goto-mark-and-skip-white nil com))) - (t (error viper-InvalidTextmarker char)))) - -(defun viper-insert-tab () - (interactive) - (insert-tab)) - -(defun viper-exchange-point-and-mark () - (interactive) - (exchange-point-and-mark) - (back-to-indentation)) - -;; Input Mode Indentation - -;; Returns t, if the string before point matches the regexp STR. -(defsubst viper-looking-back (str) - (and (save-excursion (re-search-backward str nil t)) - (= (point) (match-end 0)))) - - -(defun viper-forward-indent () - "Indent forward -- `C-t' in Vi." - (interactive) - (setq viper-cted t) - (indent-to (+ (current-column) viper-shift-width))) - -(defun viper-backward-indent () - "Backtab, C-d in VI" - (interactive) - (if viper-cted - (let ((p (point)) (c (current-column)) bol (indent t)) - (if (viper-looking-back "[0^]") - (progn - (if (eq ?^ (preceding-char)) - (setq viper-preserve-indent t)) - (delete-backward-char 1) - (setq p (point)) - (setq indent nil))) - (save-excursion - (beginning-of-line) - (setq bol (point))) - (if (re-search-backward "[^ \t]" bol 1) (forward-char)) - (delete-region (point) p) - (if indent - (indent-to (- c viper-shift-width))) - (if (or (bolp) (viper-looking-back "[^ \t]")) - (setq viper-cted nil))))) - -(defun viper-autoindent () - "Auto Indentation, Vi-style." - (interactive) - (let ((col (current-indentation))) - (if abbrev-mode (expand-abbrev)) - (if viper-preserve-indent - (setq viper-preserve-indent nil) - (setq viper-current-indent col)) - ;; don't leave whitespace lines around - (if (memq last-command - '(viper-autoindent - viper-open-line viper-Open-line - viper-replace-state-exit-cmd)) - (indent-to-left-margin)) - ;; use \n instead of newline, or else <Return> will move the insert point - ;;(newline 1) - (insert "\n") - (if viper-auto-indent - (progn - (setq viper-cted t) - (if (and viper-electric-mode - (not - (memq major-mode '(fundamental-mode - text-mode - paragraph-indent-text-mode )))) - (indent-according-to-mode) - (indent-to viper-current-indent)) - )) - )) - - -;; Viewing registers - -(defun viper-ket-function (arg) - "Function called by \], the ket. View registers and call \]\]." - (interactive "P") - (let ((reg (read-char))) - (cond ((viper-valid-register reg '(letter Letter)) - (view-register (downcase reg))) - ((viper-valid-register reg '(digit)) - (let ((text (current-kill (- reg ?1) 'do-not-rotate))) - (with-output-to-temp-buffer " *viper-info*" - (princ (format "Register %c contains the string:\n" reg)) - (princ text)) - )) - ((= ?\] reg) - (viper-next-heading arg)) - (t (error - viper-InvalidRegister reg))))) - -(defun viper-brac-function (arg) - "Function called by \[, the brac. View textmarkers and call \[\[" - (interactive "P") - (let ((reg (read-char))) - (cond ((= ?\[ reg) - (viper-prev-heading arg)) - ((= ?\] reg) - (viper-heading-end arg)) - ((viper-valid-register reg '(letter)) - (let* ((val (get-register (1+ (- reg ?a)))) - (buf (if (not (markerp val)) - (error viper-EmptyTextmarker reg) - (marker-buffer val))) - (pos (marker-position val)) - line-no text (s pos) (e pos)) - (with-output-to-temp-buffer " *viper-info*" - (if (and buf pos) - (progn - (save-excursion - (set-buffer buf) - (setq line-no (1+ (count-lines (point-min) val))) - (goto-char pos) - (beginning-of-line) - (if (re-search-backward "[^ \t]" nil t) - (progn - (beginning-of-line) - (setq s (point)))) - (goto-char pos) - (forward-line 1) - (if (re-search-forward "[^ \t]" nil t) - (progn - (end-of-line) - (setq e (point)))) - (setq text (buffer-substring s e)) - (setq text (format "%s<%c>%s" - (substring text 0 (- pos s)) - reg (substring text (- pos s))))) - (princ - (format - "Textmarker `%c' is in buffer `%s' at line %d.\n" - reg (buffer-name buf) line-no)) - (princ (format "Here is some text around %c:\n\n %s" - reg text))) - (princ (format viper-EmptyTextmarker reg)))) - )) - (t (error viper-InvalidTextmarker reg))))) - - - -;; commands in insertion mode - -(defun viper-delete-backward-word (arg) - "Delete previous word." - (interactive "p") - (save-excursion - (push-mark nil t) - (backward-word arg) - (delete-region (point) (mark t)) - (pop-mark))) - - -(defun viper-set-expert-level (&optional dont-change-unless) - "Sets the expert level for a Viper user. -Can be called interactively to change (temporarily or permanently) the -current expert level. - -The optional argument DONT-CHANGE-UNLESS, if not nil, says that -the level should not be changed, unless its current value is -meaningless (i.e., not one of 1,2,3,4,5). - -User level determines the setting of Viper variables that are most -sensitive for VI-style look-and-feel." - - (interactive) - - (if (not (natnump viper-expert-level)) (setq viper-expert-level 0)) - - (save-window-excursion - (delete-other-windows) - ;; if 0 < viper-expert-level < viper-max-expert-level - ;; & dont-change-unless = t -- use it; else ask - (viper-ask-level dont-change-unless)) - - (setq viper-always t - viper-ex-style-motion t - viper-ex-style-editing t - viper-want-ctl-h-help nil) - - (cond ((eq viper-expert-level 1) ; novice or beginner - (global-set-key ; in emacs-state - viper-toggle-key - (if (viper-window-display-p) 'viper-iconify 'suspend-emacs)) - (setq viper-no-multiple-ESC t - viper-re-search t - viper-vi-style-in-minibuffer t - viper-search-wrap-around-t t - viper-electric-mode nil - viper-want-emacs-keys-in-vi nil - viper-want-emacs-keys-in-insert nil)) - - ((and (> viper-expert-level 1) (< viper-expert-level 5)) - ;; intermediate to guru - (setq viper-no-multiple-ESC (if (viper-window-display-p) - t 'twice) - viper-electric-mode t - viper-want-emacs-keys-in-vi t - viper-want-emacs-keys-in-insert (> viper-expert-level 2)) - - (if (eq viper-expert-level 4) ; respect user's ex-style motion - ; and viper-no-multiple-ESC - (progn - (setq-default - viper-ex-style-editing - (viper-standard-value 'viper-ex-style-editing) - viper-ex-style-motion - (viper-standard-value 'viper-ex-style-motion)) - (setq viper-ex-style-motion - (viper-standard-value 'viper-ex-style-motion) - viper-ex-style-editing - (viper-standard-value 'viper-ex-style-editing) - viper-re-search - (viper-standard-value 'viper-re-search) - viper-no-multiple-ESC - (viper-standard-value 'viper-no-multiple-ESC))))) - - ;; A wizard!! - ;; Ideally, if 5 is selected, a buffer should pop up to let the - ;; user toggle the values of variables. - (t (setq-default viper-ex-style-editing - (viper-standard-value 'viper-ex-style-editing) - viper-ex-style-motion - (viper-standard-value 'viper-ex-style-motion)) - (setq viper-want-ctl-h-help - (viper-standard-value 'viper-want-ctl-h-help) - viper-always - (viper-standard-value 'viper-always) - viper-no-multiple-ESC - (viper-standard-value 'viper-no-multiple-ESC) - viper-ex-style-motion - (viper-standard-value 'viper-ex-style-motion) - viper-ex-style-editing - (viper-standard-value 'viper-ex-style-editing) - viper-re-search - (viper-standard-value 'viper-re-search) - viper-electric-mode - (viper-standard-value 'viper-electric-mode) - viper-want-emacs-keys-in-vi - (viper-standard-value 'viper-want-emacs-keys-in-vi) - viper-want-emacs-keys-in-insert - (viper-standard-value 'viper-want-emacs-keys-in-insert)))) - - (viper-set-mode-vars-for viper-current-state) - (if (or viper-always - (and (> viper-expert-level 0) (> 5 viper-expert-level))) - (viper-set-hooks))) - -;; Ask user expert level. -(defun viper-ask-level (dont-change-unless) - (let ((ask-buffer " *viper-ask-level*") - level-changed repeated) - (save-window-excursion - (switch-to-buffer ask-buffer) - - (while (or (> viper-expert-level viper-max-expert-level) - (< viper-expert-level 1) - (null dont-change-unless)) - (erase-buffer) - (if repeated - (progn - (message "Invalid user level") - (beep 1)) - (setq repeated t)) - (setq dont-change-unless t - level-changed t) - (insert " -Please specify your level of familiarity with the venomous VI PERil -(and the VI Plan for Emacs Rescue). -You can change it at any time by typing `M-x viper-set-expert-level RET' - - 1 -- BEGINNER: Almost all Emacs features are suppressed. - Feels almost like straight Vi. File name completion and - command history in the minibuffer are thrown in as a bonus. - To use Emacs productively, you must reach level 3 or higher. - 2 -- MASTER: C-c now has its standard Emacs meaning in Vi command state, - so most Emacs commands can be used when Viper is in Vi state. - Good progress---you are well on the way to level 3! - 3 -- GRAND MASTER: Like 3, but most Emacs commands are available also - in Viper's insert state. - 4 -- GURU: Like 3, but user settings are respected for viper-no-multiple-ESC, - viper-ex-style-motion, viper-ex-style-editing, and - viper-re-search variables. Adjust these settings to your taste. - 5 -- WIZARD: Like 4, but user settings are also respected for viper-always, - viper-electric-mode, viper-want-ctl-h-help, viper-want-emacs-keys-in-vi, - and viper-want-emacs-keys-in-insert. Adjust these to your taste. - -Please, specify your level now: ") - - (setq viper-expert-level (- (viper-read-char-exclusive) ?0)) - ) ; end while - - ;; tell the user if level was changed - (and level-changed - (progn - (insert - (format "\n\n\n\n\n\t\tYou have selected user level %d" - viper-expert-level)) - (if (y-or-n-p "Do you wish to make this change permanent? ") - ;; save the setting for viper-expert-level - (viper-save-setting - 'viper-expert-level - (format "Saving user level %d ..." viper-expert-level) - viper-custom-file-name)) - )) - (bury-buffer) ; remove ask-buffer from screen - (message "") - ))) - - -(defun viper-nil () - (interactive) - (beep 1)) - - -;; if ENFORCE-BUFFER is not nil, error if CHAR is a marker in another buffer -(defun viper-register-to-point (char &optional enforce-buffer) - "Like jump-to-register, but switches to another buffer in another window." - (interactive "cViper register to point: ") - (let ((val (get-register char))) - (cond - ((and (fboundp 'frame-configuration-p) - (frame-configuration-p val)) - (set-frame-configuration val)) - ((window-configuration-p val) - (set-window-configuration val)) - ((viper-valid-marker val) - (if (and enforce-buffer - (not (equal (current-buffer) (marker-buffer val)))) - (error (concat viper-EmptyTextmarker " in this buffer") - (1- (+ char ?a)))) - (pop-to-buffer (marker-buffer val)) - (goto-char val)) - ((and (consp val) (eq (car val) 'file)) - (find-file (cdr val))) - (t - (error viper-EmptyTextmarker (1- (+ char ?a))))))) - - -(defun viper-save-kill-buffer () - "Save then kill current buffer. " - (interactive) - (if (< viper-expert-level 2) - (save-buffers-kill-emacs) - (save-buffer) - (kill-buffer (current-buffer)))) - - - -;;; Bug Report - -(defun viper-submit-report () - "Submit bug report on Viper." - (interactive) - (let ((reporter-prompt-for-summary-p t) - (viper-device-type (viper-device-type)) - color-display-p frame-parameters - minibuffer-emacs-face minibuffer-vi-face minibuffer-insert-face - varlist salutation window-config) - - ;; If mode info is needed, add variable to `let' and then set it below, - ;; like we did with color-display-p. - (setq color-display-p (if (viper-window-display-p) - (viper-color-display-p) - 'non-x) - minibuffer-vi-face (if (viper-has-face-support-p) - (viper-get-face viper-minibuffer-vi-face) - 'non-x) - minibuffer-insert-face (if (viper-has-face-support-p) - (viper-get-face - viper-minibuffer-insert-face) - 'non-x) - minibuffer-emacs-face (if (viper-has-face-support-p) - (viper-get-face - viper-minibuffer-emacs-face) - 'non-x) - frame-parameters (if (fboundp 'frame-parameters) - (frame-parameters (selected-frame)))) - - (setq varlist (list 'viper-vi-minibuffer-minor-mode - 'viper-insert-minibuffer-minor-mode - 'viper-vi-intercept-minor-mode - 'viper-vi-local-user-minor-mode - 'viper-vi-kbd-minor-mode - 'viper-vi-global-user-minor-mode - 'viper-vi-state-modifier-minor-mode - 'viper-vi-diehard-minor-mode - 'viper-vi-basic-minor-mode - 'viper-replace-minor-mode - 'viper-insert-intercept-minor-mode - 'viper-insert-local-user-minor-mode - 'viper-insert-kbd-minor-mode - 'viper-insert-global-user-minor-mode - 'viper-insert-state-modifier-minor-mode - 'viper-insert-diehard-minor-mode - 'viper-insert-basic-minor-mode - 'viper-emacs-intercept-minor-mode - 'viper-emacs-local-user-minor-mode - 'viper-emacs-kbd-minor-mode - 'viper-emacs-global-user-minor-mode - 'viper-emacs-state-modifier-minor-mode - 'viper-automatic-iso-accents - 'viper-special-input-method - 'viper-want-emacs-keys-in-insert - 'viper-want-emacs-keys-in-vi - 'viper-keep-point-on-undo - 'viper-no-multiple-ESC - 'viper-electric-mode - 'viper-ESC-key - 'viper-want-ctl-h-help - 'viper-ex-style-editing - 'viper-delete-backwards-in-replace - 'viper-vi-style-in-minibuffer - 'viper-vi-state-hook - 'viper-insert-state-hook - 'viper-replace-state-hook - 'viper-emacs-state-hook - 'ex-cycle-other-window - 'ex-cycle-through-non-files - 'viper-expert-level - 'major-mode - 'viper-device-type - 'color-display-p - 'frame-parameters - 'minibuffer-vi-face - 'minibuffer-insert-face - 'minibuffer-emacs-face - )) - (setq salutation " -Congratulations! You may have unearthed a bug in Viper! -Please mail a concise, accurate summary of the problem to the address above. - --------------------------------------------------------------------") - (setq window-config (current-window-configuration)) - (with-output-to-temp-buffer " *viper-info*" - (switch-to-buffer " *viper-info*") - (delete-other-windows) - (princ " -PLEASE FOLLOW THESE PROCEDURES ------------------------------- - -Before reporting a bug, please verify that it is related to Viper, and is -not cause by other packages you are using. - -Don't report compilation warnings, unless you are certain that there is a -problem. These warnings are normal and unavoidable. - -Please note that users should not modify variables and keymaps other than -those advertised in the manual. Such `customization' is likely to crash -Viper, as it would any other improperly customized Emacs package. - -If you are reporting an error message received while executing one of the -Viper commands, type: - - M-x set-variable <Return> debug-on-error <Return> t <Return> - -Then reproduce the error. The above command will cause Emacs to produce a -back trace of the execution that leads to the error. Please include this -trace in your bug report. - -If you believe that one of Viper's commands goes into an infinite loop -\(e.g., Emacs freezes\), type: - - M-x set-variable <Return> debug-on-quit <Return> t <Return> - -Then reproduce the problem. Wait for a few seconds, then type C-g to abort -the current command. Include the resulting back trace in the bug report. - -Mail anyway (y or n)? ") - (if (y-or-n-p "Mail anyway? ") - () - (set-window-configuration window-config) - (error "Bug report aborted"))) - - (require 'reporter) - (set-window-configuration window-config) - - (reporter-submit-bug-report "kifer@cs.sunysb.edu" - (viper-version) - varlist - nil 'delete-other-windows - salutation) - )) - - - - -;; Smoothes out the difference between Emacs' unread-command-events -;; and XEmacs unread-command-event. Arg is a character, an event, a list of -;; events or a sequence of keys. -;; -;; Due to the way unread-command-events in Emacs (not XEmacs), a non-event -;; symbol in unread-command-events list may cause Emacs to turn this symbol -;; into an event. Below, we delete nil from event lists, since nil is the most -;; common symbol that might appear in this wrong context. -(defun viper-set-unread-command-events (arg) - (if viper-emacs-p - (setq - unread-command-events - (let ((new-events - (cond ((eventp arg) (list arg)) - ((listp arg) arg) - ((sequencep arg) - (listify-key-sequence arg)) - (t (error - "viper-set-unread-command-events: Invalid argument, %S" - arg))))) - (if (not (eventp nil)) - (setq new-events (delq nil new-events))) - (append new-events unread-command-events))) - ;; XEmacs - (setq - unread-command-events - (append - (cond ((viper-characterp arg) (list (character-to-event arg))) - ((eventp arg) (list arg)) - ((stringp arg) (mapcar 'character-to-event arg)) - ((vectorp arg) (append arg nil)) ; turn into list - ((listp arg) (viper-eventify-list-xemacs arg)) - (t (error - "viper-set-unread-command-events: Invalid argument, %S" arg))) - unread-command-events)))) - -;; list is assumed to be a list of events of characters -(defun viper-eventify-list-xemacs (lis) - (mapcar - (function (lambda (elt) - (cond ((viper-characterp elt) (character-to-event elt)) - ((eventp elt) elt) - (t (error - "viper-eventify-list-xemacs: can't convert to event, %S" - elt))))) - lis)) - - - -;;; viper-cmd.el ends here
--- a/lisp/viper/viper-ex.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2154 +0,0 @@ -;;; viper-ex.el --- functions implementing the Ex commands for Viper - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Code - -(provide 'viper-ex) - -;; Compiler pacifier -(defvar read-file-name-map) -(defvar viper-use-register) -(defvar viper-s-string) -(defvar viper-shift-width) -(defvar viper-ex-history) -(defvar viper-related-files-and-buffers-ring) -(defvar viper-local-search-start-marker) -(defvar viper-expert-level) -(defvar viper-custom-file-name) -(defvar viper-case-fold-search) -(defvar explicit-shell-file-name) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-keym) - (load "viper-keym.el" nil nil 'nosuffix)) - (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) - ))) -;; end pacifier - -(require 'viper-util) - -(defgroup viper-ex nil - "Viper support for Ex commands" - :prefix "ex-" - :group 'viper) - - - -;;; Variables - -(defconst viper-ex-work-buf-name " *ex-working-space*") -(defconst viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) -(defconst viper-ex-tmp-buf-name " *ex-tmp*") - - -;;; Variable completion in :set command - -;; The list of Ex commands. Used for completing command names. -(defconst ex-token-alist - '(("!") ("=") (">") ("&") ("~") - ("yank") ("xit") ("WWrite") ("Write") ("write") ("wq") ("visual") - ("version") ("vglobal") ("unmap") ("undo") ("tag") ("transfer") ("suspend") - ("substitute") ("submitReport") ("stop") ("sr") ("source") ("shell") - ("set") ("rewind") ("recover") ("read") ("quit") ("pwd") - ("put") ("preserve") ("PreviousRelatedFile") ("RelatedFile") - ("next") ("Next") ("move") ("mark") ("map") ("kmark") ("join") - ("help") ("goto") ("global") ("file") ("edit") ("delete") ("copy") - ("chdir") ("cd") ("Buffer") ("buffer") ("args")) ) - -;; A-list of Ex variables that can be set using the :set command. -(defconst ex-variable-alist - '(("wrapscan") ("ws") ("wrapmargin") ("wm") - ("tabstop-global") ("ts-g") ("tabstop") ("ts") - ("showmatch") ("sm") ("shiftwidth") ("sw") ("shell") ("sh") - ("readonly") ("ro") - ("nowrapscan") ("nows") ("noshowmatch") ("nosm") - ("noreadonly") ("noro") ("nomagic") ("noma") - ("noignorecase") ("noic") - ("noautoindent-global") ("noai-g") ("noautoindent") ("noai") - ("magic") ("ma") ("ignorecase") ("ic") - ("autoindent-global") ("ai-g") ("autoindent") ("ai") - ("all") - )) - - - -;; Token recognized during parsing of Ex commands (e.g., "read", "comma") -(defvar ex-token nil) - -;; Type of token. -;; If non-nil, gives type of address; if nil, it is a command. -(defvar ex-token-type nil) - -;; List of addresses passed to Ex command -(defvar ex-addresses nil) - -;; This flag is supposed to be set only by `#', `print', and `list', -;; none of which is implemented. So, it and the pices of the code it -;; controls are dead weight. We keep it just in case this might be -;; needed in the future. -(defvar ex-flag nil) - -;; "buffer" where Ex commands keep deleted data. -;; In Emacs terms, this is a register. -(defvar ex-buffer nil) - -;; Value of ex count. -(defvar ex-count nil) - -;; Flag indicating that :global Ex command is being executed. -(defvar ex-g-flag nil) -;; Flag indicating that :vglobal Ex command is being executed. -(defvar ex-g-variant nil) - -;; Save reg-exp used in substitute. -(defvar ex-reg-exp nil) - - -;; Replace pattern for substitute. -(defvar ex-repl nil) - -;; Pattern for global command. -(defvar ex-g-pat nil) - -(defcustom ex-unix-type-shell - (let ((case-fold-search t)) - (and (stringp shell-file-name) - (string-match - (concat - "\\(" - "csh$\\|csh.exe$" - "\\|" - "ksh$\\|ksh.exe$" - "\\|" - "^sh$\\|sh.exe$" - "\\|" - "[^a-z]sh$\\|[^a-z]sh.exe$" - "\\|" - "bash$\\|bash.exe$" - "\\)") - shell-file-name))) - "Is the user using a unix-type shell under a non-OS?" - :type 'boolean - :group 'viper-ex) - -(defcustom ex-unix-type-shell-options - (let ((case-fold-search t)) - (if ex-unix-type-shell - (cond ((string-match "\\(csh$\\|csh.exe$\\)" shell-file-name) - "-f") ; csh: do it fast - ((string-match "\\(bash$\\|bash.exe$\\)" shell-file-name) - "-noprofile") ; bash: ignore .profile - ))) - "Options to pass to the Unix-style shell. -Don't put `-c' here, as it is added automatically." - :type 'string - :group 'viper-ex) - -(defvar ex-nontrivial-find-file-function - (cond (ex-unix-type-shell 'viper-ex-nontrivial-find-file-unix) - ((eq system-type 'emx) 'viper-ex-nontrivial-find-file-ms) ; OS/2 - (viper-ms-style-os-p 'viper-ex-nontrivial-find-file-ms) ; Microsoft OS - (viper-vms-os-p 'viper-ex-nontrivial-find-file-unix) ; VMS - (t 'viper-ex-nontrivial-find-file-unix) ; presumably UNIX - )) - -;; Remembers the previous Ex tag. -(defvar ex-tag nil) - -;; file used by Ex commands like :r, :w, :n -(defvar ex-file nil) - -;; If t, tells Ex that this is a variant-command, i.e., w>>, r!, etc. -(defvar ex-variant nil) - -;; Specified the offset of an Ex command, such as :read. -(defvar ex-offset nil) - -;; Tells Ex that this is a w>> command. -(defvar ex-append nil) - -;; File containing the shell command to be executed at Ex prompt, -;; e.g., :r !date -(defvar ex-cmdfile nil) - -;; flag used in viper-ex-read-file-name to indicate that we may be reading -;; multiple file names. Used for :edit and :next -(defvar viper-keep-reading-filename nil) - -(defcustom ex-cycle-other-window t - "*If t, :n and :b cycles through files and buffers in other window. -Then :N and :B cycles in the current window. If nil, this behavior is -reversed." - :type 'boolean - :group 'viper-ex) - -(defcustom ex-cycle-through-non-files nil - "*Cycle through *scratch* and other buffers that don't visit any file." - :type 'boolean - :group 'viper-ex) - -;; Last shell command executed with :! command. -(defvar viper-ex-last-shell-com nil) - -;; Indicates if Minibuffer was exited temporarily in Ex-command. -(defvar viper-incomplete-ex-cmd nil) - -;; Remembers the last ex-command prompt. -(defvar viper-last-ex-prompt "") - - -;;; Code - -;; Check if ex-token is an initial segment of STR -(defun viper-check-sub (str) - (let ((length (length ex-token))) - (if (and (<= length (length str)) - (string= ex-token (substring str 0 length))) - (setq ex-token str) - (setq ex-token-type 'non-command)))) - -;; Get a complete ex command -(defun viper-get-ex-com-subr () - (let (case-fold-search) - (set-mark (point)) - (re-search-forward "[a-zA-Z][a-zA-Z]*") - (setq ex-token-type 'command) - (setq ex-token (buffer-substring (point) (mark t))) - (exchange-point-and-mark) - (cond ((looking-at "a") - (cond ((looking-at "ab") (viper-check-sub "abbreviate")) - ((looking-at "ar") (viper-check-sub "args")) - (t (viper-check-sub "append")))) - ((looking-at "h") (viper-check-sub "help")) - ((looking-at "c") - (cond ((looking-at "cd") (viper-check-sub "cd")) - ((looking-at "ch") (viper-check-sub "chdir")) - ((looking-at "co") (viper-check-sub "copy")) - (t (viper-check-sub "change")))) - ((looking-at "d") (viper-check-sub "delete")) - ((looking-at "b") (viper-check-sub "buffer")) - ((looking-at "B") (viper-check-sub "Buffer")) - ((looking-at "e") - (if (looking-at "ex") (viper-check-sub "ex") - (viper-check-sub "edit"))) - ((looking-at "f") (viper-check-sub "file")) - ((looking-at "g") (viper-check-sub "global")) - ((looking-at "i") (viper-check-sub "insert")) - ((looking-at "j") (viper-check-sub "join")) - ((looking-at "l") (viper-check-sub "list")) - ((looking-at "m") - (cond ((looking-at "map") (viper-check-sub "map")) - ((looking-at "mar") (viper-check-sub "mark")) - (t (viper-check-sub "move")))) - ((looking-at "k[a-z][^a-z]") - (setq ex-token "kmark") - (forward-char 1) - (exchange-point-and-mark)) ; this is canceled out by another - ; exchange-point-and-mark at the end - ((looking-at "k") (viper-check-sub "kmark")) - ((looking-at "n") (if (looking-at "nu") - (viper-check-sub "number") - (viper-check-sub "next"))) - ((looking-at "N") (viper-check-sub "Next")) - ((looking-at "o") (viper-check-sub "open")) - ((looking-at "p") - (cond ((looking-at "pre") (viper-check-sub "preserve")) - ((looking-at "pu") (viper-check-sub "put")) - ((looking-at "pw") (viper-check-sub "pwd")) - (t (viper-check-sub "print")))) - ((looking-at "P") (viper-check-sub "PreviousRelatedFile")) - ((looking-at "R") (viper-check-sub "RelatedFile")) - ((looking-at "q") (viper-check-sub "quit")) - ((looking-at "r") - (cond ((looking-at "rec") (viper-check-sub "recover")) - ((looking-at "rew") (viper-check-sub "rewind")) - (t (viper-check-sub "read")))) - ((looking-at "s") - (cond ((looking-at "se") (viper-check-sub "set")) - ((looking-at "sh") (viper-check-sub "shell")) - ((looking-at "so") (viper-check-sub "source")) - ((looking-at "sr") (viper-check-sub "sr")) - ((looking-at "st") (viper-check-sub "stop")) - ((looking-at "sus") (viper-check-sub "suspend")) - ((looking-at "subm") (viper-check-sub "submitReport")) - (t (viper-check-sub "substitute")))) - ((looking-at "t") - (if (looking-at "ta") (viper-check-sub "tag") - (viper-check-sub "transfer"))) - ((looking-at "u") - (cond ((looking-at "una") (viper-check-sub "unabbreviate")) - ((looking-at "unm") (viper-check-sub "unmap")) - (t (viper-check-sub "undo")))) - ((looking-at "v") - (cond ((looking-at "ve") (viper-check-sub "version")) - ((looking-at "vi") (viper-check-sub "visual")) - (t (viper-check-sub "vglobal")))) - ((looking-at "w") - (if (looking-at "wq") (viper-check-sub "wq") - (viper-check-sub "write"))) - ((looking-at "W") - (if (looking-at "WW") - (viper-check-sub "WWrite") - (viper-check-sub "Write"))) - ((looking-at "x") (viper-check-sub "xit")) - ((looking-at "y") (viper-check-sub "yank")) - ((looking-at "z") (viper-check-sub "z"))) - (exchange-point-and-mark) - )) - -;; Get an ex-token which is either an address or a command. -;; A token has a type, \(command, address, end-mark\), and a value -(defun viper-get-ex-token () - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t|") - (let ((case-fold-search t)) - (cond ((looking-at "#") - (setq ex-token-type 'command) - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - ((looking-at "[a-z]") (viper-get-ex-com-subr)) - ((looking-at "\\.") - (forward-char 1) - (setq ex-token-type 'dot)) - ((looking-at "[0-9]") - (set-mark (point)) - (re-search-forward "[0-9]*") - (setq ex-token-type - (cond ((eq ex-token-type 'plus) 'add-number) - ((eq ex-token-type 'minus) 'sub-number) - (t 'abs-number))) - (setq ex-token - (string-to-int (buffer-substring (point) (mark t))))) - ((looking-at "\\$") - (forward-char 1) - (setq ex-token-type 'end)) - ((looking-at "%") - (forward-char 1) - (setq ex-token-type 'whole)) - ((looking-at "+") - (cond ((or (looking-at "+[-+]") (looking-at "+[\n|]")) - (forward-char 1) - (insert "1") - (backward-char 1) - (setq ex-token-type 'plus)) - ((looking-at "+[0-9]") - (forward-char 1) - (setq ex-token-type 'plus)) - (t - (error viper-BadAddress)))) - ((looking-at "-") - (cond ((or (looking-at "-[-+]") (looking-at "-[\n|]")) - (forward-char 1) - (insert "1") - (backward-char 1) - (setq ex-token-type 'minus)) - ((looking-at "-[0-9]") - (forward-char 1) - (setq ex-token-type 'minus)) - (t - (error viper-BadAddress)))) - ((looking-at "/") - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - ;;(re-search-forward "[^/]*/") - (re-search-forward "[^/]*\\(/\\|\n\\)") - (if (not (viper-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\/")) - (setq cont nil)))) - (backward-char 1) - (setq ex-token (buffer-substring (point) (mark t))) - (if (looking-at "/") (forward-char 1)) - (setq ex-token-type 'search-forward)) - ((looking-at "\\?") - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - ;;(re-search-forward "[^\\?]*\\?") - (re-search-forward "[^\\?]*\\(\\?\\|\n\\)") - (if (not (viper-looking-back "[^\\\\]\\(\\\\\\\\\\)*\\\\\\?")) - (setq cont nil)) - (backward-char 1) - (if (not (looking-at "\n")) (forward-char 1)))) - (setq ex-token-type 'search-backward) - (setq ex-token (buffer-substring (1- (point)) (mark t)))) - ((looking-at ",") - (forward-char 1) - (setq ex-token-type 'comma)) - ((looking-at ";") - (forward-char 1) - (setq ex-token-type 'semi-colon)) - ((looking-at "[!=><&~]") - (setq ex-token-type 'command) - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - ((looking-at "'") - (setq ex-token-type 'goto-mark) - (forward-char 1) - (cond ((looking-at "'") (setq ex-token nil)) - ((looking-at "[a-z]") (setq ex-token (following-char))) - (t (error "Marks are ' and a-z"))) - (forward-char 1)) - ((looking-at "\n") - (setq ex-token-type 'end-mark) - (setq ex-token "goto")) - (t - (error viper-BadExCommand)))))) - -;; Reads Ex command. Tries to determine if it has to exit because command -;; is complete or invalid. If not, keeps reading command. -(defun ex-cmd-read-exit () - (interactive) - (setq viper-incomplete-ex-cmd t) - (let ((quit-regex1 (concat - "\\(" "set[ \t]*" - "\\|" "edit[ \t]*" - "\\|" "[nN]ext[ \t]*" - "\\|" "unm[ \t]*" - "\\|" "^[ \t]*rep" - "\\)")) - (quit-regex2 (concat - "[a-zA-Z][ \t]*" - "\\(" "!" "\\|" ">>" - "\\|" "\\+[0-9]+" - "\\)" - "*[ \t]*$")) - (stay-regex (concat - "\\(" "^[ \t]*$" - "\\|" "[?/].*" - "\\|" "[ktgjmsz][ \t]*$" - "\\|" "^[ \t]*ab.*" - "\\|" "tr[ansfer \t]*" - "\\|" "sr[ \t]*" - "\\|" "mo.*" - "\\|" "^[ \t]*k?ma[^p]*" - "\\|" "^[ \t]*fi.*" - "\\|" "v?gl.*" - "\\|" "[vg][ \t]*$" - "\\|" "jo.*" - "\\|" "^[ \t]*ta.*" - "\\|" "^[ \t]*una.*" - "\\|" "^[ \t]*su.*" - "\\|['`][a-z][ \t]*" - "\\|" "![ \t]*[a-zA-Z].*" - "\\)" - "!*"))) - - (save-window-excursion ;; put cursor at the end of the Ex working buffer - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (goto-char (point-max))) - (cond ((viper-looking-back quit-regex1) (exit-minibuffer)) - ((viper-looking-back stay-regex) (insert " ")) - ((viper-looking-back quit-regex2) (exit-minibuffer)) - (t (insert " "))))) - -;; complete Ex command -(defun ex-cmd-complete () - (interactive) - (let (save-pos dist compl-list string-to-complete completion-result) - - (save-excursion - (setq dist (skip-chars-backward "[a-zA-Z!=>&~]") - save-pos (point))) - - (if (or (= dist 0) - (viper-looking-back "\\([ \t]*['`][ \t]*[a-z]*\\)") - (viper-looking-back - "^[ \t]*[a-zA-Z!=>&~][ \t]*[/?]*+[ \t]+[a-zA-Z!=>&~]+")) - ;; Preceding characters are not the ones allowed in an Ex command - ;; or we have typed past command name. - ;; Note: we didn't do parsing, so there may be surprises. - (if (or (viper-looking-back "[a-zA-Z!=>&~][ \t]*[/?]*[ \t]*") - (viper-looking-back "\\([ \t]*['`][ \t]*[a-z]*\\)") - (looking-at "[^ \t\n\C-m]")) - nil - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (viper-alist-to-list ex-token-alist)))) - ;; Preceding chars may be part of a command name - (setq string-to-complete (buffer-substring save-pos (point))) - (setq completion-result - (try-completion string-to-complete ex-token-alist)) - - (cond ((eq completion-result t) ; exact match--do nothing - (viper-tmp-insert-at-eob " (Sole completion)")) - ((eq completion-result nil) - (viper-tmp-insert-at-eob " (No match)")) - (t ;; partial completion - (goto-char save-pos) - (delete-region (point) (point-max)) - (insert completion-result) - (let (case-fold-search) - (setq compl-list - (viper-filter-alist (concat "^" completion-result) - ex-token-alist))) - (if (> (length compl-list) 1) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (viper-alist-to-list (reverse compl-list))))))) - ))) - - -;; Read Ex commands -(defun viper-ex (&optional string) - (interactive) - (or string - (setq ex-g-flag nil - ex-g-variant nil)) - (let* ((map (copy-keymap minibuffer-local-map)) - (address nil) - (cont t) - (dot (point)) - prev-token-type com-str) - - (viper-add-keymap viper-ex-cmd-map map) - - (setq com-str (or string (viper-read-string-with-history - ":" - nil - 'viper-ex-history - (car viper-ex-history) - map))) - (save-window-excursion - ;; just a precaution - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (delete-region (point-min) (point-max)) - (insert com-str "\n") - (goto-char (point-min))) - (setq ex-token-type nil - ex-addresses nil) - (while cont - (viper-get-ex-token) - (cond ((memq ex-token-type '(command end-mark)) - (if address (setq ex-addresses (cons address ex-addresses))) - (cond ((string= ex-token "global") - (ex-global nil) - (setq cont nil)) - ((string= ex-token "vglobal") - (ex-global t) - (setq cont nil)) - (t - (viper-execute-ex-command) - (save-window-excursion - (setq viper-ex-work-buf - (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (cond ((looking-at "|") - (forward-char 1)) - ((looking-at "\n") - (setq cont nil)) - (t (error "`%s': %s" ex-token viper-SpuriousText))) - )) - )) - ((eq ex-token-type 'non-command) - (error "`%s': %s" ex-token viper-BadExCommand)) - ((eq ex-token-type 'whole) - (setq address nil) - (setq ex-addresses - (if ex-addresses - (cons (point-max) ex-addresses) - (cons (point-max) (cons (point-min) ex-addresses))))) - ((eq ex-token-type 'comma) - (if (eq prev-token-type 'whole) - (setq address (point-min))) - (setq ex-addresses - (cons (if (null address) (point) address) ex-addresses))) - ((eq ex-token-type 'semi-colon) - (if (eq prev-token-type 'whole) - (setq address (point-min))) - (if address (setq dot address)) - (setq ex-addresses - (cons (if (null address) (point) address) ex-addresses))) - (t (let ((ans (viper-get-ex-address-subr address dot))) - (if ans (setq address ans))))) - (setq prev-token-type ex-token-type)))) - - -;; Get a regular expression and set `ex-variant', if found -(defun viper-get-ex-pat () - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-g-variant (not ex-g-variant) - ex-g-flag (not ex-g-flag)) - (forward-char 1) - (skip-chars-forward " \t"))) - (let ((c (following-char))) - (if (string-match "[0-9A-Za-z]" (format "%c" c)) - (error - "Global regexp must be inside matching non-alphanumeric chars")) - (if (looking-at "[^\\\\\n]") - (progn - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - (if (not (re-search-forward (format "[^%c]*%c" c c) nil t)) - (if (member ex-token '("global" "vglobal")) - (error - "Missing closing delimiter for global regexp") - (goto-char (point-max)))) - (if (not (viper-looking-back - (format "[^\\\\]\\(\\\\\\\\\\)*\\\\%c" c))) - (setq cont nil)))) - (setq ex-token - (if (= (mark t) (point)) "" - (buffer-substring (1- (point)) (mark t)))) - (backward-char 1) - ;; if the user doesn't specify the final pattern delimiter, we're - ;; at newline now. In this case, insert the initial delimiter - ;; specified in variable c - (if (looking-at "\n") - (progn - (insert c) - (backward-char 1))) - ) - (setq ex-token nil)) - c))) - -;; get an ex command -(defun viper-get-ex-command () - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (if (looking-at "/") (forward-char 1)) - (skip-chars-forward " \t") - (cond ((looking-at "[a-z]") - (viper-get-ex-com-subr) - (if (eq ex-token-type 'non-command) - (error "`%s': %s" ex-token viper-BadExCommand))) - ((looking-at "[!=><&~]") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - (t (error viper-BadExCommand))))) - -;; Get an Ex option g or c -(defun viper-get-ex-opt-gc (c) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (if (looking-at (format "%c" c)) (forward-char 1)) - (skip-chars-forward " \t") - (cond ((looking-at "g") - (setq ex-token "g") - (forward-char 1) - t) - ((looking-at "c") - (setq ex-token "c") - (forward-char 1) - t) - (t nil)))) - -;; Compute default addresses. WHOLE-FLAG means use the whole buffer -(defun viper-default-ex-addresses (&optional whole-flag) - (cond ((null ex-addresses) - (setq ex-addresses - (if whole-flag - (cons (point-max) (cons (point-min) nil)) - (cons (point) (cons (point) nil))))) - ((null (cdr ex-addresses)) - (setq ex-addresses - (cons (car ex-addresses) ex-addresses))))) - -;; Get an ex-address as a marker and set ex-flag if a flag is found -(defun viper-get-ex-address () - (let ((address (point-marker)) - (cont t)) - (setq ex-token "") - (setq ex-flag nil) - (while cont - (viper-get-ex-token) - (cond ((eq ex-token-type 'command) - (if (member ex-token '("print" "list" "#")) - (progn - (setq ex-flag t - cont nil)) - (error "Address expected in this Ex command"))) - ((eq ex-token-type 'end-mark) - (setq cont nil)) - ((eq ex-token-type 'whole) - (error "Trailing address expected")) - ((eq ex-token-type 'comma) - (error "`%s': %s" ex-token viper-SpuriousText)) - (t (let ((ans (viper-get-ex-address-subr address (point-marker)))) - (if ans (setq address ans)))))) - address)) - -;; Returns an address as a point -(defun viper-get-ex-address-subr (old-address dot) - (let ((address nil)) - (if (null old-address) (setq old-address dot)) - (cond ((eq ex-token-type 'dot) - (setq address dot)) - ((eq ex-token-type 'add-number) - (save-excursion - (goto-char old-address) - (forward-line (if (= old-address 0) (1- ex-token) ex-token)) - (setq address (point-marker)))) - ((eq ex-token-type 'sub-number) - (save-excursion - (goto-char old-address) - (forward-line (- ex-token)) - (setq address (point-marker)))) - ((eq ex-token-type 'abs-number) - (save-excursion - (goto-char (point-min)) - (if (= ex-token 0) (setq address 0) - (forward-line (1- ex-token)) - (setq address (point-marker))))) - ((eq ex-token-type 'end) - (setq address (point-max-marker))) - ((eq ex-token-type 'plus) t) ; do nothing - ((eq ex-token-type 'minus) t) ; do nothing - ((eq ex-token-type 'search-forward) - (save-excursion - (ex-search-address t) - (setq address (point-marker)))) - ((eq ex-token-type 'search-backward) - (save-excursion - (ex-search-address nil) - (setq address (point-marker)))) - ((eq ex-token-type 'goto-mark) - (save-excursion - (if (null ex-token) - (exchange-point-and-mark) - (goto-char (viper-register-to-point - (1+ (- ex-token ?a)) 'enforce-buffer))) - (setq address (point-marker))))) - address)) - - -;; Search pattern and set address -(defun ex-search-address (forward) - (if (string= ex-token "") - (if (null viper-s-string) - (error viper-NoPrevSearch) - (setq ex-token viper-s-string)) - (setq viper-s-string ex-token)) - (if forward - (progn - (forward-line 1) - (re-search-forward ex-token)) - (forward-line -1) - (re-search-backward ex-token))) - -;; Get a buffer name and set `ex-count' and `ex-flag' if found -(defun viper-get-ex-buffer () - (setq ex-buffer nil) - (setq ex-count nil) - (setq ex-flag nil) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (if (looking-at "[a-zA-Z]") - (progn - (setq ex-buffer (following-char)) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at "[0-9]") - (progn - (set-mark (point)) - (re-search-forward "[0-9][0-9]*") - (setq ex-count (string-to-int (buffer-substring (point) (mark t)))) - (skip-chars-forward " \t"))) - (if (looking-at "[pl#]") - (progn - (setq ex-flag t) - (forward-char 1))) - (if (not (looking-at "[\n|]")) - (error "`%s': %s" ex-token viper-SpuriousText)))) - -(defun viper-get-ex-count () - (setq ex-variant nil - ex-count nil - ex-flag nil) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-variant t) - (forward-char 1))) - (skip-chars-forward " \t") - (if (looking-at "[0-9]") - (progn - (set-mark (point)) - (re-search-forward "[0-9][0-9]*") - (setq ex-count (string-to-int (buffer-substring (point) (mark t)))) - (skip-chars-forward " \t"))) - (if (looking-at "[pl#]") - (progn - (setq ex-flag t) - (forward-char 1))) - (if (not (looking-at "[\n|]")) - (error "`%s': %s" - (buffer-substring - (point-min) (1- (point-max))) viper-BadExCommand)))) - -;; Expand \% and \# in ex command -(defun ex-expand-filsyms (cmd buf) - (let (cf pf ret) - (save-excursion - (set-buffer buf) - (setq cf buffer-file-name) - (setq pf (ex-next nil t))) ; this finds alternative file name - (if (and (null cf) (string-match "[^\\]%\\|\\`%" cmd)) - (error "No current file to substitute for `%%'")) - (if (and (null pf) (string-match "[^\\]#\\|\\`#" cmd)) - (error "No alternate file to substitute for `#'")) - (save-excursion - (set-buffer (get-buffer-create viper-ex-tmp-buf-name)) - (erase-buffer) - (insert cmd) - (goto-char (point-min)) - (while (re-search-forward "%\\|#" nil t) - (let ((data (match-data)) - (char (buffer-substring (match-beginning 0) (match-end 0)))) - (if (viper-looking-back (concat "\\\\" char)) - (replace-match char) - (store-match-data data) - (if (string= char "%") - (replace-match cf) - (replace-match pf))))) - (end-of-line) - (setq ret (buffer-substring (point-min) (point))) - (message "%s" ret)) - ret)) - -;; Get a file name and set ex-variant, `ex-append' and `ex-offset' if found -(defun viper-get-ex-file () - (let (prompt) - (setq ex-file nil - ex-variant nil - ex-append nil - ex-offset nil - ex-cmdfile nil) - (save-excursion - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (if (looking-at "!") - (if (and (not (viper-looking-back "[ \t]")) - ;; read doesn't have a corresponding :r! form, so ! is - ;; immediately interpreted as a shell command. - (not (string= ex-token "read"))) - (progn - (setq ex-variant t) - (forward-char 1) - (skip-chars-forward " \t")) - (setq ex-cmdfile t) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at ">>") - (progn - (setq ex-append t - ex-variant t) - (forward-char 2) - (skip-chars-forward " \t"))) - (if (looking-at "+") - (progn - (forward-char 1) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq ex-offset (buffer-substring (point) (mark t))) - (forward-char 1) - (skip-chars-forward " \t"))) - ;; this takes care of :r, :w, etc., when they get file names - ;; from the history list - (if (member ex-token '("read" "write" "edit" "visual" "next")) - (progn - (setq ex-file (buffer-substring (point) (1- (point-max)))) - (setq ex-file - ;; For :e, match multiple non-white strings separated - ;; by white. For others, find the first non-white string - (if (string-match - (if (string= ex-token "edit") - "[^ \t\n]+\\([ \t]+[^ \t\n]+\\)*" - "[^ \t\n]+") - ex-file) - (progn - ;; if file name comes from history, don't leave - ;; minibuffer when the user types space - (setq viper-incomplete-ex-cmd nil) - ;; this must be the last clause in this progn - (substring ex-file (match-beginning 0) (match-end 0)) - ) - "")) - ;; this leaves only the command name in the work area - ;; file names are gone - (delete-region (point) (1- (point-max))) - )) - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (setq prompt (buffer-substring (point-min) (point))) - )) - - (setq viper-last-ex-prompt prompt) - - ;; If we just finished reading command, redisplay prompt - (if viper-incomplete-ex-cmd - (setq ex-file (viper-ex-read-file-name (format ":%s " prompt))) - ;; file was typed in-line - (setq ex-file (or ex-file ""))) - )) - - -;; Completes file name or exits minibuffer. If Ex command accepts multiple -;; file names, arranges to re-enter the minibuffer. -(defun viper-complete-filename-or-exit () - (interactive) - (setq viper-keep-reading-filename t) - ;; don't exit if directory---ex-commands don't - (cond ((ex-cmd-accepts-multiple-files-p ex-token) (exit-minibuffer)) - ;; apparently the argument to an Ex command is - ;; supposed to be a shell command - ((viper-looking-back "^[ \t]*!.*") - (setq ex-cmdfile t) - (insert " ")) - (t - (setq ex-cmdfile nil) - (minibuffer-complete-word)))) - -(defun viper-handle-! () - (interactive) - (if (and (string= - (buffer-string) (viper-abbreviate-file-name default-directory)) - (member ex-token '("read" "write"))) - (erase-buffer)) - (insert "!")) - -(defun ex-cmd-accepts-multiple-files-p (token) - (member token '("edit" "next" "Next"))) - -;; If user doesn't enter anything, then "" is returned, i.e., the -;; prompt-directory is not returned. -(defun viper-ex-read-file-name (prompt) - (let* ((str "") - (minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map)) - beg end cont val) - - (viper-add-keymap ex-read-filename-map - (if viper-emacs-p - minibuffer-local-completion-map - read-file-name-map)) - - (setq cont (setq viper-keep-reading-filename t)) - (while cont - (setq viper-keep-reading-filename nil - val (read-file-name (concat prompt str) nil default-directory)) - (if (string-match " " val) - (setq val (concat "\\\"" val "\\\""))) - (setq str (concat str (if (equal val "") "" " ") - val (if (equal val "") "" " "))) - - ;; Only edit, next, and Next commands accept multiple files. - ;; viper-keep-reading-filename is set in the anonymous function that is - ;; bound to " " in ex-read-filename-map. - (setq cont (and viper-keep-reading-filename - (ex-cmd-accepts-multiple-files-p ex-token))) - ) - - (setq beg (string-match "[^ \t]" str) ; delete leading blanks - end (string-match "[ \t]*$" str)) ; delete trailing blanks - (if (member ex-token '("read" "write")) - (if (string-match "[\t ]*!" str) - ;; this is actually a shell command - (progn - (setq ex-cmdfile t) - (setq beg (1+ beg)) - (setq viper-last-ex-prompt - (concat viper-last-ex-prompt " !"))))) - (substring str (or beg 0) end))) - -;; Execute ex command using the value of addresses -(defun viper-execute-ex-command () - (viper-deactivate-mark) - (cond ((string= ex-token "args") (ex-args)) - ((string= ex-token "copy") (ex-copy nil)) - ((string= ex-token "cd") (ex-cd)) - ((string= ex-token "chdir") (ex-cd)) - ((string= ex-token "delete") (ex-delete)) - ((string= ex-token "edit") (ex-edit)) - ((string= ex-token "file") (viper-info-on-file)) - ((string= ex-token "goto") (ex-goto)) - ((string= ex-token "help") (ex-help)) - ((string= ex-token "join") (ex-line "join")) - ((string= ex-token "kmark") (ex-mark)) - ((string= ex-token "mark") (ex-mark)) - ((string= ex-token "map") (ex-map)) - ((string= ex-token "move") (ex-copy t)) - ((string= ex-token "next") (ex-next ex-cycle-other-window)) - ((string= ex-token "Next") (ex-next (not ex-cycle-other-window))) - ((string= ex-token "RelatedFile") (ex-next-related-buffer 1)) - ((string= ex-token "put") (ex-put)) - ((string= ex-token "pwd") (ex-pwd)) - ((string= ex-token "preserve") (ex-preserve)) - ((string= ex-token "PreviousRelatedFile") (ex-next-related-buffer -1)) - ((string= ex-token "quit") (ex-quit)) - ((string= ex-token "read") (ex-read)) - ((string= ex-token "recover") (ex-recover)) - ((string= ex-token "rewind") (ex-rewind)) - ((string= ex-token "submitReport") (viper-submit-report)) - ((string= ex-token "set") (ex-set)) - ((string= ex-token "shell") (ex-shell)) - ((string= ex-token "source") (ex-source)) - ((string= ex-token "sr") (ex-substitute t t)) - ((string= ex-token "substitute") (ex-substitute)) - ((string= ex-token "suspend") (suspend-emacs)) - ((string= ex-token "stop") (suspend-emacs)) - ((string= ex-token "transfer") (ex-copy nil)) - ((string= ex-token "buffer") (if ex-cycle-other-window - (viper-switch-to-buffer-other-window) - (viper-switch-to-buffer))) - ((string= ex-token "Buffer") (if ex-cycle-other-window - (viper-switch-to-buffer) - (viper-switch-to-buffer-other-window))) - ((string= ex-token "tag") (ex-tag)) - ((string= ex-token "undo") (viper-undo)) - ((string= ex-token "unmap") (ex-unmap)) - ((string= ex-token "version") (viper-version)) - ((string= ex-token "visual") (ex-edit)) - ((string= ex-token "write") (ex-write nil)) - ((string= ex-token "Write") (save-some-buffers)) - ((string= ex-token "wq") (ex-write t)) - ((string= ex-token "WWrite") (save-some-buffers t)) ; don't ask - ((string= ex-token "xit") (ex-write t)) - ((string= ex-token "yank") (ex-yank)) - ((string= ex-token "!") (ex-command)) - ((string= ex-token "=") (ex-line-no)) - ((string= ex-token ">") (ex-line "right")) - ((string= ex-token "<") (ex-line "left")) - ((string= ex-token "&") (ex-substitute t)) - ((string= ex-token "~") (ex-substitute t t)) - ((or (string= ex-token "append") - (string= ex-token "change") - (string= ex-token "insert") - (string= ex-token "open")) - (error "`%s': Obsolete command, not supported by Viper" ex-token)) - ((or (string= ex-token "abbreviate") - (string= ex-token "unabbreviate")) - (error - "`%s': Vi abbrevs are obsolete. Use the more powerful Emacs abbrevs" - ex-token)) - ((or (string= ex-token "list") - (string= ex-token "print") - (string= ex-token "z") - (string= ex-token "#")) - (error "`%s': Command not implemented in Viper" ex-token)) - (t (error "`%s': %s" ex-token viper-BadExCommand)))) - -(defun viper-undisplayed-files () - (mapcar - (function - (lambda (b) - (if (null (get-buffer-window b)) - (let ((f (buffer-file-name b))) - (if f f - (if ex-cycle-through-non-files - (let ((s (buffer-name b))) - (if (string= " " (substring s 0 1)) - nil - s)) - nil))) - nil))) - (buffer-list))) - - -(defun ex-args () - (let ((l (viper-undisplayed-files)) - (args "") - (file-count 1)) - (while (not (null l)) - (if (car l) - (setq args (format "%s %d) %s\n" args file-count (car l)) - file-count (1+ file-count))) - (setq l (cdr l))) - (if (string= args "") - (message "All files are already displayed") - (save-excursion - (save-window-excursion - (with-output-to-temp-buffer " *viper-info*" - (princ "\n\nThese files are not displayed in any window.\n") - (princ "\n=============\n") - (princ args) - (princ "\n=============\n") - (princ "\nThe numbers can be given as counts to :next. ") - (princ "\n\nPress any key to continue...\n\n")) - (viper-read-event)))))) - -;; Ex cd command. Default directory of this buffer changes -(defun ex-cd () - (viper-get-ex-file) - (if (string= ex-file "") - (setq ex-file "~")) - (setq default-directory (file-name-as-directory (expand-file-name ex-file)))) - -;; Ex copy and move command. DEL-FLAG means delete -(defun ex-copy (del-flag) - (viper-default-ex-addresses) - (let ((address (viper-get-ex-address)) - (end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (goto-char end) - (save-excursion - (push-mark beg t) - (viper-enlarge-region (mark t) (point)) - (if del-flag - (kill-region (point) (mark t)) - (copy-region-as-kill (point) (mark t))) - (if ex-flag - (progn - (with-output-to-temp-buffer " *copy text*" - (princ - (if (or del-flag ex-g-flag ex-g-variant) - (current-kill 0) - (buffer-substring (point) (mark t))))) - (condition-case nil - (progn - (read-string "[Hit return to confirm] ") - (save-excursion (kill-buffer " *copy text*"))) - (quit (save-excursion (kill-buffer " *copy text*")) - (signal 'quit nil)))))) - (if (= address 0) - (goto-char (point-min)) - (goto-char address) - (forward-line 1)) - (insert (current-kill 0)))) - -;; Ex delete command -(defun ex-delete () - (viper-default-ex-addresses) - (viper-get-ex-buffer) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error viper-FirstAddrExceedsSecond)) - (save-excursion - (viper-enlarge-region beg end) - (exchange-point-and-mark) - (if ex-count - (progn - (set-mark (point)) - (forward-line (1- ex-count))) - (set-mark end)) - (viper-enlarge-region (point) (mark t)) - (if ex-flag - ;; show text to be deleted and ask for confirmation - (progn - (with-output-to-temp-buffer " *delete text*" - (princ (buffer-substring (point) (mark t)))) - (condition-case nil - (read-string "[Hit return to confirm] ") - (quit - (save-excursion (kill-buffer " *delete text*")) - (error ""))) - (save-excursion (kill-buffer " *delete text*"))) - (if ex-buffer - (cond ((viper-valid-register ex-buffer '(Letter)) - (viper-append-to-register - (downcase ex-buffer) (point) (mark t))) - ((viper-valid-register ex-buffer) - (copy-to-register ex-buffer (point) (mark t) nil)) - (t (error viper-InvalidRegister ex-buffer)))) - (kill-region (point) (mark t)))))) - - - -;; Ex edit command -;; In Viper, `e' and `e!' behave identically. In both cases, the user is -;; asked if current buffer should really be discarded. -;; This command can take multiple file names. It replaces the current buffer -;; with the first file in its argument list -(defun ex-edit (&optional file) - (if (not file) - (viper-get-ex-file)) - (cond ((and (string= ex-file "") buffer-file-name) - (setq ex-file (viper-abbreviate-file-name (buffer-file-name)))) - ((string= ex-file "") - (error viper-NoFileSpecified))) - - (let (msg do-edit) - (if buffer-file-name - (cond ((buffer-modified-p) - (setq msg - (format "Buffer %s is modified. Discard changes? " - (buffer-name)) - do-edit t)) - ((not (verify-visited-file-modtime (current-buffer))) - (setq msg - (format "File %s changed on disk. Reread from disk? " - buffer-file-name) - do-edit t)) - (t (setq do-edit nil)))) - - (if do-edit - (if (yes-or-no-p msg) - (progn - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (message "Buffer %s was left intact" (buffer-name)))) - ) ; let - - (if (null (setq file (get-file-buffer ex-file))) - (progn - (ex-find-file ex-file) - (or (eq major-mode 'dired-mode) - (viper-change-state-to-vi)) - (goto-char (point-min))) - (switch-to-buffer file)) - (if ex-offset - (progn - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (delete-region (point-min) (point-max)) - (insert ex-offset "\n") - (goto-char (point-min))) - (goto-char (viper-get-ex-address)) - (beginning-of-line))) - (ex-fixup-history viper-last-ex-prompt ex-file)) - -;; Find-file FILESPEC if it appears to specify a single file. -;; Otherwise, assume that FILES{EC is a wildcard. -;; In this case, split it into substrings separated by newlines. -;; Each line is assumed to be a file name. find-file's each file thus obtained. -(defun ex-find-file (filespec) - (let ((nonstandard-filename-chars "[^-a-zA-Z0-9_./,~$\\]")) - (cond ((file-exists-p filespec) (find-file filespec)) - ((string-match nonstandard-filename-chars filespec) - (funcall ex-nontrivial-find-file-function filespec)) - (t (find-file filespec))) - )) - - -;; Ex global command -;; This is executed in response to: -;; :global "pattern" ex-command -;; :vglobal "pattern" ex-command -;; :global executes ex-command on all lines matching <pattern> -;; :vglobal executes ex-command on all lines that don't match <pattern> -;; -;; With VARIANT nil, this functions executes :global -;; With VARIANT t, executes :vglobal -(defun ex-global (variant) - (let ((gcommand ex-token)) - (if (or ex-g-flag ex-g-variant) - (error "`%s' within `global' is not allowed" gcommand) - (if variant - (setq ex-g-flag nil - ex-g-variant t) - (setq ex-g-flag t - ex-g-variant nil))) - (viper-get-ex-pat) - (if (null ex-token) - (error "`%s': Missing regular expression" gcommand))) - - (if (string= ex-token "") - (if (null viper-s-string) - (error viper-NoPrevSearch) - (setq ex-g-pat viper-s-string)) - (setq ex-g-pat ex-token - viper-s-string ex-token)) - (if (null ex-addresses) - (setq ex-addresses (list (point-max) (point-min))) - (viper-default-ex-addresses)) - (let ((marks nil) - (mark-count 0) - (end (car ex-addresses)) - (beg (car (cdr ex-addresses))) - com-str) - (if (> beg end) (error viper-FirstAddrExceedsSecond)) - (save-excursion - (viper-enlarge-region beg end) - (exchange-point-and-mark) - (let ((cont t) (limit (point-marker))) - (exchange-point-and-mark) - ;; skip the last line if empty - (beginning-of-line) - (if (eobp) (viper-backward-char-carefully)) - (while (and cont (not (bobp)) (>= (point) limit)) - (beginning-of-line) - (set-mark (point)) - (end-of-line) - (let ((found (re-search-backward ex-g-pat (mark t) t))) - (if (or (and ex-g-flag found) - (and ex-g-variant (not found))) - (progn - (end-of-line) - (setq mark-count (1+ mark-count)) - (setq marks (cons (point-marker) marks))))) - (beginning-of-line) - (if (bobp) (setq cont nil) - (forward-line -1) - (end-of-line))))) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (setq com-str (buffer-substring (1+ (point)) (1- (point-max))))) - (while marks - (goto-char (car marks)) - (viper-ex com-str) - (setq mark-count (1- mark-count)) - (setq marks (cdr marks))))) - -;; Ex goto command -(defun ex-goto () - (if (null ex-addresses) - (setq ex-addresses (cons (point) nil))) - (push-mark (point) t) - (goto-char (car ex-addresses)) - (beginning-of-line)) - -;; Ex line commands. COM is join, shift-right or shift-left -(defun ex-line (com) - (viper-default-ex-addresses) - (viper-get-ex-count) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses))) point) - (if (> beg end) (error viper-FirstAddrExceedsSecond)) - (save-excursion - (viper-enlarge-region beg end) - (exchange-point-and-mark) - (if ex-count - (progn - (set-mark (point)) - (forward-line ex-count))) - (if ex-flag - ;; show text to be joined and ask for confirmation - (progn - (with-output-to-temp-buffer " *join text*" - (princ (buffer-substring (point) (mark t)))) - (condition-case nil - (progn - (read-string "[Hit return to confirm] ") - (ex-line-subr com (point) (mark t))) - (quit (ding))) - (save-excursion (kill-buffer " *join text*"))) - (ex-line-subr com (point) (mark t))) - (setq point (point))) - (goto-char (1- point)) - (beginning-of-line))) - -(defun ex-line-subr (com beg end) - (cond ((string= com "join") - (goto-char (min beg end)) - (while (and (not (eobp)) (< (point) (max beg end))) - (end-of-line) - (if (and (<= (point) (max beg end)) (not (eobp))) - (progn - (forward-line 1) - (delete-region (point) (1- (point))) - (if (not ex-variant) (fixup-whitespace)))))) - ((or (string= com "right") (string= com "left")) - (indent-rigidly - (min beg end) (max beg end) - (if (string= com "right") viper-shift-width (- viper-shift-width))) - (goto-char (max beg end)) - (end-of-line) - (viper-forward-char-carefully)))) - - -;; Ex mark command -(defun ex-mark () - (let (char) - (if (null ex-addresses) - (setq ex-addresses - (cons (point) nil))) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (if (looking-at "[a-z]") - (progn - (setq char (following-char)) - (forward-char 1) - (skip-chars-forward " \t") - (if (not (looking-at "[\n|]")) - (error "`%s': %s" ex-token viper-SpuriousText))) - (error "`%s' requires a following letter" ex-token))) - (save-excursion - (goto-char (car ex-addresses)) - (point-to-register (1+ (- char ?a)))))) - - - -;; Alternate file is the file next to the first one in the buffer ring -(defun ex-next (cycle-other-window &optional find-alt-file) - (catch 'ex-edit - (let (count l) - (if (not find-alt-file) - (progn - (viper-get-ex-file) - (if (or (char-or-string-p ex-offset) - (and (not (string= "" ex-file)) - (not (string-match "^[0-9]+$" ex-file)))) - (progn - (ex-edit t) - (throw 'ex-edit nil)) - (setq count (string-to-int ex-file)) - (if (= count 0) (setq count 1)) - (if (< count 0) (error "Usage: `next <count>' (count >= 0)")))) - (setq count 1)) - (setq l (viper-undisplayed-files)) - (while (> count 0) - (while (and (not (null l)) (null (car l))) - (setq l (cdr l))) - (setq count (1- count)) - (if (> count 0) - (setq l (cdr l)))) - (if find-alt-file (car l) - (progn - (if (and (car l) (get-file-buffer (car l))) - (let* ((w (if cycle-other-window - (get-lru-window) (selected-window))) - (b (window-buffer w))) - (set-window-buffer w (get-file-buffer (car l))) - (bury-buffer b) - ;; this puts "next <count>" in the ex-command history - (ex-fixup-history viper-last-ex-prompt ex-file)) - (error "Not that many undisplayed files"))))))) - - -(defun ex-next-related-buffer (direction &optional no-recursion) - - (viper-ring-rotate1 viper-related-files-and-buffers-ring direction) - - (let ((file-or-buffer-name - (viper-current-ring-item viper-related-files-and-buffers-ring)) - (old-ring viper-related-files-and-buffers-ring) - (old-win (selected-window)) - skip-rest buf wind) - - (or (and (ring-p viper-related-files-and-buffers-ring) - (> (ring-length viper-related-files-and-buffers-ring) 0)) - (error "This buffer has no related files or buffers")) - - (or (stringp file-or-buffer-name) - (error - "File and buffer names must be strings, %S" file-or-buffer-name)) - - (setq buf (cond ((get-buffer file-or-buffer-name)) - ((file-exists-p file-or-buffer-name) - (find-file-noselect file-or-buffer-name)) - )) - - (if (not (viper-buffer-live-p buf)) - (error "Didn't find buffer %S or file %S" - file-or-buffer-name - (viper-abbreviate-file-name - (expand-file-name file-or-buffer-name)))) - - (if (equal buf (current-buffer)) - (or no-recursion - ;; try again - (progn - (setq skip-rest t) - (ex-next-related-buffer direction 'norecursion)))) - - (if skip-rest - () - ;; setup buffer - (if (setq wind (viper-get-visible-buffer-window buf)) - () - (setq wind (get-lru-window (if viper-xemacs-p nil 'visible))) - (set-window-buffer wind buf)) - - (if (viper-window-display-p) - (progn - (raise-frame (window-frame wind)) - (if (equal (window-frame wind) (window-frame old-win)) - (save-window-excursion (select-window wind) (sit-for 1)) - (select-window wind))) - (save-window-excursion (select-window wind) (sit-for 1))) - - (save-excursion - (set-buffer buf) - (setq viper-related-files-and-buffers-ring old-ring)) - - (setq viper-local-search-start-marker (point-marker)) - ))) - - -;; Force auto save -(defun ex-preserve () - (message "Autosaving all buffers that need to be saved...") - (do-auto-save t)) - -;; Ex put -(defun ex-put () - (let ((point (if (null ex-addresses) (point) (car ex-addresses)))) - (viper-get-ex-buffer) - (setq viper-use-register ex-buffer) - (goto-char point) - (if (bobp) (viper-Put-back 1) (viper-put-back 1)))) - -;; Ex print working directory -(defun ex-pwd () - (message default-directory)) - -;; Ex quit command -(defun ex-quit () - ;; skip "!", if it is q!. In Viper q!, w!, etc., behave as q, w, etc. - (save-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (if (looking-at "!") (forward-char 1))) - (if (< viper-expert-level 3) - (save-buffers-kill-emacs) - (kill-buffer (current-buffer)))) - - -;; Ex read command -(defun ex-read () - (viper-get-ex-file) - (let ((point (if (null ex-addresses) (point) (car ex-addresses))) - command) - (goto-char point) - (viper-add-newline-at-eob-if-necessary) - (if (not (or (bobp) (eobp))) (forward-line 1)) - (if (and (not ex-variant) (string= ex-file "")) - (progn - (if (null buffer-file-name) - (error viper-NoFileSpecified)) - (setq ex-file buffer-file-name))) - (if ex-cmdfile - (progn - (setq command (ex-expand-filsyms ex-file (current-buffer))) - (shell-command command t)) - (insert-file-contents ex-file))) - (ex-fixup-history viper-last-ex-prompt ex-file)) - -;; this function fixes ex-history for some commands like ex-read, ex-edit -(defun ex-fixup-history (&rest args) - (setq viper-ex-history - (cons (mapconcat 'identity args " ") (cdr viper-ex-history)))) - - -;; Ex recover from emacs \#file\# -(defun ex-recover () - (viper-get-ex-file) - (if (or ex-append ex-offset) - (error "`recover': %s" viper-SpuriousText)) - (if (string= ex-file "") - (progn - (if (null buffer-file-name) - (error "This buffer isn't visiting any file")) - (setq ex-file buffer-file-name)) - (setq ex-file (expand-file-name ex-file))) - (if (and (not (string= ex-file (buffer-file-name))) - (buffer-modified-p) - (not ex-variant)) - (error "No write since last change \(:rec! overrides\)")) - (recover-file ex-file)) - -;; Tell that `rewind' is obsolete and to use `:next count' instead -(defun ex-rewind () - (message - "Use `:n <count>' instead. Counts are obtained from the `:args' command")) - - -;; read variable name for ex-set -(defun ex-set-read-variable () - (let ((minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map)) - (cursor-in-echo-area t) - str batch) - (define-key - minibuffer-local-completion-map " " 'minibuffer-complete-and-exit) - (define-key minibuffer-local-completion-map "=" 'exit-minibuffer) - (if (viper-set-unread-command-events - (ex-get-inline-cmd-args "[ \t]*[a-zA-Z]*[ \t]*" nil "\C-m")) - (progn - (setq batch t) - (viper-set-unread-command-events ?\C-m))) - (message ":set <Variable> [= <Value>]") - (or batch (sit-for 2)) - - (while (string-match "^[ \\t\\n]*$" - (setq str - (completing-read ":set " ex-variable-alist))) - (message ":set <Variable> [= <Value>]") - ;; if there are unread events, don't wait - (or (viper-set-unread-command-events "") (sit-for 2)) - ) ; while - str)) - - -(defun ex-set () - (let ((var (ex-set-read-variable)) - (val 0) - (set-cmd "setq") - (ask-if-save t) - (auto-cmd-label "; don't touch or else...") - (delete-turn-on-auto-fill-pattern - "([ \t]*add-hook[ \t]+'viper-insert-state-hooks[ \t]+'turn-on-auto-fill.*)") - actual-lisp-cmd lisp-cmd-del-pattern - val2 orig-var) - (setq orig-var var) - (cond ((string= var "all") - (setq ask-if-save nil - set-cmd nil)) - ((member var '("ai" "autoindent")) - (setq var "viper-auto-indent" - set-cmd "setq" - ask-if-save nil - val "t")) - ((member var '("ai-g" "autoindent-global")) - (kill-local-variable 'viper-auto-indent) - (setq var "viper-auto-indent" - set-cmd "setq-default" - val "t")) - ((member var '("noai" "noautoindent")) - (setq var "viper-auto-indent" - ask-if-save nil - val "nil")) - ((member var '("noai-g" "noautoindent-global")) - (kill-local-variable 'viper-auto-indent) - (setq var "viper-auto-indent" - set-cmd "setq-default" - val "nil")) - ((member var '("ic" "ignorecase")) - (setq var "viper-case-fold-search" - val "t")) - ((member var '("noic" "noignorecase")) - (setq var "viper-case-fold-search" - val "nil")) - ((member var '("ma" "magic")) - (setq var "viper-re-search" - val "t")) - ((member var '("noma" "nomagic")) - (setq var "viper-re-search" - val "nil")) - ((member var '("ro" "readonly")) - (setq var "buffer-read-only" - val "t")) - ((member var '("noro" "noreadonly")) - (setq var "buffer-read-only" - val "nil")) - ((member var '("sm" "showmatch")) - (setq var "blink-matching-paren" - val "t")) - ((member var '("nosm" "noshowmatch")) - (setq var "blink-matching-paren" - val "nil")) - ((member var '("ws" "wrapscan")) - (setq var "viper-search-wrap-around-t" - val "t")) - ((member var '("nows" "nowrapscan")) - (setq var "viper-search-wrap-around-t" - val "nil"))) - (if (and set-cmd (eq val 0)) ; value must be set by the user - (let ((cursor-in-echo-area t)) - (message ":set %s = <Value>" var) - ;; if there are unread events, don't wait - (or (viper-set-unread-command-events "") (sit-for 2)) - (setq val (read-string (format ":set %s = " var))) - (ex-fixup-history "set" orig-var val) - - ;; check numerical values - (if (member var - '("sw" "shiftwidth" - "ts" "tabstop" - "ts-g" "tabstop-global" - "wm" "wrapmargin")) - (condition-case nil - (or (numberp (setq val2 (car (read-from-string val)))) - (error "%s: Invalid value, numberp, %S" var val)) - (error - (error "%s: Invalid value, numberp, %S" var val)))) - - (cond - ((member var '("sw" "shiftwidth")) - (setq var "viper-shift-width")) - ((member var '("ts" "tabstop")) - ;; make it take effect in curr buff and new bufs - (setq var "tab-width" - set-cmd "setq" - ask-if-save nil)) - ((member var '("ts-g" "tabstop-global")) - (kill-local-variable 'tab-width) - (setq var "tab-width" - set-cmd "setq-default")) - ((member var '("wm" "wrapmargin")) - ;; make it take effect in curr buff and new bufs - (kill-local-variable 'fill-column) - (setq var "fill-column" - val (format "(- (window-width) %s)" val) - set-cmd "setq-default")) - ((member var '("sh" "shell")) - (setq var "explicit-shell-file-name" - val (format "\"%s\"" val))))) - (ex-fixup-history "set" orig-var)) - - (if set-cmd - (setq actual-lisp-cmd - (format "\n(%s %s %s) %s" set-cmd var val auto-cmd-label) - lisp-cmd-del-pattern - (format "^\n?[ \t]*([ \t]*%s[ \t]+%s[ \t].*)[ \t]*%s" - set-cmd var auto-cmd-label))) - - (if (and ask-if-save - (y-or-n-p (format "Do you want to save this setting in %s " - viper-custom-file-name))) - (progn - (viper-save-string-in-file - actual-lisp-cmd viper-custom-file-name - ;; del pattern - lisp-cmd-del-pattern) - (if (string= var "fill-column") - (if (> val2 0) - (viper-save-string-in-file - (concat - "(add-hook 'viper-insert-state-hooks 'turn-on-auto-fill) " - auto-cmd-label) - viper-custom-file-name - delete-turn-on-auto-fill-pattern) - (viper-save-string-in-file - nil viper-custom-file-name delete-turn-on-auto-fill-pattern) - (viper-save-string-in-file - nil viper-custom-file-name - ;; del pattern - lisp-cmd-del-pattern) - )) - )) - - (if set-cmd - (message "%s %s %s" - set-cmd var - (if (string-match "^[ \t]*$" val) - (format "%S" val) - val))) - (if actual-lisp-cmd - (eval (car (read-from-string actual-lisp-cmd)))) - (if (string= var "fill-column") - (if (> val2 0) - (auto-fill-mode 1) - (auto-fill-mode -1))) - (if (string= var "all") (ex-show-vars)) - )) - -;; In inline args, skip regex-forw and (optionally) chars-back. -;; Optional 3d arg is a string that should replace ' ' to prevent its -;; special meaning -(defun ex-get-inline-cmd-args (regex-forw &optional chars-back replace-str) - (save-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (goto-char (point-min)) - (re-search-forward regex-forw nil t) - (let ((beg (point)) - end) - (goto-char (point-max)) - (if chars-back - (skip-chars-backward chars-back) - (skip-chars-backward " \t\n\C-m")) - (setq end (point)) - ;; replace SPC with `=' to suppress the special meaning SPC has - ;; in Ex commands - (goto-char beg) - (if replace-str - (while (re-search-forward " +" nil t) - (replace-match replace-str nil t) - (viper-forward-char-carefully))) - (goto-char end) - (buffer-substring beg end)))) - - -;; Ex shell command -(defun ex-shell () - (shell)) - -;; Viper help. Invokes Info -(defun ex-help () - (condition-case nil - (progn - (pop-to-buffer (get-buffer-create "*info*")) - (info (if viper-xemacs-p "viper.info" "viper")) - (message "Type `i' to search for a specific topic")) - (error (beep 1) - (with-output-to-temp-buffer " *viper-info*" - (princ (format " -The Info file for Viper does not seem to be installed. - -This file is part of the standard distribution of %sEmacs. -Please contact your system administrator. " - (if viper-xemacs-p "X" "") - )))))) - -;; Ex source command. Loads the file specified as argument or `~/.viper' -(defun ex-source () - (viper-get-ex-file) - (if (string= ex-file "") - (load viper-custom-file-name) - (load ex-file))) - -;; Ex substitute command -;; If REPEAT use previous regexp which is ex-reg-exp or viper-s-string -(defun ex-substitute (&optional repeat r-flag) - (let ((opt-g nil) - (opt-c nil) - (matched-pos nil) - (case-fold-search viper-case-fold-search) - delim pat repl) - (if repeat (setq ex-token nil) (setq delim (viper-get-ex-pat))) - (if (null ex-token) - (progn - (setq pat (if r-flag viper-s-string ex-reg-exp)) - (or (stringp pat) - (error "No previous pattern to use in substitution")) - (setq repl ex-repl - delim (string-to-char pat))) - (setq pat (if (string= ex-token "") viper-s-string ex-token)) - (setq viper-s-string pat - ex-reg-exp pat) - (setq delim (viper-get-ex-pat)) - (if (null ex-token) - (setq ex-token "" - ex-repl "") - (setq repl ex-token - ex-repl ex-token))) - (while (viper-get-ex-opt-gc delim) - (if (string= ex-token "g") (setq opt-g t) (setq opt-c t))) - (viper-get-ex-count) - (if ex-count - (save-excursion - (if ex-addresses (goto-char (car ex-addresses))) - (set-mark (point)) - (forward-line (1- ex-count)) - (setq ex-addresses (cons (point) (cons (mark t) nil)))) - (if (null ex-addresses) - (setq ex-addresses (cons (point) (cons (point) nil))) - (if (null (cdr ex-addresses)) - (setq ex-addresses (cons (car ex-addresses) ex-addresses))))) - ;(setq G opt-g) - (let ((beg (car ex-addresses)) - (end (car (cdr ex-addresses))) - eol-mark) - (save-excursion - (viper-enlarge-region beg end) - (let ((limit (save-excursion - (goto-char (max (point) (mark t))) - (point-marker)))) - (goto-char (min (point) (mark t))) - (while (< (point) limit) - (end-of-line) - (setq eol-mark (point-marker)) - (beginning-of-line) - (if opt-g - (progn - (while (and (not (eolp)) - (re-search-forward pat eol-mark t)) - (if (or (not opt-c) (y-or-n-p "Replace? ")) - (progn - (setq matched-pos (point)) - (if (not (stringp repl)) - (error "Can't perform Ex substitution: No previous replacement pattern")) - (replace-match repl t)))) - (end-of-line) - (viper-forward-char-carefully)) - (if (null pat) - (error - "Can't repeat Ex substitution: No previous regular expression")) - (if (and (re-search-forward pat eol-mark t) - (or (not opt-c) (y-or-n-p "Replace? "))) - (progn - (setq matched-pos (point)) - (if (not (stringp repl)) - (error "Can't perform Ex substitution: No previous replacement pattern")) - (replace-match repl t))) - (end-of-line) - (viper-forward-char-carefully)))))) - (if matched-pos (goto-char matched-pos)) - (beginning-of-line) - (if opt-c (message "done")))) - -;; Ex tag command -(defun ex-tag () - (let (tag) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (set-mark (point)) - (skip-chars-forward "^ |\t\n") - (setq tag (buffer-substring (mark t) (point)))) - (if (not (string= tag "")) (setq ex-tag tag)) - (viper-change-state-to-emacs) - (condition-case conds - (progn - (if (string= tag "") - (find-tag ex-tag t) - (find-tag-other-window ex-tag)) - (viper-change-state-to-vi)) - (error - (viper-change-state-to-vi) - (viper-message-conditions conds))))) - -;; Ex write command -(defun ex-write (q-flag) - (viper-default-ex-addresses t) - (viper-get-ex-file) - (let ((end (car ex-addresses)) - (beg (car (cdr ex-addresses))) - (orig-buf (current-buffer)) - (orig-buf-file-name (buffer-file-name)) - (orig-buf-name (buffer-name)) - (buff-changed-p (buffer-modified-p)) - temp-buf writing-same-file region - file-exists writing-whole-file) - (if (> beg end) (error viper-FirstAddrExceedsSecond)) - (if ex-cmdfile - (progn - (viper-enlarge-region beg end) - (shell-command-on-region (point) (mark t) ex-file)) - (if (and (string= ex-file "") (not (buffer-file-name))) - (setq ex-file - (read-file-name - (format "Buffer %s isn't visiting any file. File to save in: " - (buffer-name))))) - - (setq writing-whole-file (and (= (point-min) beg) (= (point-max) end)) - ex-file (if (string= ex-file "") - (buffer-file-name) - (expand-file-name ex-file))) - ;; if ex-file is a directory use the file portion of the buffer file name - (if (and (file-directory-p ex-file) - buffer-file-name - (not (file-directory-p buffer-file-name))) - (setq ex-file - (concat (file-name-as-directory ex-file) - (file-name-nondirectory buffer-file-name)))) - - (setq file-exists (file-exists-p ex-file) - writing-same-file (string= ex-file (buffer-file-name))) - - (if (and writing-whole-file writing-same-file) - (if (not (buffer-modified-p)) - (message "(No changes need to be saved)") - (save-buffer) - (save-restriction - (widen) - (ex-write-info file-exists ex-file (point-min) (point-max)) - )) - ;; writing some other file or portion of the current file - (cond ((and file-exists - (not writing-same-file) - (not (yes-or-no-p - (format "File %s exists. Overwrite? " ex-file)))) - (error "Quit")) - ((and writing-whole-file (not ex-append)) - (unwind-protect - (progn - (set-visited-file-name ex-file) - (set-buffer-modified-p t) - (save-buffer)) - ;; restore the buffer file name - (set-visited-file-name orig-buf-file-name) - (set-buffer-modified-p buff-changed-p) - ;; If the buffer wasn't visiting a file, restore buffer name. - ;; Name could've been changed by packages such as uniquify. - (or orig-buf-file-name - (progn - (unlock-buffer) - (rename-buffer orig-buf-name)))) - (save-restriction - (widen) - (ex-write-info - file-exists ex-file (point-min) (point-max)))) - (t ; writing a region - (unwind-protect - (save-excursion - (viper-enlarge-region beg end) - (setq region (buffer-substring (point) (mark t))) - ;; create temp buffer for the region - (setq temp-buf (get-buffer-create " *ex-write*")) - (set-buffer temp-buf) - (set-visited-file-name ex-file 'noquerry) - (erase-buffer) - (if (and file-exists ex-append) - (insert-file-contents ex-file)) - (goto-char (point-max)) - (insert region) - (save-buffer) - (ex-write-info - file-exists ex-file (point-min) (point-max)) - )) - (set-buffer temp-buf) - (set-buffer-modified-p nil) - (kill-buffer temp-buf)) - )) - (set-buffer orig-buf) - ;; this prevents the loss of data if writing part of the buffer - (if (and (buffer-file-name) writing-same-file) - (set-visited-file-modtime)) - (or writing-whole-file - (not writing-same-file) - (set-buffer-modified-p t)) - (if q-flag - (if (< viper-expert-level 2) - (save-buffers-kill-emacs) - (kill-buffer (current-buffer)))) - ))) - - -(defun ex-write-info (exists file-name beg end) - (message "`%s'%s %d lines, %d characters" - (viper-abbreviate-file-name file-name) - (if exists "" " [New file]") - (count-lines beg (min (1+ end) (point-max))) - (- end beg))) - -;; Ex yank command -(defun ex-yank () - (viper-default-ex-addresses) - (viper-get-ex-buffer) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error viper-FirstAddrExceedsSecond)) - (save-excursion - (viper-enlarge-region beg end) - (exchange-point-and-mark) - (if (or ex-g-flag ex-g-variant) - (error "Can't execute `yank' within `global'")) - (if ex-count - (progn - (set-mark (point)) - (forward-line (1- ex-count))) - (set-mark end)) - (viper-enlarge-region (point) (mark t)) - (if ex-flag (error "`yank': %s" viper-SpuriousText)) - (if ex-buffer - (cond ((viper-valid-register ex-buffer '(Letter)) - (viper-append-to-register - (downcase ex-buffer) (point) (mark t))) - ((viper-valid-register ex-buffer) - (copy-to-register ex-buffer (point) (mark t) nil)) - (t (error viper-InvalidRegister ex-buffer)))) - (copy-region-as-kill (point) (mark t))))) - -;; Execute shell command -(defun ex-command () - (let (command) - (save-window-excursion - (setq viper-ex-work-buf (get-buffer-create viper-ex-work-buf-name)) - (set-buffer viper-ex-work-buf) - (skip-chars-forward " \t") - (setq command (buffer-substring (point) (point-max))) - (end-of-line)) - (setq command (ex-expand-filsyms command (current-buffer))) - (if (and (> (length command) 0) (string= "!" (substring command 0 1))) - (if viper-ex-last-shell-com - (setq command - (concat viper-ex-last-shell-com (substring command 1))) - (error "No previous shell command"))) - (setq viper-ex-last-shell-com command) - (if (null ex-addresses) - (shell-command command) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (null beg) (setq beg end)) - (save-excursion - (goto-char beg) - (set-mark end) - (viper-enlarge-region (point) (mark t)) - (shell-command-on-region (point) (mark t) command t)) - (goto-char beg))))) - -;; Print line number -(defun ex-line-no () - (message "%d" - (1+ (count-lines - (point-min) - (if (null ex-addresses) (point-max) (car ex-addresses)))))) - -;; Give information on the file visited by the current buffer -(defun viper-info-on-file () - (interactive) - (let ((pos1 (viper-line-pos 'start)) - (pos2 (viper-line-pos 'end)) - lines file info) - (setq lines (count-lines (point-min) (viper-line-pos 'end)) - file (if (buffer-file-name) - (concat (viper-abbreviate-file-name (buffer-file-name)) ":") - (concat (buffer-name) " [Not visiting any file]:")) - info (format "line=%d/%d pos=%d/%d col=%d %s" - (if (= pos1 pos2) - (1+ lines) - lines) - (count-lines (point-min) (point-max)) - (point) (1- (point-max)) - (1+ (current-column)) - (if (buffer-modified-p) "[Modified]" "[Unchanged]"))) - (if (< (+ 1 (length info) (length file)) - (window-width (minibuffer-window))) - (message (concat file " " info)) - (save-window-excursion - (with-output-to-temp-buffer " *viper-info*" - (princ (concat "\n" file "\n\n\t" info "\n\n"))) - (let ((inhibit-quit t)) - (viper-set-unread-command-events (viper-read-event))) - (kill-buffer " *viper-info*"))) - )) - -;; display all variables set through :set -(defun ex-show-vars () - (with-output-to-temp-buffer " *viper-info*" - (princ (if viper-auto-indent - "autoindent (local)\n" "noautoindent (local)\n")) - (princ (if (default-value 'viper-auto-indent) - "autoindent (global) \n" "noautoindent (global) \n")) - (princ (if viper-case-fold-search "ignorecase\n" "noignorecase\n")) - (princ (if viper-re-search "magic\n" "nomagic\n")) - (princ (if buffer-read-only "readonly\n" "noreadonly\n")) - (princ (if blink-matching-paren "showmatch\n" "noshowmatch\n")) - (princ (if viper-search-wrap-around-t "wrapscan\n" "nowrapscan\n")) - (princ (format "shiftwidth \t\t= %S\n" viper-shift-width)) - (princ (format "tabstop (local) \t= %S\n" tab-width)) - (princ (format "tabstop (global) \t= %S\n" (default-value 'tab-width))) - (princ (format "wrapmargin (local) \t= %S\n" - (- (window-width) fill-column))) - (princ (format "wrapmargin (global) \t= %S\n" - (- (window-width) (default-value 'fill-column)))) - (princ (format "shell \t\t\t= %S\n" (if (boundp 'explicit-shell-file-name) - explicit-shell-file-name - 'none))) - )) - - - - - -;;; viper-ex.el ends here
--- a/lisp/viper/viper-init.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1057 +0,0 @@ -;;; viper-init.el --- some common definitions for Viper - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Code - -(provide 'viper-init) - -;; compiler pacifier -(defvar mark-even-if-inactive) -(defvar quail-mode) -(defvar iso-accents-mode) -(defvar viper-current-state) -(defvar viper-version) -(defvar viper-expert-level) -;; end pacifier - - -;; Viper version -(defun viper-version () - (interactive) - (message "Viper version is %s" viper-version)) - -;; Is it XEmacs? -(defconst viper-xemacs-p (string-match "XEmacs" emacs-version)) -;; Is it Emacs? -(defconst viper-emacs-p (not viper-xemacs-p)) -;; Tell whether we are running as a window application or on a TTY -(defsubst viper-device-type () - (if viper-emacs-p - window-system - (device-type (selected-device)))) -;; in XEmacs: device-type is tty on tty and stream in batch. -(defun viper-window-display-p () - (and (viper-device-type) (not (memq (viper-device-type) '(tty stream pc))))) - -(defcustom viper-ms-style-os-p (memq system-type - '(ms-dos windows-nt windows-95)) - "Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95." - :type 'boolean - :tag "Is it Microsoft-made OS?" - :group 'viper-misc) -(defcustom viper-vms-os-p (memq system-type '(vax-vms axp-vms)) - "Tells if Emacs is running under VMS." - :type 'boolean - :tag "Is it VMS?" - :group 'viper-misc) - -(defcustom viper-force-faces nil - "If t, Viper will think that it is running on a display that supports faces. -This is provided as a temporary relief for users of graphics-capable terminals -that Viper doesn't know about. -In all likelihood, you don't need to bother with this setting." - :type 'boolean - :group 'viper-highlighting) - -(defun viper-has-face-support-p () - (cond ((viper-window-display-p)) - (viper-force-faces) - (viper-emacs-p (memq (viper-device-type) '(pc))) - (viper-xemacs-p (memq (viper-device-type) '(tty pc))))) - - -;;; Macros - -(defmacro viper-deflocalvar (var default-value &optional documentation) - (` (progn - (defvar (, var) (, default-value) - (, (format "%s\n\(buffer local\)" documentation))) - (make-variable-buffer-local '(, var)) - ))) - -;; (viper-loop COUNT BODY) Execute BODY COUNT times. -(defmacro viper-loop (count &rest body) - (` (let ((count (, count))) - (while (> count 0) - (progn - (,@ body) - (setq count (1- count)) - )) - ))) - -(defmacro viper-buffer-live-p (buf) - (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf)))))) - -;; return buffer-specific macro definition, given a full macro definition -(defmacro viper-kbd-buf-alist (macro-elt) - (` (nth 1 (, macro-elt)))) -;; get a pair: (curr-buffer . macro-definition) -(defmacro viper-kbd-buf-pair (macro-elt) - (` (assoc (buffer-name) (viper-kbd-buf-alist (, macro-elt))))) -;; get macro definition for current buffer -(defmacro viper-kbd-buf-definition (macro-elt) - (` (cdr (viper-kbd-buf-pair (, macro-elt))))) - -;; return mode-specific macro definitions, given a full macro definition -(defmacro viper-kbd-mode-alist (macro-elt) - (` (nth 2 (, macro-elt)))) -;; get a pair: (major-mode . macro-definition) -(defmacro viper-kbd-mode-pair (macro-elt) - (` (assoc major-mode (viper-kbd-mode-alist (, macro-elt))))) -;; get macro definition for the current major mode -(defmacro viper-kbd-mode-definition (macro-elt) - (` (cdr (viper-kbd-mode-pair (, macro-elt))))) - -;; return global macro definition, given a full macro definition -(defmacro viper-kbd-global-pair (macro-elt) - (` (nth 3 (, macro-elt)))) -;; get global macro definition from an elt of macro-alist -(defmacro viper-kbd-global-definition (macro-elt) - (` (cdr (viper-kbd-global-pair (, macro-elt))))) - -;; last elt of a sequence -(defsubst viper-seq-last-elt (seq) - (elt seq (1- (length seq)))) - -(defsubst viper-string-to-list (string) - (append (vconcat string) nil)) - -(defsubst viper-charlist-to-string (list) - (mapconcat 'char-to-string list "")) - -;; like char-after/before, but saves typing -(defun viper-char-at-pos (direction &optional offset) - (or (integerp offset) (setq offset 0)) - (if (eq direction 'forward) - (char-after (+ (point) offset)) - (char-before (- (point) offset)))) - - -(defvar viper-minibuffer-overlay-priority 300) -(defvar viper-replace-overlay-priority 400) -(defvar viper-search-overlay-priority 500) - - -;;; Viper minor modes - -;; Mode for vital things like \e, C-z. -(viper-deflocalvar viper-vi-intercept-minor-mode nil) - -(viper-deflocalvar viper-vi-basic-minor-mode nil - "Viper's minor mode for Vi bindings.") - -(viper-deflocalvar viper-vi-local-user-minor-mode nil - "Auxiliary minor mode for user-defined local bindings in Vi state.") - -(viper-deflocalvar viper-vi-global-user-minor-mode nil - "Auxiliary minor mode for user-defined global bindings in Vi state.") - -(viper-deflocalvar viper-vi-state-modifier-minor-mode nil - "Minor mode used to make major-mode-specific modification to Vi state.") - -(viper-deflocalvar viper-vi-diehard-minor-mode nil - "This minor mode is in effect when the user wants Viper to be Vi.") - -(viper-deflocalvar viper-vi-kbd-minor-mode nil - "Minor mode for Ex command macros in Vi state. -The corresponding keymap stores key bindings of Vi macros defined with -the Ex command :map.") - -;; Mode for vital things like \e, C-z. -(viper-deflocalvar viper-insert-intercept-minor-mode nil) - -(viper-deflocalvar viper-insert-basic-minor-mode nil - "Viper's minor mode for bindings in Insert mode.") - -(viper-deflocalvar viper-insert-local-user-minor-mode nil - "Auxiliary minor mode for buffer-local user-defined bindings in Insert state. -This is a way to overshadow normal Insert mode bindings locally to certain -designated buffers.") - -(viper-deflocalvar viper-insert-global-user-minor-mode nil - "Auxiliary minor mode for global user-defined bindings in Insert state.") - -(viper-deflocalvar viper-insert-state-modifier-minor-mode nil - "Minor mode used to make major-mode-specific modification to Insert state.") - -(viper-deflocalvar viper-insert-diehard-minor-mode nil - "Minor mode that simulates Vi very closely. -Not recommened, except for the novice user.") - -(viper-deflocalvar viper-insert-kbd-minor-mode nil -"Minor mode for Ex command macros Insert state. -The corresponding keymap stores key bindings of Vi macros defined with -the Ex command :map!.") - -(viper-deflocalvar viper-replace-minor-mode nil - "Minor mode in effect in replace state (cw, C, and the like commands).") - -;; Mode for vital things like \C-z and \C-x) -;; This is t, by default. So, any new buffer will have C-z defined as -;; switch to Vi, unless we switched states in this buffer -(viper-deflocalvar viper-emacs-intercept-minor-mode t) - -(viper-deflocalvar viper-emacs-local-user-minor-mode t - "Minor mode for local user bindings effective in Emacs state. -Users can use it to override Emacs bindings when Viper is in its Emacs -state.") - -(viper-deflocalvar viper-emacs-global-user-minor-mode t - "Minor mode for global user bindings in effect in Emacs state. -Users can use it to override Emacs bindings when Viper is in its Emacs -state.") - -(viper-deflocalvar viper-emacs-kbd-minor-mode t - "Minor mode for Vi style macros in Emacs state. -The corresponding keymap stores key bindings of Vi macros defined with -`viper-record-kbd-macro' command. There is no Ex-level command to do this -interactively.") - -(viper-deflocalvar viper-emacs-state-modifier-minor-mode t - "Minor mode used to make major-mode-specific modification to Emacs state. -For instance, a Vi purist may want to bind `dd' in Dired mode to a function -that deletes a file.") - -(viper-deflocalvar viper-vi-minibuffer-minor-mode nil - "Minor mode that forces Vi-style when the Minibuffer is in Vi state.") - -(viper-deflocalvar viper-insert-minibuffer-minor-mode nil - "Minor mode that forces Vi-style when the Minibuffer is in Insert state.") - - - -;; Some common error messages - -(defconst viper-SpuriousText "Spurious text after command" "") -(defconst viper-BadExCommand "Not an editor command" "") -(defconst viper-InvalidCommandArgument "Invalid command argument" "") -(defconst viper-NoPrevSearch "No previous search string" "") -(defconst viper-EmptyRegister "`%c': Nothing in this register" "") -(defconst viper-InvalidRegister "`%c': Invalid register" "") -(defconst viper-EmptyTextmarker "`%c': Text marker doesn't point anywhere" "") -(defconst viper-InvalidTextmarker "`%c': Invalid text marker" "") -(defconst viper-InvalidViCommand "Invalid command" "") -(defconst viper-BadAddress "Ill-formed address" "") -(defconst viper-FirstAddrExceedsSecond "First address exceeds second" "") -(defconst viper-NoFileSpecified "No file specified" "") - -;; Is t until viper-mode executes for the very first time. -;; Prevents recursive descend into startup messages. -(defvar viper-first-time t) - -(defvar viper-expert-level (if (boundp 'viper-expert-level) viper-expert-level 0) - "User's expert level. -The minor mode viper-vi-diehard-minor-mode is in effect when -viper-expert-level is 1 or 2 or when viper-want-emacs-keys-in-vi is t. -The minor mode viper-insert-diehard-minor-mode is in effect when -viper-expert-level is 1 or 2 or if viper-want-emacs-keys-in-insert is t. -Use `M-x viper-set-expert-level' to change this.") - -;; Max expert level supported by Viper. This is NOT a user option. -;; It is here to make it hard for the user from resetting it. -(defconst viper-max-expert-level 5) - - -;;; ISO characters and MULE - -;; If non-nil, ISO accents will be turned on in insert/replace emacs states and -;; turned off in vi-state. For some users, this behavior may be too -;; primitive. In this case, use insert/emacs/vi state hooks. -(viper-deflocalvar viper-automatic-iso-accents nil "") -;; Set iso-accents-mode to ARG. Check if it is bound first -(defsubst viper-set-iso-accents-mode (arg) - (if (boundp 'iso-accents-mode) - (setq iso-accents-mode arg))) - -;; Internal flag used to control when viper mule hooks are run. -;; Don't change this! -(defvar viper-mule-hook-flag t) -;; If non-nil, the default intl. input method is turned on. -(viper-deflocalvar viper-special-input-method nil "") - -;; viper hook to run on input-method activation -(defun viper-activate-input-method-action () - (if (null viper-mule-hook-flag) - () - (setq viper-special-input-method t) - ;; turn off special input methods in vi-state - (if (eq viper-current-state 'vi-state) - (viper-set-input-method nil)) - (if (memq viper-current-state '(vi-state insert-state replace-state)) - (message "Viper special input method%s: on" - (if (or current-input-method default-input-method) - (format " %S" - (or current-input-method default-input-method)) - ""))) - )) -;; viper hook to run on input-method deactivation -(defun viper-inactivate-input-method-action () - (if (null viper-mule-hook-flag) - () - (setq viper-special-input-method nil) - (if (memq viper-current-state '(vi-state insert-state replace-state)) - (message "Viper special input method%s: off" - (if (or current-input-method default-input-method) - (format " %S" - (or current-input-method default-input-method)) - ""))))) - -(defun viper-inactivate-input-method () - (cond ((and viper-emacs-p (fboundp 'inactivate-input-method)) - (inactivate-input-method)) - ((and viper-xemacs-p (boundp 'current-input-method)) - ;; XEmacs had broken quil-mode for some time, so we are working around - ;; it here - (setq quail-mode nil) - (if (featurep 'quail) - (quail-delete-overlays)) - (setq describe-current-input-method-function nil) - (setq current-input-method nil) - (run-hooks 'input-method-inactivate-hook) - (force-mode-line-update)) - )) -(defun viper-activate-input-method () - (cond ((and viper-emacs-p (fboundp 'activate-input-method)) - (activate-input-method default-input-method)) - ((and viper-xemacs-p (fboundp 'quail-mode)) - (quail-mode 1)))) - -;; Set quail-mode to ARG -(defun viper-set-input-method (arg) - (setq viper-mule-hook-flag t) ; just a precaution - (let (viper-mule-hook-flag) ; temporarily inactivate viper mule hooks - (cond ((and arg (> (prefix-numeric-value arg) 0) default-input-method) - ;; activate input method - (viper-activate-input-method)) - (t ; deactivate input method - (viper-inactivate-input-method))) - )) - - -;; VI-style Undo - -;; Used to 'undo' complex commands, such as replace and insert commands. -(viper-deflocalvar viper-undo-needs-adjustment nil) -(put 'viper-undo-needs-adjustment 'permanent-local t) - -;; A mark that Viper puts on buffer-undo-list. Marks the beginning of a -;; complex command that must be undone atomically. If inserted, it is -;; erased by viper-change-state-to-vi and viper-repeat. -(defconst viper-buffer-undo-list-mark 'viper) - -(defcustom viper-keep-point-on-undo nil - "*Non-nil means not to move point while undoing commands. -This style is different from Emacs and Vi. Try it to see if -it better fits your working style." - :type 'boolean - :tag "Preserve Position of Point After Undo" - :group 'viper) - -;; Replace mode and changing text - -;; Viper's own after/before change functions, which get viper-add-hook'ed to -;; Emacs's -(viper-deflocalvar viper-after-change-functions nil "") -(viper-deflocalvar viper-before-change-functions nil "") -(viper-deflocalvar viper-post-command-hooks nil "") -(viper-deflocalvar viper-pre-command-hooks nil "") - -;; Can be used to pass global states around for short period of time -(viper-deflocalvar viper-intermediate-command nil "") - -;; This is used to pass the right Vi command key sequence to -;; viper-set-destructive-command whenever (this-command-keys) doesn't give the -;; right result. For instance, in commands like c/bla<RET>, (this-command-keys) -;; will return ^M, which invoked exit-minibuffer, while we need "c/" -(defconst viper-this-command-keys nil) - -;; Indicates that the current destructive command has started in replace mode. -(viper-deflocalvar viper-began-as-replace nil "") - -(defcustom viper-allow-multiline-replace-regions t - "If non-nil, Viper will allow multi-line replace regions. -This is an extension to standard Vi. -If nil, commands that attempt to replace text spanning multiple lines first -delete the text being replaced, as in standard Vi." - :type 'boolean - :group 'viper) - -(defcustom viper-replace-overlay-cursor-color "Red" - "*Cursor color when Viper is in Replace state." - :type 'string - :group 'viper) -(defcustom viper-insert-state-cursor-color "Green" - "Cursor color when Viper is in insert state." - :type 'string - :group 'viper) - -;; place to save cursor colow when switching to insert mode -(viper-deflocalvar viper-saved-cursor-color nil "") - -(viper-deflocalvar viper-replace-overlay nil "") -(put 'viper-replace-overlay 'permanent-local t) - -(defcustom viper-replace-region-end-delimiter "$" - "A string marking the end of replacement regions. -It is used only with TTYs or if `viper-use-replace-region-delimiters' -is non-nil." - :type 'string - :group 'viper) -(defcustom viper-replace-region-start-delimiter "" - "A string marking the beginning of replacement regions. -It is used only with TTYs or if `viper-use-replace-region-delimiters' -is non-nil." - :type 'string - :group 'viper) -(defcustom viper-use-replace-region-delimiters - (or (not (viper-has-face-support-p)) - (and viper-xemacs-p (eq (viper-device-type) 'tty))) - "*If non-nil, Viper will always use `viper-replace-region-end-delimiter' and -`viper-replace-region-start-delimiter' to delimit replacement regions, even on -color displays. By default, the delimiters are used only on TTYs." - :type 'boolean - :group 'viper) - -;; XEmacs requires glyphs -(if viper-xemacs-p - (progn - (or (glyphp viper-replace-region-end-delimiter) - (setq viper-replace-region-end-delimiter - (make-glyph viper-replace-region-end-delimiter))) - (or (glyphp viper-replace-region-start-delimiter) - (setq viper-replace-region-start-delimiter - (make-glyph viper-replace-region-start-delimiter))) - )) - - -;; These are local marker that must be initialized to nil and moved with -;; `viper-move-marker-locally' -;; -;; Remember the last position inside the replace region. -(viper-deflocalvar viper-last-posn-in-replace-region nil) -;; Remember the last position while inserting -(viper-deflocalvar viper-last-posn-while-in-insert-state nil) -(put 'viper-last-posn-in-replace-region 'permanent-local t) -(put 'viper-last-posn-while-in-insert-state 'permanent-local t) - -(viper-deflocalvar viper-sitting-in-replace nil "") -(put 'viper-sitting-in-replace 'permanent-local t) - -;; Remember the number of characters that have to be deleted in replace -;; mode to compensate for the inserted characters. -(viper-deflocalvar viper-replace-chars-to-delete 0 "") -;; This variable is used internally by the before/after changed functions to -;; determine how many chars were deleted by the change. This can't be -;; determined inside after-change-functions because those get the length of the -;; deleted region, not the number of chars deleted (which are two different -;; things under MULE). -(viper-deflocalvar viper-replace-region-chars-deleted 0 "") - -;; Insertion ring and command ring -(defcustom viper-insertion-ring-size 14 - "The size of history of inserted text. -This is a list where Viper keeps the history of previously inserted pieces of -text." - :type 'integer - :group 'viper-misc) -;; The insertion ring. -(defvar viper-insertion-ring nil) -;; This is temp insertion ring. Used to do rotation for display purposes. -;; When rotation just started, it is initialized to viper-insertion-ring. -(defvar viper-temp-insertion-ring nil) -(defvar viper-last-inserted-string-from-insertion-ring "") - -(defcustom viper-command-ring-size 14 - "The size of history of Vi commands repeatable with dot." - :type 'integer - :group 'viper-misc) -;; The command ring. -(defvar viper-command-ring nil) -;; This is temp command ring. Used to do rotation for display purposes. -;; When rotation just started, it is initialized to viper-command-ring. -(defvar viper-temp-command-ring nil) - -;; Fast keyseq and ESC keyseq timeouts -(defcustom viper-fast-keyseq-timeout 200 - "*Key sequence separated by no more than this many milliseconds is viewed as a Vi-style macro, if such a macro is defined. -Setting this too high may slow down your typing. Setting this value too low -will make it hard to use Vi-stile timeout macros." - :type 'integer - :group 'viper-misc) - -(defcustom viper-ESC-keyseq-timeout (if (viper-window-display-p) - 0 viper-fast-keyseq-timeout) - "*Key sequence beginning with ESC and separated by no more than this many milliseconds is considered to be generated by a keyboard function key. -Setting this too high may slow down switching from insert to vi state. Setting -this value too low will make it impossible to use function keys in insert mode -on a dumb terminal." - :type 'integer - :group 'viper-misc) - -;; Modes and related variables - -;; Current mode. One of: `emacs-state', `vi-state', `insert-state' -(viper-deflocalvar viper-current-state 'emacs-state) - - -;; Autoindent in insert - -;; Variable that keeps track of whether C-t has been pressed. -(viper-deflocalvar viper-cted nil "") - -;; Preserve the indent value, used by C-d in insert mode. -(viper-deflocalvar viper-current-indent 0) - -;; Whether to preserve the indent, used by C-d in insert mode. -(viper-deflocalvar viper-preserve-indent nil) - -(viper-deflocalvar viper-auto-indent nil "") -(defcustom viper-auto-indent nil - "*Enable autoindent, if t. -This is a buffer-local variable." - :type 'boolean - :group 'viper) - -(viper-deflocalvar viper-electric-mode t "") -(defcustom viper-electric-mode t - "*If t, electrify Viper. -Currently, this only electrifies auto-indentation, making it appropriate to the -mode of the buffer. -This means that auto-indentation will depart from standard Vi and will indent -appropriate to the mode of the buffer. This is especially useful for editing -programs and LaTeX documents." - :type 'boolean - :group 'viper) - -(defcustom viper-shift-width 8 - "*The shiftwidth variable." - :type 'integer - :group 'viper) - -;; Variables for repeating destructive commands - -(defcustom viper-keep-point-on-repeat t - "*If t, don't move point when repeating previous command. -This is useful for doing repeated changes with the '.' key. -The user can change this to nil, if she likes when the cursor moves -to a new place after repeating previous Vi command." - :type 'boolean - :group 'viper) - -;; Remember insert point as a marker. This is a local marker that must be -;; initialized to nil and moved with `viper-move-marker-locally'. -(viper-deflocalvar viper-insert-point nil) -(put 'viper-insert-point 'permanent-local t) - -;; This remembers the point before dabbrev-expand was called. -;; If viper-insert-point turns out to be bigger than that, it is reset -;; back to viper-pre-command-point. -;; The reason this is needed is because dabbrev-expand (and possibly -;; others) may jump to before the insertion point, delete something and -;; then reinsert a bigger piece. For instance: bla^blo -;; If dabbrev-expand is called after `blo' and ^ undicates viper-insert-point, -;; then point jumps to the beginning of `blo'. If expansion is found, `blablo' -;; is deleted, and we have |^, where | denotes point. Next, dabbrev-expand -;; will insert the expansion, and we get: blablo^ -;; Whatever we insert next goes before the ^, i.e., before the -;; viper-insert-point marker. So, Viper will think that nothing was -;; inserted. Remembering the orig position of the marker circumvents the -;; problem. -;; We don't know of any command, except dabbrev-expand, that has the same -;; problem. However, the same trick can be used if such a command is -;; discovered later. -;; -(viper-deflocalvar viper-pre-command-point nil) -(put 'viper-pre-command-point 'permanent-local t) ; this is probably an overkill - -;; This is used for saving inserted text. -(defvar viper-last-insertion nil) - -;; Remembers the last replaced region. -(defvar viper-last-replace-region "") - -;; Remember com point as a marker. -;; This is a local marker. Should be moved with `viper-move-marker-locally' -(viper-deflocalvar viper-com-point nil) - -;; If non-nil, the value is a list (M-COM VAL COM REG inserted-text cmd-keys) -;; It is used to re-execute last destructive command. -;; M-COM is a Lisp symbol representing the function to be executed. -;; VAL is the prefix argument that was used with that command. -;; COM is an internal descriptor, such as ?r, ?c, ?C, which contains -;; additional information on how the function in M-COM is to be handled. -;; REG is the register used by command -;; INSERTED-TEXT is text inserted by that command (in case of o, c, C, i, r -;; commands). -;; COMMAND-KEYS are the keys that were typed to invoke the command. -(defvar viper-d-com nil) - -;; The character remembered by the Vi `r' command. -(defvar viper-d-char nil) - -;; Name of register to store deleted or yanked strings -(defvar viper-use-register nil) - - -;;; Variables for Moves and Searches - -(defgroup viper-search nil - "Variables that define the search and query-replace behavior of Viper." - :prefix "viper-" - :group 'viper) - -;; For use by `;' command. -(defvar viper-f-char nil) - -;; For use by `.' command. -(defvar viper-F-char nil) - -;; For use by `;' command. -(defvar viper-f-forward nil) - -;; For use by `;' command. -(defvar viper-f-offset nil) - -;; Last search string -(defvar viper-s-string "") - -(defcustom viper-quote-string "> " - "String inserted at the beginning of quoted region." - :type 'string - :group 'viper) - -;; If t, search is forward. -(defvar viper-s-forward nil) - -(defcustom viper-case-fold-search nil - "*If not nil, search ignores cases." - :type 'boolean - :group 'viper-search) - -(defcustom viper-re-search t - "*If not nil, search is regexp search, otherwise vanilla search." - :type 'boolean - :tag "Regexp Search" - :group 'viper-search) - -(defcustom viper-search-scroll-threshold 2 - "*If search lands within this threshnold from the window top/bottom, -the window will be scrolled up or down appropriately, to reveal context. -If you want Viper search to behave as usual in Vi, set this variable to a -negative number." - :type 'boolean - :group 'viper-search) - -(defcustom viper-re-query-replace t - "*If t then do regexp replace, if nil then do string replace." - :type 'boolean - :tag "Regexp Query Replace" - :group 'viper-search) - -(defcustom viper-re-replace t - "*If t, do regexp replace. nil means do string replace." - :type 'boolean - :tag "Regexp Replace" - :group 'viper-search) - -(defcustom viper-parse-sexp-ignore-comments t - "*If t, `%' ignores the parentheses that occur inside comments." - :type 'boolean - :group 'viper) - -(viper-deflocalvar viper-ex-style-motion t "") -(defcustom viper-ex-style-motion t - "*If t, the commands l,h do not cross lines, etc (Ex-style). -If nil, these commands cross line boundaries." - :type 'boolean - :group 'viper) - -(viper-deflocalvar viper-ex-style-editing t "") -(defcustom viper-ex-style-editing t - "*If t, Ex-style behavior while editing in Vi command and insert states. -`Backspace' and `Delete' don't cross line boundaries in insert. -`X' and `x' can't delete characters across line boundary in Vi, etc. -Note: this doesn't preclude `Backspace' and `Delete' from deleting characters -by moving past the insertion point. This is a feature, not a bug. - -If nil, the above commands can work across lines." - :type 'boolean - :group 'viper) - -(viper-deflocalvar viper-ESC-moves-cursor-back viper-ex-style-editing "") -(defcustom viper-ESC-moves-cursor-back nil - "*If t, ESC moves cursor back when changing from insert to vi state. -If nil, the cursor stays where it was when ESC was hit." - :type 'boolean - :group 'viper) - -(viper-deflocalvar viper-delete-backwards-in-replace nil "") -(defcustom viper-delete-backwards-in-replace nil - "*If t, DEL key will delete characters while moving the cursor backwards. -If nil, the cursor will move backwards without deleting anything." - :type 'boolean - :group 'viper) - -(defcustom viper-buffer-search-char nil - "*Key used for buffer-searching. Must be a character type, e.g., ?g." - :type '(choice (const nil) character) - :group 'viper-search) - -(defcustom viper-search-wrap-around-t t - "*If t, search wraps around." - :type 'boolean - :tag "Search Wraps Around" - :group 'viper-search) - -(viper-deflocalvar viper-related-files-and-buffers-ring nil "") -(defcustom viper-related-files-and-buffers-ring nil - "*List of file and buffer names that are considered to be related to the current buffer. -Related buffers can be cycled through via :R and :P commands." - :type 'boolean - :group 'viper-misc) -(put 'viper-related-files-and-buffers-ring 'permanent-local t) - -;; Used to find out if we are done with searching the current buffer. -(viper-deflocalvar viper-local-search-start-marker nil) -;; As above, but global -(defvar viper-search-start-marker (make-marker)) - -;; the search overlay -(viper-deflocalvar viper-search-overlay nil) - - -(defvar viper-heading-start - (concat "^\\s-*(\\s-*defun\\s-\\|" ; lisp - "^{\\s-*$\\|^[_a-zA-Z][^()]*[()].*{\\s-*$\\|" ; C/C++ - "^\\s-*class.*{\\|^\\s-*struct.*{\\|^\\s-*enum.*{\\|" - "^\\\\[sb][a-z]*{.*}\\s-*$\\|" ; latex - "^@node\\|@table\\|^@m?enu\\|^@itemize\\|^@if\\|" ; texinfo - "^.+:-") ; prolog - "*Regexps for Headings. Used by \[\[ and \]\].") - -(defvar viper-heading-end - (concat "^}\\|" ; C/C++ - "^\\\\end{\\|" ; latex - "^@end \\|" ; texinfo - ")\n\n[ \t\n]*\\|" ; lisp - "\\.\\s-*$") ; prolog - "*Regexps to end Headings/Sections. Used by \[\].") - - -;; These two vars control the interaction of jumps performed by ' and `. -;; In this new version, '' doesn't erase the marks set by ``, so one can -;; use both kinds of jumps interchangeably and without loosing positions -;; inside the lines. - -;; Remembers position of the last jump done using ``'. -(viper-deflocalvar viper-last-jump nil) -;; Remembers position of the last jump done using `''. -(viper-deflocalvar viper-last-jump-ignore 0) - -;; History variables - -;; History of search strings. -(defvar viper-search-history (list "")) -;; History of query-replace strings used as a source. -(defvar viper-replace1-history nil) -;; History of query-replace strings used as replacement. -(defvar viper-replace2-history nil) -;; History of region quoting strings. -(defvar viper-quote-region-history (list viper-quote-string)) -;; History of Ex-style commands. -(defvar viper-ex-history nil) -;; History of shell commands. -(defvar viper-shell-history nil) - - -;; Last shell command. There are two of these, one for Ex (in viper-ex) -;; and one for Vi. - -;; Last shell command executed with ! command. -(defvar viper-last-shell-com nil) - - -;;; Face-saving tricks - -;;(defcustom viper-replace-overlay-pixmap "gray3" -;; "Pixmap to use for search face on non-color displays." -;; :type 'string -;; :group 'viper) -;;(defcustom viper-search-face-pixmap "gray3" -;; "Pixmap to use for search face on non-color displays." -;; :type 'string -;; :group 'viper) - -(defun viper-hide-face (face) - (if (and (viper-has-face-support-p) viper-emacs-p) - (add-to-list 'facemenu-unlisted-faces face))) - - -(defgroup viper-highlighting nil - "Hilighting of replace region, search pattern, minibuffer, etc." - :prefix "viper-" - :group 'viper) - -;;(defvar viper-search-face -;; (if (viper-has-face-support-p) -;; (progn -;; (make-face 'viper-search-face) -;; (or (face-differs-from-default-p 'viper-search-face) -;; ;; face wasn't set in .viper or .Xdefaults -;; (if (viper-can-use-colors "Black" "khaki") -;; (progn -;; (set-face-background 'viper-search-face "khaki") -;; (set-face-foreground 'viper-search-face "Black")) -;; (set-face-underline-p 'viper-search-face t) -;; (viper-set-face-pixmap 'viper-search-face -;; viper-search-face-pixmap))) -;; 'viper-search-face)) -;; "*Face used to flash out the search pattern.") - -(defface viper-search-face - '((((class color)) (:foreground "Black" :background "khaki")) - (t (:underline t :stipple "gray3"))) - "*Face used to flash out the search pattern." - :group 'viper-highlighting) -;; An internal variable. Viper takes the face from here. -(defvar viper-search-face 'viper-search-face - "Face used to flash out the search pattern. -DO NOT CHANGE this variable. Instead, use the customization widget -to customize the actual face object `viper-search-face' -this variable represents.") -(viper-hide-face 'viper-search-face) - -;;(defvar viper-replace-overlay-face -;; (if (viper-has-face-support-p) -;; (progn -;; (make-face 'viper-replace-overlay-face) -;; (or (face-differs-from-default-p 'viper-replace-overlay-face) -;; (progn -;; (if (viper-can-use-colors "darkseagreen2" "Black") -;; (progn -;; (set-face-background -;; 'viper-replace-overlay-face "darkseagreen2") -;; (set-face-foreground 'viper-replace-overlay-face "Black"))) -;; (set-face-underline-p 'viper-replace-overlay-face t) -;; (viper-set-face-pixmap -;; 'viper-replace-overlay-face viper-replace-overlay-pixmap))) -;; 'viper-replace-overlay-face)) -;; "*Face for highlighting replace regions on a window display.") - -(defface viper-replace-overlay-face - '((((class color)) (:foreground "Black" :background "darkseagreen2")) - (t (:underline t :stipple "gray3"))) - "*Face for highlighting replace regions on a window display." - :group 'viper-highlighting) -;; An internal variable. Viper takes the face from here. -(defvar viper-replace-overlay-face 'viper-replace-overlay-face - "Face for highlighting replace regions on a window display. -DO NOT CHANGE this variable. Instead, use the customization widget -to customize the actual face object `viper-replace-overlay-face' -this variable represents.") -(viper-hide-face 'viper-replace-overlay-face) - -;;(defvar viper-minibuffer-emacs-face -;; (if (viper-has-face-support-p) -;; (progn -;; (make-face 'viper-minibuffer-emacs-face) -;; (or (face-differs-from-default-p 'viper-minibuffer-emacs-face) -;; ;; face wasn't set in .viper or .Xdefaults -;; (if viper-vi-style-in-minibuffer -;; ;; emacs state is an exception in the minibuffer -;; (if (viper-can-use-colors "darkseagreen2" "Black") -;; (progn -;; (set-face-background -;; 'viper-minibuffer-emacs-face "darkseagreen2") -;; (set-face-foreground -;; 'viper-minibuffer-emacs-face "Black")) -;; (copy-face 'modeline 'viper-minibuffer-emacs-face)) -;; ;; emacs state is the main state in the minibuffer -;; (if (viper-can-use-colors "Black" "pink") -;; (progn -;; (set-face-background 'viper-minibuffer-emacs-face "pink") -;; (set-face-foreground -;; 'viper-minibuffer-emacs-face "Black")) -;; (copy-face 'italic 'viper-minibuffer-emacs-face)) -;; )) -;; 'viper-minibuffer-emacs-face)) -;; "Face used in the Minibuffer when it is in Emacs state.") - -(defface viper-minibuffer-emacs-face - '((((class color)) (:foreground "Black" :background "darkseagreen2")) - (t (:bold t))) - "Face used in the Minibuffer when it is in Emacs state." - :group 'viper-highlighting) -;; An internal variable. Viper takes the face from here. -(defvar viper-minibuffer-emacs-face 'viper-minibuffer-emacs-face - "Face used in the Minibuffer when it is in Emacs state. -DO NOT CHANGE this variable. Instead, use the customization widget -to customize the actual face object `viper-minibuffer-emacs-face' -this variable represents.") -(viper-hide-face 'viper-minibuffer-emacs-face) - -;;(defvar viper-minibuffer-insert-face -;; (if (viper-has-face-support-p) -;; (progn -;; (make-face 'viper-minibuffer-insert-face) -;; (or (face-differs-from-default-p 'viper-minibuffer-insert-face) -;; (if viper-vi-style-in-minibuffer -;; (if (viper-can-use-colors "Black" "pink") -;; (progn -;; (set-face-background 'viper-minibuffer-insert-face "pink") -;; (set-face-foreground -;; 'viper-minibuffer-insert-face "Black")) -;; (copy-face 'italic 'viper-minibuffer-insert-face)) -;; ;; If Insert state is an exception -;; (if (viper-can-use-colors "darkseagreen2" "Black") -;; (progn -;; (set-face-background -;; 'viper-minibuffer-insert-face "darkseagreen2") -;; (set-face-foreground -;; 'viper-minibuffer-insert-face "Black")) -;; (copy-face 'modeline 'viper-minibuffer-insert-face)) -;; (viper-italicize-face 'viper-minibuffer-insert-face))) -;; 'viper-minibuffer-insert-face)) -;; "Face used in the Minibuffer when it is in Insert state.") - -(defface viper-minibuffer-insert-face - '((((class color)) (:foreground "Black" :background "pink")) - (t (:italic t))) - "Face used in the Minibuffer when it is in Insert state." - :group 'viper-highlighting) -;; An internal variable. Viper takes the face from here. -(defvar viper-minibuffer-insert-face 'viper-minibuffer-insert-face - "Face used in the Minibuffer when it is in Insert state. -DO NOT CHANGE this variable. Instead, use the customization widget -to customize the actual face object `viper-minibuffer-insert-face' -this variable represents.") -(viper-hide-face 'viper-minibuffer-insert-face) - -;;(defvar viper-minibuffer-vi-face -;; (if (viper-has-face-support-p) -;; (progn -;; (make-face 'viper-minibuffer-vi-face) -;; (or (face-differs-from-default-p 'viper-minibuffer-vi-face) -;; (if viper-vi-style-in-minibuffer -;; (if (viper-can-use-colors "Black" "grey") -;; (progn -;; (set-face-background 'viper-minibuffer-vi-face "grey") -;; (set-face-foreground 'viper-minibuffer-vi-face "Black")) -;; (copy-face 'bold 'viper-minibuffer-vi-face)) -;; (copy-face 'bold 'viper-minibuffer-vi-face) -;; (invert-face 'viper-minibuffer-vi-face))) -;; 'viper-minibuffer-vi-face)) -;; "Face used in the Minibuffer when it is in Vi state.") - -(defface viper-minibuffer-vi-face - '((((class color)) (:foreground "DarkGreen" :background "grey")) - (t (:inverse-video t))) - "Face used in the Minibuffer when it is in Vi state." - :group 'viper-highlighting) -;; An internal variable. Viper takes the face from here. -(defvar viper-minibuffer-vi-face 'viper-minibuffer-vi-face - "Face used in the Minibuffer when it is in Vi state. -DO NOT CHANGE this variable. Instead, use the customization widget -to customize the actual face object `viper-minibuffer-vi-face' -this variable represents.") -(viper-hide-face 'viper-minibuffer-vi-face) - -;; the current face to be used in the minibuffer -(viper-deflocalvar - viper-minibuffer-current-face viper-minibuffer-emacs-face "") - - -;;; Miscellaneous - -(defvar viper-inhibit-startup-message nil - "Whether Viper startup message should be inhibited.") - -(defcustom viper-spell-function 'ispell-region - "Spell function used by #s<move> command to spell." - :type 'function - :group 'viper-misc) - -(defcustom viper-tags-file-name "TAGS" - "The tags file used by Viper." - :type 'string - :group 'viper-misc) - -;; Minibuffer - -(defcustom viper-vi-style-in-minibuffer t - "If t, use vi-style editing in minibuffer. -Should be set in `~/.viper' file." - :type 'boolean - :group 'viper) - -;; overlay used in the minibuffer to indicate which state it is in -(viper-deflocalvar viper-minibuffer-overlay nil) - -;; Hook, specific to Viper, which is run just *before* exiting the minibuffer. -;; Beginning with Emacs 19.26, the standard `minibuffer-exit-hook' is run -;; *after* exiting the minibuffer -(defvar viper-minibuffer-exit-hook '(viper-minibuffer-trim-tail)) - - -;; Mode line -(defconst viper-vi-state-id "<V> " - "Mode line tag identifying the Vi mode of Viper.") -(defconst viper-emacs-state-id "<E> " - "Mode line tag identifying the Emacs mode of Viper.") -(defconst viper-insert-state-id "<I> " - "Mode line tag identifying the Insert mode of Viper.") -(defconst viper-replace-state-id "<R> " - "Mode line tag identifying the Replace mode of Viper.") - - -(defgroup viper-hooks nil - "Viper hooks." - :prefix "viper-" - :group 'viper) - -(defcustom viper-vi-state-hook nil - "*Hooks run just before the switch to Vi mode is completed." - :type 'hook - :group 'viper-hooks) -(defcustom viper-insert-state-hook nil - "*Hooks run just before the switch to Insert mode is completed." - :type 'hook - :group 'viper-hooks) -(defcustom viper-replace-state-hook nil - "*Hooks run just before the switch to Replace mode is completed." - :type 'hook - :group 'viper-hooks) -(defcustom viper-emacs-state-hook nil - "*Hooks run just before the switch to Emacs mode is completed." - :type 'hook - :group 'viper-hooks) - -(defcustom viper-load-hook nil - "Hooks run just after loading Viper." - :type 'hook - :group 'viper-hooks) - - -;;; Local Variables: -;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) -;;; End: - -;;; viper-ex.el ends here
--- a/lisp/viper/viper-keym.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,641 +0,0 @@ -;;; viper-keym.el --- Viper keymaps - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Code - -(provide 'viper-keym) - -;; compiler pacifier -(defvar viper-always) -(defvar viper-current-state) -(defvar viper-mode-string) -(defvar viper-expert-level) -(defvar viper-ex-style-editing) -(defvar viper-ex-style-motion) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - ))) -;; end pacifier - -(require 'viper-util) - - -;;; Variables - -(defvar viper-toggle-key "\C-z" - "The key used to change states from emacs to Vi and back. -In insert mode, this key also functions as Meta. -Must be set in .viper file or prior to loading Viper. -This setting cannot be changed interactively.") - -(defvar viper-ESC-key "\e" - "Key used to ESC. -Must be set in .viper file or prior to loading Viper. -This setting cannot be changed interactively.") - -;;; Emacs keys in other states. - -(defcustom viper-want-emacs-keys-in-insert t - "*Set to nil if you want complete Vi compatibility in insert mode. -Complete compatibility with Vi is not recommended for power use of Viper." - :type 'boolean - :group 'viper) - -(defcustom viper-want-emacs-keys-in-vi t - "*Set to nil if you want complete Vi compatibility in Vi mode. -Full Vi compatibility is not recommended for power use of Viper." - :type 'boolean - :group 'viper) - -(defcustom viper-no-multiple-ESC t - "*If true, multiple ESC in Vi mode will cause bell to ring. -This is set to t on a windowing terminal and to 'twice on a dumb -terminal (unless the user level is 1, 2, or 5). On a dumb terminal, this -enables cursor keys and is generally more convenient, as terminals usually -don't have a convenient Meta key. -Setting viper-no-multiple-ESC to nil will allow as many multiple ESC, -as is allowed by the major mode in effect." - :type 'boolean - :group 'viper) - -(defcustom viper-want-ctl-h-help nil - "*If non-nil, C-h gets bound to help-command; otherwise, C-h gets the usual Vi bindings." - :type 'boolean - :group 'viper) - - -;;; Keymaps - -;; Keymaps for vital things like \e and C-z. -;; Not for users -(defvar viper-vi-intercept-map (make-sparse-keymap)) -(defvar viper-insert-intercept-map (make-sparse-keymap)) -(defvar viper-emacs-intercept-map (make-sparse-keymap)) - -;; keymap used to zap all keymaps other than function-key-map, -;; device-function-key-map, etc. -(defvar viper-overriding-map (make-sparse-keymap)) - -(viper-deflocalvar viper-vi-local-user-map (make-sparse-keymap) - "Keymap for user-defined local bindings. -Useful for changing bindings such as ZZ in certain major modes. -For instance, in letter-mode, one may want to bind ZZ to -mh-send-letter. In a newsreader such as gnus, tin, or rn, ZZ could be bound -to save-buffers-kill-emacs then post article, etc.") -(put 'viper-vi-local-user-map 'permanent-local t) - -(defvar viper-vi-global-user-map (make-sparse-keymap) - "Keymap for user-defined global bindings. -These bindings are seen in all Viper buffers.") - -(defvar viper-vi-basic-map (make-keymap) - "This is the main keymap in effect in Viper's Vi state. -This map is global, shared by all buffers.") - -(defvar viper-vi-kbd-map (make-sparse-keymap) - "This keymap keeps keyboard macros defined via the :map command.") - -(defvar viper-vi-diehard-map (make-sparse-keymap) - "This keymap is in use when the user asks Viper to simulate Vi very closely. -This happens when viper-expert-level is 1 or 2. See viper-set-expert-level.") - - -(viper-deflocalvar viper-insert-local-user-map (make-sparse-keymap) - "Auxiliary map for per-buffer user-defined keybindings in Insert state.") -(put 'viper-insert-local-user-map 'permanent-local t) - -(defvar viper-insert-global-user-map (make-sparse-keymap) - "Auxiliary map for global user-defined bindings in Insert state.") - -(defvar viper-insert-basic-map (make-sparse-keymap) - "The basic insert-mode keymap.") - -(defvar viper-insert-diehard-map (make-keymap) - "Map used when user wants vi-style keys in insert mode. -Most of the Emacs keys are suppressed. This map overshadows -viper-insert-basic-map. Not recommended, except for novice users.") - -(defvar viper-insert-kbd-map (make-sparse-keymap) - "This keymap keeps VI-style kbd macros for insert mode.") - -(defvar viper-replace-map (make-sparse-keymap) - "Map used in Viper's replace state.") - -(defvar viper-emacs-global-user-map (make-sparse-keymap) - "Auxiliary map for global user-defined bindings in Emacs state.") - -(defvar viper-emacs-kbd-map (make-sparse-keymap) - "This keymap keeps Vi-style kbd macros for emacs mode.") - -(viper-deflocalvar viper-emacs-local-user-map (make-sparse-keymap) - "Auxiliary map for local user-defined bindings in Emacs state.") -(put 'viper-emacs-local-user-map 'permanent-local t) - -;; This keymap should stay empty -(defvar viper-empty-keymap (make-sparse-keymap)) - -;; This was the main Vi mode in old versions of VIP which may have been -;; extensively used by VIP users. We declare it as a global var -;; and, after .viper is loaded, we add this keymap to viper-vi-basic-map. -(defvar viper-mode-map (make-sparse-keymap)) - - -;;; Variables used by minor modes - -;; Association list of the form -;; ((major-mode . keymap) (major-mode . keymap) ...) -;; Viper uses these keymaps to make user-requested adjustments -;; to its Vi state in various major modes.") -(defvar viper-vi-state-modifier-alist nil) - -;; Association list of the form -;; ((major-mode . keymap) (major-mode . keymap) ...) -;; Viper uses these keymaps to make user-requested adjustments -;; to its Insert state in various major modes.") -(defvar viper-insert-state-modifier-alist nil) - -;; Association list of the form -;; ((major-mode . keymap) (major-mode . keymap) ...) -;; Viper uses these keymaps to make user-requested adjustments -;; to its Emacs state in various major modes. -(defvar viper-emacs-state-modifier-alist nil) - -;; Tells viper-add-local-keys to create a new viper-vi-local-user-map for new -;; buffers. Not a user option. -(viper-deflocalvar viper-need-new-vi-local-map t "") -(put 'viper-need-new-vi-local-map 'permanent-local t) - -;; Tells viper-add-local-keys to create a new viper-insert-local-user-map for -;; new buffers. Not a user option. -(viper-deflocalvar viper-need-new-insert-local-map t "") -(put 'viper-need-new-insert-local-map 'permanent-local t) - -;; Tells viper-add-local-keys to create a new viper-emacs-local-user-map for -;; new buffers. Not a user option. -(viper-deflocalvar viper-need-new-emacs-local-map t "") -(put 'viper-need-new-emacs-local-map 'permanent-local t) - - - -;; Insert mode keymap - -;; for novice users, pretend you are the real vi. -(define-key viper-insert-diehard-map "\t" 'viper-insert-tab) -(define-key viper-insert-diehard-map "\C-a" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-b" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-c" 'viper-change-state-to-vi) -(define-key viper-insert-diehard-map "\C-e" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-f" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-g" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-i" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-k" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-l" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-n" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-o" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-p" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-q" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-r" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-s" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-u" 'viper-erase-line) -(define-key viper-insert-diehard-map "\C-x" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-y" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-z" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-]" 'self-insert-command) -(define-key viper-insert-diehard-map "\C-_" 'self-insert-command) - -(let ((i ?\ )) - (while (<= i ?~) - (define-key viper-insert-diehard-map (make-string 1 i) 'self-insert-command) - (setq i (1+ i)))) - -;; Insert mode map when user wants emacs style -(define-key viper-insert-basic-map "\C-d" 'viper-backward-indent) -(define-key viper-insert-basic-map "\C-w" 'viper-delete-backward-word) -(define-key viper-insert-basic-map "\C-t" 'viper-forward-indent) -(define-key viper-insert-basic-map - (if viper-xemacs-p [(shift tab)] [S-tab]) 'viper-insert-tab) -(define-key viper-insert-basic-map "\C-v" 'quoted-insert) -(define-key viper-insert-basic-map "\C-?" 'viper-del-backward-char-in-insert) -(define-key viper-insert-basic-map [backspace] 'viper-del-backward-char-in-insert) -(define-key viper-insert-basic-map "\C-\\" 'viper-alternate-Meta-key) -(define-key viper-insert-basic-map viper-toggle-key 'viper-escape-to-vi) -(define-key viper-insert-basic-map "\C-c\M-p" - 'viper-insert-prev-from-insertion-ring) -(define-key viper-insert-basic-map "\C-c\M-n" - 'viper-insert-next-from-insertion-ring) - - -;; Replace keymap -(define-key viper-replace-map "\C-t" 'viper-forward-indent) -(define-key viper-replace-map "\C-j" 'viper-replace-state-carriage-return) -(define-key viper-replace-map "\C-m" 'viper-replace-state-carriage-return) -(define-key viper-replace-map "\C-?" 'viper-del-backward-char-in-replace) -(define-key viper-replace-map [backspace] 'viper-del-backward-char-in-replace) - - - -;; Vi keymaps - -(define-key viper-vi-basic-map "\C-^" - (function (lambda () (interactive) (viper-ex "e#")))) -(define-key viper-vi-basic-map "\C-b" 'viper-scroll-screen-back) -(define-key viper-vi-basic-map "\C-d" 'viper-scroll-up) -(define-key viper-vi-basic-map "\C-e" 'viper-scroll-up-one) -(define-key viper-vi-basic-map "\C-f" 'viper-scroll-screen) -(define-key viper-vi-basic-map "\C-m" 'viper-next-line-at-bol) -(define-key viper-vi-basic-map "\C-u" 'viper-scroll-down) -(define-key viper-vi-basic-map "\C-y" 'viper-scroll-down-one) -(define-key viper-vi-basic-map "\C-s" 'viper-isearch-forward) -(define-key viper-vi-basic-map "\C-r" 'viper-isearch-backward) -(define-key viper-vi-basic-map "\C-c/" 'viper-toggle-search-style) -(define-key viper-vi-basic-map "\C-cg" 'viper-info-on-file) - -(define-key viper-vi-basic-map "\C-c\M-p" 'viper-prev-destructive-command) -(define-key viper-vi-basic-map "\C-c\M-n" 'viper-next-destructive-command) - - -(define-key viper-vi-basic-map " " 'viper-forward-char) -(define-key viper-vi-basic-map "!" 'viper-command-argument) -(define-key viper-vi-basic-map "\"" 'viper-command-argument) -(define-key viper-vi-basic-map "#" 'viper-command-argument) -(define-key viper-vi-basic-map "$" 'viper-goto-eol) -(define-key viper-vi-basic-map "%" 'viper-paren-match) -(define-key viper-vi-basic-map "&" - (function (lambda () (interactive) (viper-ex "&")))) -(define-key viper-vi-basic-map "'" 'viper-goto-mark-and-skip-white) -(define-key viper-vi-basic-map "(" 'viper-backward-sentence) -(define-key viper-vi-basic-map ")" 'viper-forward-sentence) -(define-key viper-vi-basic-map "*" 'call-last-kbd-macro) -(define-key viper-vi-basic-map "+" 'viper-next-line-at-bol) -(define-key viper-vi-basic-map "," 'viper-repeat-find-opposite) -(define-key viper-vi-basic-map "-" 'viper-previous-line-at-bol) -(define-key viper-vi-basic-map "." 'viper-repeat) -(define-key viper-vi-basic-map "/" 'viper-search-forward) - -(define-key viper-vi-basic-map "0" 'viper-beginning-of-line) -(define-key viper-vi-basic-map "1" 'viper-digit-argument) -(define-key viper-vi-basic-map "2" 'viper-digit-argument) -(define-key viper-vi-basic-map "3" 'viper-digit-argument) -(define-key viper-vi-basic-map "4" 'viper-digit-argument) -(define-key viper-vi-basic-map "5" 'viper-digit-argument) -(define-key viper-vi-basic-map "6" 'viper-digit-argument) -(define-key viper-vi-basic-map "7" 'viper-digit-argument) -(define-key viper-vi-basic-map "8" 'viper-digit-argument) -(define-key viper-vi-basic-map "9" 'viper-digit-argument) - -(define-key viper-vi-basic-map ":" 'viper-ex) -(define-key viper-vi-basic-map ";" 'viper-repeat-find) -(define-key viper-vi-basic-map "<" 'viper-command-argument) -(define-key viper-vi-basic-map "=" 'viper-command-argument) -(define-key viper-vi-basic-map ">" 'viper-command-argument) -(define-key viper-vi-basic-map "?" 'viper-search-backward) -(define-key viper-vi-basic-map "@" 'viper-register-macro) - -(define-key viper-vi-basic-map "A" 'viper-Append) -(define-key viper-vi-basic-map "B" 'viper-backward-Word) -(define-key viper-vi-basic-map "C" 'viper-change-to-eol) -(define-key viper-vi-basic-map "D" 'viper-kill-line) -(define-key viper-vi-basic-map "E" 'viper-end-of-Word) -(define-key viper-vi-basic-map "F" 'viper-find-char-backward) -(define-key viper-vi-basic-map "G" 'viper-goto-line) -(define-key viper-vi-basic-map "H" 'viper-window-top) -(define-key viper-vi-basic-map "I" 'viper-Insert) -(define-key viper-vi-basic-map "J" 'viper-join-lines) -(define-key viper-vi-basic-map "K" 'viper-nil) -(define-key viper-vi-basic-map "L" 'viper-window-bottom) -(define-key viper-vi-basic-map "M" 'viper-window-middle) -(define-key viper-vi-basic-map "N" 'viper-search-Next) -(define-key viper-vi-basic-map "O" 'viper-Open-line) -(define-key viper-vi-basic-map "P" 'viper-Put-back) -(define-key viper-vi-basic-map "Q" 'viper-query-replace) -(define-key viper-vi-basic-map "R" 'viper-overwrite) -(define-key viper-vi-basic-map "S" 'viper-substitute-line) -(define-key viper-vi-basic-map "T" 'viper-goto-char-backward) -(define-key viper-vi-basic-map "U" 'viper-undo) -(define-key viper-vi-basic-map "V" 'find-file-other-window) -(define-key viper-vi-basic-map "W" 'viper-forward-Word) -(define-key viper-vi-basic-map "X" 'viper-delete-backward-char) -(define-key viper-vi-basic-map "Y" 'viper-yank-line) -(define-key viper-vi-basic-map "ZZ" 'viper-save-kill-buffer) - -(define-key viper-vi-basic-map "\\" 'viper-escape-to-emacs) -(define-key viper-vi-basic-map "[" 'viper-brac-function) -(define-key viper-vi-basic-map "]" 'viper-ket-function) -(define-key viper-vi-basic-map "\C-\\" 'viper-alternate-Meta-key) -(define-key viper-vi-basic-map "^" 'viper-bol-and-skip-white) -(define-key viper-vi-basic-map "`" 'viper-goto-mark) - -(define-key viper-vi-basic-map "a" 'viper-append) -(define-key viper-vi-basic-map "b" 'viper-backward-word) -(define-key viper-vi-basic-map "c" 'viper-command-argument) -(define-key viper-vi-basic-map "d" 'viper-command-argument) -(define-key viper-vi-basic-map "e" 'viper-end-of-word) -(define-key viper-vi-basic-map "f" 'viper-find-char-forward) -(define-key viper-vi-basic-map "g" 'viper-nil) -(define-key viper-vi-basic-map "h" 'viper-backward-char) -(define-key viper-vi-basic-map [backspace] 'viper-backward-char) -(define-key viper-vi-basic-map "i" 'viper-insert) -(define-key viper-vi-basic-map "j" 'viper-next-line) -(define-key viper-vi-basic-map "k" 'viper-previous-line) -(define-key viper-vi-basic-map "l" 'viper-forward-char) -(define-key viper-vi-basic-map "m" 'viper-mark-point) -(define-key viper-vi-basic-map "n" 'viper-search-next) -(define-key viper-vi-basic-map "o" 'viper-open-line) -(define-key viper-vi-basic-map "p" 'viper-put-back) -(define-key viper-vi-basic-map "q" 'viper-nil) -(define-key viper-vi-basic-map "r" 'viper-replace-char) -(define-key viper-vi-basic-map "s" 'viper-substitute) -(define-key viper-vi-basic-map "t" 'viper-goto-char-forward) -(define-key viper-vi-basic-map "u" 'viper-undo) -(define-key viper-vi-basic-map "v" 'find-file) -(define-key viper-vi-basic-map "\C-v" 'find-file-other-frame) -(define-key viper-vi-basic-map "w" 'viper-forward-word) -(define-key viper-vi-basic-map "x" 'viper-delete-char) -(define-key viper-vi-basic-map "y" 'viper-command-argument) -(define-key viper-vi-basic-map "zH" 'viper-line-to-top) -(define-key viper-vi-basic-map "zM" 'viper-line-to-middle) -(define-key viper-vi-basic-map "zL" 'viper-line-to-bottom) -(define-key viper-vi-basic-map "z\C-m" 'viper-line-to-top) -(define-key viper-vi-basic-map "z." 'viper-line-to-middle) -(define-key viper-vi-basic-map "z-" 'viper-line-to-bottom) - -(define-key viper-vi-basic-map "{" 'viper-backward-paragraph) -(define-key viper-vi-basic-map "|" 'viper-goto-col) -(define-key viper-vi-basic-map "}" 'viper-forward-paragraph) -(define-key viper-vi-basic-map "~" 'viper-toggle-case) -(define-key viper-vi-basic-map "\C-?" 'viper-backward-char) -(define-key viper-vi-basic-map "_" 'viper-nil) - -;;; Escape from Emacs to Vi for one command -(global-set-key "\C-c\\" 'viper-escape-to-vi) ; everywhere - -;;; This is viper-vi-diehard-map. Used when viper-vi-diehard-minor-mode is on. - -(define-key viper-vi-diehard-map "\C-a" 'viper-nil) -(define-key viper-vi-diehard-map "\C-c" 'viper-nil) -(define-key viper-vi-diehard-map "\C-g" 'viper-info-on-file) -(define-key viper-vi-diehard-map "\C-i" 'viper-nil) -(define-key viper-vi-diehard-map "\C-k" 'viper-nil) -(define-key viper-vi-diehard-map "\C-l" 'redraw-display) -(define-key viper-vi-diehard-map "\C-n" 'viper-next-line) -(define-key viper-vi-diehard-map "\C-o" 'viper-nil) -(define-key viper-vi-diehard-map "\C-p" 'viper-previous-line) -(define-key viper-vi-diehard-map "\C-q" 'viper-nil) -(define-key viper-vi-diehard-map "\C-r" 'redraw-display) -(define-key viper-vi-diehard-map "\C-s" 'viper-nil) -(define-key viper-vi-diehard-map "\C-t" 'viper-nil) -(define-key viper-vi-diehard-map "\C-v" 'viper-nil) -(define-key viper-vi-diehard-map "\C-w" 'viper-nil) -(define-key viper-vi-diehard-map "@" 'viper-nil) -(define-key viper-vi-diehard-map "_" 'viper-nil) -(define-key viper-vi-diehard-map "*" 'viper-nil) -(define-key viper-vi-diehard-map "#" 'viper-nil) -(define-key viper-vi-diehard-map "\C-_" 'viper-nil) -(define-key viper-vi-diehard-map "\C-]" 'viper-nil) ; This is actually tags. - - -;;; Minibuffer keymap - - -(defvar viper-minibuffer-map (make-sparse-keymap) - "Keymap used to modify keys when Minibuffer is in Insert state.") - -(define-key viper-minibuffer-map "\C-m" 'viper-exit-minibuffer) -(define-key viper-minibuffer-map "\C-j" 'viper-exit-minibuffer) - -;; Map used to read Ex-style commands. -(defvar viper-ex-cmd-map (make-sparse-keymap)) -(define-key viper-ex-cmd-map " " 'ex-cmd-read-exit) -(define-key viper-ex-cmd-map "\t" 'ex-cmd-complete) - -;; Keymap for reading file names in Ex-style commands. -(defvar ex-read-filename-map (make-sparse-keymap)) -(define-key ex-read-filename-map " " 'viper-complete-filename-or-exit) -(define-key ex-read-filename-map "!" 'viper-handle-!) - -;; Some other maps -(defvar viper-slash-and-colon-map (make-sparse-keymap) - "This map redefines `/' and `:' to behave as in Vi. -Useful in some modes, such as Gnus, MH, etc.") -(define-key viper-slash-and-colon-map ":" 'viper-ex) -(define-key viper-slash-and-colon-map "/" 'viper-search-forward) - -(defvar viper-comint-mode-modifier-map (make-sparse-keymap) - "This map modifies comint mode.") -(define-key viper-comint-mode-modifier-map "\C-m" 'comint-send-input) -(define-key viper-comint-mode-modifier-map "\C-d" 'comint-delchar-or-maybe-eof) - -(defvar viper-dired-modifier-map (make-sparse-keymap) - "This map modifies Dired behavior.") -(define-key viper-dired-modifier-map ":" 'viper-ex) -(define-key viper-dired-modifier-map "/" 'viper-search-forward) - - - -;;; Code - -(defun viper-add-local-keys (state alist) - "Override some vi-state or insert-state bindings in the current buffer. -The effect is seen in the current buffer only. -Useful for customizing mailer buffers, gnus, etc. -STATE is 'vi-state, 'insert-state, or 'emacs-state -ALIST is of the form ((key . func) (key . func) ...) -Normally, this would be called from a hook to a major mode or -on a per buffer basis. -Usage: - (viper-add-local-keys state '((key-str . func) (key-str . func)...)) " - - (let (map) - (cond ((eq state 'vi-state) - (if viper-need-new-vi-local-map - (setq viper-vi-local-user-map (make-sparse-keymap))) - (setq viper-need-new-vi-local-map nil - map viper-vi-local-user-map)) - ((eq state 'insert-state) - (if viper-need-new-insert-local-map - (setq viper-insert-local-user-map (make-sparse-keymap))) - (setq viper-need-new-insert-local-map nil - map viper-insert-local-user-map)) - ((eq state 'emacs-state) - (if viper-need-new-emacs-local-map - (setq viper-emacs-local-user-map (make-sparse-keymap))) - (setq viper-need-new-emacs-local-map nil - map viper-emacs-local-user-map)) - (t - (error - "Invalid state in viper-add-local-keys: %S. Valid states: vi-state, insert-state or emacs-state" state))) - - (viper-modify-keymap map alist) - (viper-normalize-minor-mode-map-alist) - (viper-set-mode-vars-for viper-current-state))) - -(defun viper-zap-local-keys () - "Unconditionally reset Viper viper-*-local-user-map's. -Rarely useful, but if u made a mistake by switching to a mode that adds -undesirable local keys, e.g., comint-mode, then this function can restore -sanity." - (interactive) - (setq viper-vi-local-user-map (make-sparse-keymap) - viper-need-new-vi-local-map nil - viper-insert-local-user-map (make-sparse-keymap) - viper-need-new-insert-local-map nil - viper-emacs-local-user-map (make-sparse-keymap) - viper-need-new-emacs-local-map nil) - (viper-normalize-minor-mode-map-alist)) - - -(defun viper-modify-major-mode (mode state keymap) - "Modify key bindings in a major-mode in a Viper state using a keymap. - -If the default for a major mode is emacs-state, then modifications to this -major mode may not take effect until the buffer switches state to Vi, -Insert or Emacs. If this happens, add viper-change-state-to-emacs to this -major mode's hook. If no such hook exists, you may have to put an advice on -the function that invokes the major mode. See viper-set-hooks for hints. - -The above needs not to be done for major modes that come up in Vi or Insert -state by default. - -Arguments: (major-mode viper-state keymap)" - (let ((alist - (cond ((eq state 'vi-state) 'viper-vi-state-modifier-alist) - ((eq state 'insert-state) 'viper-insert-state-modifier-alist) - ((eq state 'emacs-state) 'viper-emacs-state-modifier-alist))) - elt) - (if (setq elt (assoc mode (eval alist))) - (set alist (delq elt (eval alist)))) - (set alist (cons (cons mode keymap) (eval alist))) - - ;; Normalization usually doesn't help here, since one needs to - ;; normalize in the actual buffer where changes to the keymap are - ;; to take place. However, it doesn't hurt, and it helps whenever this - ;; function is actually called from within the right buffer. - (viper-normalize-minor-mode-map-alist) - - (viper-set-mode-vars-for viper-current-state))) - - -;; Displays variables that control Viper's keymaps -(defun viper-debug-keymaps () - (interactive) - (with-output-to-temp-buffer " *viper-debug*" - (princ (format "Buffer name: %s\n\n" (buffer-name))) - (princ "Variables: \n") - (princ (format "major-mode: %S\n" major-mode)) - (princ (format "viper-current-state: %S\n" viper-current-state)) - (princ (format "viper-mode-string: %S\n\n" viper-mode-string)) - (princ (format "viper-vi-intercept-minor-mode: %S\n" - viper-vi-intercept-minor-mode)) - (princ (format "viper-insert-intercept-minor-mode: %S\n" - viper-insert-intercept-minor-mode)) - (princ (format "viper-emacs-intercept-minor-mode: %S\n" - viper-emacs-intercept-minor-mode)) - (princ (format "viper-vi-minibuffer-minor-mode: %S\n" - viper-vi-minibuffer-minor-mode)) - (princ (format "viper-insert-minibuffer-minor-mode: %S\n\n" - viper-insert-minibuffer-minor-mode)) - (princ (format "viper-vi-local-user-minor-mode: %S\n" - viper-vi-local-user-minor-mode)) - (princ (format "viper-vi-global-user-minor-mode: %S\n" - viper-vi-global-user-minor-mode)) - (princ (format "viper-vi-kbd-minor-mode: %S\n" viper-vi-kbd-minor-mode)) - (princ (format "viper-vi-state-modifier-minor-mode: %S\n" - viper-vi-state-modifier-minor-mode)) - (princ (format "viper-vi-diehard-minor-mode: %S\n" - viper-vi-diehard-minor-mode)) - (princ (format "viper-vi-basic-minor-mode: %S\n" viper-vi-basic-minor-mode)) - (princ (format "viper-replace-minor-mode: %S\n" viper-replace-minor-mode)) - (princ (format "viper-insert-local-user-minor-mode: %S\n" - viper-insert-local-user-minor-mode)) - (princ (format "viper-insert-global-user-minor-mode: %S\n" - viper-insert-global-user-minor-mode)) - (princ (format "viper-insert-kbd-minor-mode: %S\n" - viper-insert-kbd-minor-mode)) - (princ (format "viper-insert-state-modifier-minor-mode: %S\n" - viper-insert-state-modifier-minor-mode)) - (princ (format "viper-insert-diehard-minor-mode: %S\n" - viper-insert-diehard-minor-mode)) - (princ (format "viper-insert-basic-minor-mode: %S\n" - viper-insert-basic-minor-mode)) - (princ (format "viper-emacs-local-user-minor-mode: %S\n" - viper-emacs-local-user-minor-mode)) - (princ (format "viper-emacs-kbd-minor-mode: %S\n" - viper-emacs-kbd-minor-mode)) - (princ (format "viper-emacs-global-user-minor-mode: %S\n" - viper-emacs-global-user-minor-mode)) - (princ (format "viper-emacs-state-modifier-minor-mode: %S\n" - viper-emacs-state-modifier-minor-mode)) - - (princ (format "\nviper-expert-level %S\n" viper-expert-level)) - (princ (format "viper-no-multiple-ESC %S\n" viper-no-multiple-ESC)) - (princ (format "viper-always %S\n" viper-always)) - (princ (format "viper-ex-style-motion %S\n" - viper-ex-style-motion)) - (princ (format "viper-ex-style-editing %S\n" - viper-ex-style-editing)) - (princ (format "viper-want-emacs-keys-in-vi %S\n" - viper-want-emacs-keys-in-vi)) - (princ (format "viper-want-emacs-keys-in-insert %S\n" - viper-want-emacs-keys-in-insert)) - (princ (format "viper-want-ctl-h-help %S\n" viper-want-ctl-h-help)) - - (princ "\n\n\n") - (princ (format "Default value for minor-mode-map-alist: \n%S\n\n" - (default-value 'minor-mode-map-alist))) - (princ (format "Actual value for minor-mode-map-alist: \n%S\n" - minor-mode-map-alist)) - )) - - -;;; Keymap utils - -(defun viper-add-keymap (mapsrc mapdst) - "Add contents of mapsrc to mapdst. It is assumed that mapsrc is sparse." - (if viper-xemacs-p - (map-keymap (function (lambda (key binding) - (define-key mapdst key binding))) - mapsrc) - (mapcar - (function (lambda (p) - (define-key mapdst (vector (car p)) (cdr p)) - )) - (cdr mapsrc)))) - -(defun viper-modify-keymap (map alist) - "Modifies MAP with bindings specified in the ALIST. The alist has the -form ((key . function) (key . function) ... )." - (mapcar (function (lambda (p) - (define-key map (eval (car p)) (cdr p)))) - alist)) - - -;;; Local Variables: -;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) -;;; End: - - -;;; viper-keym.el ends here
--- a/lisp/viper/viper-macs.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,955 +0,0 @@ -;;; viper-macs.el --- functions implementing keyboard macros for Viper - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Code - -(provide 'viper-macs) - -;; compiler pacifier -(defvar viper-ex-work-buf) -(defvar viper-custom-file-name) -(defvar viper-current-state) -(defvar viper-fast-keyseq-timeout) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-keym) - (load "viper-keym.el" nil nil 'nosuffix)) - (or (featurep 'viper-mous) - (load "viper-mous.el" nil nil 'nosuffix)) - (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) - ))) -;; end pacifier - -(require 'viper-util) -(require 'viper-keym) - - -;;; Variables - -;; Register holding last macro. -(defvar viper-last-macro-reg nil) - -;; format of the elements of kbd alists: -;; (name ((buf . macr)...(buf . macr)) ((maj-mode . macr)...) (t . macr)) -;; kbd macro alist for Vi state -(defvar viper-vi-kbd-macro-alist nil) -;; same for insert/replace state -(defvar viper-insert-kbd-macro-alist nil) -;; same for emacs state -(defvar viper-emacs-kbd-macro-alist nil) - -;; Internal var that passes info between start-kbd-macro and end-kbd-macro -;; in :map and :map! -(defvar viper-kbd-macro-parameters nil) - -(defvar viper-this-kbd-macro nil - "Vector of keys representing the name of currently running Viper kbd macro.") -(defvar viper-last-kbd-macro nil - "Vector of keys representing the name of last Viper keyboard macro.") - -(defcustom viper-repeat-from-history-key 'f12 - "Prefix key for accessing previously typed Vi commands. - -The previous command is accessible, as usual, via `.'. The command before this -can be invoked as `<this key> 1', and the command before that, and the command -before that one is accessible as `<this key> 2'. -The notation for these keys is borrowed from XEmacs. Basically, -a key is a symbol, e.g., `a', `\\1', `f2', etc., or a list, e.g., -`(meta control f1)'." - :type 'sexp - :group 'viper) - - - -;;; Code - -;; Ex map command -(defun ex-map () - (let ((mod-char "") - macro-name macro-body map-args ins) - (save-window-excursion - (set-buffer viper-ex-work-buf) - (if (looking-at "!") - (progn - (setq ins t - mod-char "!") - (forward-char 1)))) - (setq map-args (ex-map-read-args mod-char) - macro-name (car map-args) - macro-body (cdr map-args)) - (setq viper-kbd-macro-parameters (list ins mod-char macro-name macro-body)) - (if macro-body - (viper-end-mapping-kbd-macro 'ignore) - (ex-fixup-history (format "map%s %S" mod-char - (viper-display-macro macro-name))) - ;; if defining macro for insert, switch there for authentic WYSIWYG - (if ins (viper-change-state-to-insert)) - (start-kbd-macro nil) - (define-key viper-vi-intercept-map "\C-x)" 'viper-end-mapping-kbd-macro) - (define-key viper-insert-intercept-map "\C-x)" 'viper-end-mapping-kbd-macro) - (define-key viper-emacs-intercept-map "\C-x)" 'viper-end-mapping-kbd-macro) - (message "Mapping %S in %s state. Hit `C-x )' to complete the mapping" - (viper-display-macro macro-name) - (if ins "Insert" "Vi"))) - )) - - -;; Ex unmap -(defun ex-unmap () - (let ((mod-char "") - temp macro-name ins) - (save-window-excursion - (set-buffer viper-ex-work-buf) - (if (looking-at "!") - (progn - (setq ins t - mod-char "!") - (forward-char 1)))) - - (setq macro-name (ex-unmap-read-args mod-char)) - (setq temp (viper-fixup-macro (vconcat macro-name))) ;; copy and fixup - (ex-fixup-history (format "unmap%s %S" mod-char - (viper-display-macro temp))) - (viper-unrecord-kbd-macro macro-name (if ins 'insert-state 'vi-state)) - )) - - -;; read arguments for ex-map -(defun ex-map-read-args (variant) - (let ((cursor-in-echo-area t) - (key-seq []) - temp key event message - macro-name macro-body args) - - (condition-case nil - (setq args (concat (ex-get-inline-cmd-args ".*map[!]*[ \t]?" "\n\C-m") - " nil nil ") - temp (read-from-string args) - macro-name (car temp) - macro-body (car (read-from-string args (cdr temp)))) - (error - (signal - 'error - '("map: Macro name and body must be a quoted string or a vector")))) - - ;; We expect macro-name to be a vector, a string, or a quoted string. - ;; In the second case, it will emerge as a symbol when read from - ;; the above read-from-string. So we need to convert it into a string - (if macro-name - (cond ((vectorp macro-name) nil) - ((stringp macro-name) - (setq macro-name (vconcat macro-name))) - (t (setq macro-name (vconcat (prin1-to-string macro-name))))) - (message ":map%s <Name>" variant)(sit-for 2) - (while - (not (member key - '(?\C-m ?\n (control m) (control j) return linefeed))) - (setq key-seq (vconcat key-seq (if key (vector key) []))) - ;; the only keys available for editing are these-- no help while there - (if (member - key - '(?\b ?\d '^? '^H (control h) (control \?) backspace delete)) - (setq key-seq (subseq key-seq 0 (- (length key-seq) 2)))) - (setq message - (format - ":map%s %s" - variant (if (> (length key-seq) 0) - (prin1-to-string (viper-display-macro key-seq)) - ""))) - (message message) - (setq event (viper-read-key)) - ;;(setq event (viper-read-event)) - (setq key - (if (viper-mouse-event-p event) - (progn - (message "%s (No mouse---only keyboard keys, please)" - message) - (sit-for 2) - nil) - (viper-event-key event))) - ) - (setq macro-name key-seq)) - - (if (= (length macro-name) 0) - (error "Can't map an empty macro name")) - (setq macro-name (viper-fixup-macro macro-name)) - (if (viper-char-array-p macro-name) - (setq macro-name (viper-char-array-to-macro macro-name))) - - (if macro-body - (cond ((viper-char-array-p macro-body) - (setq macro-body (viper-char-array-to-macro macro-body))) - ((vectorp macro-body) nil) - (t (error "map: Invalid syntax in macro definition")))) - (setq cursor-in-echo-area nil)(sit-for 0) ; this overcomes xemacs tty bug - (cons macro-name macro-body))) - - - -;; read arguments for ex-unmap -(defun ex-unmap-read-args (variant) - (let ((cursor-in-echo-area t) - (macro-alist (if (string= variant "!") - viper-insert-kbd-macro-alist - viper-vi-kbd-macro-alist)) - ;; these are disabled just in case, to avoid surprises when doing - ;; completing-read - viper-vi-kbd-minor-mode viper-insert-kbd-minor-mode - viper-emacs-kbd-minor-mode - viper-vi-intercept-minor-mode viper-insert-intercept-minor-mode - viper-emacs-intercept-minor-mode - event message - key key-seq macro-name) - (setq macro-name (ex-get-inline-cmd-args ".*unma?p?[!]*[ \t]*")) - - (if (> (length macro-name) 0) - () - (message ":unmap%s <Name>" variant) (sit-for 2) - (while - (not - (member key '(?\C-m ?\n (control m) (control j) return linefeed))) - (setq key-seq (vconcat key-seq (if key (vector key) []))) - ;; the only keys available for editing are these-- no help while there - (cond ((member - key - '(?\b ?\d '^? '^H (control h) (control \?) backspace delete)) - (setq key-seq (subseq key-seq 0 (- (length key-seq) 2)))) - ((member key '(tab (control i) ?\t)) - (setq key-seq (subseq key-seq 0 (1- (length key-seq)))) - (setq message - (format - ":unmap%s %s" - variant (if (> (length key-seq) 0) - (prin1-to-string - (viper-display-macro key-seq)) - ""))) - (setq key-seq - (viper-do-sequence-completion key-seq macro-alist message)) - )) - (setq message - (format - ":unmap%s %s" - variant (if (> (length key-seq) 0) - (prin1-to-string - (viper-display-macro key-seq)) - ""))) - (message message) - (setq event (viper-read-key)) - ;;(setq event (viper-read-event)) - (setq key - (if (viper-mouse-event-p event) - (progn - (message "%s (No mouse---only keyboard keys, please)" - message) - (sit-for 2) - nil) - (viper-event-key event))) - ) - (setq macro-name key-seq)) - - (if (= (length macro-name) 0) - (error "Can't unmap an empty macro name")) - - ;; convert macro names into vector, if starts with a `[' - (if (memq (elt macro-name 0) '(?\[ ?\")) - (car (read-from-string macro-name)) - (vconcat macro-name)) - )) - - -;; Terminate a Vi kbd macro. -;; optional argument IGNORE, if t, indicates that we are dealing with an -;; existing macro that needs to be registered, but there is no need to -;; terminate a kbd macro. -(defun viper-end-mapping-kbd-macro (&optional ignore) - (interactive) - (define-key viper-vi-intercept-map "\C-x)" nil) - (define-key viper-insert-intercept-map "\C-x)" nil) - (define-key viper-emacs-intercept-map "\C-x)" nil) - (if (and (not ignore) - (or (not viper-kbd-macro-parameters) - (not defining-kbd-macro))) - (error "Not mapping a kbd-macro")) - (let ((mod-char (nth 1 viper-kbd-macro-parameters)) - (ins (nth 0 viper-kbd-macro-parameters)) - (macro-name (nth 2 viper-kbd-macro-parameters)) - (macro-body (nth 3 viper-kbd-macro-parameters))) - (setq viper-kbd-macro-parameters nil) - (or ignore - (progn - (end-kbd-macro nil) - (setq macro-body (viper-events-to-macro last-kbd-macro)) - ;; always go back to Vi, since this is where we started - ;; defining macro - (viper-change-state-to-vi))) - - (viper-record-kbd-macro macro-name - (if ins 'insert-state 'vi-state) - (viper-display-macro macro-body)) - - (ex-fixup-history (format "map%s %S %S" mod-char - (viper-display-macro macro-name) - (viper-display-macro macro-body))) - )) - - - - -;;; Recording, unrecording, executing - -;; accepts as macro names: strings and vectors. -;; strings must be strings of characters; vectors must be vectors of keys -;; in canonic form. the canonic form is essentially the form used in XEmacs -(defun viper-record-kbd-macro (macro-name state macro-body &optional scope) - "Record a Vi macro. Can be used in `.viper' file to define permanent macros. -MACRO-NAME is a string of characters or a vector of keys. STATE is -either `vi-state' or `insert-state'. It specifies the Viper state in which to -define the macro. MACRO-BODY is a string that represents the keyboard macro. -Optional SCOPE says whether the macro should be global \(t\), mode-specific -\(a major-mode symbol\), or buffer-specific \(buffer name, a string\). -If SCOPE is nil, the user is asked to specify the scope." - (let* (state-name keymap - (macro-alist-var - (cond ((eq state 'vi-state) - (setq state-name "Vi state" - keymap viper-vi-kbd-map) - 'viper-vi-kbd-macro-alist) - ((memq state '(insert-state replace-state)) - (setq state-name "Insert state" - keymap viper-insert-kbd-map) - 'viper-insert-kbd-macro-alist) - (t - (setq state-name "Emacs state" - keymap viper-emacs-kbd-map) - 'viper-emacs-kbd-macro-alist) - )) - new-elt old-elt old-sub-elt msg - temp lis lis2) - - (if (= (length macro-name) 0) - (error "Can't map an empty macro name")) - - ;; Macro-name is usually a vector. However, command history or macros - ;; recorded in ~/.viper may be recorded as strings. So, convert to vectors. - (setq macro-name (viper-fixup-macro macro-name)) - (if (viper-char-array-p macro-name) - (setq macro-name (viper-char-array-to-macro macro-name))) - (setq macro-body (viper-fixup-macro macro-body)) - (if (viper-char-array-p macro-body) - (setq macro-body (viper-char-array-to-macro macro-body))) - - ;; don't ask if scope is given and is of the right type - (or (eq scope t) - (stringp scope) - (and scope (symbolp scope)) - (progn - (setq scope - (cond - ((y-or-n-p - (format - "Map this macro for buffer `%s' only? " - (buffer-name))) - (setq msg - (format - "%S is mapped to %s for %s in `%s'" - (viper-display-macro macro-name) - (viper-abbreviate-string - (format - "%S" - (setq temp (viper-display-macro macro-body))) - 14 "" "" - (if (stringp temp) " ....\"" " ....]")) - state-name (buffer-name))) - (buffer-name)) - ((y-or-n-p - (format - "Map this macro for the major mode `%S' only? " - major-mode)) - (setq msg - (format - "%S is mapped to %s for %s in `%S'" - (viper-display-macro macro-name) - (viper-abbreviate-string - (format - "%S" - (setq temp (viper-display-macro macro-body))) - 14 "" "" - (if (stringp macro-body) " ....\"" " ....]")) - state-name major-mode)) - major-mode) - (t - (setq msg - (format - "%S is globally mapped to %s in %s" - (viper-display-macro macro-name) - (viper-abbreviate-string - (format - "%S" - (setq temp (viper-display-macro macro-body))) - 14 "" "" - (if (stringp macro-body) " ....\"" " ....]")) - state-name)) - t))) - (if (y-or-n-p - (format "Save this macro in %s? " - (viper-abbreviate-file-name viper-custom-file-name))) - (viper-save-string-in-file - (format "\n(viper-record-kbd-macro %S '%S %s '%S)" - (viper-display-macro macro-name) - state - ;; if we don't let vector macro-body through %S, - ;; the symbols `\.' `\[' etc will be converted into - ;; characters, causing invalid read error on recorded - ;; macros in .viper. - ;; I am not sure is macro-body can still be a string at - ;; this point, but I am preserving this option anyway. - (if (vectorp macro-body) - (format "%S" macro-body) - macro-body) - scope) - viper-custom-file-name)) - - (message msg) - )) - - (setq new-elt - (cons macro-name - (cond ((eq scope t) (list nil nil (cons t nil))) - ((symbolp scope) - (list nil (list (cons scope nil)) (cons t nil))) - ((stringp scope) - (list (list (cons scope nil)) nil (cons t nil)))))) - (setq old-elt (assoc macro-name (eval macro-alist-var))) - - (if (null old-elt) - (progn - ;; insert new-elt in macro-alist-var and keep the list sorted - (define-key - keymap - (vector (viper-key-to-emacs-key (aref macro-name 0))) - 'viper-exec-mapped-kbd-macro) - (setq lis (eval macro-alist-var)) - (while (and lis (string< (viper-array-to-string (car (car lis))) - (viper-array-to-string macro-name))) - (setq lis2 (cons (car lis) lis2)) - (setq lis (cdr lis))) - - (setq lis2 (reverse lis2)) - (set macro-alist-var (append lis2 (cons new-elt lis))) - (setq old-elt new-elt))) - (setq old-sub-elt - (cond ((eq scope t) (viper-kbd-global-pair old-elt)) - ((symbolp scope) (assoc scope (viper-kbd-mode-alist old-elt))) - ((stringp scope) (assoc scope (viper-kbd-buf-alist old-elt))))) - (if old-sub-elt - (setcdr old-sub-elt macro-body) - (cond ((symbolp scope) (setcar (cdr (cdr old-elt)) - (cons (cons scope macro-body) - (viper-kbd-mode-alist old-elt)))) - ((stringp scope) (setcar (cdr old-elt) - (cons (cons scope macro-body) - (viper-kbd-buf-alist old-elt)))))) - )) - - - -;; macro name must be a vector of viper-style keys -(defun viper-unrecord-kbd-macro (macro-name state) - "Delete macro MACRO-NAME from Viper STATE. -MACRO-NAME must be a vector of viper-style keys. This command is used by Viper -internally, but the user can also use it in ~/.viper to delete pre-defined -macros supplied with Viper. The best way to avoid mistakes in macro names to be -passed to this function is to use viper-describe-kbd-macros and copy the name -from there." - (let* (state-name keymap - (macro-alist-var - (cond ((eq state 'vi-state) - (setq state-name "Vi state" - keymap viper-vi-kbd-map) - 'viper-vi-kbd-macro-alist) - ((memq state '(insert-state replace-state)) - (setq state-name "Insert state" - keymap viper-insert-kbd-map) - 'viper-insert-kbd-macro-alist) - (t - (setq state-name "Emacs state" - keymap viper-emacs-kbd-map) - 'viper-emacs-kbd-macro-alist) - )) - buf-mapping mode-mapping global-mapping - macro-pair macro-entry) - - ;; Macro-name is usually a vector. However, command history or macros - ;; recorded in ~/.viper may appear as strings. So, convert to vectors. - (setq macro-name (viper-fixup-macro macro-name)) - (if (viper-char-array-p macro-name) - (setq macro-name (viper-char-array-to-macro macro-name))) - - (setq macro-entry (assoc macro-name (eval macro-alist-var))) - (if (= (length macro-name) 0) - (error "Can't unmap an empty macro name")) - (if (null macro-entry) - (error "%S is not mapped to a macro for %s in `%s'" - (viper-display-macro macro-name) - state-name (buffer-name))) - - (setq buf-mapping (viper-kbd-buf-pair macro-entry) - mode-mapping (viper-kbd-mode-pair macro-entry) - global-mapping (viper-kbd-global-pair macro-entry)) - - (cond ((and (cdr buf-mapping) - (or (and (not (cdr mode-mapping)) (not (cdr global-mapping))) - (y-or-n-p - (format "Unmap %S for `%s' only? " - (viper-display-macro macro-name) - (buffer-name))))) - (setq macro-pair buf-mapping) - (message "%S is unmapped for %s in `%s'" - (viper-display-macro macro-name) - state-name (buffer-name))) - ((and (cdr mode-mapping) - (or (not (cdr global-mapping)) - (y-or-n-p - (format "Unmap %S for the major mode `%S' only? " - (viper-display-macro macro-name) - major-mode)))) - (setq macro-pair mode-mapping) - (message "%S is unmapped for %s in %S" - (viper-display-macro macro-name) state-name major-mode)) - ((cdr (setq macro-pair (viper-kbd-global-pair macro-entry))) - (message - "Global mapping for %S in %s is removed" - (viper-display-macro macro-name) state-name)) - (t (error "%S is not mapped to a macro for %s in `%s'" - (viper-display-macro macro-name) - state-name (buffer-name)))) - (setcdr macro-pair nil) - (or (cdr buf-mapping) - (cdr mode-mapping) - (cdr global-mapping) - (progn - (set macro-alist-var (delq macro-entry (eval macro-alist-var))) - (if (viper-can-release-key (aref macro-name 0) - (eval macro-alist-var)) - (define-key - keymap - (vector (viper-key-to-emacs-key (aref macro-name 0))) - nil)) - )) - )) - -;; Check if MACRO-ALIST has an entry for a macro name starting with -;; CHAR. If not, this indicates that the binding for this char -;; in viper-vi/insert-kbd-map can be released. -(defun viper-can-release-key (char macro-alist) - (let ((lis macro-alist) - (can-release t) - macro-name) - - (while (and lis can-release) - (setq macro-name (car (car lis))) - (if (eq char (aref macro-name 0)) - (setq can-release nil)) - (setq lis (cdr lis))) - can-release)) - - -(defun viper-exec-mapped-kbd-macro (count) - "Dispatch kbd macro." - (interactive "P") - (let* ((macro-alist (cond ((eq viper-current-state 'vi-state) - viper-vi-kbd-macro-alist) - ((memq viper-current-state - '(insert-state replace-state)) - viper-insert-kbd-macro-alist) - (t - viper-emacs-kbd-macro-alist))) - (unmatched-suffix "") - ;; Macros and keys are executed with other macros turned off - ;; For macros, this is done to avoid macro recursion - viper-vi-kbd-minor-mode viper-insert-kbd-minor-mode - viper-emacs-kbd-minor-mode - next-best-match keyseq event-seq - macro-first-char macro-alist-elt macro-body - command) - - (setq macro-first-char last-command-event - event-seq (viper-read-fast-keysequence macro-first-char macro-alist) - keyseq (viper-events-to-macro event-seq) - macro-alist-elt (assoc keyseq macro-alist) - next-best-match (viper-find-best-matching-macro macro-alist keyseq)) - - (if (null macro-alist-elt) - (setq macro-alist-elt (car next-best-match) - unmatched-suffix (subseq event-seq (cdr next-best-match)))) - - (cond ((null macro-alist-elt)) - ((setq macro-body (viper-kbd-buf-definition macro-alist-elt))) - ((setq macro-body (viper-kbd-mode-definition macro-alist-elt))) - ((setq macro-body (viper-kbd-global-definition macro-alist-elt)))) - - ;; when defining keyboard macro, don't use the macro mappings - (if (and macro-body (not defining-kbd-macro)) - ;; block cmd executed as part of a macro from entering command history - (let ((command-history command-history)) - (setq viper-this-kbd-macro (car macro-alist-elt)) - (execute-kbd-macro (viper-macro-to-events macro-body) count) - (setq viper-this-kbd-macro nil - viper-last-kbd-macro (car macro-alist-elt)) - (viper-set-unread-command-events unmatched-suffix)) - ;; If not a macro, or the macro is suppressed while defining another - ;; macro, put keyseq back on the event queue - (viper-set-unread-command-events event-seq) - ;; if the user typed arg, then use it if prefix arg is not set by - ;; some other command (setting prefix arg can happen if we do, say, - ;; 2dw and there is a macro starting with 2. Then control will go to - ;; this routine - (or prefix-arg (setq prefix-arg count)) - (setq command (key-binding (read-key-sequence nil))) - (if (commandp command) - (command-execute command) - (beep 1))) - )) - - - -;;; Displaying and completing macros - -(defun viper-describe-kbd-macros () - "Show currently defined keyboard macros." - (interactive) - (with-output-to-temp-buffer " *viper-info*" - (princ "Macros in Vi state:\n===================\n") - (mapcar 'viper-describe-one-macro viper-vi-kbd-macro-alist) - (princ "\n\nMacros in Insert and Replace states:\n====================================\n") - (mapcar 'viper-describe-one-macro viper-insert-kbd-macro-alist) - (princ "\n\nMacros in Emacs state:\n======================\n") - (mapcar 'viper-describe-one-macro viper-emacs-kbd-macro-alist) - )) - -(defun viper-describe-one-macro (macro) - (princ (format "\n *** Mappings for %S:\n ------------\n" - (viper-display-macro (car macro)))) - (princ " ** Buffer-specific:") - (if (viper-kbd-buf-alist macro) - (mapcar 'viper-describe-one-macro-elt (viper-kbd-buf-alist macro)) - (princ " none\n")) - (princ "\n ** Mode-specific:") - (if (viper-kbd-mode-alist macro) - (mapcar 'viper-describe-one-macro-elt (viper-kbd-mode-alist macro)) - (princ " none\n")) - (princ "\n ** Global:") - (if (viper-kbd-global-definition macro) - (princ (format "\n %S" (cdr (viper-kbd-global-pair macro)))) - (princ " none")) - (princ "\n")) - -(defun viper-describe-one-macro-elt (elt) - (let ((name (car elt)) - (defn (cdr elt))) - (princ (format "\n * %S:\n %S\n" name defn)))) - - - -;; check if SEQ is a prefix of some car of an element in ALIST -(defun viper-keyseq-is-a-possible-macro (seq alist) - (let ((converted-seq (viper-events-to-macro seq))) - (eval (cons 'or - (mapcar - (function (lambda (elt) - (viper-prefix-subseq-p converted-seq elt))) - (viper-this-buffer-macros alist)))))) - -;; whether SEQ1 is a prefix of SEQ2 -(defun viper-prefix-subseq-p (seq1 seq2) - (let ((len1 (length seq1)) - (len2 (length seq2))) - (if (<= len1 len2) - (equal seq1 (subseq seq2 0 len1))))) - -;; find the longest common prefix -(defun viper-common-seq-prefix (&rest seqs) - (let* ((first (car seqs)) - (rest (cdr seqs)) - (pref []) - (idx 0) - len) - (if (= (length seqs) 0) - (setq len 0) - (setq len (apply 'min (mapcar 'length seqs)))) - (while (< idx len) - (if (eval (cons 'and - (mapcar (function (lambda (s) - (equal (elt first idx) - (elt s idx)))) - rest))) - (setq pref (vconcat pref (vector (elt first idx))))) - (setq idx (1+ idx))) - pref)) - -;; get all sequences that match PREFIX from a given A-LIST -(defun viper-extract-matching-alist-members (pref alist) - (delq nil (mapcar (function (lambda (elt) - (if (viper-prefix-subseq-p pref elt) - elt))) - (viper-this-buffer-macros alist)))) - -(defun viper-do-sequence-completion (seq alist compl-message) - (let* ((matches (viper-extract-matching-alist-members seq alist)) - (new-seq (apply 'viper-common-seq-prefix matches)) - ) - (cond ((and (equal seq new-seq) (= (length matches) 1)) - (message "%s (Sole completion)" compl-message) - (sit-for 2)) - ((null matches) - (message "%s (No match)" compl-message) - (sit-for 2) - (setq new-seq seq)) - ((member seq matches) - (message "%s (Complete, but not unique)" compl-message) - (sit-for 2) - (viper-display-vector-completions matches)) - ((equal seq new-seq) - (viper-display-vector-completions matches))) - new-seq)) - - -(defun viper-display-vector-completions (list) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (mapcar 'prin1-to-string - (mapcar 'viper-display-macro list))))) - - - -;; alist is the alist of macros -;; str is the fast key sequence entered -;; returns: (matching-macro-def . unmatched-suffix-start-index) -(defun viper-find-best-matching-macro (alist str) - (let ((lis alist) - (def-len 0) - (str-len (length str)) - match unmatched-start-idx found macro-def) - (while (and (not found) lis) - (setq macro-def (car lis) - def-len (length (car macro-def))) - (if (and (>= str-len def-len) - (equal (car macro-def) (subseq str 0 def-len))) - (if (or (viper-kbd-buf-definition macro-def) - (viper-kbd-mode-definition macro-def) - (viper-kbd-global-definition macro-def)) - (setq found t)) - ) - (setq lis (cdr lis))) - - (if found - (setq match macro-def - unmatched-start-idx def-len) - (setq match nil - unmatched-start-idx 0)) - - (cons match unmatched-start-idx))) - - - -;; returns a list of names of macros defined for the current buffer -(defun viper-this-buffer-macros (macro-alist) - (let (candidates) - (setq candidates - (mapcar (function - (lambda (elt) - (if (or (viper-kbd-buf-definition elt) - (viper-kbd-mode-definition elt) - (viper-kbd-global-definition elt)) - (car elt)))) - macro-alist)) - (setq candidates (delq nil candidates)))) - - -;; if seq of Viper key symbols (representing a macro) can be converted to a -;; string--do so. Otherwise, do nothing. -(defun viper-display-macro (macro-name-or-body) - (cond ((viper-char-symbol-sequence-p macro-name-or-body) - (mapconcat 'symbol-name macro-name-or-body "")) - ((viper-char-array-p macro-name-or-body) - (mapconcat 'char-to-string macro-name-or-body "")) - (t macro-name-or-body))) - -;; convert sequence of events (that came presumably from emacs kbd macro) into -;; Viper's macro, which is a vector of the form -;; [ desc desc ... ] -;; Each desc is either a symbol of (meta symb), (shift symb), etc. -;; Here we purge events that happen to be lists. In most cases, these events -;; got into a macro definition unintentionally; say, when the user moves mouse -;; during a macro definition, then something like (switch-frame ...) might get -;; in. Another reason for purging lists-events is that we can't store them in -;; textual form (say, in .emacs) and then read them back. -(defun viper-events-to-macro (event-seq) - (vconcat (delq nil (mapcar (function (lambda (elt) - (if (consp elt) - nil - (viper-event-key elt)))) - event-seq)))) - -;; convert strings or arrays of characters to Viper macro form -(defun viper-char-array-to-macro (array) - (let ((vec (vconcat array)) - macro) - (if viper-xemacs-p - (setq macro (mapcar 'character-to-event vec)) - (setq macro vec)) - (vconcat (mapcar 'viper-event-key macro)))) - -;; For macros bodies and names, goes over MACRO and checks if all members are -;; names of keys (actually, it only checks if they are symbols or lists -;; if a digit is found, it is converted into a symbol (e.g., 0 -> \0, etc). -;; If MACRO is not a list or vector -- doesn't change MACRO. -(defun viper-fixup-macro (macro) - (let ((len (length macro)) - (idx 0) - elt break) - (if (or (vectorp macro) (listp macro)) - (while (and (< idx len) (not break)) - (setq elt (elt macro idx)) - (cond ((numberp elt) - ;; fix number - (if (and (<= 0 elt) (<= elt 9)) - (cond ((arrayp macro) - (aset macro - idx - (intern (char-to-string (+ ?0 elt))))) - ((listp macro) - (setcar (nthcdr idx macro) - (intern (char-to-string (+ ?0 elt))))) - ))) - ((listp elt) - (viper-fixup-macro elt)) - ((symbolp elt) nil) - (t (setq break t))) - (setq idx (1+ idx)))) - - (if break - (error "Wrong type macro component, symbol-or-listp, %S" elt) - macro))) - -(defun viper-char-array-p (array) - (eval (cons 'and (mapcar 'viper-characterp array)))) - -(defun viper-macro-to-events (macro-body) - (vconcat (mapcar 'viper-key-to-emacs-key macro-body))) - - -;; check if vec is a vector of character symbols -(defun viper-char-symbol-sequence-p (vec) - (and - (sequencep vec) - (eval - (cons 'and - (mapcar - (function (lambda (elt) - (and (symbolp elt) (= (length (symbol-name elt)) 1)))) - vec))))) - - -;; Check if vec is a vector of key-press events representing characters -;; XEmacs only -(defun viper-event-vector-p (vec) - (and (vectorp vec) - (eval (cons 'and (mapcar '(lambda (elt) (if (eventp elt) t)) vec))))) - - -;;; Reading fast key sequences - -;; Assuming that CHAR was the first character in a fast succession of key -;; strokes, read the rest. Return the vector of keys that was entered in -;; this fast succession of key strokes. -;; A fast keysequence is one that is terminated by a pause longer than -;; viper-fast-keyseq-timeout. -(defun viper-read-fast-keysequence (event macro-alist) - (let ((lis (vector event)) - next-event) - (while (and (viper-fast-keysequence-p) - (viper-keyseq-is-a-possible-macro lis macro-alist)) - (setq next-event (viper-read-key)) - ;;(setq next-event (viper-read-event)) - (or (viper-mouse-event-p next-event) - (setq lis (vconcat lis (vector next-event))))) - lis)) - - -;;; Keyboard macros in registers - -;; sets register to last-kbd-macro carefully. -(defun viper-set-register-macro (reg) - (if (get-register reg) - (if (y-or-n-p "Register contains data. Overwrite? ") - () - (error - "Macro not saved in register. Can still be invoked via `C-x e'"))) - (set-register reg last-kbd-macro)) - -(defun viper-register-macro (count) - "Keyboard macros in registers - a modified \@ command." - (interactive "P") - (let ((reg (downcase (read-char)))) - (cond ((or (and (<= ?a reg) (<= reg ?z))) - (setq viper-last-macro-reg reg) - (if defining-kbd-macro - (progn - (end-kbd-macro) - (viper-set-register-macro reg)) - (execute-kbd-macro (get-register reg) count))) - ((or (= ?@ reg) (= ?\^j reg) (= ?\^m reg)) - (if viper-last-macro-reg - nil - (error "No previous kbd macro")) - (execute-kbd-macro (get-register viper-last-macro-reg) count)) - ((= ?\# reg) - (start-kbd-macro count)) - ((= ?! reg) - (setq reg (downcase (read-char))) - (if (or (and (<= ?a reg) (<= reg ?z))) - (progn - (setq viper-last-macro-reg reg) - (viper-set-register-macro reg)))) - (t - (error "`%c': Unknown register" reg))))) - - -(defun viper-global-execute () - "Call last keyboad macro for each line in the region." - (if (> (point) (mark t)) (exchange-point-and-mark)) - (beginning-of-line) - (call-last-kbd-macro) - (while (< (point) (mark t)) - (forward-line 1) - (beginning-of-line) - (call-last-kbd-macro))) - - -;;; viper-macs.el ends here
--- a/lisp/viper/viper-mous.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,647 +0,0 @@ -;;; viper-mous.el --- mouse support for Viper - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Code - -(provide 'viper-mous) - -;; compiler pacifier -(defvar double-click-time) -(defvar mouse-track-multi-click-time) -(defvar viper-search-start-marker) -(defvar viper-local-search-start-marker) -(defvar viper-search-history) -(defvar viper-s-string) -(defvar viper-re-search) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) - ))) -;; end pacifier - -(require 'viper-util) - - -(defgroup viper-mouse nil - "Support for Viper special mouse-bound commands" - :prefix "viper-" - :group 'viper) - - -;;; Variables - -;; Variable used for catching the switch-frame event. -;; If non-nil, indicates that previous-frame should be the selected -;; one. Used by viper-mouse-click-get-word. Not a user option. -(defvar viper-frame-of-focus nil) - -;; Frame that was selected before the switch-frame event. -(defconst viper-current-frame-saved (selected-frame)) - -(defcustom viper-surrounding-word-function 'viper-surrounding-word - "*Function that determines what constitutes a word for clicking events. -Takes two parameters: a COUNT, indicating how many words to return, -and CLICK-COUNT, telling whether this is the first click, a double-click, -or a tripple-click." - :type 'boolean - :group 'viper-mouse) - -;; time interval in millisecond within which successive clicks are -;; considered related -(defcustom viper-multiclick-timeout (if (viper-window-display-p) - (if viper-xemacs-p - mouse-track-multi-click-time - double-click-time) - 500) - "*Time interval in millisecond within which successive mouse clicks are -considered related." - :type 'integer - :group 'viper-mouse) - -;; current event click count; XEmacs only -(defvar viper-current-click-count 0) -;; time stamp of the last click event; XEmacs only -(defvar viper-last-click-event-timestamp 0) - -;; Local variable used to toggle wraparound search on click. -(viper-deflocalvar viper-mouse-click-search-noerror t) - -;; Local variable used to delimit search after wraparound. -(viper-deflocalvar viper-mouse-click-search-limit nil) - -;; remembers prefix argument to pass along to commands invoked by second -;; click. -;; This is needed because in Emacs (not XEmacs), assigning to preix-arg -;; causes Emacs to count the second click as if it was a single click -(defvar viper-global-prefix-argument nil) - - -;; same keys, but parsed -(defvar viper-mouse-up-search-key-parsed nil) -(defvar viper-mouse-down-search-key-parsed nil) -(defvar viper-mouse-up-insert-key-parsed nil) -(defvar viper-mouse-down-insert-key-parsed nil) - - - - -;;; Code - -(defsubst viper-multiclick-p () - (not (viper-sit-for-short viper-multiclick-timeout t))) - -;; Returns window where click occurs -(defsubst viper-mouse-click-window (click) - (if viper-xemacs-p - (event-window click) - (posn-window (event-start click)))) - -;; Returns window where click occurs -(defsubst viper-mouse-click-frame (click) - (window-frame (viper-mouse-click-window click))) - -;; Returns the buffer of the window where click occurs -(defsubst viper-mouse-click-window-buffer (click) - (window-buffer (viper-mouse-click-window click))) - -;; Returns the name of the buffer in the window where click occurs -(defsubst viper-mouse-click-window-buffer-name (click) - (buffer-name (viper-mouse-click-window-buffer click))) - -;; Returns position of a click -(defsubst viper-mouse-click-posn (click) - (if viper-xemacs-p - (event-point click) - (posn-point (event-start click)))) - - -(defun viper-surrounding-word (count click-count) - "Returns word surrounding point according to a heuristic. -COUNT indicates how many regions to return. -If CLICK-COUNT is 1, `word' is a word in Vi sense. -If CLICK-COUNT is 2,then `word' is a Word in Vi sense. -If the character clicked on is a non-separator and is non-alphanumeric but -is adjacent to an alphanumeric symbol, then it is considered alphanumeric -for the purpose of this command. If this character has a matching -character, such as `\(' is a match for `\)', then the matching character is -also considered alphanumeric. -For convenience, in Lisp modes, `-' is considered alphanumeric. - -If CLICK-COUNT is 3 or more, returns the line clicked on with leading and -trailing space and tabs removed. In that case, the first argument, COUNT, -is ignored." - (let ((modifiers "") - beg skip-flag result - word-beg) - (if (> click-count 2) - (save-excursion - (beginning-of-line) - (viper-skip-all-separators-forward 'within-line) - (setq beg (point)) - (end-of-line) - (setq result (buffer-substring beg (point)))) - - (if (and (not (viper-looking-at-alphasep)) - (or (save-excursion (viper-backward-char-carefully) - (viper-looking-at-alpha)) - (save-excursion (viper-forward-char-carefully) - (viper-looking-at-alpha)))) - (setq modifiers - (cond ((looking-at "\\\\") "\\\\") - ((looking-at "-") "C-C-") - ((looking-at "[][]") "][") - ((looking-at "[()]") ")(") - ((looking-at "[{}]") "{}") - ((looking-at "[<>]") "<>") - ((looking-at "[`']") "`'") - ((looking-at "\\^") "\\^") - ((viper-looking-at-separator) "") - (t (char-to-string (following-char)))) - )) - - ;; Add `-' to alphanum, if it wasn't added and if we are in Lisp - (or (looking-at "-") - (not (string-match "lisp" (symbol-name major-mode))) - (setq modifiers (concat modifiers "C-C-"))) - - - (save-excursion - (cond ((> click-count 1) (viper-skip-nonseparators 'backward)) - ((viper-looking-at-alpha modifiers) - (viper-skip-alpha-backward modifiers)) - ((not (viper-looking-at-alphasep modifiers)) - (viper-skip-nonalphasep-backward)) - (t (if (> click-count 1) - (viper-skip-nonseparators 'backward) - (viper-skip-alpha-backward modifiers)))) - - (setq word-beg (point)) - - (setq skip-flag nil) ; don't move 1 char forw the first time - (while (> count 0) - (if skip-flag (viper-forward-char-carefully 1)) - (setq skip-flag t) ; now always move 1 char forward - (if (> click-count 1) - (viper-skip-nonseparators 'forward) - (viper-skip-alpha-forward modifiers)) - (setq count (1- count))) - - (setq result (buffer-substring word-beg (point)))) - ) ; if - ;; XEmacs doesn't have set-text-properties, but there buffer-substring - ;; doesn't return properties together with the string, so it's not needed. - (if viper-emacs-p - (set-text-properties 0 (length result) nil result)) - result - )) - - -(defun viper-mouse-click-get-word (click count click-count) - "Returns word surrounding the position of a mouse click. -Click may be in another window. Current window and buffer isn't changed. -On single or double click, returns the word as determined by -`viper-surrounding-word-function'." - - (let ((click-word "") - (click-pos (viper-mouse-click-posn click)) - (click-buf (viper-mouse-click-window-buffer click))) - (or (natnump count) (setq count 1)) - (or (natnump click-count) (setq click-count 1)) - - (save-excursion - (save-window-excursion - (if click-pos - (progn - (set-buffer click-buf) - - (goto-char click-pos) - (setq click-word - (funcall viper-surrounding-word-function count click-count))) - (error "Click must be over a window.")) - click-word)))) - - -(defun viper-mouse-click-insert-word (click arg) - "Insert word clicked or double-clicked on. -With prefix argument, N, insert that many words. -This command must be bound to a mouse click. -The double-click action of the same mouse button must not be bound -\(or it must be bound to the same function\). -See `viper-surrounding-word' for the definition of a word in this case." - (interactive "e\nP") - (if viper-frame-of-focus ;; to handle clicks in another frame - (select-frame viper-frame-of-focus)) - (if (or (not (eq (key-binding viper-mouse-down-insert-key-parsed) - 'viper-mouse-catch-frame-switch)) - (not (eq (key-binding viper-mouse-up-insert-key-parsed) - 'viper-mouse-click-insert-word)) - (and viper-xemacs-p (not (event-over-text-area-p click)))) - () ; do nothing, if binding isn't right or not over text - ;; turn arg into a number - (cond ((integerp arg) nil) - ;; prefix arg is a list when one hits C-u then command - ((and (listp arg) (integerp (car arg))) - (setq arg (car arg))) - (t (setq arg 1))) - - (if (not (eq (key-binding viper-mouse-down-insert-key-parsed) - 'viper-mouse-catch-frame-switch)) - () ; do nothing - (let (click-count interrupting-event) - (if (and - (viper-multiclick-p) - ;; This trick checks if there is a pending mouse event if so, we - ;; use this latter event and discard the current mouse click If - ;; the next pending event is not a mouse event, we execute the - ;; current mouse event - (progn - (setq interrupting-event (viper-read-event)) - (viper-mouse-event-p last-input-event))) - (progn ; interrupted wait - (setq viper-global-prefix-argument arg) - ;; count this click for XEmacs - (viper-event-click-count click)) - ;; uninterrupted wait or the interrupting event wasn't a mouse event - (setq click-count (viper-event-click-count click)) - (if (> click-count 1) - (setq arg viper-global-prefix-argument - viper-global-prefix-argument nil)) - (insert (viper-mouse-click-get-word click arg click-count)) - (if (and interrupting-event - (eventp interrupting-event) - (not (viper-mouse-event-p interrupting-event))) - (viper-set-unread-command-events interrupting-event)) - ))))) - -;; arg is an event. accepts symbols and numbers, too -(defun viper-mouse-event-p (event) - (if (eventp event) - (string-match "\\(mouse-\\|frame\\|screen\\|track\\)" - (prin1-to-string (viper-event-key event))))) - -;; XEmacs has no double-click events. So, we must simulate. -;; So, we have to simulate event-click-count. -(defun viper-event-click-count (click) - (if viper-xemacs-p - (progn - ;; if more than 1 second - (if (> (- (event-timestamp click) viper-last-click-event-timestamp) - viper-multiclick-timeout) - (setq viper-current-click-count 0)) - (setq viper-last-click-event-timestamp (event-timestamp click) - viper-current-click-count (1+ viper-current-click-count))) - (event-click-count click))) - - - -(defun viper-mouse-click-search-word (click arg) - "Find the word clicked or double-clicked on. Word may be in another window. -With prefix argument, N, search for N-th occurrence. -This command must be bound to a mouse click. The double-click action of the -same button must not be bound \(or it must be bound to the same function\). -See `viper-surrounding-word' for the details on what constitutes a word for -this command." - (interactive "e\nP") - (if viper-frame-of-focus ;; to handle clicks in another frame - (select-frame viper-frame-of-focus)) - (if (or (not (eq (key-binding viper-mouse-down-search-key-parsed) - 'viper-mouse-catch-frame-switch)) - (not (eq (key-binding viper-mouse-up-search-key-parsed) - 'viper-mouse-click-search-word)) - (and viper-xemacs-p (not (event-over-text-area-p click)))) - () ; do nothing, if binding isn't right or not over text - (let ((previous-search-string viper-s-string) - click-word click-count) - - (if (and - (viper-multiclick-p) - ;; This trick checks if there is a pending mouse event if so, we use - ;; this latter event and discard the current mouse click If the next - ;; pending event is not a mouse event, we execute the current mouse - ;; event - (progn - (viper-read-event) - (viper-mouse-event-p last-input-event))) - (progn ; interrupted wait - (setq viper-global-prefix-argument - (or viper-global-prefix-argument arg)) - ;; remember command that was before the multiclick - (setq this-command last-command) - ;; make sure we counted this event---needed for XEmacs only - (viper-event-click-count click)) - ;; uninterrupted wait - (setq click-count (viper-event-click-count click)) - (setq click-word (viper-mouse-click-get-word click nil click-count)) - - (if (> click-count 1) - (setq arg viper-global-prefix-argument - viper-global-prefix-argument nil)) - (setq arg (or arg 1)) - - (viper-deactivate-mark) - (if (or (not (string= click-word viper-s-string)) - (not (markerp viper-search-start-marker)) - (not (equal (marker-buffer viper-search-start-marker) - (current-buffer))) - (not (eq last-command 'viper-mouse-click-search-word))) - (progn - (setq viper-search-start-marker (point-marker) - viper-local-search-start-marker viper-search-start-marker - viper-mouse-click-search-noerror t - viper-mouse-click-search-limit nil) - - ;; make search string known to Viper - (setq viper-s-string (if viper-re-search - (regexp-quote click-word) - click-word)) - (if (not (string= viper-s-string (car viper-search-history))) - (setq viper-search-history - (cons viper-s-string viper-search-history))) - )) - - (push-mark nil t) - (while (> arg 0) - (viper-forward-word 1) - (condition-case nil - (progn - (if (not (search-forward - click-word viper-mouse-click-search-limit - viper-mouse-click-search-noerror)) - (progn - (setq viper-mouse-click-search-noerror nil) - (setq viper-mouse-click-search-limit - (save-excursion - (if (and - (markerp viper-local-search-start-marker) - (marker-buffer viper-local-search-start-marker)) - (goto-char viper-local-search-start-marker)) - (viper-line-pos 'end))) - - (goto-char (point-min)) - (search-forward click-word - viper-mouse-click-search-limit nil))) - (goto-char (match-beginning 0)) - (message "Searching for: %s" viper-s-string) - (if (<= arg 1) ; found the right occurrence of the pattern - (progn - (viper-adjust-window) - (viper-flash-search-pattern))) - ) - (error (beep 1) - (if (or (not (string= click-word previous-search-string)) - (not (eq last-command 'viper-mouse-click-search-word))) - (message "`%s': String not found in %s" - viper-s-string (buffer-name (current-buffer))) - (message - "`%s': Last occurrence in %s. Back to beginning of search" - click-word (buffer-name (current-buffer))) - (setq arg 1) ;; to terminate the loop - (sit-for 2)) - (setq viper-mouse-click-search-noerror t) - (setq viper-mouse-click-search-limit nil) - (if (and (markerp viper-local-search-start-marker) - (marker-buffer viper-local-search-start-marker)) - (goto-char viper-local-search-start-marker)))) - (setq arg (1- arg))) - )))) - -(defun viper-mouse-catch-frame-switch (event arg) - "Catch the event of switching frame. -Usually is bound to a `down-mouse' event to work properly. See sample -bindings in the Viper manual." - (interactive "e\nP") - (setq viper-frame-of-focus nil) - ;; pass prefix arg along to viper-mouse-click-search/insert-word - (setq prefix-arg arg) - (if (eq last-command 'handle-switch-frame) - (setq viper-frame-of-focus viper-current-frame-saved)) - ;; make Emacs forget that it executed viper-mouse-catch-frame-switch - (setq this-command last-command)) - -;; Called just before switching frames. Saves the old selected frame. -;; Sets last-command to handle-switch-frame (this is done automatically in -;; Emacs. -;; The semantics of switching frames is different in Emacs and XEmacs. -;; In Emacs, if you select-frame A while mouse is over frame B and then -;; start typing, input goes to frame B, which becomes selected. -;; In XEmacs, input will go to frame A. This may be a bug in one of the -;; Emacsen, but also may be a design decision. -;; Also, in Emacs sending input to frame B generates handle-switch-frame -;; event, while in XEmacs it doesn't. -;; All this accounts for the difference in the behavior of -;; viper-mouse-click-* commands when you click in a frame other than the one -;; that was the last to receive input. In Emacs, focus will be in frame A -;; until you do something other than viper-mouse-click-* command. -;; In XEmacs, you have to manually select frame B (with the mouse click) in -;; order to shift focus to frame B. -(defsubst viper-remember-current-frame (frame) - (setq last-command 'handle-switch-frame - viper-current-frame-saved (selected-frame))) - - -;; The key is of the form (MODIFIER ... BUTTON-NUMBER) -;; Converts into a valid mouse button spec for the appropriate version of -;; Emacs. EVENT-TYPE is either `up' or `down'. Up returns button-up key; down -;; returns button-down key. -(defun viper-parse-mouse-key (key-var event-type) - (let ((key (eval key-var)) - button-spec meta-spec shift-spec control-spec key-spec) - (if (null key) - ;; just return nil - () - (setq button-spec - (cond ((memq 1 key) - (if viper-emacs-p - (if (eq 'up event-type) - "mouse-1" "down-mouse-1") - (if (eq 'up event-type) - 'button1up 'button1))) - ((memq 2 key) - (if viper-emacs-p - (if (eq 'up event-type) - "mouse-2" "down-mouse-2") - (if (eq 'up event-type) - 'button2up 'button2))) - ((memq 3 key) - (if viper-emacs-p - (if (eq 'up event-type) - "mouse-3" "down-mouse-3") - (if (eq 'up event-type) - 'button3up 'button3))) - (t (error - "%S: invalid button number, %S" key-var key))) - meta-spec - (if (memq 'meta key) - (if viper-emacs-p "M-" 'meta) - (if viper-emacs-p "" nil)) - shift-spec - (if (memq 'shift key) - (if viper-emacs-p "S-" 'shift) - (if viper-emacs-p "" nil)) - control-spec - (if (memq 'control key) - (if viper-emacs-p "C-" 'control) - (if viper-emacs-p "" nil))) - - (setq key-spec (if viper-emacs-p - (vector - (intern - (concat - control-spec meta-spec shift-spec button-spec))) - (vector - (delq - nil - (list - control-spec meta-spec shift-spec button-spec))))) - ))) - -(defun viper-unbind-mouse-search-key () - (if viper-mouse-up-search-key-parsed - (global-unset-key viper-mouse-up-search-key-parsed)) - (if viper-mouse-down-search-key-parsed - (global-unset-key viper-mouse-down-search-key-parsed)) - (setq viper-mouse-up-search-key-parsed nil - viper-mouse-down-search-key-parsed nil)) - -(defun viper-unbind-mouse-insert-key () - (if viper-mouse-up-insert-key-parsed - (global-unset-key viper-mouse-up-insert-key-parsed)) - (if viper-mouse-down-insert-key-parsed - (global-unset-key viper-mouse-down-insert-key-parsed)) - (setq viper-mouse-up-insert-key-parsed nil - viper-mouse-down-insert-key-parsed nil)) - -;; If FORCE, bind even if this mouse action is already bound to something else -(defun viper-bind-mouse-search-key (&optional force) - (setq viper-mouse-up-search-key-parsed - (viper-parse-mouse-key 'viper-mouse-search-key 'up) - viper-mouse-down-search-key-parsed - (viper-parse-mouse-key 'viper-mouse-search-key 'down)) - (cond ((or (null viper-mouse-up-search-key-parsed) - (null viper-mouse-down-search-key-parsed)) - nil) ; just quit - ((and (null force) - (key-binding viper-mouse-up-search-key-parsed) - (not (eq (key-binding viper-mouse-up-search-key-parsed) - 'viper-mouse-click-search-word))) - (message - "%S already bound to a mouse event. Viper mouse-search feature disabled" - viper-mouse-up-search-key-parsed)) - ((and (null force) - (key-binding viper-mouse-down-search-key-parsed) - (not (eq (key-binding viper-mouse-down-search-key-parsed) - 'viper-mouse-catch-frame-switch))) - (message - "%S already bound to a mouse event. Viper mouse-search feature disabled" - viper-mouse-down-search-key-parsed)) - (t - (global-set-key viper-mouse-up-search-key-parsed - 'viper-mouse-click-search-word) - (global-set-key viper-mouse-down-search-key-parsed - 'viper-mouse-catch-frame-switch)))) - -;; If FORCE, bind even if this mouse action is already bound to something else -(defun viper-bind-mouse-insert-key (&optional force) - (setq viper-mouse-up-insert-key-parsed - (viper-parse-mouse-key 'viper-mouse-insert-key 'up) - viper-mouse-down-insert-key-parsed - (viper-parse-mouse-key 'viper-mouse-insert-key 'down)) - (cond ((or (null viper-mouse-up-insert-key-parsed) - (null viper-mouse-down-insert-key-parsed)) - nil) ; just quit - ((and (null force) - (key-binding viper-mouse-up-insert-key-parsed) - (not (eq (key-binding viper-mouse-up-insert-key-parsed) - 'viper-mouse-click-insert-word))) - (message - "%S already bound to a mouse event. Viper mouse-insert feature disabled" - viper-mouse-up-insert-key-parsed)) - ((and (null force) - (key-binding viper-mouse-down-insert-key-parsed) - (not (eq (key-binding viper-mouse-down-insert-key-parsed) - 'viper-mouse-catch-frame-switch))) - (message - "%S already bound to a mouse event. Viper mouse-insert feature disabled" - viper-mouse-down-insert-key-parsed)) - (t - (global-set-key viper-mouse-up-insert-key-parsed - 'viper-mouse-click-insert-word) - (global-set-key viper-mouse-down-insert-key-parsed - 'viper-mouse-catch-frame-switch)))) - -(defun viper-reset-mouse-search-key (symb val) - (viper-unbind-mouse-search-key) - (set symb val) - (viper-bind-mouse-search-key 'force)) - -(defun viper-reset-mouse-insert-key (symb val) - (viper-unbind-mouse-insert-key) - (set symb val) - (viper-bind-mouse-insert-key 'force)) - - -(defcustom viper-mouse-search-key '(meta shift 1) - "*Key used to click-search in Viper. -This must be a list that specifies the mouse button and modifiers. -The supported modifiers are `meta', `shift', and `control'. -For instance, `(meta shift 1)' means that holding the meta and shift -keys down and clicking on a word with mouse button 1 -will search for that word in the buffer that was current before the click. -This buffer may be different from the one where the click occurred." - :type '(list (set :inline t :tag "Modifiers" :format "%t: %v" - (const :format "%v " meta) - (const :format "%v " shift) - (const control)) - (integer :tag "Button")) - :set 'viper-reset-mouse-search-key - :group 'viper-mouse) - -(defcustom viper-mouse-insert-key '(meta shift 2) - "*Key used to click-insert in Viper. -Must be a list that specifies the mouse button and modifiers. -The supported modifiers are `meta', `shift', and `control'. -For instance, `(meta shift 2)' means that holding the meta and shift keys -down, and clicking on a word with mouse button 2, will insert that word -at the cursor in the buffer that was current just before the click. -This buffer may be different from the one where the click occurred." - :type '(list (set :inline t :tag "Modifiers" :format "%t: %v" - (const :format "%v " meta) - (const :format "%v " shift) - (const control)) - (integer :tag "Button")) - :set 'viper-reset-mouse-insert-key - :group 'viper-mouse) - - - -;;; Local Variables: -;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) -;;; End: - - -;;; viper-mous.el ends here
--- a/lisp/viper/viper-util.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1343 +0,0 @@ -;;; viper-util.el --- Utilities used by viper.el - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - - -;; Code - -;; Compiler pacifier -(defvar viper-overriding-map) -(defvar pm-color-alist) -(defvar zmacs-region-stays) -(defvar viper-minibuffer-current-face) -(defvar viper-minibuffer-insert-face) -(defvar viper-minibuffer-vi-face) -(defvar viper-minibuffer-emacs-face) -(defvar viper-replace-overlay-face) -(defvar viper-fast-keyseq-timeout) -(defvar ex-unix-type-shell) -(defvar ex-unix-type-shell-options) -(defvar viper-ex-tmp-buf-name) -(defvar viper-syntax-preference) - -(require 'cl) -(require 'ring) - -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-init) - (load "viper-init.el" nil nil 'nosuffix)) - ))) -;; end pacifier - -(require 'viper-init) - - -;; A fix for NeXT Step -;; Should go away, when NS people fix the design flaw, which leaves the -;; two x-* functions undefined. -(if (and (not (fboundp 'x-display-color-p)) (fboundp 'ns-display-color-p)) - (fset 'x-display-color-p (symbol-function 'ns-display-color-p))) -(if (and (not (fboundp 'x-color-defined-p)) (fboundp 'ns-color-defined-p)) - (fset 'x-color-defined-p (symbol-function 'ns-color-defined-p))) - - -;;; XEmacs support - - -(if viper-xemacs-p - (progn - (fset 'viper-read-event (symbol-function 'next-command-event)) - (fset 'viper-make-overlay (symbol-function 'make-extent)) - (fset 'viper-overlay-start (symbol-function 'extent-start-position)) - (fset 'viper-overlay-end (symbol-function 'extent-end-position)) - (fset 'viper-overlay-put (symbol-function 'set-extent-property)) - (fset 'viper-overlay-p (symbol-function 'extentp)) - (fset 'viper-overlay-get (symbol-function 'extent-property)) - (fset 'viper-move-overlay (symbol-function 'set-extent-endpoints)) - (if (viper-window-display-p) - (fset 'viper-iconify (symbol-function 'iconify-frame))) - (cond ((viper-has-face-support-p) - (fset 'viper-get-face (symbol-function 'get-face)) - (fset 'viper-color-defined-p - (symbol-function 'valid-color-name-p)) - ))) - (fset 'viper-read-event (symbol-function 'read-event)) - (fset 'viper-make-overlay (symbol-function 'make-overlay)) - (fset 'viper-overlay-start (symbol-function 'overlay-start)) - (fset 'viper-overlay-end (symbol-function 'overlay-end)) - (fset 'viper-overlay-put (symbol-function 'overlay-put)) - (fset 'viper-overlay-p (symbol-function 'overlayp)) - (fset 'viper-overlay-get (symbol-function 'overlay-get)) - (fset 'viper-move-overlay (symbol-function 'move-overlay)) - (if (viper-window-display-p) - (fset 'viper-iconify (symbol-function 'iconify-or-deiconify-frame))) - (cond ((viper-has-face-support-p) - (fset 'viper-get-face (symbol-function 'internal-get-face)) - (fset 'viper-color-defined-p (symbol-function 'x-color-defined-p)) - ))) - - -(fset 'viper-characterp - (symbol-function - (if viper-xemacs-p 'characterp 'integerp))) - -(defsubst viper-color-display-p () - (if viper-emacs-p - (x-display-color-p) - (eq (device-class (selected-device)) 'color))) - -(defsubst viper-get-cursor-color () - (if viper-emacs-p - (cdr (assoc 'cursor-color (frame-parameters))) - (color-instance-name (frame-property (selected-frame) 'cursor-color)))) - -;;(defun viper-set-face-pixmap (face pixmap) -;; "Set face pixmap on a monochrome display." -;; (if (and (viper-window-display-p) (not (viper-color-display-p))) -;; (condition-case nil -;; (set-face-background-pixmap face pixmap) -;; (error -;; (message "Pixmap not found for %S: %s" (face-name face) pixmap) -;; (sit-for 1))))) - - -;; OS/2 -(cond ((eq (viper-device-type) 'pm) - (fset 'viper-color-defined-p - (function (lambda (color) (assoc color pm-color-alist)))))) - -;; needed to smooth out the difference between Emacs and XEmacs -;;(defsubst viper-italicize-face (face) -;; (if viper-xemacs-p -;; (make-face-italic face) -;; (make-face-italic face nil 'noerror))) - -;; test if display is color and the colors are defined -;;(defsubst viper-can-use-colors (&rest colors) -;; (if (viper-color-display-p) -;; (not (memq nil (mapcar 'viper-color-defined-p colors))) -;; )) - -;; cursor colors -(defun viper-change-cursor-color (new-color) - (if (and (viper-window-display-p) (viper-color-display-p) - (stringp new-color) (viper-color-defined-p new-color) - (not (string= new-color (viper-get-cursor-color)))) - (modify-frame-parameters - (selected-frame) (list (cons 'cursor-color new-color))))) - -(defun viper-save-cursor-color () - (if (and (viper-window-display-p) (viper-color-display-p)) - (let ((color (viper-get-cursor-color))) - (if (and (stringp color) (viper-color-defined-p color) - (not (string= color viper-replace-overlay-cursor-color))) - (viper-overlay-put viper-replace-overlay 'viper-cursor-color color))))) - -;; restore cursor color from replace overlay -(defsubst viper-restore-cursor-color-after-replace () - (viper-change-cursor-color - (viper-overlay-get viper-replace-overlay 'viper-cursor-color))) -(defsubst viper-restore-cursor-color-after-insert () - (viper-change-cursor-color viper-saved-cursor-color)) - - - -;; Check the current version against the major and minor version numbers -;; using op: cur-vers op major.minor If emacs-major-version or -;; emacs-minor-version are not defined, we assume that the current version -;; is hopelessly outdated. We assume that emacs-major-version and -;; emacs-minor-version are defined. Otherwise, for Emacs/XEmacs 19, if the -;; current minor version is < 10 (xemacs) or < 23 (emacs) the return value -;; will be nil (when op is =, >, or >=) and t (when op is <, <=), which may be -;; incorrect. However, this gives correct result in our cases, since we are -;; testing for sufficiently high Emacs versions. -(defun viper-check-version (op major minor &optional type-of-emacs) - (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) - (and (cond ((eq type-of-emacs 'xemacs) viper-xemacs-p) - ((eq type-of-emacs 'emacs) viper-emacs-p) - (t t)) - (cond ((eq op '=) (and (= emacs-minor-version minor) - (= emacs-major-version major))) - ((memq op '(> >= < <=)) - (and (or (funcall op emacs-major-version major) - (= emacs-major-version major)) - (if (= emacs-major-version major) - (funcall op emacs-minor-version minor) - t))) - (t - (error "%S: Invalid op in viper-check-version" op)))) - (cond ((memq op '(= > >=)) nil) - ((memq op '(< <=)) t)))) - - -(defun viper-get-visible-buffer-window (wind) - (if viper-xemacs-p - (get-buffer-window wind t) - (get-buffer-window wind 'visible))) - - -;; Return line position. -;; If pos is 'start then returns position of line start. -;; If pos is 'end, returns line end. If pos is 'mid, returns line center. -;; Pos = 'indent returns beginning of indentation. -;; Otherwise, returns point. Current point is not moved in any case." -(defun viper-line-pos (pos) - (let ((cur-pos (point)) - (result)) - (cond - ((equal pos 'start) - (beginning-of-line)) - ((equal pos 'end) - (end-of-line)) - ((equal pos 'mid) - (goto-char (+ (viper-line-pos 'start) (viper-line-pos 'end) 2))) - ((equal pos 'indent) - (back-to-indentation)) - (t nil)) - (setq result (point)) - (goto-char cur-pos) - result)) - -;; Emacs counts each multibyte character as several positions in the buffer, so -;; we use Emacs' chars-in-region. XEmacs is counting each char as just one pos, -;; so we can simply subtract. -(defun viper-chars-in-region (beg end &optional preserve-sign) - (let ((count (abs (if (fboundp 'chars-in-region) - (chars-in-region beg end) - (- end beg))))) - (if (and (< end beg) preserve-sign) - (- count) - count))) - -;; Test if POS is between BEG and END -(defsubst viper-pos-within-region (pos beg end) - (and (>= pos (min beg end)) (>= (max beg end) pos))) - - -;; Like move-marker but creates a virgin marker if arg isn't already a marker. -;; The first argument must eval to a variable name. -;; Arguments: (var-name position &optional buffer). -;; -;; This is useful for moving markers that are supposed to be local. -;; For this, VAR-NAME should be made buffer-local with nil as a default. -;; Then, each time this var is used in `viper-move-marker-locally' in a new -;; buffer, a new marker will be created. -(defun viper-move-marker-locally (var pos &optional buffer) - (if (markerp (eval var)) - () - (set var (make-marker))) - (move-marker (eval var) pos buffer)) - - -;; Print CONDITIONS as a message. -(defun viper-message-conditions (conditions) - (let ((case (car conditions)) (msg (cdr conditions))) - (if (null msg) - (message "%s" case) - (message "%s: %s" case (mapconcat 'prin1-to-string msg " "))) - (beep 1))) - - - -;;; List/alist utilities - -;; Convert LIST to an alist -(defun viper-list-to-alist (lst) - (let ((alist)) - (while lst - (setq alist (cons (list (car lst)) alist)) - (setq lst (cdr lst))) - alist)) - -;; Convert ALIST to a list. -(defun viper-alist-to-list (alst) - (let ((lst)) - (while alst - (setq lst (cons (car (car alst)) lst)) - (setq alst (cdr alst))) - lst)) - -;; Filter ALIST using REGEXP. Return alist whose elements match the regexp. -(defun viper-filter-alist (regexp alst) - (interactive "s x") - (let ((outalst) (inalst alst)) - (while (car inalst) - (if (string-match regexp (car (car inalst))) - (setq outalst (cons (car inalst) outalst))) - (setq inalst (cdr inalst))) - outalst)) - -;; Filter LIST using REGEXP. Return list whose elements match the regexp. -(defun viper-filter-list (regexp lst) - (interactive "s x") - (let ((outlst) (inlst lst)) - (while (car inlst) - (if (string-match regexp (car inlst)) - (setq outlst (cons (car inlst) outlst))) - (setq inlst (cdr inlst))) - outlst)) - - -;; Append LIS2 to LIS1, both alists, by side-effect and returns LIS1 -;; LIS2 is modified by filtering it: deleting its members of the form -;; \(car elt\) such that (car elt') is in LIS1. -(defun viper-append-filter-alist (lis1 lis2) - (let ((temp lis1) - elt) - - ;;filter-append the second list - (while temp - ;; delete all occurrences - (while (setq elt (assoc (car (car temp)) lis2)) - (setq lis2 (delq elt lis2))) - (setq temp (cdr temp))) - - (nconc lis1 lis2))) - - -;;; Support for :e and file globbing - -(defun viper-ex-nontrivial-find-file-unix (filespec) - "Glob the file spec and visit all files matching the spec. -This function is designed to work under Unix. It may also work under VMS. - -Users who prefer other types of shells should write their own version of this -function and set the variable `ex-nontrivial-find-file-function' -appropriately." - (let ((gshell - (cond (ex-unix-type-shell shell-file-name) - ((memq system-type '(vax-vms axp-vms)) "*dcl*") ; VAX VMS - (t "sh"))) ; probably Unix anyway - (gshell-options - ;; using cond in anticipation of further additions - (cond (ex-unix-type-shell-options) - )) - (command (cond (viper-ms-style-os-p (format "\"ls -1 -d %s\"" filespec)) - (t (format "ls -1 -d %s" filespec)))) - file-list status) - (save-excursion - (set-buffer (get-buffer-create viper-ex-tmp-buf-name)) - (erase-buffer) - (setq status - (if gshell-options - (call-process gshell nil t nil - gshell-options - "-c" - command) - (call-process gshell nil t nil - "-c" - command))) - (goto-char (point-min)) - ;; Issue an error, if no match. - (if (> status 0) - (save-excursion - (skip-chars-forward " \t\n\j") - (if (looking-at "ls:") - (viper-forward-Word 1)) - (error "%s: %s" - (if (stringp gshell) - gshell - "shell") - (buffer-substring (point) (viper-line-pos 'end))) - )) - (goto-char (point-min)) - (setq file-list (viper-get-filenames-from-buffer 'one-per-line))) - - (mapcar 'find-file file-list) - )) - -(defun viper-ex-nontrivial-find-file-ms (filespec) - "Glob the file spec and visit all files matching the spec. -This function is designed to work under MS type systems, such as NT, W95, and -DOS. It may also work under OS/2. - -The users of Unix-type shells should be able to use -`viper-ex-nontrivial-find-file-unix', making it into the value of the variable -`ex-nontrivial-find-file-function'. If this doesn't work, the user may have -to write a custom function, similar to `viper-ex-nontrivial-find-file-unix'." - (save-excursion - (set-buffer (get-buffer-create viper-ex-tmp-buf-name)) - (erase-buffer) - (insert filespec) - (goto-char (point-min)) - (mapcar 'find-file - (viper-glob-ms-windows-files (viper-get-filenames-from-buffer))) - )) - - -;; Interpret the stuff in the buffer as a list of file names -;; return a list of file names listed in the buffer beginning at point -;; If optional arg is supplied, assume each filename is listed on a separate -;; line -(defun viper-get-filenames-from-buffer (&optional one-per-line) - (let ((skip-chars (if one-per-line "\t\n" " \t\n")) - result fname delim) - (skip-chars-forward skip-chars) - (while (not (eobp)) - (if (cond ((looking-at "\"") - (setq delim ?\") - (re-search-forward "[^\"]+" nil t)) ; noerror - ((looking-at "'") - (setq delim ?') - (re-search-forward "[^']+" nil t)) ; noerror - (t - (re-search-forward - (concat "[^" skip-chars "]+") nil t))) ;noerror - (setq fname - (buffer-substring (match-beginning 0) (match-end 0)))) - (if delim - (forward-char 1)) - (skip-chars-forward " \t\n") - (setq result (cons fname result))) - result)) - -;; convert MS-DOS wildcards to regexp -(defun viper-wildcard-to-regexp (wcard) - (save-excursion - (set-buffer (get-buffer-create viper-ex-tmp-buf-name)) - (erase-buffer) - (insert wcard) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^*?.\\\\") - (cond ((eq (char-after (point)) ?*) (insert ".")(forward-char 1)) - ((eq (char-after (point)) ?.) (insert "\\")(forward-char 1)) - ((eq (char-after (point)) ?\\) (insert "\\")(forward-char 1)) - ((eq (char-after (point)) ??) (delete-char 1)(insert "."))) - ) - (buffer-string) - )) - - -;; glob windows files -;; LIST is expected to be in reverse order -(defun viper-glob-ms-windows-files (list) - (let ((tmp list) - (case-fold-search t) - tmp2) - (while tmp - (setq tmp2 (cons (directory-files - ;; the directory part - (or (file-name-directory (car tmp)) - "") - t ; return full names - ;; the regexp part: globs the file names - (concat "^" - (viper-wildcard-to-regexp - (file-name-nondirectory (car tmp))) - "$")) - tmp2)) - (setq tmp (cdr tmp))) - (reverse (apply 'append tmp2)))) - - -;;; Insertion ring - -;; Rotate RING's index. DIRection can be positive or negative. -(defun viper-ring-rotate1 (ring dir) - (if (and (ring-p ring) (> (ring-length ring) 0)) - (progn - (setcar ring (cond ((> dir 0) - (ring-plus1 (car ring) (ring-length ring))) - ((< dir 0) - (ring-minus1 (car ring) (ring-length ring))) - ;; don't rotate if dir = 0 - (t (car ring)))) - (viper-current-ring-item ring) - ))) - -(defun viper-special-ring-rotate1 (ring dir) - (if (memq viper-intermediate-command - '(repeating-display-destructive-command - repeating-insertion-from-ring)) - (viper-ring-rotate1 ring dir) - ;; don't rotate otherwise - (viper-ring-rotate1 ring 0))) - -;; current ring item; if N is given, then so many items back from the -;; current -(defun viper-current-ring-item (ring &optional n) - (setq n (or n 0)) - (if (and (ring-p ring) (> (ring-length ring) 0)) - (aref (cdr (cdr ring)) (mod (- (car ring) 1 n) (ring-length ring))))) - -;; push item onto ring. the second argument is a ring-variable, not value. -(defun viper-push-onto-ring (item ring-var) - (or (ring-p (eval ring-var)) - (set ring-var (make-ring (eval (intern (format "%S-size" ring-var)))))) - (or (null item) ; don't push nil - (and (stringp item) (string= item "")) ; or empty strings - (equal item (viper-current-ring-item (eval ring-var))) ; or old stuff - ;; Since viper-set-destructive-command checks if we are inside - ;; viper-repeat, we don't check whether this-command-keys is a `.'. The - ;; cmd viper-repeat makes a call to the current function only if `.' is - ;; executing a command from the command history. It doesn't call the - ;; push-onto-ring function if `.' is simply repeating the last - ;; destructive command. We only check for ESC (which happens when we do - ;; insert with a prefix argument, or if this-command-keys doesn't give - ;; anything meaningful (in that case we don't know what to show to the - ;; user). - (and (eq ring-var 'viper-command-ring) - (string-match "\\([0-9]*\e\\|^[ \t]*$\\|escape\\)" - (viper-array-to-string (this-command-keys)))) - (viper-ring-insert (eval ring-var) item)) - ) - - -;; removing elts from ring seems to break it -(defun viper-cleanup-ring (ring) - (or (< (ring-length ring) 2) - (null (viper-current-ring-item ring)) - ;; last and previous equal - (if (equal (viper-current-ring-item ring) - (viper-current-ring-item ring 1)) - (viper-ring-pop ring)))) - -;; ring-remove seems to be buggy, so we concocted this for our purposes. -(defun viper-ring-pop (ring) - (let* ((ln (ring-length ring)) - (vec (cdr (cdr ring))) - (veclen (length vec)) - (hd (car ring)) - (idx (max 0 (ring-minus1 hd ln))) - (top-elt (aref vec idx))) - - ;; shift elements - (while (< (1+ idx) veclen) - (aset vec idx (aref vec (1+ idx))) - (setq idx (1+ idx))) - (aset vec idx nil) - - (setq hd (max 0 (ring-minus1 hd ln))) - (if (= hd (1- ln)) (setq hd 0)) - (setcar ring hd) ; move head - (setcar (cdr ring) (max 0 (1- ln))) ; adjust length - top-elt - )) - -(defun viper-ring-insert (ring item) - (let* ((ln (ring-length ring)) - (vec (cdr (cdr ring))) - (veclen (length vec)) - (hd (car ring)) - (vecpos-after-hd (if (= hd 0) ln hd)) - (idx ln)) - - (if (= ln veclen) - (progn - (aset vec hd item) ; hd is always 1+ the actual head index in vec - (setcar ring (ring-plus1 hd ln))) - (setcar (cdr ring) (1+ ln)) - (setcar ring (ring-plus1 vecpos-after-hd (1+ ln))) - (while (and (>= idx vecpos-after-hd) (> ln 0)) - (aset vec idx (aref vec (1- idx))) - (setq idx (1- idx))) - (aset vec vecpos-after-hd item)) - item)) - - -;;; String utilities - -;; If STRING is longer than MAX-LEN, truncate it and print ...... instead -;; PRE-STRING is a string to prepend to the abbrev string. -;; POST-STRING is a string to append to the abbrev string. -;; ABBREV_SIGN is a string to be inserted before POST-STRING -;; if the orig string was truncated. -(defun viper-abbreviate-string (string max-len - pre-string post-string abbrev-sign) - (let (truncated-str) - (setq truncated-str - (if (stringp string) - (substring string 0 (min max-len (length string))))) - (cond ((null truncated-str) "") - ((> (length string) max-len) - (format "%s%s%s%s" - pre-string truncated-str abbrev-sign post-string)) - (t (format "%s%s%s" pre-string truncated-str post-string))))) - -;; tells if we are over a whitespace-only line -(defsubst viper-over-whitespace-line () - (save-excursion - (beginning-of-line) - (looking-at "^[ \t]*$"))) - - -;;; Saving settings in custom file - -;; Save the current setting of VAR in CUSTOM-FILE. -;; If given, MESSAGE is a message to be displayed after that. -;; This message is erased after 2 secs, if erase-msg is non-nil. -;; Arguments: var message custom-file &optional erase-message -(defun viper-save-setting (var message custom-file &optional erase-msg) - (let* ((var-name (symbol-name var)) - (var-val (if (boundp var) (eval var))) - (regexp (format "^[^;]*%s[ \t\n]*[a-zA-Z---_']*[ \t\n)]" var-name)) - (buf (find-file-noselect (substitute-in-file-name custom-file))) - ) - (message message) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (if (re-search-forward regexp nil t) - (let ((reg-end (1- (match-end 0)))) - (search-backward var-name) - (delete-region (match-beginning 0) reg-end) - (goto-char (match-beginning 0)) - (insert (format "%s '%S" var-name var-val))) - (goto-char (point-max)) - (if (not (bolp)) (insert "\n")) - (insert (format "(setq %s '%S)\n" var-name var-val))) - (save-buffer)) - (kill-buffer buf) - (if erase-msg - (progn - (sit-for 2) - (message ""))) - )) - -;; Save STRING in CUSTOM-FILE. If PATTERN is non-nil, remove strings that -;; match this pattern. -(defun viper-save-string-in-file (string custom-file &optional pattern) - (let ((buf (find-file-noselect (substitute-in-file-name custom-file)))) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (if pattern (delete-matching-lines pattern)) - (goto-char (point-max)) - (if string (insert string)) - (save-buffer)) - (kill-buffer buf) - )) - - -;;; Overlays - -;; Search - -(defun viper-flash-search-pattern () - (if (viper-overlay-p viper-search-overlay) - (viper-move-overlay - viper-search-overlay (match-beginning 0) (match-end 0)) - (setq viper-search-overlay - (viper-make-overlay - (match-beginning 0) (match-end 0) (current-buffer)))) - - (viper-overlay-put - viper-search-overlay 'priority viper-search-overlay-priority) - (if (viper-has-face-support-p) - (progn - (viper-overlay-put viper-search-overlay 'face viper-search-face) - (sit-for 2) - (viper-overlay-put viper-search-overlay 'face nil)))) - - -;; Replace state - -(defsubst viper-move-replace-overlay (beg end) - (viper-move-overlay viper-replace-overlay beg end)) - -(defun viper-set-replace-overlay (beg end) - (if (viper-overlay-p viper-replace-overlay) - (viper-move-replace-overlay beg end) - (setq viper-replace-overlay (viper-make-overlay beg end (current-buffer))) - ;; never detach - (viper-overlay-put - viper-replace-overlay (if viper-emacs-p 'evaporate 'detachable) nil) - (viper-overlay-put - viper-replace-overlay 'priority viper-replace-overlay-priority) - ;; If Emacs will start supporting overlay maps, as it currently supports - ;; text-property maps, we could do away with viper-replace-minor-mode and - ;; just have keymap attached to replace overlay. - ;;(viper-overlay-put - ;; viper-replace-overlay - ;; (if viper-xemacs-p 'keymap 'local-map) - ;; viper-replace-map) - ) - (if (viper-has-face-support-p) - (viper-overlay-put - viper-replace-overlay 'face viper-replace-overlay-face)) - (viper-save-cursor-color) - (viper-change-cursor-color viper-replace-overlay-cursor-color) - ) - - -(defun viper-set-replace-overlay-glyphs (before-glyph after-glyph) - (if (or (not (viper-has-face-support-p)) - viper-use-replace-region-delimiters) - (let ((before-name (if viper-xemacs-p 'begin-glyph 'before-string)) - (after-name (if viper-xemacs-p 'end-glyph 'after-string))) - (viper-overlay-put viper-replace-overlay before-name before-glyph) - (viper-overlay-put viper-replace-overlay after-name after-glyph)))) - -(defun viper-hide-replace-overlay () - (viper-set-replace-overlay-glyphs nil nil) - (viper-restore-cursor-color-after-replace) - (viper-restore-cursor-color-after-insert) - (if (viper-has-face-support-p) - (viper-overlay-put viper-replace-overlay 'face nil))) - - -(defsubst viper-replace-start () - (viper-overlay-start viper-replace-overlay)) -(defsubst viper-replace-end () - (viper-overlay-end viper-replace-overlay)) - - -;; Minibuffer - -(defun viper-set-minibuffer-overlay () - (viper-check-minibuffer-overlay) - (if (viper-has-face-support-p) - (progn - (viper-overlay-put - viper-minibuffer-overlay 'face viper-minibuffer-current-face) - (viper-overlay-put - viper-minibuffer-overlay 'priority viper-minibuffer-overlay-priority) - ;; never detach - (viper-overlay-put - viper-minibuffer-overlay - (if viper-emacs-p 'evaporate 'detachable) - nil) - ;; make viper-minibuffer-overlay open-ended - ;; In emacs, it is made open ended at creation time - (if viper-xemacs-p - (progn - (viper-overlay-put viper-minibuffer-overlay 'start-open nil) - (viper-overlay-put viper-minibuffer-overlay 'end-open nil))) - ))) - -(defun viper-check-minibuffer-overlay () - (or (viper-overlay-p viper-minibuffer-overlay) - (setq viper-minibuffer-overlay - (if viper-xemacs-p - (viper-make-overlay 1 (1+ (buffer-size)) (current-buffer)) - ;; make overlay open-ended - (viper-make-overlay - 1 (1+ (buffer-size)) (current-buffer) nil 'rear-advance))) - )) - - -(defsubst viper-is-in-minibuffer () - (string-match "\*Minibuf-" (buffer-name))) - - - -;;; XEmacs compatibility - -(defun viper-abbreviate-file-name (file) - (if viper-emacs-p - (abbreviate-file-name file) - ;; XEmacs requires addl argument - (abbreviate-file-name file t))) - -;; Sit for VAL milliseconds. XEmacs doesn't support the millisecond arg -;; in sit-for, so this function smoothes out the differences. -(defsubst viper-sit-for-short (val &optional nodisp) - (if viper-xemacs-p - (sit-for (/ val 1000.0) nodisp) - (sit-for 0 val nodisp))) - -;; EVENT may be a single event of a sequence of events -(defsubst viper-ESC-event-p (event) - (let ((ESC-keys '(?\e (control \[) escape)) - (key (viper-event-key event))) - (member key ESC-keys))) - -;; checks if object is a marker, has a buffer, and points to within that buffer -(defun viper-valid-marker (marker) - (if (and (markerp marker) (marker-buffer marker)) - (let ((buf (marker-buffer marker)) - (pos (marker-position marker))) - (save-excursion - (set-buffer buf) - (and (<= pos (point-max)) (<= (point-min) pos)))))) - -(defsubst viper-mark-marker () - (if viper-xemacs-p - (mark-marker t) - (mark-marker))) - -;; like (set-mark-command nil) but doesn't push twice, if (car mark-ring) -;; is the same as (mark t). -(defsubst viper-set-mark-if-necessary () - (setq mark-ring (delete (viper-mark-marker) mark-ring)) - (set-mark-command nil)) - -;; In transient mark mode (zmacs mode), it is annoying when regions become -;; highlighted due to Viper's pushing marks. So, we deactivate marks, unless -;; the user explicitly wants highlighting, e.g., by hitting '' or `` -(defun viper-deactivate-mark () - (if viper-xemacs-p - (zmacs-deactivate-region) - (deactivate-mark))) - -(defsubst viper-leave-region-active () - (if viper-xemacs-p - (setq zmacs-region-stays t))) - -;; Check if arg is a valid character for register -;; TYPE is a list that can contain `letter', `Letter', and `digit'. -;; Letter means lowercase letters, Letter means uppercase letters, and -;; digit means digits from 1 to 9. -;; If TYPE is nil, then down/uppercase letters and digits are allowed. -(defun viper-valid-register (reg &optional type) - (or type (setq type '(letter Letter digit))) - (or (if (memq 'letter type) - (and (<= ?a reg) (<= reg ?z))) - (if (memq 'digit type) - (and (<= ?1 reg) (<= reg ?9))) - (if (memq 'Letter type) - (and (<= ?A reg) (<= reg ?Z))) - )) - - -(defsubst viper-events-to-keys (events) - (cond (viper-xemacs-p (events-to-keys events)) - (t events))) - - -;; This is here because Emacs changed the way local hooks work. -;; -;;Add to the value of HOOK the function FUNCTION. -;;FUNCTION is not added if already present. -;;FUNCTION is added (if necessary) at the beginning of the hook list -;;unless the optional argument APPEND is non-nil, in which case -;;FUNCTION is added at the end. -;; -;;HOOK should be a symbol, and FUNCTION may be any valid function. If -;;HOOK is void, it is first set to nil. If HOOK's value is a single -;;function, it is changed to a list of functions." -(defun viper-add-hook (hook function &optional append) - (if (not (boundp hook)) (set hook nil)) - ;; If the hook value is a single function, turn it into a list. - (let ((old (symbol-value hook))) - (if (or (not (listp old)) (eq (car old) 'lambda)) - (setq old (list old))) - (if (member function old) - nil - (set hook (if append - (append old (list function)) ; don't nconc - (cons function old)))))) - -;; This is here because of Emacs's changes in the semantics of add/remove-hooks -;; and due to the bugs they introduced. -;; -;; Remove from the value of HOOK the function FUNCTION. -;; HOOK should be a symbol, and FUNCTION may be any valid function. If -;; FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the -;; list of hooks to run in HOOK, then nothing is done. See `viper-add-hook'." -(defun viper-remove-hook (hook function) - (if (or (not (boundp hook)) ;unbound symbol, or - (null (symbol-value hook)) ;value is nil, or - (null function)) ;function is nil, then - nil ;Do nothing. - (let ((hook-value (symbol-value hook))) - (if (consp hook-value) - ;; don't side-effect the list - (setq hook-value (delete function (copy-sequence hook-value))) - (if (equal hook-value function) - (setq hook-value nil))) - (set hook hook-value)))) - - -;; it is suggested that an event must be copied before it is assigned to -;; last-command-event in XEmacs -(defun viper-copy-event (event) - (if viper-xemacs-p - (copy-event event) - event)) - -;; like read-event, but in XEmacs also try to convert to char, if possible -(defun viper-read-event-convert-to-char () - (let (event) - (if viper-emacs-p - (read-event) - (setq event (next-command-event)) - (or (event-to-character event) - event)) - )) - -;; This function lets function-key-map convert key sequences into logical -;; keys. This does a better job than viper-read-event when it comes to kbd -;; macros, since it enables certain macros to be shared between X and TTY modes -;; by correctly mapping key sequences for Left/Right/... (one an ascii -;; terminal) into logical keys left, right, etc. -(defun viper-read-key () - (let ((overriding-local-map viper-overriding-map) - (inhibit-quit t) - help-char key) - (use-global-map viper-overriding-map) - (unwind-protect - (setq key (elt (read-key-sequence nil) 0)) - (use-global-map global-map)) - key)) - - -;; Emacs has a bug in eventp, which causes (eventp nil) to return (nil) -;; instead of nil, if '(nil) was previously inadvertently assigned to -;; unread-command-events -(defun viper-event-key (event) - (or (and event (eventp event)) - (error "viper-event-key: Wrong type argument, eventp, %S" event)) - (when (cond (viper-xemacs-p (or (key-press-event-p event) - (mouse-event-p event))) - (t t)) - (let ((mod (event-modifiers event)) - basis) - (setq basis - (cond - (viper-xemacs-p - (cond ((key-press-event-p event) - (event-key event)) - ((button-event-p event) - (concat "mouse-" (prin1-to-string (event-button event)))) - (t - (error "viper-event-key: Unknown event, %S" event)))) - (t - ;; Emacs doesn't handle capital letters correctly, since - ;; \S-a isn't considered the same as A (it behaves as - ;; plain `a' instead). So we take care of this here - (cond ((and (viper-characterp event) (<= ?A event) (<= event ?Z)) - (setq mod nil - event event)) - ;; Emacs has the oddity whereby characters 128+char - ;; represent M-char *if* this appears inside a string. - ;; So, we convert them manually to (meta char). - ((and (viper-characterp event) - (< ?\C-? event) (<= event 255)) - (setq mod '(meta) - event (- event ?\C-? 1))) - ((and (null mod) (eq event 'return)) - (setq event ?\C-m)) - ((and (null mod) (eq event 'space)) - (setq event ?\ )) - ((and (null mod) (eq event 'delete)) - (setq event ?\C-?)) - ((and (null mod) (eq event 'backspace)) - (setq event ?\C-h)) - (t (event-basic-type event))) - ))) - (if (viper-characterp basis) - (setq basis - (if (= basis ?\C-?) - (list 'control '\?) ; taking care of an emacs bug - (intern (char-to-string basis))))) - (if mod - (append mod (list basis)) - basis)))) - -(defun viper-key-to-emacs-key (key) - (let (key-name char-p modifiers mod-char-list base-key base-key-name) - (cond (viper-xemacs-p key) - - ((symbolp key) - (setq key-name (symbol-name key)) - (cond ((= (length key-name) 1) ; character event - (string-to-char key-name)) - ;; Emacs doesn't recognize `return' and `escape' as events on - ;; dumb terminals, so we translate them into characters - ((and viper-emacs-p (not (viper-window-display-p)) - (string= key-name "return")) - ?\C-m) - ((and viper-emacs-p (not (viper-window-display-p)) - (string= key-name "escape")) - ?\e) - ;; pass symbol-event as is - (t key))) - - ((listp key) - (setq modifiers (subseq key 0 (1- (length key))) - base-key (viper-seq-last-elt key) - base-key-name (symbol-name base-key) - char-p (= (length base-key-name) 1)) - (setq mod-char-list - (mapcar - '(lambda (elt) (upcase (substring (symbol-name elt) 0 1))) - modifiers)) - (if char-p - (setq key-name - (car (read-from-string - (concat - "?\\" - (mapconcat 'identity mod-char-list "-\\") - "-" - base-key-name)))) - (setq key-name - (intern - (concat - (mapconcat 'identity mod-char-list "-") - "-" - base-key-name)))))) - )) - - -;; Args can be a sequence of events, a string, or a Viper macro. Will try to -;; convert events to keys and, if all keys are regular printable -;; characters, will return a string. Otherwise, will return a string -;; representing a vector of converted events. If the input was a Viper macro, -;; will return a string that represents this macro as a vector. -(defun viper-array-to-string (event-seq) - (let (temp temp2) - (cond ((stringp event-seq) event-seq) - ((viper-event-vector-p event-seq) - (setq temp (mapcar 'viper-event-key event-seq)) - (cond ((viper-char-symbol-sequence-p temp) - (mapconcat 'symbol-name temp "")) - ((and (viper-char-array-p - (setq temp2 (mapcar 'viper-key-to-character temp)))) - (mapconcat 'char-to-string temp2 "")) - (t (prin1-to-string (vconcat temp))))) - ((viper-char-symbol-sequence-p event-seq) - (mapconcat 'symbol-name event-seq "")) - ((and (vectorp event-seq) - (viper-char-array-p - (setq temp (mapcar 'viper-key-to-character event-seq)))) - (mapconcat 'char-to-string temp "")) - (t (prin1-to-string event-seq))))) - -(defun viper-key-press-events-to-chars (events) - (mapconcat (if viper-emacs-p - 'char-to-string - (function - (lambda (elt) (char-to-string (event-to-character elt))))) - events - "")) - - -;; Uses different timeouts for ESC-sequences and others -(defsubst viper-fast-keysequence-p () - (not (viper-sit-for-short - (if (viper-ESC-event-p last-input-event) - viper-ESC-keyseq-timeout - viper-fast-keyseq-timeout) - t))) - -(defun viper-read-char-exclusive () - (let (char - (echo-keystrokes 1)) - (while (null char) - (condition-case nil - (setq char (read-char)) - (error - ;; skip event if not char - (viper-read-event)))) - char)) - -;; key is supposed to be in viper's representation, e.g., (control l), a -;; character, etc. -(defun viper-key-to-character (key) - (cond ((eq key 'space) ?\ ) - ((eq key 'delete) ?\C-?) - ((eq key 'return) ?\C-m) - ((eq key 'backspace) ?\C-h) - ((and (symbolp key) - (= 1 (length (symbol-name key)))) - (string-to-char (symbol-name key))) - ((and (listp key) - (eq (car key) 'control) - (symbol-name (nth 1 key)) - (= 1 (length (symbol-name (nth 1 key))))) - (read (format "?\\C-%s" (symbol-name (nth 1 key))))) - (t key))) - - -(defun viper-setup-master-buffer (&rest other-files-or-buffers) - "Set up the current buffer as a master buffer. -Arguments become related buffers. This function should normally be used in -the `Local variables' section of a file." - (setq viper-related-files-and-buffers-ring - (make-ring (1+ (length other-files-or-buffers)))) - (mapcar '(lambda (elt) - (viper-ring-insert viper-related-files-and-buffers-ring elt)) - other-files-or-buffers) - (viper-ring-insert viper-related-files-and-buffers-ring (buffer-name)) - ) - -;;; Movement utilities - -;; Characters that should not be considered as part of the word, in reformed-vi -;; syntax mode. -(defconst viper-non-word-characters-reformed-vi - "!@#$%^&*()-+=|\\~`{}[];:'\",<.>/?") -;; These are characters that are not to be considered as parts of a word in -;; Viper. -;; Set each time state changes and at loading time -(viper-deflocalvar viper-non-word-characters nil) - -;; must be buffer-local -(viper-deflocalvar viper-ALPHA-char-class "w" - "String of syntax classes characterizing Viper's alphanumeric symbols. -In addition, the symbol `_' may be considered alphanumeric if -`viper-syntax-preference' is `strict-vi' or `reformed-vi'.") - -(defconst viper-strict-ALPHA-chars "a-zA-Z0-9_" - "Regexp matching the set of alphanumeric characters acceptable to strict -Vi.") -(defconst viper-strict-SEP-chars " \t\n" - "Regexp matching the set of alphanumeric characters acceptable to strict -Vi.") -(defconst viper-strict-SEP-chars-sans-newline " \t" - "Regexp matching the set of alphanumeric characters acceptable to strict -Vi.") - -(defconst viper-SEP-char-class " -" - "String of syntax classes for Vi separators. -Usually contains ` ', linefeed, TAB or formfeed.") - - -;; Set Viper syntax classes and related variables according to -;; `viper-syntax-preference'. -(defun viper-update-syntax-classes (&optional set-default) - (let ((preference (cond ((eq viper-syntax-preference 'emacs) - "w") ; Viper words have only Emacs word chars - ((eq viper-syntax-preference 'extended) - "w_") ; Viper words have Emacs word & symbol chars - (t "w"))) ; Viper words are Emacs words plus `_' - (non-word-chars (cond ((eq viper-syntax-preference 'reformed-vi) - (viper-string-to-list - viper-non-word-characters-reformed-vi)) - (t nil)))) - (if set-default - (setq-default viper-ALPHA-char-class preference - viper-non-word-characters non-word-chars) - (setq viper-ALPHA-char-class preference - viper-non-word-characters non-word-chars)) - )) - -;; SYMBOL is used because customize requires it, but it is ignored, unless it -;; is `nil'. If nil, use setq. -(defun viper-set-syntax-preference (&optional symbol value) - "Set Viper syntax preference. -If called interactively or if SYMBOL is nil, sets syntax preference in current -buffer. If called non-interactively, preferably via the customization widget, -sets the default value." - (interactive) - (or value - (setq value - (completing-read - "Viper syntax preference: " - '(("strict-vi") ("reformed-vi") ("extended") ("emacs")) - nil 'require-match))) - (if (stringp value) (setq value (intern value))) - (or (memq value '(strict-vi reformed-vi extended emacs)) - (error "Invalid Viper syntax preference, %S" value)) - (if symbol - (setq-default viper-syntax-preference value) - (setq viper-syntax-preference value)) - (viper-update-syntax-classes)) - -(defcustom viper-syntax-preference 'reformed-vi - "*Syntax type characterizing Viper's alphanumeric symbols. -Affects movement and change commands that deal with Vi-style words. -Works best when set in the hooks to various major modes. - -`strict-vi' means Viper words are (hopefully) exactly as in Vi. - -`reformed-vi' means Viper words are like Emacs words \(as determined using -Emacs syntax tables, which are different for different major modes\) with two -exceptions: the symbol `_' is always part of a word and typical Vi non-word -symbols, such as `,',:,\",),{, etc., are excluded. -This behaves very close to `strict-vi', but also works well with non-ASCII -characters from various alphabets. - -`extended' means Viper word constituents are symbols that are marked as being -parts of words OR symbols in Emacs syntax tables. -This is most appropriate for major modes intended for editing programs. - -`emacs' means Viper words are the same as Emacs words as specified by Emacs -syntax tables. -This option is appropriate if you like Emacs-style words." - :type '(radio (const strict-vi) (const reformed-vi) - (const extended) (const emacs)) - :set 'viper-set-syntax-preference - :group 'viper) -(make-variable-buffer-local 'viper-syntax-preference) - - -;; addl-chars are characters to be temporarily considered as alphanumerical -(defun viper-looking-at-alpha (&optional addl-chars) - (or (stringp addl-chars) (setq addl-chars "")) - (if (eq viper-syntax-preference 'reformed-vi) - (setq addl-chars (concat addl-chars "_"))) - (let ((char (char-after (point)))) - (if char - (if (eq viper-syntax-preference 'strict-vi) - (looking-at (concat "[" viper-strict-ALPHA-chars addl-chars "]")) - (or - ;; or one of the additional chars being asked to include - (memq char (viper-string-to-list addl-chars)) - (and - ;; not one of the excluded word chars - (not (memq char viper-non-word-characters)) - ;; char of the Viper-word syntax class - (memq (char-syntax char) - (viper-string-to-list viper-ALPHA-char-class)))))) - )) - -(defun viper-looking-at-separator () - (let ((char (char-after (point)))) - (if char - (if (eq viper-syntax-preference 'strict-vi) - (memq char (viper-string-to-list viper-strict-SEP-chars)) - (or (eq char ?\n) ; RET is always a separator in Vi - (memq (char-syntax char) - (viper-string-to-list viper-SEP-char-class))))) - )) - -(defsubst viper-looking-at-alphasep (&optional addl-chars) - (or (viper-looking-at-separator) (viper-looking-at-alpha addl-chars))) - -(defun viper-skip-alpha-forward (&optional addl-chars) - (or (stringp addl-chars) (setq addl-chars "")) - (viper-skip-syntax - 'forward - (cond ((eq viper-syntax-preference 'strict-vi) - "") - (t viper-ALPHA-char-class)) - (cond ((eq viper-syntax-preference 'strict-vi) - (concat viper-strict-ALPHA-chars addl-chars)) - (t addl-chars)))) - -(defun viper-skip-alpha-backward (&optional addl-chars) - (or (stringp addl-chars) (setq addl-chars "")) - (viper-skip-syntax - 'backward - (cond ((eq viper-syntax-preference 'strict-vi) - "") - (t viper-ALPHA-char-class)) - (cond ((eq viper-syntax-preference 'strict-vi) - (concat viper-strict-ALPHA-chars addl-chars)) - (t addl-chars)))) - -;; weird syntax tables may confuse strict-vi style -(defsubst viper-skip-all-separators-forward (&optional within-line) - (if (eq viper-syntax-preference 'strict-vi) - (if within-line - (skip-chars-forward viper-strict-SEP-chars-sans-newline) - (skip-chars-forward viper-strict-SEP-chars)) - (viper-skip-syntax 'forward - viper-SEP-char-class - (or within-line "\n") - (if within-line (viper-line-pos 'end))))) -(defsubst viper-skip-all-separators-backward (&optional within-line) - (if (eq viper-syntax-preference 'strict-vi) - (if within-line - (skip-chars-backward viper-strict-SEP-chars-sans-newline) - (skip-chars-backward viper-strict-SEP-chars)) - (viper-skip-syntax 'backward - viper-SEP-char-class - (or within-line "\n") - (if within-line (viper-line-pos 'start))))) -(defun viper-skip-nonseparators (direction) - (viper-skip-syntax - direction - (concat "^" viper-SEP-char-class) - nil - (viper-line-pos (if (eq direction 'forward) 'end 'start)))) - - -;; skip over non-word constituents and non-separators -(defun viper-skip-nonalphasep-forward () - (if (eq viper-syntax-preference 'strict-vi) - (skip-chars-forward - (concat "^" viper-strict-SEP-chars viper-strict-ALPHA-chars)) - (viper-skip-syntax - 'forward - (concat "^" viper-ALPHA-char-class viper-SEP-char-class) - ;; Emacs may consider some of these as words, but we don't want them - viper-non-word-characters - (viper-line-pos 'end)))) -(defun viper-skip-nonalphasep-backward () - (if (eq viper-syntax-preference 'strict-vi) - (skip-chars-backward - (concat "^" viper-strict-SEP-chars viper-strict-ALPHA-chars)) - (viper-skip-syntax - 'backward - (concat "^" viper-ALPHA-char-class viper-SEP-char-class) - ;; Emacs may consider some of these as words, but we don't want them - viper-non-word-characters - (viper-line-pos 'start)))) - -;; Skip SYNTAX like skip-syntax-* and ADDL-CHARS like skip-chars-* -;; Return the number of chars traveled. -;; Both SYNTAX or ADDL-CHARS can be strings or lists of characters. -;; When SYNTAX is "w", then viper-non-word-characters are not considered to be -;; words, even if Emacs syntax table says they are. -(defun viper-skip-syntax (direction syntax addl-chars &optional limit) - (let ((total 0) - (local 1) - (skip-chars-func - (if (eq direction 'forward) - 'skip-chars-forward 'skip-chars-backward)) - (skip-syntax-func - (if (eq direction 'forward) - 'viper-forward-char-carefully 'viper-backward-char-carefully)) - char-looked-at syntax-of-char-looked-at negated-syntax) - (setq addl-chars - (cond ((listp addl-chars) (viper-charlist-to-string addl-chars)) - ((stringp addl-chars) addl-chars) - (t ""))) - (setq syntax - (cond ((listp syntax) syntax) - ((stringp syntax) (viper-string-to-list syntax)) - (t nil))) - (if (memq ?^ syntax) (setq negated-syntax t)) - - (while (and (not (= local 0)) (not (eobp))) - (setq char-looked-at (viper-char-at-pos direction) - ;; if outside the range, set to nil - syntax-of-char-looked-at (if char-looked-at - (char-syntax char-looked-at))) - (setq local - (+ (if (and - (cond ((and limit (eq direction 'forward)) - (< (point) limit)) - (limit ; backward & limit - (> (point) limit)) - (t t)) ; no limit - ;; char under/before cursor has appropriate syntax - (if negated-syntax - (not (memq syntax-of-char-looked-at syntax)) - (memq syntax-of-char-looked-at syntax)) - ;; if char-syntax class is "word", make sure it is not one - ;; of the excluded characters - (if (and (eq syntax-of-char-looked-at ?w) - (not negated-syntax)) - (not (memq char-looked-at viper-non-word-characters)) - t)) - (funcall skip-syntax-func 1) - 0) - (funcall skip-chars-func addl-chars limit))) - (setq total (+ total local))) - total - )) - - - -(provide 'viper-util) - - -;;; Local Variables: -;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) -;;; End: - -;;; viper-util.el ends here
--- a/lisp/viper/viper.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1239 +0,0 @@ -;;; viper.el --- A full-featured Vi emulator for GNU Emacs and XEmacs, -;; a VI Plan for Emacs Rescue, -;; and a venomous VI PERil. -;; Viper Is also a Package for Emacs Rebels. -;; -;; Keywords: emulations -;; Author: Michael Kifer <kifer@cs.sunysb.edu> - -;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -(defconst viper-version "3.001 (Polyglot) of September 23, 1997" - "The current version of Viper") - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Viper is a full-featured Vi emulator for Emacs and XEmacs. It emulates and -;; improves upon the standard features of Vi and, at the same time, allows -;; full access to all Emacs facilities. Viper supports multiple undo, -;; file name completion, command, file, and search history and it extends -;; Vi in many other ways. Viper is highly customizable through the various -;; hooks, user variables, and keymaps. It is implemented as a collection -;; of minor modes and it is designed to provide full access to all Emacs -;; major and minor modes. -;; -;;; History -;; -;; Viper is a new name for a package formerly known as VIP-19, -;; which was a successor of VIP version 3.5 by Masahiko Sato -;; <ms@sail.stanford.edu> and VIP version 4.2 by Aamod Sane -;; <sane@cs.uiuc.edu>. Some ideas from vip 4.4.2 by Aamod Sane -;; were also shamelessly plagiarized. -;; -;; Viper maintains some degree of compatibility with these older -;; packages. See the documentation for customization. -;; -;; The main difference between Viper and these older packages are: -;; -;; 1. Viper emulates Vi at several levels, from almost complete conformity -;; to a rather loose Vi-compliance. -;; -;; 2. Viper provides full access to all major and minor modes of Emacs -;; without the need to type extra keys. -;; The older versions of VIP (and other Vi emulators) do not work with -;; some major and minor modes. -;; -;; 3. Viper supports vi-style undo. -;; -;; 4. Viper fully emulates (and improves upon) vi's replacement mode. -;; -;; 5. Viper has a better interface to ex, including command, variable, and -;; file name completion. -;; -;; 6. Viper uses native Emacs history and completion features; it doesn't -;; rely on other packages (such as gmhist.el and completer.el) to provide -;; these features. -;; -;; 7. Viper supports Vi-style editing in the minibuffer, by allowing the -;; user to switch from Insert state to Vi state to Replace state, etc. -;; -;; 8. Viper keeps history of recently inserted pieces of text and recently -;; executed Vi-style destructive commands, such as `i', `d', etc. -;; These pieces of text can be inserted in later insertion commands; -;; the previous destructive commands can be re-executed. -;; -;; 9. Viper has Vi-style keyboard macros, which enhances the similar -;; facility in the original Vi. -;; First, one can execute any Emacs command while defining a -;; macro, not just the Vi commands. Second, macros are defined in a -;; WYSYWYG mode, using an interface to Emacs' WYSIWYG style of defining -;; macros. Third, in Viper, one can define macros that are specific to -;; a given buffer, a given major mode, or macros defined for all buffers. -;; The same macro name can have several different definitions: -;; one global, several definitions for various major modes, and -;; definitions for specific buffers. -;; Buffer-specific definitions override mode-specific -;; definitions, which, in turn, override global definitions. -;; -;; -;;; Installation: -;; ------------- -;; -;; (require 'viper) -;; - -;;; Acknowledgements: -;; ----------------- -;; Bug reports and ideas contributed by many users have helped -;; improve Viper and the various versions of VIP. -;; See the on-line manual for a complete list of contributors. -;; -;; -;;; Notes: -;; -;; 1. Major modes. -;; In most cases, Viper handles major modes correctly, i.e., they come up -;; in the right state (either vi-state or emacs-state). For instance, text -;; files come up in vi-state, while, say, Dired appears in emacs-state by -;; default. -;; However, some modes do not appear in the right mode in the beginning, -;; usually because they neglect to follow Emacs conventions (e.g., they don't -;; use kill-all-local-variables when they start). Some major modes -;; may fail to come up in emacs-state if they call hooks, such as -;; text-hook, for no good reason. -;; -;; As an immediate solution, you can hit C-z to bring about the right mode. -;; An interim solution is to add an appropriate hook to the mode like this: -;; -;; (add-hook 'your-favorite-mode 'viper-mode) -;; or -;; (add-hook 'your-favorite-mode 'viper-change-state-to-emacs) -;; -;; whichever applies. The right thing to do, however, is to complain to the -;; author of the respective package. (Sometimes they also neglect to equip -;; their modes with hooks, which is one more reason for complaining.) -;; -;; 2. Keymap handling -;; Each Viper state (insert, vi, replace) is implemented as a collection of -;; several minor modes, each with its own keymap. -;; -;; Viper's Vi state consists of seven minor modes: -;; -;; viper-vi-intercept-minor-mode -;; viper-vi-local-user-minor-mode -;; viper-vi-global-user-minor-mode -;; viper-vi-kbd-minor-mode -;; viper-vi-state-modifier-minor-mode -;; viper-vi-diehard-minor-mode -;; viper-vi-basic-minor-mode -;; -;; Bindings done to the keymap of the first mode overshadow those done to -;; the second, which, in turn, overshadows those done to the third, etc. -;; -;; The last viper-vi-basic-minor-mode contains most of the usual Vi bindings -;; in its edit mode. This mode provides access to all Emacs facilities. -;; Novice users, however, may want to set their viper-expert-level to 1 -;; in their .viper file. This will enable viper-vi-diehard-minor-mode. This -;; minor mode's bindings make Viper simulate the usual Vi very closely. -;; For instance, C-c will not have its standard Emacs binding -;; and so many of the goodies of Emacs are not available. -;; -;; A skilled user should set viper-expert-level to at least 3. This will -;; enable `C-c' and many Emacs facilities will become available. -;; In this case, viper-vi-diehard-minor-mode is inactive. -;; -;; Viper gurus should have at least -;; (setq viper-expert-level 4) -;; in their ~/.viper files. This will unsuppress all Emacs keys that are not -;; essential for VI-style editing. -;; Pick-and-choose users may want to put -;; (setq viper-expert-level 5) -;; in ~/.viper. Viper will then leave it up to the user to set the variables -;; viper-want-* See viper-set-expert-level for details. -;; -;; The very first minor mode, viper-vi-intercept-minor-mode, is of no -;; concern for the user. It is needed to bind Viper's vital keys, such as -;; ESC and C-z. -;; -;; The second mode, viper-vi-local-user-minor-mode, usually has an -;; empty keymap. However, the user can set bindings in this keymap, which -;; will overshadow the corresponding bindings in the other two minor -;; modes. This is useful, for example, for setting up ZZ in gnus, -;; rmail, mh-e, etc., to send message instead of saving it in a file. -;; Likewise, in Dired mode, you may want to bind ZN and ZP to commands -;; that would visit the next or the previous file in the Dired buffer. -;; Setting local keys is tricky, so don't do it directly. Instead, use -;; viper-add-local-keys function (see its doc). -;; -;; The third minor mode, viper-vi-global-user-minor-mode, is also intended -;; for the users but, unlike viper-vi-local-user-minor-mode, its key -;; bindings are seen in all Viper buffers. This mode keys can be done -;; with define-key command. -;; -;; The fourth minor mode, viper-vi-kbd-minor-mode, is used by keyboard -;; macros. Users are NOT supposed to modify this keymap directly. -;; -;; The fifth mode, viper-vi-state-modifier-minor-mode, can be used to set -;; key bindings that are visible in some major modes but not in others. -;; -;; Users are allowed to modify keymaps that belong to -;; viper-vi-local-user-minor-mode, viper-vi-global-user-minor-mode, -;; and viper-vi-state-modifier-minor-mode only. -;; -;; Viper's Insert state also has seven minor modes: -;; -;; viper-insert-intercept-minor-mode -;; viper-insert-local-user-minor-mode -;; viper-insert-global-user-minor-mode -;; viper-insert-kbd-minor-mode -;; viper-insert-state-modifier-minor-mode -;; viper-insert-diehard-minor-mode -;; viper-insert-basic-minor-mode -;; -;; As with VI's editing modes, the first mode, -;; viper-insert-intercept-minor-mode is used to bind vital keys that are not -;; to be changed by the user. -;; -;; The next mode, viper-insert-local-user-minor-mode, is used to customize -;; bindings in the insert state of Viper. The third mode, -;; viper-insert-global-user-minor-mode is like -;; viper-insert-local-user-minor-mode, except that its bindings are seen in -;; all Viper buffers. As with viper-vi-local-user-minor-mode, its bindings -;; should be done via the function viper-add-local-keys. Bindings for -;; viper-insert-global-user-minor-mode can be set with the define-key command. -;; -;; The next minor mode, viper-insert-kbd-minor-mode, -;; is used for keyboard VI-style macros defined with :map!. -;; -;; The fifth minor mode, viper-insert-state-modifier-minor-mode, is like -;; viper-vi-state-modifier-minor-mode, except that it is used in the Insert -;; state; it can be used to modify keys in a mode-specific fashion. -;; -;; The minor mode viper-insert-diehard-minor-mode is in effect when -;; the user wants a high degree of Vi compatibility (a bad idea, really!). -;; The last minor mode, viper-insert-basic-minor-mode, is always in effect -;; when Viper is in insert state. It binds a small number of keys needed for -;; Viper's operation. -;; -;; Finally, Viper provides minor modes for overriding bindings set by Emacs -;; modes when Viper is in Emacs state: -;; -;; viper-emacs-local-user-minor-mode -;; viper-emacs-global-user-minor-mode -;; viper-emacs-kbd-minor-mode -;; viper-emacs-state-modifier-minor-mode -;; -;; These minor modes are in effect when Viper is in Emacs state. The keymap -;; associated with viper-emacs-global-user-minor-mode, -;; viper-emacs-global-user-map, overrides the global and local keymaps as -;; well as the minor mode keymaps set by other modes. The keymap of -;; viper-emacs-local-user-minor-mode, viper-emacs-local-user-map, overrides -;; everything, but it is used on a per buffer basis. -;; The keymap associated with viper-emacs-state-modifier-minor-mode -;; overrides keys on a per-major-mode basis. The mode -;; viper-emacs-kbd-minor-mode is used to define Vi-style macros in Emacs -;; state. -;; -;; 3. There is also one minor mode that is used when Viper is in its -;; replace-state (used for commands like cw, C, etc.). This mode is -;; called -;; -;; viper-replace-minor-mode -;; -;; and its keymap is viper-replace-map. Replace minor mode is always -;; used in conjunction with the minor modes for insert-state, and its -;; keymap overshadows the keymaps for insert minor modes. -;; -;; 4. Defining buffer-local bindings in Vi and Insert modes. -;; As mentioned before, sometimes, it is convenient to have -;; buffer-specific of mode-specific key bindings in Vi and insert modes. -;; Viper provides a special function, viper-add-local-keys, to do precisely -;; this. For instance, is you need to add couple of mode-specific bindings -;; to Insert mode, you can put -;; -;; (viper-add-local-keys 'insert-state '((key1 . func1) (key2 .func2))) -;; -;; somewhere in a hook of this major mode. If you put something like this -;; in your own elisp function, this will define bindings specific to the -;; buffer that was current at the time of the call to viper-add-local-keys. -;; The only thing to make sure here is that the major mode of this buffer -;; is written according to Emacs conventions, which includes a call to -;; (kill-all-local-variables). See viper-add-local-keys for more details. -;; -;; -;; TO DO (volunteers?): -;; -;; 1. Some of the code that is inherited from VIP-3.5 is rather -;; convoluted. Instead of viper-command-argument, keymaps should bind the -;; actual commands. E.g., "dw" should be bound to a generic command -;; viper-delete that will delete things based on the value of -;; last-command-char. This would greatly simplify the logic and the code. -;; -;; 2. Somebody should venture to write a customization package a la -;; options.el that would allow the user to change values of variables -;; that meet certain specs (e.g., match a regexp) and whose doc string -;; starts with a '*'. Then, the user should be offered to save -;; variables that were changed. This will make user's customization job -;; much easier. -;; - -;; Code - -(require 'advice) -(require 'cl) -(require 'ring) - -;; compiler pacifier -(defvar mark-even-if-inactive) -(defvar quail-mode) -(defvar viper-expert-level) -(defvar viper-expert-level) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-init) - (load "viper-init.el" nil nil 'nosuffix)) - (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) - ))) -;; end pacifier - -(require 'viper-init) - -;; better be defined before Viper custom group. -(defvar viper-custom-file-name (convert-standard-filename "~/.viper") - "Viper customisation file. -If set by the user, this must be done _before_ Viper is loaded in `~/.emacs'.") - -(defgroup viper nil - "Vi emulation within Emacs. -NOTE: Viper customization should be saved in `viper-custom-file-name', which -defaults to `~/.viper'." - :prefix "viper-" - :group 'emulations) - -(require 'viper-cmd) - -(defgroup viper-misc nil - "Miscellaneous Viper customization." - :prefix "viper-" - :group 'viper) - - -(defcustom viper-always t - "Non-nil means, arrange for vi-state to be a default when appropriate. -This is different from `viper-mode' variable in that `viper-mode' determines -whether to use Viper in the first place, while `viper-always', if nil, lets -user decide when to invoke Viper in a major mode." - :type 'boolean - :tag "Always Invoke Viper" - :group 'viper-misc) - -;; Non-viper variables that need to be saved in case the user decides to -;; de-viperize emacs. -(defvar viper-saved-non-viper-variables nil) -;; Contains user settings for vars affected by viper-set-expert-level function. -;; Not a user option. -(defvar viper-saved-user-settings nil) - -(defcustom viper-mode (cond (noninteractive nil) - (t 'ask)) - "To Viperize or not to Viperize. -If t, viperize emacs. If nil -- don't. If `ask', ask the user. -This variable is used primatily when Viper is being loaded. - -Must be set in `~/.emacs' before Viper is loaded. -DO NOT set this variable interactively, unless you are using the customization -widget." - :type '(choice (const nil) (const t) (const ask)) - :tag "Set Viper Mode on Loading" - :group 'viper-misc) - -(defcustom viper-non-vi-major-modes - '(custom-mode dired-mode efs-mode internal-ange-ftp-mode tar-mode - mh-folder-mode gnus-group-mode gnus-summary-mode Info-mode - Buffer-menu-mode view-mode vm-mode vm-summary-mode) - "*A list of major modes that should never come up in Vi command mode. -Viper automatically augments this list with some obvious modes, such as -`dired-mode', `tar-mode', etc. So, don't put a mode on this list, unless -it comes up in a wrong Viper state." - :type '(repeat symbol) - :group 'viper-misc) - - - - -;;;###autoload -(defun toggle-viper-mode () - (interactive) - (if (eq viper-mode t) - (viper-go-away) - (setq viper-mode nil) - (viper-mode))) - -;;;###autoload -(defun viper-mode () - "Turn on Viper emulation of Vi." - (interactive) - (if (not noninteractive) - (progn - ;; if the user requested viper-mode explicitly - (if viper-mode - () - (setq viper-mode t) - (load-library "viper")) - - (if viper-first-time ; Important check. Prevents mix-up of startup and - (progn ; expert-level msgs when viper-mode recurses - (setq viper-first-time nil) - (if (not viper-inhibit-startup-message) - (save-window-excursion - (setq viper-inhibit-startup-message t) - (delete-other-windows) - (switch-to-buffer "Viper Startup Message") - (erase-buffer) - (insert - (substitute-command-keys - "Viper Is a Package for Emacs Rebels, -a VI Plan for Emacs Rescue, and a venomous VI PERil. - -Incidentally, Viper emulates Vi under GNU Emacs 20 and XEmacs 20. -It supports all of what is good in Vi and Ex, while extending -and improving upon much of it. - - 1. Viper supports Vi at several levels. Level 1 is the closest to Vi, - level 5 provides the most flexibility to depart from many Vi conventions. - - You will be asked to specify your user level in a following screen. - - If you select user level 1 then the keys ^X, ^C, ^Z, and ^G will behave - as in VI, to smooth transition to Viper for the beginners. However, to - use Emacs productively, you are advised to reach user level 3 or higher. - - At user level 2 or higher, ^X and ^C have Emacs, not Vi, bindings; - ^Z toggles Vi/Emacs states; ^G is Emacs' keyboard-quit (like ^C in Vi). - - 2. Vi exit functions (e.g., :wq, ZZ) work on INDIVIDUAL files -- they - do not cause Emacs to quit, except at user level 1 (for a novice). - 3. ^X^C EXITS EMACS. - 4. Viper supports multiple undo: `u' will undo. Typing `.' will repeat - undo. Another `u' changes direction. - - 6. Emacs Meta key is `C-\\' (in all modes) or `\\ ESC' (in Vi command mode). - On a window system, the best way is to use the Meta-key on your keyboard. - 7. Try \\[keyboard-quit] and \\[abort-recursive-edit] repeatedly,if - something funny happens. This would abort the current editing command. - -For more information on Viper: - - a. Type `:help' in Vi command mode - b. Print Viper manual, found in ./etc/viper.dvi - c. Print the Quick Reference, found in ./etc/viperCard.dvi - -To submit a bug report or to contact the author, type :submitReport in Vi -command mode. To shoo Viper away and return to pure Emacs (horror!), type: - - M-x viper-go-away - -This startup message appears whenever you load Viper, unless you type `y' now." - )) - (goto-char (point-min)) - (if (y-or-n-p "Inhibit Viper startup message? ") - (viper-save-setting - 'viper-inhibit-startup-message - "Viper startup message inhibited" - viper-custom-file-name t)) - ;;(kill-buffer (current-buffer)) - (message - "The last message is in buffer `Viper Startup Message'") - (sit-for 4) - )) - (viper-set-expert-level 'dont-change-unless))) - - (or (memq major-mode viper-non-vi-major-modes) ; don't switch to Vi - (viper-change-state-to-vi))))) - - -;; This hook designed to enable Vi-style editing in comint-based modes." -(defun viper-comint-mode-hook () - (setq require-final-newline nil - viper-ex-style-editing nil - viper-ex-style-motion nil) - (viper-change-state-to-insert)) - - -;; remove viper hooks from SYMBOL -(defun viper-remove-hooks (symbol) - (cond ((not (boundp symbol)) nil) - ((not (listp (eval symbol))) nil) - ((string-match "-hook" (symbol-name symbol)) - (remove-hook symbol 'viper-mode) - (remove-hook symbol 'viper-change-state-to-emacs) - (remove-hook symbol 'viper-change-state-to-insert) - (remove-hook symbol 'viper-change-state-to-vi) - ))) - -;; Remove local value in all existing buffers -;; This doesn't delocalize vars (which would have been desirable) -(defun viper-delocalize-var (symbol) - (mapcar (function (lambda (buf) - (save-excursion - (set-buffer buf) - (kill-local-variable symbol)))) - (buffer-list))) - - -(defun viper-go-away () - "De-Viperize Emacs. -This function tries to do as good a job as possible. However, it may undo some -user customization, unrelated to Viper. For instance, if the user advised -`read-file-name', `describe-key', and some others, then this advice will be -undone. -It also doesn't undo some Viper settings. For instance, `minor-mode-map-alist' -remains buffer-local." - (interactive) - - ;; restore non-viper vars - (setq-default - default-major-mode - (viper-standard-value 'default-major-mode viper-saved-non-viper-variables) - next-line-add-newlines - (viper-standard-value - 'next-line-add-newlines viper-saved-non-viper-variables) - require-final-newline - (viper-standard-value - 'require-final-newline viper-saved-non-viper-variables) - scroll-step - (viper-standard-value 'scroll-step viper-saved-non-viper-variables) - mode-line-buffer-identification - (viper-standard-value - 'mode-line-buffer-identification viper-saved-non-viper-variables) - global-mode-string - (viper-standard-value 'global-mode-string viper-saved-non-viper-variables)) - - (if viper-emacs-p - (setq-default - mark-even-if-inactive - (viper-standard-value - 'mark-even-if-inactive viper-saved-non-viper-variables))) - - ;; Ideally, we would like to be able to de-localize local variables - (viper-delocalize-var 'minor-mode-map-alist) - (viper-delocalize-var 'require-final-newline) - - - ;; deactivate all advices done by Viper. - (ad-deactivate-regexp "viper-") - - (setq viper-mode nil) - - (viper-delocalize-var 'viper-vi-minibuffer-minor-mode) - (viper-delocalize-var 'viper-insert-minibuffer-minor-mode) - (viper-delocalize-var 'viper-vi-intercept-minor-mode) - (viper-delocalize-var 'viper-insert-intercept-minor-mode) - - (viper-delocalize-var 'viper-vi-local-user-minor-mode) - (viper-delocalize-var 'viper-vi-kbd-minor-mode) - (viper-delocalize-var 'viper-vi-global-user-minor-mode) - (viper-delocalize-var 'viper-vi-state-modifier-minor-mode) - (viper-delocalize-var 'viper-vi-diehard-minor-mode) - (viper-delocalize-var 'viper-vi-basic-minor-mode) - - (viper-delocalize-var 'viper-replace-minor-mode) - - (viper-delocalize-var 'viper-insert-local-user-minor-mode) - (viper-delocalize-var 'viper-insert-kbd-minor-mode) - (viper-delocalize-var 'viper-insert-global-user-minor-mode) - (viper-delocalize-var 'viper-insert-state-modifier-minor-mode) - (viper-delocalize-var 'viper-insert-diehard-minor-mode) - (viper-delocalize-var 'viper-insert-basic-minor-mode) - - (viper-delocalize-var 'viper-emacs-intercept-minor-mode) - (viper-delocalize-var 'viper-emacs-local-user-minor-mode) - (viper-delocalize-var 'viper-emacs-kbd-minor-mode) - (viper-delocalize-var 'viper-emacs-global-user-minor-mode) - (viper-delocalize-var 'viper-emacs-state-modifier-minor-mode) - - (setq-default viper-vi-minibuffer-minor-mode nil - viper-insert-minibuffer-minor-mode nil - viper-vi-intercept-minor-mode nil - viper-insert-intercept-minor-mode nil - - viper-vi-local-user-minor-mode nil - viper-vi-kbd-minor-mode nil - viper-vi-global-user-minor-mode nil - viper-vi-state-modifier-minor-mode nil - viper-vi-diehard-minor-mode nil - viper-vi-basic-minor-mode nil - - viper-replace-minor-mode nil - - viper-insert-local-user-minor-mode nil - viper-insert-kbd-minor-mode nil - viper-insert-global-user-minor-mode nil - viper-insert-state-modifier-minor-mode nil - viper-insert-diehard-minor-mode nil - viper-insert-basic-minor-mode nil - - viper-emacs-intercept-minor-mode nil - viper-emacs-local-user-minor-mode nil - viper-emacs-kbd-minor-mode nil - viper-emacs-global-user-minor-mode nil - viper-emacs-state-modifier-minor-mode nil - ) - - ;; remove all hooks set by viper - (mapatoms 'viper-remove-hooks) - (remove-hook 'comint-mode-hook 'viper-comint-mode-hook) - (remove-hook 'minibuffer-setup-hook 'viper-minibuffer-setup-sentinel) - - ;; unbind Viper mouse bindings - (viper-unbind-mouse-search-key) - (viper-unbind-mouse-insert-key) - ;; In emacs, we have to advice handle-switch-frame - ;; This advice is undone earlier, when all advices matchine "viper-" are - ;; deactivated. - (if viper-xemacs-p - (remove-hook 'mouse-leave-frame-hook 'viper-remember-current-frame)) - ) ; end viper-go-away - - - - -;; This sets major mode hooks to make them come up in vi-state. -(defun viper-set-hooks () - - ;; It is of course a misnomer to call viper-mode a `major mode'. - ;; However, this has the effect that if the user didn't specify the - ;; default mode, new buffers that fall back on the default will come up - ;; in Fundamental Mode and Vi state. - (setq default-major-mode 'viper-mode) - - ;; The following major modes should come up in vi-state - (defadvice fundamental-mode (after viper-fundamental-mode-ad activate) - "Run `viper-change-state-to-vi' on entry." - (viper-change-state-to-vi)) - - (defvar makefile-mode-hook) - (add-hook 'makefile-mode-hook 'viper-mode) - - ;; Help mode is now for viewing only - (defvar help-mode-hook) - (add-hook 'help-mode-hook 'viper-change-state-to-emacs) - (viper-modify-major-mode 'help-mode 'emacs-state viper-slash-and-colon-map) - - (defvar awk-mode-hook) - (add-hook 'awk-mode-hook 'viper-mode) - - (defvar html-mode-hook) - (add-hook 'html-mode-hook 'viper-mode) - (defvar html-helper-mode-hook) - (add-hook 'html-helper-mode-hook 'viper-mode) - - (defvar java-mode-hook) - (add-hook 'java-mode-hook 'viper-mode) - - (defvar javascript-mode-hook) - (add-hook 'javascript-mode-hook 'viper-mode) - - (defvar emacs-lisp-mode-hook) - (add-hook 'emacs-lisp-mode-hook 'viper-mode) - (defvar lisp-mode-hook) - (add-hook 'lisp-mode-hook 'viper-mode) - (defvar lisp-interaction-mode-hook) - (add-hook 'lisp-interaction-mode-hook 'viper-mode) - - (defvar bibtex-mode-hook) - (add-hook 'bibtex-mode-hook 'viper-mode) - - (defvar cc-mode-hook) - (add-hook 'cc-mode-hook 'viper-mode) - - (defvar c-mode-hook) - (add-hook 'c-mode-hook 'viper-mode) - - (defvar c++-mode-hook) - (add-hook 'c++-mode-hook 'viper-mode) - - (defvar fortran-mode-hook) - (add-hook 'fortran-mode-hook 'viper-mode) - (defvar f90-mode-hook) - (add-hook 'f90-mode-hook 'viper-mode) - - (defvar basic-mode-hook) - (add-hook 'basic-mode-hook 'viper-mode) - (defvar bat-mode-hook) - (add-hook 'bat-mode-hook 'viper-mode) - - (defvar asm-mode-hook) - (add-hook 'asm-mode-hook 'viper-mode) - - (defvar prolog-mode-hook) - (add-hook 'prolog-mode-hook 'viper-mode) - - (defvar text-mode-hook) - (add-hook 'text-mode-hook 'viper-mode) - - (add-hook 'completion-list-mode-hook 'viper-mode) - (add-hook 'compilation-mode-hook 'viper-mode) - - (defvar perl-mode-hook) - (add-hook 'perl-mode-hook 'viper-mode) - - (defvar tcl-mode-hook) - (add-hook 'tcl-mode-hook 'viper-mode) - - (defvar python-mode-hook) - (add-hook 'python-mode-hook 'viper-mode) - - (defvar emerge-startup-hook) - (add-hook 'emerge-startup-hook 'viper-change-state-to-emacs) - - ;; Tell vc-diff to put *vc* in Vi mode - (if (featurep 'vc) - (defadvice vc-diff (after viper-vc-ad activate) - "Force Vi state in VC diff buffer." - (viper-change-state-to-vi)) - (eval-after-load - "vc" - '(defadvice vc-diff (after viper-vc-ad activate) - "Force Vi state in VC diff buffer." - (viper-change-state-to-vi)))) - - (eval-after-load - "emerge" - '(defadvice emerge-quit (after viper-emerge-advice activate) - "Run `viper-change-state-to-vi' after quitting emerge." - (viper-change-state-to-vi))) - ;; In case Emerge was loaded before Viper. - (defadvice emerge-quit (after viper-emerge-advice activate) - "Run `viper-change-state-to-vi' after quitting emerge." - (viper-change-state-to-vi)) - - ;; passwd.el sets up its own buffer, which turns up in Vi mode, - ;; thus overriding the local map. We don't need Vi mode here. - (eval-after-load - "passwd" - '(defadvice read-passwd-1 (before viper-passwd-ad activate) - "Switch to emacs state while reading password." - (viper-change-state-to-emacs))) - - ;; Emacs shell, ange-ftp, and comint-based modes - (defvar comint-mode-hook) - (viper-modify-major-mode - 'comint-mode 'insert-state viper-comint-mode-modifier-map) - (viper-modify-major-mode - 'comint-mode 'vi-state viper-comint-mode-modifier-map) - (viper-modify-major-mode - 'shell-mode 'insert-state viper-comint-mode-modifier-map) - (viper-modify-major-mode - 'shell-mode 'vi-state viper-comint-mode-modifier-map) - ;; ange-ftp in XEmacs - (viper-modify-major-mode - 'ange-ftp-shell-mode 'insert-state viper-comint-mode-modifier-map) - (viper-modify-major-mode - 'ange-ftp-shell-mode 'vi-state viper-comint-mode-modifier-map) - ;; ange-ftp in Emacs - (viper-modify-major-mode - 'internal-ange-ftp-mode 'insert-state viper-comint-mode-modifier-map) - (viper-modify-major-mode - 'internal-ange-ftp-mode 'vi-state viper-comint-mode-modifier-map) - ;; set hook - (add-hook 'comint-mode-hook 'viper-comint-mode-hook) - - ;; Shell scripts - (defvar sh-mode-hook) - (add-hook 'sh-mode-hook 'viper-mode) - (defvar ksh-mode-hook) - (add-hook 'ksh-mode-hook 'viper-mode) - - ;; Dired - (viper-modify-major-mode 'dired-mode 'emacs-state viper-dired-modifier-map) - (viper-set-emacs-state-searchstyle-macros nil 'dired-mode) - (add-hook 'dired-mode-hook 'viper-change-state-to-emacs) - - ;; Tar - (viper-modify-major-mode 'tar-mode 'emacs-state viper-slash-and-colon-map) - (viper-set-emacs-state-searchstyle-macros nil 'tar-mode) - - ;; MH-E - (viper-modify-major-mode - 'mh-folder-mode 'emacs-state viper-slash-and-colon-map) - (viper-set-emacs-state-searchstyle-macros nil 'mh-folder-mode) - ;; changing state to emacs is needed so the preceding will take hold - (add-hook 'mh-folder-mode-hook 'viper-change-state-to-emacs) - (add-hook 'mh-show-mode-hook 'viper-mode) - - ;; Gnus - (viper-modify-major-mode - 'gnus-group-mode 'emacs-state viper-slash-and-colon-map) - (viper-set-emacs-state-searchstyle-macros nil 'gnus-group-mode) - (viper-modify-major-mode - 'gnus-summary-mode 'emacs-state viper-slash-and-colon-map) - (viper-set-emacs-state-searchstyle-macros nil 'gnus-summary-mode) - ;; changing state to emacs is needed so the preceding will take hold - (add-hook 'gnus-group-mode-hook 'viper-change-state-to-emacs) - (add-hook 'gnus-summary-mode-hook 'viper-change-state-to-emacs) - (add-hook 'gnus-article-mode-hook 'viper-mode) - - ;; Info - (viper-modify-major-mode 'Info-mode 'emacs-state viper-slash-and-colon-map) - (viper-set-emacs-state-searchstyle-macros nil 'Info-mode) - ;; Switching to emacs is needed so the above will take hold - (defadvice Info-mode (after viper-Info-ad activate) - "Switch to emacs mode." - (viper-change-state-to-emacs)) - - ;; Buffer menu - (viper-modify-major-mode - 'Buffer-menu-mode 'emacs-state viper-slash-and-colon-map) - (viper-set-emacs-state-searchstyle-macros nil 'Buffer-menu-mode) - ;; Switching to emacs is needed so the above will take hold - (defadvice Buffer-menu-mode (after viper-Buffer-menu-ad activate) - "Switch to emacs mode." - (viper-change-state-to-emacs)) - - ;; View mode - (defvar view-mode-hook) - (defvar view-hook) - (add-hook 'view-hook 'viper-change-state-to-emacs) - (add-hook 'view-mode-hook 'viper-change-state-to-emacs) - - ;; For VM users. - ;; Put summary and other VM buffers in Emacs state. - (defvar vm-mode-hooks) - (defvar vm-summary-mode-hooks) - (add-hook 'vm-mode-hooks 'viper-change-state-to-emacs) - (add-hook 'vm-summary-mode-hooks 'viper-change-state-to-emacs) - - ;; For RMAIL users. - ;; Put buf in Emacs state after edit. - (eval-after-load - "rmailedit" - '(defadvice rmail-cease-edit (after viper-rmail-advice activate) - "Switch to emacs state when done editing message." - (viper-change-state-to-emacs))) - ;; In case RMAIL was loaded before Viper. - (defadvice rmail-cease-edit (after viper-rmail-advice activate) - "Switch to emacs state when done editing message." - (viper-change-state-to-emacs)) - - ;; ISO accents - ;; Need to do it after loading iso-acc, or else this loading will wipe out - ;; the advice. - (eval-after-load - "iso-acc" - (defadvice iso-accents-mode (around viper-iso-accents-advice activate) - "Set viper-automatic-iso-accents to iso-accents-mode." - (let ((arg (ad-get-arg 0))) - ad-do-it - (setq viper-automatic-iso-accents - (if (eq viper-current-state 'vi-state) - (if arg - ;; if iso-accents-mode was called with positive arg, turn - ;; accents on - (> (prefix-numeric-value arg) 0) - ;; else: toggle viper-automatic-iso-accents - (not viper-automatic-iso-accents)) - ;; other states: accept what iso-accents-mode has done - iso-accents-mode)) - ;; turn off ISO accents in vi-state - (if (eq viper-current-state 'vi-state) - (viper-set-iso-accents-mode nil)) - (if (memq viper-current-state '(vi-state insert-state replace-state)) - (message "Viper ISO accents mode: %s" - (if viper-automatic-iso-accents "on" "off"))) - ))) - - ;; International input methods - (if viper-emacs-p - (eval-after-load "mule-cmds" - (progn - (defadvice inactivate-input-method (after viper-mule-advice activate) - "Set viper-special-input-method to disable intl. input methods." - (viper-inactivate-input-method-action)) - (defadvice activate-input-method (after viper-mule-advice activate) - "Set viper-special-input-method to enable intl. input methods." - (viper-activate-input-method-action)) - )) - ;; XEmacs Although these hooks exist in Emacs, they don't seem to be always - ;; called on input-method activation/deactivation, so we the above advise - ;; functions instead. - (eval-after-load "mule-cmds" - (progn - (add-hook 'input-method-activate-hook - 'viper-activate-input-method-action t) - (add-hook 'input-method-inactivate-hook - 'viper-inactivate-input-method-action t))) - ) - (eval-after-load "mule-cmds" - (defadvice toggle-input-method (around viper-mule-advice activate) - "Adjust input-method toggling in vi-state." - (if (and viper-special-input-method (eq viper-current-state 'vi-state)) - (viper-inactivate-input-method) - ad-do-it))) - - ) ; viper-set-hooks - - -;; these are primarily advices and Vi-ish variable settings -(defun viper-non-hook-settings () - - ;; This var is not local in Emacs, so we make it local. It must be local - ;; because although the stack of minor modes can be the same for all buffers, - ;; the associated *keymaps* can be different. In Viper, - ;; viper-vi-local-user-map, viper-insert-local-user-map, and others can have - ;; different keymaps for different buffers. Also, the keymaps associated - ;; with viper-vi/insert-state-modifier-minor-mode can be different. - (make-variable-buffer-local 'minor-mode-map-alist) - - ;; Viper changes the default mode-line-buffer-identification - (setq-default mode-line-buffer-identification '(" %b")) - - ;; setup emacs-supported vi-style feel - (setq next-line-add-newlines nil - require-final-newline t) - - (make-variable-buffer-local 'require-final-newline) - - ;; don't bark when mark is inactive - (if viper-emacs-p - (setq mark-even-if-inactive t)) - - (setq scroll-step 1) - - ;; Variable displaying the current Viper state in the mode line. - (viper-deflocalvar viper-mode-string viper-emacs-state-id) - (or (memq 'viper-mode-string global-mode-string) - (setq global-mode-string - (append '("" viper-mode-string) (cdr global-mode-string)))) - - (defadvice read-key-sequence (around viper-read-keyseq-ad activate) - "Harness to work for Viper. This advice is harmless---don't worry!" - (let (inhibit-quit event keyseq) - (setq keyseq ad-do-it) - (setq event (if viper-xemacs-p - (elt keyseq 0) ; XEmacs returns vector of events - (elt (listify-key-sequence keyseq) 0))) - (if (viper-ESC-event-p event) - (let (unread-command-events) - (viper-set-unread-command-events keyseq) - (if (viper-fast-keysequence-p) - (let ((viper-vi-global-user-minor-mode nil) - (viper-vi-local-user-minor-mode nil) - (viper-replace-minor-mode nil) ; actually unnecessary - (viper-insert-global-user-minor-mode nil) - (viper-insert-local-user-minor-mode nil)) - (setq keyseq ad-do-it)) - (setq keyseq ad-do-it)))) - keyseq)) - - (defadvice describe-key (before viper-read-keyseq-ad protect activate) - "Force to read key via `read-key-sequence'." - (interactive (list (viper-events-to-keys - (read-key-sequence "Describe key: "))))) - - (defadvice describe-key-briefly - (before viper-read-keyseq-ad protect activate) - "Force to read key via `read-key-sequence'." - (interactive (list (viper-events-to-keys - (read-key-sequence "Describe key briefly: "))))) - - - ;; This is now done in viper-minibuffer-exit-hook - ;;;; Advice for use in find-file and read-file-name commands. - ;;(defadvice exit-minibuffer (before viper-exit-minibuffer-advice activate) - ;; "Run `viper-minibuffer-exit-hook' just before exiting the minibuffer." - ;; (run-hooks 'viper-minibuffer-exit-hook)) - - (defadvice find-file (before viper-add-suffix-advice activate) - "Use `read-file-name' for reading arguments." - (interactive (cons (read-file-name "Find file: " nil default-directory) - ;; if Mule and prefix argument, ask for coding system - (cond ((and viper-emacs-p - (boundp 'MULE)) ; Emacs 20 with MULE - nil) - ((and viper-xemacs-p - (featurep 'mule)) ; XEmacs 20 with MULE - (list - (and current-prefix-arg - (read-coding-system - "Coding-system: ")))) - ) - ))) - - (defadvice find-file-other-window (before viper-add-suffix-advice activate) - "Use `read-file-name' for reading arguments." - (interactive (cons (read-file-name "Find file in other window: " - nil default-directory) - ;; if Mule and prefix argument, ask for coding system - (cond ((and viper-emacs-p - (boundp 'MULE)) ; Emacs 20 with MULE - nil) - ((and viper-xemacs-p - (featurep 'mule)) ; XEmacs 20 with MULE - (list - (and current-prefix-arg - (read-coding-system - "Coding-system: ")))) - ) - ))) - - - (defadvice find-file-other-frame (before viper-add-suffix-advice activate) - "Use `read-file-name' for reading arguments." - (interactive (cons (read-file-name "Find file in other frame: " - nil default-directory) - ;; if Mule and prefix argument, ask for coding system - (cond ((and viper-emacs-p - (boundp 'MULE)) ; Emacs 20 with MULE - nil) - ((and viper-xemacs-p - (featurep 'mule)) ; XEmacs 20 with MULE - (list - (and current-prefix-arg - (read-coding-system - "Coding-system: ")))) - ) - ))) - - - (defadvice read-file-name (around viper-suffix-advice activate) - "Tell `exit-minibuffer' to run `viper-file-add-suffix' as a hook." - (let ((viper-minibuffer-exit-hook - (append viper-minibuffer-exit-hook '(viper-file-add-suffix)))) - ad-do-it)) - - (defadvice start-kbd-macro (after viper-kbd-advice activate) - "Remove Viper's intercepting bindings for C-x ). - This may be needed if the previous `:map' command terminated abnormally." - (define-key viper-vi-intercept-map "\C-x)" nil) - (define-key viper-insert-intercept-map "\C-x)" nil) - (define-key viper-emacs-intercept-map "\C-x)" nil)) - - ;; catch frame switching event - (if (viper-window-display-p) - (if viper-xemacs-p - (add-hook 'mouse-leave-frame-hook - 'viper-remember-current-frame) - (defadvice handle-switch-frame (before viper-frame-advice activate) - "Remember the selected frame before the switch-frame event." - (viper-remember-current-frame (selected-frame)))) ) - - ) ; end viper-non-hook-settings - - -;; Ask only if this-command/last-command are nil, i.e., when loading -(cond ((and (eq viper-mode 'ask) (null this-command) (null last-command)) - (save-window-excursion - (with-output-to-temp-buffer " *viper-info*" - (princ " -You have loaded Viper, and are about to Viperize your emacs! - -Viper is a Package for Emacs Rebels and a venomous VI PERil, - -It's time to decide: to Viperize or not to Viperize... - -If you wish to Viperize AND make this your way of life, please put - - (setq viper-mode t) - (require 'viper) - -in your .emacs file (preferably, close to the top). -These two lines must come in the order given. - -** Viper users: - **** The startup file name has been changed from .vip to .viper - **** All vip-* style names have been converted to viper-* style.")) - (if (y-or-n-p "Viperize? ") - (setq viper-mode t) - (setq viper-mode nil)) - (message "") - (kill-buffer " *viper-info*"))) - - ;; If viper-mode is t, then just continue. Viper will kick in. - ((eq viper-mode t)) - ;; Otherwise, it was asking mode and Viper was not loaded through .emacs - ;; In this case, it was either through M-x viper-mode or via something - ;; else, like the custom widget. If Viper was loaded through - ;; M-x viper-mode, then viper will kick in anyway. - (t (setq viper-mode nil))) - -(defun viper-load-custom-file () - (if (and (file-exists-p viper-custom-file-name) - (not noninteractive)) - (load viper-custom-file-name))) - - - - -;; Get viper standard value of SYMBOL. If symbol is customized, get its -;; standard value. Otherwise, get the value saved in the alist STORAGE. If -;; STORAGE is nil, use viper-saved-user-settings. -(defun viper-standard-value (symbol &optional storage) - (or (eval (car (get symbol 'customized-value))) - (eval (car (get symbol 'saved-value))) - (nth 1 (assoc symbol (or storage viper-saved-user-settings))))) - - - -;; save non-viper vars that Viper might change -(if (null viper-saved-non-viper-variables) - (setq viper-saved-non-viper-variables - (list - (cons 'default-major-mode (list default-major-mode)) - (cons 'next-line-add-newlines (list next-line-add-newlines)) - (cons 'require-final-newline (list require-final-newline)) - (cons 'scroll-step (list scroll-step)) - (cons 'mode-line-buffer-identification - (list (default-value 'mode-line-buffer-identification))) - (cons 'global-mode-string (list global-mode-string)) - (if viper-emacs-p - (cons 'mark-even-if-inactive (list mark-even-if-inactive))) - ))) - - -;; Set some useful macros, advices -;; These must be BEFORE ~/.viper is loaded, -;; so the user can unrecord them in ~/.viper. -(if viper-mode - (progn - ;; set advices and some variables that give emacs Vi look. - (viper-non-hook-settings) - - ;; repeat the 2nd previous command without rotating the command history - (viper-record-kbd-macro - (vector viper-repeat-from-history-key '\1) 'vi-state - [(meta x) v i p e r - r e p e a t - f r o m - h i s t o r y return] 't) - ;; repeat the 3d previous command without rotating the command history - (viper-record-kbd-macro - (vector viper-repeat-from-history-key '\2) 'vi-state - [(meta x) v i p e r - r e p e a t - f r o m - h i s t o r y return] 't) - - ;; set macros for toggling case sensitivity and regexp search - (viper-set-searchstyle-toggling-macros nil) - ;; Make %%% toggle parsing comments for matching parentheses - (viper-set-parsing-style-toggling-macro nil) - - ;; ~/.viper is loaded if exists - (viper-load-custom-file) - - ;; should be after loading custom file to avoid the pesky msg that - ;; mouse-search/insert keys are already bound - (viper-bind-mouse-search-key) - (viper-bind-mouse-insert-key) - )) - - - -;; Applying Viper customization -- runs after (load .viper) - -;; Save user settings or Viper defaults for vars controled by -;; viper-expert-level -(if (null viper-saved-user-settings) - (setq viper-saved-user-settings - (list (cons 'viper-want-ctl-h-help (list viper-want-ctl-h-help)) - (cons 'viper-always (list viper-always)) - (cons 'viper-no-multiple-ESC (list viper-no-multiple-ESC)) - (cons 'viper-ex-style-motion (list viper-ex-style-motion)) - (cons 'viper-ex-style-editing - (list viper-ex-style-editing)) - (cons 'viper-want-emacs-keys-in-vi - (list viper-want-emacs-keys-in-vi)) - (cons 'viper-electric-mode (list viper-electric-mode)) - (cons 'viper-want-emacs-keys-in-insert - (list viper-want-emacs-keys-in-insert)) - (cons 'viper-re-search (list viper-re-search))))) - - -(if viper-mode - (progn - (viper-set-minibuffer-style) - (if viper-buffer-search-char - (viper-buffer-search-enable)) - (viper-update-syntax-classes 'set-default) - )) - - -;;; Familiarize Viper with some minor modes that have their own keymaps -(if viper-mode - (progn - (viper-harness-minor-mode "compile") - (viper-harness-minor-mode "outline") - (viper-harness-minor-mode "allout") - (viper-harness-minor-mode "xref") - (viper-harness-minor-mode "lmenu") - (viper-harness-minor-mode "vc") - (viper-harness-minor-mode "ltx-math") ; LaTeX-math-mode in AUC-TeX, which - (viper-harness-minor-mode "latex") ; sits in one of these two files - (viper-harness-minor-mode "cyrillic") - (viper-harness-minor-mode "russian") - (viper-harness-minor-mode "view-less") - (viper-harness-minor-mode "view") - )) - - -;; Intercept maps could go in viper-keym.el -;; We keep them here in case someone redefines them in ~/.viper - -(define-key viper-vi-intercept-map viper-ESC-key 'viper-intercept-ESC-key) -(define-key viper-insert-intercept-map viper-ESC-key 'viper-intercept-ESC-key) - -;; This is taken care of by viper-insert-global-user-map. -;;(define-key viper-replace-map viper-ESC-key 'viper-intercept-ESC-key) - - -;; The default viper-toggle-key is \C-z; for the novice, it suspends or -;; iconifies Emacs -(define-key viper-vi-intercept-map viper-toggle-key 'viper-toggle-key-action) -(define-key - viper-emacs-intercept-map viper-toggle-key 'viper-change-state-to-vi) - - -(if (and viper-mode - (or viper-always - (and (< viper-expert-level 5) (> viper-expert-level 0)))) - (viper-set-hooks)) - -;; Let all minor modes take effect after loading -;; this may not be enough, so we also set default minor-mode-alist. -;; Without setting the default, new buffers that come up in emacs mode have -;; minor-mode-map-alist = nil, unless we call viper-change-state-* -(if (eq viper-current-state 'emacs-state) - (progn - (viper-change-state-to-emacs) - (setq-default minor-mode-map-alist minor-mode-map-alist) - )) - - - -(run-hooks 'viper-load-hook) ; the last chance to change something - -(provide 'viper) - - -;;; Local Variables: -;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) -;;; End: - -;;; viper.el ends here
--- a/lisp/vm/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,235 +0,0 @@ -# what Emacs version to build VM for. -# Allowed values are 18 and 19. -# Version 18 of Emacs is UNSUPPORTED. -# In fact all versions of Emacs prior to 19.34 for Emacs and -# prior to 19.14 for XEmacs are unsupported. For v20 XEmacs -# EMACS_VERSION should remain 19. -# -EMACS_VERSION = 19 - -# what emacs is called on your system -EMACS = emacs - -# where the Info file should go -INFODIR = /usr/local/lib/emacs/info - -# where the vm.elc, tapestry.elc, etc. files should go -LISPDIR = /usr/local/lib/emacs/site-lisp - -# where the toolbar pixmaps should go. -# vm-toolbar-pixmap-directory must point to the same place. -# vm-image-directory must point to the same place. -PIXMAPDIR = /usr/local/lib/emacs/etc/vm - -############## no user servicable parts beyond this point ################### - -# no csh please -SHELL = /bin/sh - -# byte compiler options -BYTEOPTS = ./vm-byteopts.el - -# have to preload the files that contain macro definitions or the -# byte compiler will compile everything that references them -# incorrectly. also preload a file that sets byte compiler options. -PRELOADS = -l $(BYTEOPTS) -l ./vm-message.el -l ./vm-misc.el -l ./vm-vars.el -l ./vm-version.el - -# compile with noninteractive and relatively clean environment -BATCHFLAGS = -batch -q -no-site-file - -# files that contain key macro definitions. almost everything -# depends on them because the byte-compiler inlines macro -# expansions. everything also depends on the byte compiler -# options file since this might do odd things like turn off -# certain compiler optimizations. -CORE = vm-message.el vm-misc.el vm-byteopts.el - -OBJECTS = \ - vm-delete.elc vm-digest.elc vm-easymenu.elc vm-edit.elc vm-folder.elc \ - vm-license.elc vm-mark.elc vm-menu.elc vm-message.elc \ - vm-mime.elc vm-minibuf.elc vm-misc.elc vm-mouse.elc \ - vm-motion.elc vm-page.elc vm-pop.elc vm-reply.elc \ - vm-save.elc \ - vm-search.elc vm-sort.elc vm-summary.elc vm-startup.elc vm-thread.elc \ - vm-toolbar.elc vm-undo.elc \ - vm-user.elc vm-vars.elc vm-version.elc vm-virtual.elc vm-window.elc - -SOURCES = \ - vm-delete.el vm-digest.el vm-easymenu.el vm-edit.el vm-folder.el \ - vm-license.el vm-mark.el vm-menu.el vm-message.el \ - vm-mime.el vm-minibuf.el vm-misc.el vm-mouse.el \ - vm-motion.el vm-page.el vm-pop.el vm-reply.el vm-save.el \ - vm-search.el vm-sort.el vm-startup.el vm-summary.el vm-thread.el \ - vm-toolbar.el vm-undo.el \ - vm-user.el vm-vars.el vm-version.el vm-virtual.el vm-window.el - -vm: vm.elc - -vm.elc: autoload - -noautoload: $(OBJECTS) tapestry.elc - @echo "building vm.elc (with all modules included)..." - @cat $(OBJECTS) tapestry.elc > vm.elc - -autoload: vm-autoload.elc $(OBJECTS) tapestry.elc - @echo "building vm.elc (with all modules set to autoload)..." - @echo "(require 'vm-startup)" > vm.elc - @echo "(require 'vm-vars)" >> vm.elc - @echo "(require 'vm-version)" >> vm.elc - @echo "(require 'vm-autoload)" >> vm.elc - -all: vm.info vm - -debug: $(SOURCES) tapestry.el - @echo "building vm.elc (uncompiled, no autoloads)..." - @cat $(SOURCES) tapestry.el > vm.elc - -install: all - cp vm.info $(INFODIR)/vm - cp *.elc $(LISPDIR) - cp pixmaps/*.xpm $(PIXMAPDIR) - -clean: - rm -f vm-autoload.el vm-autoload.elc $(OBJECTS) tapestry.elc - -vm.info: vm.texinfo - @echo "making vm.info..." - @$(EMACS) $(BATCHFLAGS) -insert vm.texinfo -l texinfmt -f texinfo-format-buffer -f save-buffer - -vm-autoload.elc: $(SOURCES) - @echo scanning sources to build autoload definitions... - @echo "(provide 'vm-autoload)" > vm-autoload.el - @$(EMACS) $(BATCHFLAGS) -l ./make-autoloads -f print-autoloads $(SOURCES) >> vm-autoload.el - @echo compiling vm-autoload.el... - @$(EMACS) $(BATCHFLAGS) -l $(BYTEOPTS) -f batch-byte-compile vm-autoload.el - -vm-delete.elc: vm-delete.el $(CORE) - @echo compiling vm-delete.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-delete.el - -vm-digest.elc: vm-digest.el $(CORE) - @echo compiling vm-digest.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-digest.el - -vm-edit.elc: vm-edit.el $(CORE) - @echo compiling vm-edit.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-edit.el - -vm-folder.elc: vm-folder.el $(CORE) - @echo compiling vm-folder.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-folder.el - -vm-license.elc: vm-license.el $(CORE) - @echo compiling vm-license.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-license.el - -vm-mark.elc: vm-mark.el $(CORE) - @echo compiling vm-mark.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-mark.el - -vm-menu.elc: vm-menu.el vm-easymenu.el $(CORE) - @echo compiling vm-menu.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -l ./vm-easymenu.el -f batch-byte-compile vm-menu.el - -vm-message.elc: vm-message.el $(CORE) - @echo compiling vm-message.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-message.el - -vm-minibuf.elc: vm-minibuf.el $(CORE) - @echo compiling vm-minibuf.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-minibuf.el - -vm-mime.elc: vm-mime.el $(CORE) - @echo compiling vm-mime.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-mime.el - -vm-misc.elc: vm-misc.el $(CORE) - @echo compiling vm-misc.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-misc.el - -vm-mouse.elc: vm-mouse.el $(CORE) - @echo compiling vm-mouse.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-mouse.el - -vm-motion.elc: vm-motion.el $(CORE) - @echo compiling vm-motion.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-motion.el - -vm-page.elc: vm-page.el $(CORE) - @echo compiling vm-page.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-page.el - -vm-pop.elc: vm-pop.el $(CORE) - @echo compiling vm-pop.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-pop.el - -vm-reply.elc: vm-reply.el $(CORE) - @echo compiling vm-reply.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-reply.el - -vm-save.elc: vm-save.el $(CORE) - @echo compiling vm-save.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-save.el - -vm-search.el: Makefile vm-search$(EMACS_VERSION).el - @echo making vm-search.el... - @{ test -f vm-search.el && \ - cmp -s vm-search.el vm-search$(EMACS_VERSION).el && \ - touch vm-search.el ; } || \ - { rm -f vm-search.el; cp vm-search$(EMACS_VERSION).el vm-search.el ; } - -vm-search.elc: vm-search.el $(CORE) - @echo compiling vm-search.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-search.el - -vm-sort.elc: vm-sort.el $(CORE) - @echo compiling vm-sort.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-sort.el - -vm-startup.elc: vm-startup.el $(CORE) - @echo compiling vm-startup.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-startup.el - -vm-summary.elc: vm-summary.el $(CORE) - @echo compiling vm-summary.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-summary.el - -vm-thread.elc: vm-thread.el $(CORE) - @echo compiling vm-thread.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-thread.el - -vm-toolbar.elc: vm-toolbar.el $(CORE) - @echo compiling vm-toolbar.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-toolbar.el - -vm-undo.elc: vm-undo.el $(CORE) - @echo compiling vm-undo.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-undo.el - -vm-user.elc: vm-user.el $(CORE) - @echo compiling vm-user.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-user.el - -vm-vars.elc: vm-vars.el $(CORE) - @echo compiling vm-vars.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-vars.el - -vm-version.elc: vm-version.el $(CORE) - @echo compiling vm-version.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-version.el - -vm-virtual.elc: vm-virtual.el $(CORE) - @echo compiling vm-virtual.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-virtual.el - -vm-window.elc: vm-window.el $(CORE) - @echo compiling vm-window.el... - @$(EMACS) $(BATCHFLAGS) $(PRELOADS) -f batch-byte-compile vm-window.el - -tapestry.elc: tapestry.el - @echo compiling tapestry.el... - @$(EMACS) $(BATCHFLAGS) -l $(BYTEOPTS) -f batch-byte-compile tapestry.el - -vm-easymenu.elc: vm-easymenu.el - @echo compiling vm-easymenu.el... - @$(EMACS) $(BATCHFLAGS) -l $(BYTEOPTS) -f batch-byte-compile vm-easymenu.el
--- a/lisp/vm/README Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -How to setup VM: - -0) Look at the Makefile and change the values of EMACS_VERSION, - EMACS, INFODIR, LISPDIR, and PIXMAPDIR. If they are not right for your - system, change them. - - Note that version 18 of Emacs is no longer supported. VM may - or may not work under v18. The old v18 support code has been left - in place for those hardy souls who want to attempt it anyway. - -1) Do one of these: - `make'. - `make vm.info' to build the Info online help document. - `make all' to make everything. - Ignore the compiler warnings. - -2) Put all the .elc files into a Lisp directory that Emacs knows - about. (see load-path). - -3) If you're using XEmacs 19.14 and you want toolbar support, - make a directory called `vm' in the XEmacs `etc' directory. - Copy the files in pixmaps directory into the directory you - just created. VM will look for the pixmap there by default. - - Alternately you can put the pixmap files in any directory you - want or just leave them where they are. Be sure to point the - variable vm-toolbar-pixmap-directory at the direrctory where - you put the files. - -4) If you built the Info document, copy the file vm.info file into - the Emacs' info directory under the name "vm". Edit the "dir" - file in that directory and add a menu entry for VM, if it's - not in there already. - -5) Put these lines in your .emacs file if they aren't there - already: - - (autoload 'vm "vm" "Start VM on your primary inbox." t) - (autoload 'vm-other-frame "vm" "Like `vm' but starts in another frame." t) - (autoload 'vm-visit-folder "vm" "Start VM on an arbitrary folder." t) - (autoload 'vm-visit-virtual-folder "vm" "Visit a VM virtual folder." t) - (autoload 'vm-mode "vm" "Run VM major mode on a buffer" t) - (autoload 'vm-mail "vm" "Send a mail message using VM." t) - (autoload 'vm-submit-bug-report "vm" "Send a bug report about VM." t) - -You're now ready to use VM. C-h i should start up the Emacs Info -system and if you've installed the Info document properly you can -use the online documentation to teach yourself how to use VM. -(Note: the Info document is currently only completely accurate for -version 4 of VM.) - -Please use M-x vm-submit-bug-report to report bugs. The bug report -will be sent to bug-vm@uunet.uu.net and be gatewayed from there to -gnu.emacs.vm.bug. - -The latest version of VM can usually be found at ftp.uu.net in -the networking/mail/vm directory.
--- a/lisp/vm/auto-autoloads.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,74 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'vm-autoloads) (error "Already loaded")) - -;;;### (autoloads (vm-easy-menu-create-keymaps vm-easy-menu-define) "vm-easymenu" "vm/vm-easymenu.el") - -(autoload 'vm-easy-menu-define "vm-easymenu" "\ -Define a menu bar submenu in maps MAPS, according to MENU. -The menu keymap is stored in symbol SYMBOL, both as its value -and as its function definition. DOC is used as the doc string for SYMBOL. - -The first element of MENU must be a string. It is the menu bar item name. -The rest of the elements are menu items. - -A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] - -NAME is a string--the menu item name. - -CALLBACK is a command to run when the item is chosen, -or a list to evaluate when the item is chosen. - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - -Alternatively, a menu item may have the form: - - [ NAME CALLBACK [ KEYWORD ARG ] ... ] - -Where KEYWORD is one of the symbol defined below. - - :keys KEYS - -KEYS is a string; a complex keyboard equivalent to this menu item. -This is normally not needed because keyboard equivalents are usually -computed automatically. - - :active ENABLE - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - - :suffix NAME - -NAME is a string; the name of an argument to CALLBACK. - - :style - -STYLE is a symbol describing the type of menu item. The following are -defined: - -toggle: A checkbox. - Currently just prepend the name with the string \"Toggle \". -radio: A radio button. -nil: An ordinary menu item. - - :selected SELECTED - -SELECTED is an expression; the checkbox or radio button is selected -whenever this expression's value is non-nil. -Currently just disable radio buttons, no effect on checkboxes. - -A menu item can be a string. Then that string appears in the menu as -unselectable text. A string consisting solely of hyphens is displayed -as a solid horizontal line. - -A menu item can be a list. It is treated as a submenu. -The first element should be the submenu name. That's used as the -menu item in the top-level menu. The cdr of the submenu list -is a list of menu items, as above." nil 'macro) - -(autoload 'vm-easy-menu-create-keymaps "vm-easymenu" nil nil nil) - -;;;*** - -(provide 'vm-autoloads)
--- a/lisp/vm/make-autoloads Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -(defun member (e list) - (while (and list (not (equal e (car list)))) - (setq list (cdr list))) - list ) - -(defun print-autoloads () - (let ((files (cdr (member "print-autoloads" command-line-args))) - ;; kludge for broken v19 emacs. it's supposed to accept - ;; t in autoloads to mean 'macro but it doesn't. this - ;; kludge will screw people who try to byte-compile VM - ;; with emacs18 for emacs19. - (macro-flag (if (string-match "^19" emacs-version) ''macro t)) - sexp function doc interactive macro) - (setq expanded-files (mapcar (function expand-file-name) files)) - (while files - (set-buffer (find-file-noselect (car expanded-files))) - (goto-char (point-min)) - (condition-case nil - (while t - (setq sexp (read (current-buffer))) - (if (and (consp sexp) (cdr sexp) - (or (eq (car sexp) 'defun) - (eq (car sexp) 'defmacro))) - (progn - (if (eq (car sexp) 'defmacro) - (setq macro macro-flag) - (setq macro nil)) - (setq sexp (cdr sexp) - function (car sexp) - sexp (cdr (cdr sexp))) - (if (stringp (car sexp)) - (setq doc (car sexp) - sexp (cdr sexp)) - (setq doc nil)) - (if (and (consp (car sexp)) - (eq (car (car sexp)) 'interactive)) - (setq interactive t) - (setq interactive nil)) - (if (string-match "\\.el$" (car files)) - (setq file (substring (car files) 0 -3)) - (setq file (car files))) - (print (list 'autoload (list 'quote function) file - doc interactive macro))))) - (end-of-file nil)) - (kill-buffer (current-buffer)) - (setq files (cdr files) - expanded-files (cdr expanded-files)))) - (kill-emacs))
--- a/lisp/vm/tapestry.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,607 +0,0 @@ -;;; Tools to configure your GNU Emacs windows -;;; Copyright (C) 1991, 1993, 1994, 1995, 1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to kyle@uunet.uu.net) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. -;;; -;;; Send bug reports to kyle@uunet.uu.net. - -(provide 'tapestry) - -(defvar tapestry-version "1.08") - -;; Pass state information between the tapestry-set-window-map -;; and tapestry-set-buffer-map stages. UGH. The reason for this -;; is explained in tapestry-set-buffer-map. -(defvar tapestry-windows-changed nil) - -(defun tapestry (&optional frame-list) - "Returns a list containing complete information about the current -configuration of Emacs frames, windows, buffers and cursor -positions. Call the function set-tapestry with the list that this function -returns to restore the configuration. - -Optional first arg FRAME-LIST should be a list of frames; only -configuration information about these frames will be returned. - -The configuration information is returned in a form that can be saved and -restored across multiple Emacs sessions." - (let ((frames (or frame-list (tapestry-frame-list))) - (frame-map (tapestry-frame-map)) - (sf (tapestry-selected-frame)) - (other-maps nil)) - (unwind-protect - (while frames - (tapestry-select-frame (car frames)) - (setq other-maps (cons (list (tapestry-window-map) - (tapestry-buffer-map) - (tapestry-position-map)) - other-maps) - frames (cdr frames))) - (tapestry-select-frame sf)) - (list frame-map other-maps))) - -(defun set-tapestry (map &optional n root-window-edges) - "Restore the frame/window/buffer configuration described by MAP, -which should be a list previously returned by a call to -tapestry. - -Optional second arg N causes frame reconfiguration to be skipped -and the windows of the current frame will configured according to -the window map of the Nth frame in MAP. - -Optional third arg ROOT-WINDOW-EDGES non-nil should be a list -containing the edges of a window in the current frame. This list -should be in the same form as returned by the `window-edges' -function. The window configuration from MAP will be restored in -this window. If no window with these exact edges exists, a -window that lies entirely within the edge coordinates will be -expanded until the edge coordinates match or the window bounded by -ROOT-WINDOW-EDGES is entirely contained within the expanded -window. If no window entirely within the ROOT-WINDOW-EDGES edge -coordinates can be found, the window with the greatest overlap of -ROOT-WINDOW-EDGES will be used." - (let ((sf (tapestry-selected-frame)) - (tapestry-windows-changed nil) - frame-list frame-map other-maps other-map) - (setq frame-map (nth 0 map) - other-maps (nth 1 map)) - (if (and root-window-edges (null n)) - (setq n 1)) - (if n - (let (first-window) - (setq other-map (nth (1- n) other-maps)) - (if (null other-map) - (error "No such map, %d" n)) - (setq first-window - (tapestry-set-window-map (nth 0 other-map) root-window-edges)) - (tapestry-set-buffer-map (nth 1 other-map) first-window) - (tapestry-set-position-map (nth 2 other-map) first-window)) - (tapestry-set-frame-map frame-map) - ;; frame list is reversed relative to the map order because - ;; created frames are added to the head of the list instead - ;; of the tail. - (setq frame-list (nreverse (tapestry-frame-list))) - (unwind-protect - (while other-maps - (tapestry-select-frame (car frame-list)) - (tapestry-set-window-map (nth 0 (car other-maps))) - (tapestry-set-buffer-map (nth 1 (car other-maps))) - (tapestry-set-position-map (nth 2 (car other-maps))) - (setq other-maps (cdr other-maps) - frame-list (cdr frame-list))) - (and (tapestry-frame-live-p sf) (tapestry-select-frame sf)))))) - -(defun tapestry-frame-map () - (let ((map (mapcar 'tapestry-frame-parameters (tapestry-frame-list))) - list cell frame-list) - (setq list map - frame-list (tapestry-frame-list)) - (while list - (setq cell (assq 'minibuffer (car list))) - (if (and cell (windowp (cdr cell))) - (if (eq (tapestry-window-frame (cdr cell)) (car frame-list)) - (setcdr cell t) - (setcdr cell 'none))) - (setq list (cdr list) - frame-list (cdr frame-list))) - map )) - -(defun tapestry-set-frame-map (map) - ;; some parameters can only be set only at frame creation time. - ;; so all existing frames must die. - (let ((doomed-frames (tapestry-frame-list))) - (while map - (tapestry-make-frame (car map)) - (setq map (cdr map))) - (while doomed-frames - (tapestry-delete-frame (car doomed-frames)) - (setq doomed-frames (cdr doomed-frames))))) - -(defun tapestry-window-map () - (let (maps map0 map1 map0-edges map1-edges x-unchanged y-unchanged) - (setq maps (mapcar 'tapestry-window-edges (tapestry-window-list))) - (while (cdr maps) - (setq map0 maps) - (while (cdr map0) - (setq map1 (cdr map0) - map0-edges (tapestry-find-window-map-edges (car map0)) - map1-edges (tapestry-find-window-map-edges (car map1)) - x-unchanged (and (= (car map0-edges) (car map1-edges)) - (= (nth 2 map0-edges) (nth 2 map1-edges))) - y-unchanged (and (= (nth 1 map0-edges) (nth 1 map1-edges)) - (= (nth 3 map0-edges) (nth 3 map1-edges)))) - (cond ((and (not x-unchanged) (not y-unchanged)) - (setq map0 (cdr map0))) - ((or (and x-unchanged (eq (car (car map0)) '-)) - (and y-unchanged (eq (car (car map0)) '|))) - (nconc (car map0) (list (car map1))) - (setcdr map0 (cdr map1))) - (t - (setcar map0 (list (if x-unchanged '- '|) - (car map0) - (car map1))) - (setcdr map0 (cdr map1)))))) - (car maps))) - -(defun tapestry-set-window-map (map &optional root-window-edges) - (let ((map-width (tapestry-compute-map-width map)) - (map-height (tapestry-compute-map-height map)) - (root-window nil)) - (if root-window-edges - (let (w-list w-edges w-area - exact-w inside-w overlap-w max-overlap overlap) - (while (null root-window) - (setq exact-w nil - inside-w nil - overlap-w nil - max-overlap -1 - w-list (tapestry-window-list)) - (while w-list - (setq w-edges (tapestry-window-edges (car w-list)) - w-area (tapestry-window-area w-edges)) - (if (equal w-edges root-window-edges) - (setq exact-w (car w-list) - w-list nil) - (setq overlap (tapestry-window-overlap w-edges - root-window-edges) - overlap (if overlap (tapestry-window-area overlap) 0) - w-area (tapestry-window-area w-edges)) - (if (< max-overlap overlap) - (setq max-overlap overlap - overlap-w (car w-list))) - ;; set inside-w each time we find a window inside - ;; the root window edges. FSF Emacs gives space - ;; to the window above or to the left if there is - ;; such a window. therefore we want to find the - ;; inside window that is bottom-most or right-most so that - ;; when we delete it, its space will be given to - ;; what will be the root window. - (if (= w-area overlap) - (setq inside-w (car w-list))) - (setq w-list (cdr w-list)))) - (cond (exact-w (setq root-window exact-w)) - (inside-w - ;; how could a window be inside the root window - ;; edges and there only be one window? a - ;; multi-line minibuffer, that's how! - (if (not (one-window-p t)) - (delete-window inside-w))) - (t (setq root-window overlap-w)))) - (tapestry-apply-window-map map map-width map-height root-window) - (setq tapestry-windows-changed t) - root-window ) - (if (tapestry-windows-match-map map map-width map-height) - (tapestry-first-window) - (delete-other-windows) - (setq root-window (selected-window)) - (tapestry-apply-window-map map map-width map-height root-window) - (setq tapestry-windows-changed t) - root-window )))) - -(defun tapestry-buffer-map () - (let ((w-list (tapestry-window-list)) - b list) - (while w-list - (setq b (window-buffer (car w-list)) - list (cons (list (buffer-file-name b) - (buffer-name b)) - list) - w-list (cdr w-list))) - (nreverse list))) - -;; This version of tapestry-set-buffer-map unconditionally set -;; the window buffer. This confused XEmacs 19.14's scroll-up -;; function when scrolling VM presentation buffers. -;; end-of-buffer was never signaled after a scroll. You can -;; duplicate this by creating a buffer that can be displayed -;; fully in the current window and then run -;; -;; (progn -;; (set-window-buffer (selected-window) (current-buffer)) -;; (scroll-up nil)) -;;;;;;;;;;; -;;(defun tapestry-set-buffer-map (buffer-map &optional first-window) -;; (let ((w-list (tapestry-window-list first-window)) wb) -;; (while (and w-list buffer-map) -;; (setq wb (car buffer-map)) -;; (set-window-buffer -;; (car w-list) -;; (if (car wb) -;; (or (get-file-buffer (car wb)) -;; (find-file-noselect (car wb))) -;; (get-buffer-create (nth 1 wb)))) -;; (setq w-list (cdr w-list) -;; buffer-map (cdr buffer-map))))) - -(defun tapestry-set-buffer-map (buffer-map &optional first-window) - (let ((w-list (tapestry-window-list first-window)) - current-wb proposed-wb cell) - (while (and w-list buffer-map) - (setq cell (car buffer-map) - proposed-wb (if (car cell) - (or (get-file-buffer (car cell)) - (find-file-noselect (car cell))) - (get-buffer-create (nth 1 cell))) - current-wb (window-buffer (car w-list))) - ;; Setting the window buffer to the same value it already - ;; has seems to confuse XEmacs' scroll-up function. But - ;; _not_ setting after windows torn down seem to cause - ;; window point to sometimes drift away from point at - ;; redisplay time. The solution (hopefully!) is to track - ;; when windows have been rearranged and unconditionally do - ;; the set-window-buffer, otherwise do it only if the - ;; window buffer and the prosed window buffer differ. - (if (or tapestry-windows-changed (not (eq proposed-wb current-wb))) - (set-window-buffer (car w-list) proposed-wb)) - (setq w-list (cdr w-list) - buffer-map (cdr buffer-map))))) - -(defun tapestry-position-map () - (let ((sw (selected-window)) - (w-list (tapestry-window-list)) - list) - (while w-list - (setq list (cons (list (window-start (car w-list)) - (window-point (car w-list)) - (window-hscroll (car w-list)) - (eq (car w-list) sw)) - list) - w-list (cdr w-list))) - (nreverse list))) - -(defun tapestry-set-position-map (position-map &optional first-window) - (let ((w-list (tapestry-window-list first-window)) - (osw (selected-window)) - sw p) - (while (and w-list position-map) - (setq p (car position-map)) - (and (car p) (set-window-start (car w-list) (car p))) - (and (nth 1 p) (set-window-point (car w-list) (nth 1 p))) - (and (nth 2 p) (set-window-hscroll (car w-list) (nth 2 p))) - (and (nth 3 p) (setq sw (car w-list))) - ;; move this buffer up in the buffer-list - (select-window (car w-list)) - (setq w-list (cdr w-list) - position-map (cdr position-map))) - (select-window (or sw osw)))) - -(defun tapestry-apply-window-map (map map-width map-height current-window - &optional - root-window-width - root-window-height) - (let ((window-min-height 1) - (window-min-width 1) - horizontal) - (if (null root-window-width) - (setq root-window-height (window-height current-window) - root-window-width (window-width current-window))) - (while map - (cond - ((numberp (car map)) (setq map nil)) - ((eq (car map) '-) (setq horizontal nil)) - ((eq (car map) '|) (setq horizontal t)) - (t - (if (cdr map) - (split-window - current-window - (if horizontal - (/ (* (tapestry-compute-map-width (car map)) - root-window-width) - map-width) - (/ (* (tapestry-compute-map-height (car map)) - root-window-height) - map-height)) - horizontal)) - (if (not (numberp (car (car map)))) - (setq current-window - (tapestry-apply-window-map (car map) - map-width map-height - current-window - root-window-width - root-window-height))) - (and (cdr map) (setq current-window (next-window current-window 0))))) - (setq map (cdr map))) - current-window )) - -(defun tapestry-windows-match-map (map - &optional - map-width map-height - window-map - window-map-width - window-map-height) - (or map-width - (setq map-width (tapestry-compute-map-width map) - map-height (tapestry-compute-map-height map))) - (or window-map - (setq window-map (tapestry-window-map) - window-map-height (tapestry-compute-map-height window-map) - window-map-width (tapestry-compute-map-width window-map))) - (let ((result t)) - (cond ((numberp (car map)) - (and (numberp (car window-map)) - (= (/ (* (nth 0 map) window-map-width) - map-width) - (nth 0 window-map)) - (= (/ (* (nth 1 map) window-map-height) - map-height) - (nth 1 window-map)) - (= (/ (* (nth 2 map) window-map-width) - map-width) - (nth 2 window-map)) - (= (/ (* (nth 3 map) window-map-height) - map-height) - (nth 3 window-map)))) - ((eq (car map) '-) - (if (not (eq (car window-map) '-)) - nil - (setq map (cdr map) - window-map (cdr window-map)) - (while (and result map window-map) - (setq result (tapestry-windows-match-map (car map) - map-width - map-height - (car window-map) - window-map-width - window-map-height) - map (cdr map) - window-map (cdr window-map))) - (and result (null map) (null window-map)))) - ((eq (car map) '|) - (if (not (eq (car window-map) '|)) - nil - (setq map (cdr map) - window-map (cdr window-map)) - (while (and result map window-map) - (setq result (tapestry-windows-match-map (car map) - map-width - map-height - (car window-map) - window-map-width - window-map-height) - map (cdr map) - window-map (cdr window-map))) - (and result (null map) (null window-map))))))) - -(defun tapestry-find-window-map-edges (map) - (let (nw-edges se-edges) - (setq nw-edges map) - (while (and (consp nw-edges) (not (numberp (car nw-edges)))) - (setq nw-edges (car (cdr nw-edges)))) - (setq se-edges map) - (while (and (consp se-edges) (not (numberp (car se-edges)))) - (while (cdr se-edges) - (setq se-edges (cdr se-edges))) - (setq se-edges (car se-edges))) - (if (eq nw-edges se-edges) - nw-edges - (setq nw-edges (copy-sequence nw-edges)) - (setcdr (nthcdr 1 nw-edges) (nthcdr 2 se-edges)) - nw-edges ))) - -(defun tapestry-compute-map-width (map) - (let ((edges (tapestry-find-window-map-edges map))) - (- (nth 2 edges) (car edges)))) - -(defun tapestry-compute-map-height (map) - (let ((edges (tapestry-find-window-map-edges map))) - (- (nth 3 edges) (nth 1 edges)))) - -;; delq is to memq as delassq is to assq -(defun tapestry-delassq (elt list) - (let ((prev nil) - (curr list)) - (while curr - (if (eq elt (car (car curr))) - (if (null prev) - (setq list (cdr list) curr list) - (setcdr prev (cdr curr)) - (setq curr (cdr curr))) - (setq prev curr curr (cdr curr)))) - list )) - -(defun tapestry-remove-frame-parameters (map params) - (let (frame-map) - (while params - (setq frame-map (nth 0 map)) - (while frame-map - (setcar frame-map (tapestry-delassq (car params) (car frame-map))) - (setq frame-map (cdr frame-map))) - (setq params (cdr params))))) - -(defun tapestry-nullify-tapestry-elements (map &optional buf-file-name buf-name - window-start window-point - window-hscroll selected-window) - (let (p) - (setq map (nth 1 map)) - (while map - (setq p (nth 1 (car map))) - (while p - (and buf-file-name (setcar (car p) nil)) - (and buf-name (setcar (cdr (car p)) nil)) - (setq p (cdr p))) - (setq p (nth 2 (car map))) - (while p - (and window-start (setcar (car p) nil)) - (and window-point (setcar (cdr (car p)) nil)) - (and window-hscroll (setcar (nthcdr 2 (car p)) nil)) - (and selected-window (setcar (nthcdr 3 (car p)) nil)) - (setq p (cdr p))) - (setq map (cdr map))))) - -(defun tapestry-replace-tapestry-element (map what function) - (let (mapi mapj p old new) - (cond ((eq what 'buffer-file-name) - (setq mapi 1 mapj 0)) - ((eq what 'buffer-name) - (setq mapi 1 mapj 1)) - ((eq what 'window-start) - (setq mapi 2 mapj 0)) - ((eq what 'window-point) - (setq mapi 2 mapj 1)) - ((eq what 'window-hscroll) - (setq mapi 2 mapj 2)) - ((eq what 'selected-window) - (setq mapi 2 mapj 3))) - (setq map (nth 1 map)) - (while map - (setq p (nth mapi (car map))) - (while p - (setq old (nth mapj (car p)) - new (funcall function old)) - (if (not (equal old new)) - (setcar (nthcdr mapj (car p)) new)) - (setq p (cdr p))) - (setq map (cdr map))))) - -(defun tapestry-window-list (&optional first-window) - (let* ((first-window (or first-window (tapestry-first-window))) - (windows (cons first-window nil)) - (current-cons windows) - (w (next-window first-window 'nomini))) - (while (not (eq w first-window)) - (setq current-cons (setcdr current-cons (cons w nil))) - (setq w (next-window w 'nomini))) - windows )) - -(defun tapestry-first-window () - (if (eq (tapestry-selected-frame) - (tapestry-window-frame (minibuffer-window))) - (next-window (minibuffer-window)) - (let ((w (selected-window)) - (top (or (cdr (assq 'menu-bar-lines (tapestry-frame-parameters))) 0)) - edges) - (while (or (not (= 0 (car (setq edges (tapestry-window-edges w))))) - ;; >= instead of = because in FSF Emacs 19.2x - ;; (whenever the Lucid menubar code was added) the - ;; menu-bar-lines frame parameter == 1 when the - ;; Lucid menubar is enabled even though the - ;; menubar doesn't steal the first line from the - ;; window. - (not (>= top (nth 1 edges)))) - (setq w (next-window w 'nomini))) - w ))) - -(defun tapestry-window-area (edges) - (* (- (nth 3 edges) (nth 1 edges)) - (- (nth 2 edges) (nth 0 edges)))) - -(defun tapestry-window-overlap (e0 e1) - (let (top left bottom right) - (cond ((and (<= (nth 0 e0) (nth 0 e1)) (< (nth 0 e1) (nth 2 e0))) - (setq left (nth 0 e1))) - ((and (<= (nth 0 e1) (nth 0 e0)) (< (nth 0 e0) (nth 2 e1))) - (setq left (nth 0 e0)))) - (cond ((and (< (nth 0 e0) (nth 2 e1)) (<= (nth 2 e1) (nth 2 e0))) - (setq right (nth 2 e1))) - ((and (< (nth 0 e1) (nth 2 e0)) (<= (nth 2 e0) (nth 2 e1))) - (setq right (nth 2 e0)))) - (cond ((and (<= (nth 1 e0) (nth 1 e1)) (< (nth 1 e1) (nth 3 e0))) - (setq top (nth 1 e1))) - ((and (<= (nth 1 e1) (nth 1 e0)) (< (nth 1 e0) (nth 3 e1))) - (setq top (nth 1 e0)))) - (cond ((and (< (nth 1 e0) (nth 3 e1)) (<= (nth 3 e1) (nth 3 e0))) - (setq bottom (nth 3 e1))) - ((and (< (nth 1 e1) (nth 3 e0)) (<= (nth 3 e0) (nth 3 e1))) - (setq bottom (nth 3 e0)))) - (and left top right bottom (list left top right bottom)))) - -(defun tapestry-window-edges (&optional window) - (if (fboundp 'window-pixel-edges) - (let ((edges (window-pixel-edges window)) - tmp) - (setq tmp edges) - (setcar tmp (/ (car tmp) (face-width 'default))) - (setq tmp (cdr tmp)) - (setcar tmp (/ (car tmp) (face-height 'default))) - (setq tmp (cdr tmp)) - (setcar tmp (/ (car tmp) (face-width 'default))) - (setq tmp (cdr tmp)) - (setcar tmp (/ (car tmp) (face-height 'default))) - edges ) - (window-edges window))) - -;; We call these functions instead of calling the Emacs 19 frame -;; functions directly to let this package work with v18 Emacs. - -(defun tapestry-frame-list () - (if (fboundp 'frame-list) - (frame-list) - (list nil))) - -(defun tapestry-frame-parameters (&optional f) - (if (fboundp 'frame-parameters) - (frame-parameters f) - nil )) - -(defun tapestry-window-frame (w) - (if (fboundp 'window-frame) - (window-frame w) - nil )) - -(defun tapestry-modify-frame-parameters (f alist) - (if (fboundp 'modify-frame-parameters) - (modify-frame-parameters f alist) - nil )) - -(defun tapestry-select-frame (f) - (if (fboundp 'select-frame) - (select-frame f) - nil )) - -(defun tapestry-selected-frame () - (if (fboundp 'selected-frame) - (selected-frame) - nil )) - -(defun tapestry-next-frame (&optional f all) - (if (fboundp 'next-frame) - (next-frame f all) - nil )) - -(defun tapestry-make-frame (&optional alist) - (if (fboundp 'make-frame) - (make-frame alist) - nil )) - -(defun tapestry-delete-frame (&optional f) - (if (fboundp 'delete-frame) - (delete-frame f) - nil )) - -(defun tapestry-frame-live-p (f) - (if (fboundp 'frame-live-p) - (frame-live-p f) - t ))
--- a/lisp/vm/vm-byteopts.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -(provide 'vm-byteopts) - -;; get the compiler loaded so we can undo some of the things that -;; happen when it's loaded. -(load "bytecomp" t t nil) -;; Emacs 19 byte compiler complains about too much stuff by default. -;; Turn off most of the warnings here. -(setq byte-compile-warnings '(free-vars)) -;; need to use these variables for v18 support. -;; stifle the compiler. -(put 'inhibit-local-variables 'byte-obsolete-variable nil) -;; Turn off dynamic docstrings and lazy function loading. This -;; is a new feature of FSF Emacs 19.29, and is incompatible -;; with pre-19.29 versions of FSF Emacs and all version of Lucid -;; Emacs / XEmacs. I like being able to share .elc files between -;; different v19 Emacses. -(setq byte-compile-dynamic nil) -(setq byte-compile-dynamic-docstrings nil)
--- a/lisp/vm/vm-delete.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,307 +0,0 @@ -;;; Delete and expunge commands for VM. -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-delete) - -(defun vm-delete-message (count) - "Add the `deleted' attribute to the current message. - -The message will be physically deleted from the current folder the next -time the current folder is expunged. - -With a prefix argument COUNT, the current message and the next -COUNT - 1 messages are deleted. A negative argument means -the current message and the previous |COUNT| - 1 messages are -deleted. - -When invoked on marked messages (via vm-next-command-uses-marks), -only marked messages are deleted, other messages are ignored." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) - (mlist (vm-select-marked-or-prefixed-messages count)) - (del-count 0)) - (while mlist - (if (not (vm-deleted-flag (car mlist))) - (progn - (vm-set-deleted-flag (car mlist) t) - (vm-increment del-count))) - (setq mlist (cdr mlist))) - (vm-display nil nil '(vm-delete-message vm-delete-message-backward) - (list this-command)) - (if (and used-marks (interactive-p)) - (if (zerop del-count) - (message "No messages deleted") - (message "%d message%s deleted" - del-count - (if (= 1 del-count) "" "s")))) - (vm-update-summary-and-mode-line) - (if (and vm-move-after-deleting (not used-marks)) - (let ((vm-circular-folders (and vm-circular-folders - (eq vm-move-after-deleting t)))) - (vm-next-message count t executing-kbd-macro))))) - -(defun vm-delete-message-backward (count) - "Like vm-delete-message, except the deletion direction is reversed." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-delete-message (- count))) - -(defun vm-undelete-message (count) - "Remove the `deleted' attribute from the current message. - -With a prefix argument COUNT, the current message and the next -COUNT - 1 messages are undeleted. A negative argument means -the current message and the previous |COUNT| - 1 messages are -deleted. - -When invoked on marked messages (via vm-next-command-uses-marks), -only marked messages are undeleted, other messages are ignored." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) - (mlist (vm-select-marked-or-prefixed-messages count)) - (undel-count 0)) - (while mlist - (if (vm-deleted-flag (car mlist)) - (progn - (vm-set-deleted-flag (car mlist) nil) - (vm-increment undel-count))) - (setq mlist (cdr mlist))) - (if (and used-marks (interactive-p)) - (if (zerop undel-count) - (message "No messages undeleted") - (message "%d message%s undeleted" - undel-count - (if (= 1 undel-count) - "" "s")))) - (vm-display nil nil '(vm-undelete-message) '(vm-undelete-message)) - (vm-update-summary-and-mode-line) - (if (and vm-move-after-undeleting (not used-marks)) - (let ((vm-circular-folders (and vm-circular-folders - (eq vm-move-after-undeleting t)))) - (vm-next-message count t executing-kbd-macro))))) - -(defun vm-kill-subject (&optional arg) - "Delete all messages with the same subject as the current message. -Message subjects are compared after ignoring parts matched by -the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix. - -The optional prefix argument ARG specifies the direction to move -if vm-move-after-killing is non-nil. The default direction is -forward. A positive prefix argument means move forward, a -negative arugment means move backward, a zero argument means -don't move at all." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (let ((subject (vm-so-sortable-subject (car vm-message-pointer))) - (mp vm-message-list) - (n 0) - (case-fold-search t)) - (while mp - (if (and (not (vm-deleted-flag (car mp))) - (string-equal subject (vm-so-sortable-subject (car mp)))) - (progn - (vm-set-deleted-flag (car mp) t) - (vm-increment n))) - (setq mp (cdr mp))) - (and (interactive-p) - (if (zerop n) - (message "No messages deleted.") - (message "%d message%s deleted" n (if (= n 1) "" "s"))))) - (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject)) - (vm-update-summary-and-mode-line) - (cond ((or (not (numberp arg)) (> arg 0)) - (setq arg 1)) - ((< arg 0) - (setq arg -1)) - (t (setq arg 0))) - (if vm-move-after-killing - (let ((vm-circular-folders (and vm-circular-folders - (eq vm-move-after-killing t)))) - (vm-next-message arg t executing-kbd-macro)))) - -(defun vm-expunge-folder (&optional shaddap) - "Expunge messages with the `deleted' attribute. -For normal folders this means that the deleted messages are -removed from the message list and the message contents are -removed from the folder buffer. - -For virtual folders, messages are removed from the virtual -message list. If virtual mirroring is in effect for the virtual -folder, the corresponding real messages are also removed from real -message lists and the message contents are removed from real folders. - -When invoked on marked messages (via vm-next-command-uses-marks), -only messages both marked and deleted are expunged, other messages are -ignored." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - ;; do this so we have a clean slate. code below depends on the - ;; fact that the numbering redo start point begins as nil in - ;; all folder buffers. - (vm-update-summary-and-mode-line) - (if (not shaddap) - (message "Expunging...")) - (let ((use-marks (eq last-command 'vm-next-command-uses-marks)) - (mp vm-message-list) - (virtual (eq major-mode 'vm-virtual-mode)) - (buffers-altered (make-vector 29 0)) - prev virtual-messages) - (while mp - (cond - ((and (vm-deleted-flag (car mp)) - (or (not use-marks) - (vm-mark-of (car mp)))) - ;; remove the message from the thread tree. - (if vm-thread-obarray - (vm-unthread-message (vm-real-message-of (car mp)))) - ;; expunge from the virtual side first, removing all - ;; references to this message before actually removing - ;; the message itself. - (cond - ((setq virtual-messages (vm-virtual-messages-of (car mp))) - (let (vms prev curr) - (if virtual - (setq vms (cons (vm-real-message-of (car mp)) - (vm-virtual-messages-of (car mp)))) - (setq vms (vm-virtual-messages-of (car mp)))) - (while vms - (save-excursion - (set-buffer (vm-buffer-of (car vms))) - (setq prev (vm-reverse-link-of (car vms)) - curr (or (cdr prev) vm-message-list)) - (intern (buffer-name) buffers-altered) - (vm-set-numbering-redo-start-point (or prev t)) - (vm-set-summary-redo-start-point (or prev t)) - (if (eq vm-message-pointer curr) - (setq vm-system-state nil - vm-message-pointer (or prev (cdr curr)))) - (if (eq vm-last-message-pointer curr) - (setq vm-last-message-pointer nil)) - ;; lock out interrupts to preserve message-list integrity - (let ((inhibit-quit t)) - ;; vm-clear-expunge-invalidated-undos uses - ;; this to recognize expunged messages. - ;; If this stuff is mirrored we'll be - ;; setting this value multiple times if there - ;; are multiple virtual messages referencing - ;; the underlying real message. Harmless. - (vm-set-deleted-flag-of (car curr) 'expunged) - ;; disable summary any summary update that may have - ;; already been scheduled. - (vm-set-su-start-of (car curr) nil) - (vm-increment vm-modification-counter) - (if (null prev) - (progn - (setq vm-message-list (cdr vm-message-list)) - (and (cdr curr) - (vm-set-reverse-link-of (car (cdr curr)) nil))) - (setcdr prev (cdr curr)) - (and (cdr curr) - (vm-set-reverse-link-of (car (cdr curr)) prev))) - (vm-set-virtual-messages-of (car mp) (cdr vms)) - (vm-set-buffer-modified-p t))) - (setq vms (cdr vms)))))) - (cond - ((or (not virtual-messages) - (not virtual)) - (and (not virtual-messages) virtual - (vm-set-virtual-messages-of - (vm-real-message-of (car mp)) - (delq (car mp) (vm-virtual-messages-of - (vm-real-message-of (car mp)))))) - (if (eq vm-message-pointer mp) - (setq vm-system-state nil - vm-message-pointer (or prev (cdr mp)))) - (if (eq vm-last-message-pointer mp) - (setq vm-last-message-pointer nil)) - (intern (buffer-name) buffers-altered) - (if (null vm-numbering-redo-start-point) - (progn - (vm-set-numbering-redo-start-point (or prev t)) - (vm-set-summary-redo-start-point (or prev t)))) - ;; lock out interrupt to preserve message list integrity - (let ((inhibit-quit t)) - (if (null prev) - (progn (setq vm-message-list (cdr vm-message-list)) - (and (cdr mp) - (vm-set-reverse-link-of (car (cdr mp)) nil))) - (setcdr prev (cdr mp)) - (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev))) - ;; vm-clear-expunge-invalidated-undos uses this to recognize - ;; expunged messages. - (vm-set-deleted-flag-of (car mp) 'expunged) - ;; disable summary any summary update that may have - ;; already been scheduled. - (vm-set-su-start-of (car mp) nil) - (vm-set-buffer-modified-p t) - (vm-increment vm-modification-counter)))) - (if (eq (vm-attributes-of (car mp)) - (vm-attributes-of (vm-real-message-of (car mp)))) - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of (car mp)))) - (vm-save-restriction - (widen) - (let ((buffer-read-only nil)) - (delete-region (vm-start-of (vm-real-message-of (car mp))) - (vm-end-of (vm-real-message-of (car mp))))))))) - (t (setq prev mp))) - (setq mp (cdr mp))) - (vm-display nil nil '(vm-expunge-folder) '(vm-expunge-folder)) - (cond - (buffers-altered - (save-excursion - (mapatoms - (function - (lambda (buffer) - (set-buffer (symbol-name buffer)) - (if (null vm-system-state) - (progn - (vm-garbage-collect-message) - (if (null vm-message-pointer) - ;; folder is now empty - (progn (setq vm-folder-type nil) - (vm-update-summary-and-mode-line)) - (vm-preview-current-message))) - (vm-update-summary-and-mode-line)) - (if (not (eq major-mode 'vm-virtual-mode)) - (setq vm-message-order-changed - (or vm-message-order-changed - vm-message-order-header-present))) - (vm-clear-expunge-invalidated-undos))) - buffers-altered)) - (if (not shaddap) - (message "Deleted messages expunged."))) - (t (message "No messages are flagged for deletion.")))))
--- a/lisp/vm/vm-digest.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,647 +0,0 @@ -;;; Message encapsulation -;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-digest) - -(defun vm-no-frills-encapsulate-message (m keep-list discard-regexp) - "Encapsulate a message M for forwarding, simply. -No message encapsulation standard is used. The message is -inserted at point in the current buffer, surrounded by two dashed -start/end separator lines. Point is not moved. - -M should be a message struct for a real message, not a virtual message. -This is the message that will be encapsulated. -KEEP-LIST should be a list of regexps matching headers to keep. -DISCARD-REGEXP should be a regexp that matches headers to be discarded. -KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers -to be forwarded. See the docs for vm-reorder-message-headers -to find out how KEEP-LIST and DISCARD-REGEXP are used." - (let ((target-buffer (current-buffer)) - source-buffer) - (save-restriction - ;; narrow to a zero length region to avoid interacting - ;; with anything that might have already been inserted - ;; into the buffer. - (narrow-to-region (point) (point)) - (insert "------- start of forwarded message -------\n") - (setq source-buffer (vm-buffer-of m)) - (save-excursion - (set-buffer source-buffer) - (save-restriction - (widen) - (save-excursion - (set-buffer target-buffer) - (let ((beg (point))) - (insert-buffer-substring source-buffer (vm-headers-of m) - (vm-text-end-of m)) - (goto-char beg) - (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)") - (vm-reorder-message-headers nil keep-list discard-regexp))))) - (goto-char (point-max)) - (insert "------- end of forwarded message -------\n")))) - -(defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp - always-use-digest) - "Encapsulate the messages in MESSAGE-LIST as per the MIME spec. -The resulting digest is inserted at point in the current buffer. -Point is not moved. - -MESSAGE-LIST should be a list of message structs (real or virtual). -These are the messages that will be encapsulated. -KEEP-LIST should be a list of regexps matching headers to keep. -DISCARD-REGEXP should be a regexp that matches headers to be discarded. -KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers -to be forwarded. See the docs for vm-reorder-message-headers -to find out how KEEP-LIST and DISCARD-REGEXP are used. - -If ALWAYS-USE-DIGEST is non-nil, always encapsulate for a multipart/digest. -Otherwise if there are fewer than two messages to be encapsulated -leave off the multipart boundary strings. The caller is assumed to -be using message/rfc822 or message/news encoding instead. - -If multipart/digest encapsulation is done, the function returns -the multipart boundary parameter (string) that should be used in -the Content-Type header. Otherwise nil is returned." - (if message-list - (let ((target-buffer (current-buffer)) - (boundary-positions nil) - (mlist message-list) - (mime-keep-list (append keep-list vm-mime-header-list)) - (boundary nil) - source-buffer m start n beg) - (save-restriction - ;; narrow to a zero length region to avoid interacting - ;; with anything that might have already been inserted - ;; into the buffer. - (narrow-to-region (point) (point)) - (setq start (point)) - (while mlist - (setq boundary-positions (cons (point-marker) boundary-positions)) - (setq m (vm-real-message-of (car mlist)) - source-buffer (vm-buffer-of m)) - (setq beg (point)) - (vm-insert-region-from-buffer source-buffer (vm-headers-of m) - (vm-text-end-of m)) - (goto-char beg) - (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)") - (vm-reorder-message-headers - nil (if (vm-mime-plain-message-p m) - keep-list - mime-keep-list) - discard-regexp) - (goto-char (point-max)) - (setq mlist (cdr mlist))) - (if (and (< (length message-list) 2) (not always-use-digest)) - nil - (goto-char start) - (setq boundary (vm-mime-make-multipart-boundary)) - (while (re-search-forward (concat "^--" - (regexp-quote boundary) - "\\(--\\)?$") - nil t) - (setq boundary (vm-mime-make-multipart-boundary)) - (goto-char start)) - (goto-char (point-max)) - (insert "\n--" boundary "--\n") - (while boundary-positions - (goto-char (car boundary-positions)) - (insert "\n--" boundary "\n\n") - (setq boundary-positions (cdr boundary-positions))) - (goto-char start) - (setq n (length message-list)) - (insert - (format "This is a digest, %d messages, MIME encapsulation.\n" - n))) - (goto-char start)) - boundary ))) - -(defun vm-mime-burst-message (m) - "Burst messages from the digest message M. -M should be a message struct for a real message. -MIME encoding is expected. Somewhere within the MIME layout -there must be at least one part of type message/news, message/rfc822 or -multipart/digest. If there are multiple parts matching those types, -all of them will be burst." - (let ((ident-header nil) - (did-burst nil) - (list (vm-mime-find-digests-in-layout (vm-mm-layout m)))) - (if vm-digest-identifier-header-format - (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m))) - (while list - (setq did-burst (or did-burst - (vm-mime-burst-layout (car list) ident-header))) - (setq list (cdr list))) - did-burst)) - -(defun vm-mime-burst-layout (layout ident-header) - (let ((work-buffer nil) - (folder-buffer (current-buffer)) - start part-list - (folder-type vm-folder-type)) - (unwind-protect - (vm-save-restriction - (save-excursion - (widen) - (setq work-buffer (generate-new-buffer "*vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - (cond ((not (vectorp layout)) - (error "Not a MIME message")) - ((vm-mime-types-match "message" - (car (vm-mm-layout-type layout))) - (insert (vm-leading-message-separator folder-type)) - (and ident-header (insert ident-header)) - (setq start (point)) - (vm-mime-insert-mime-body layout) - (vm-munge-message-separators folder-type start (point)) - (insert (vm-trailing-message-separator folder-type))) - ((vm-mime-types-match "multipart/digest" - (car (vm-mm-layout-type layout))) - (setq part-list (vm-mm-layout-parts layout)) - (while part-list - ;; Maybe we should verify that each part is - ;; of type message/rfc822 or message/news in - ;; here. But it seems more useful to just - ;; copy whatever the contents are and let the - ;; user see the goop, whatever type it really - ;; is. - (insert (vm-leading-message-separator folder-type)) - (and ident-header (insert ident-header)) - (setq start (point)) - (vm-mime-insert-mime-body (car part-list)) - (vm-munge-message-separators folder-type start (point)) - (insert (vm-trailing-message-separator folder-type)) - (setq part-list (cdr part-list)))) - (t (error - "MIME type is not multipart/digest or message/rfc822 or message/news"))) - ;; do header conversions. - (let ((vm-folder-type folder-type)) - (goto-char (point-min)) - (while (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (vm-convert-folder-type-headers folder-type folder-type) - (vm-find-trailing-message-separator) - (vm-skip-past-trailing-message-separator))) - ;; now insert the messages into the folder buffer - (cond ((not (zerop (buffer-size))) - (set-buffer folder-buffer) - (let ((old-buffer-modified-p (buffer-modified-p)) - (buffer-read-only nil) - (inhibit-quit t)) - (goto-char (point-max)) - (insert-buffer-substring work-buffer) - (set-buffer-modified-p old-buffer-modified-p) - ;; return non-nil so caller knows we found some messages - t )) - ;; return nil so the caller knows we didn't find anything - (t nil)))) - (and work-buffer (kill-buffer work-buffer))))) - -(defun vm-rfc934-char-stuff-region (start end) - "Quote RFC 934 message separators between START and END. -START and END are buffer positions in the current buffer. -Lines beginning with `-' in the region have `- ' prepended to them." - (setq end (vm-marker end)) - (save-excursion - (goto-char start) - (while (and (< (point) end) (re-search-forward "^-" end t)) - (replace-match "- -" t t))) - (set-marker end nil)) - -(defun vm-rfc934-char-unstuff-region (start end) - "Unquote lines in between START and END as per RFC 934. -START and END are buffer positions in the current buffer. -Lines beginning with `- ' in the region have that string stripped -from them." - (setq end (vm-marker end)) - (save-excursion - (goto-char start) - (while (and (< (point) end) (re-search-forward "^- " end t)) - (replace-match "" t t) - (forward-char))) - (set-marker end nil)) - -(defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp) - "Encapsulate the messages in MESSAGE-LIST as per RFC 934. -The resulting digest is inserted at point in the current buffer. -Point is not moved. - -MESSAGE-LIST should be a list of message structs (real or virtual). -These are the messages that will be encapsulated. -KEEP-LIST should be a list of regexps matching headers to keep. -DISCARD-REGEXP should be a regexp that matches headers to be discarded. -KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers -to be forwarded. See the docs for vm-reorder-message-headers -to find out how KEEP-LIST and DISCARD-REGEXP are used." - (if message-list - (let ((target-buffer (current-buffer)) - (mime-keep-list (append keep-list vm-mime-header-list)) - (mlist message-list) - source-buffer m start n) - (save-restriction - ;; narrow to a zero length region to avoid interacting - ;; with anything that might have already been inserted - ;; into the buffer. - (narrow-to-region (point) (point)) - (setq start (point)) - (while mlist - (insert "---------------\n") - (setq m (vm-real-message-of (car mlist)) - source-buffer (vm-buffer-of m)) - (save-excursion - (set-buffer source-buffer) - (save-restriction - (widen) - (save-excursion - (set-buffer target-buffer) - (let ((beg (point))) - (insert-buffer-substring source-buffer (vm-headers-of m) - (vm-text-end-of m)) - (goto-char beg) - (vm-reorder-message-headers nil nil - "\\(X-VM-\\|Status:\\)") - (vm-reorder-message-headers - nil (if (vm-mime-plain-message-p m) - keep-list - mime-keep-list) - discard-regexp) - (vm-rfc934-char-stuff-region beg (point-max)))))) - (goto-char (point-max)) - (insert "---------------") - (setq mlist (cdr mlist))) - (delete-region (point) (progn (beginning-of-line) (point))) - (insert "------- end -------\n") - (goto-char start) - (delete-region (point) (progn (forward-line 1) (point))) - (setq n (length message-list)) - (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n" - (if (cdr message-list) - "digest " - "forwarded message ") - (if (cdr message-list) - (format "(%d messages) " n) - ""))) - (goto-char start))))) - -(defun vm-rfc1153-char-stuff-region (start end) - "Quote RFC 1153 message separators between START and END. -START and END are buffer positions in the current buffer. -Lines consisting only of 30 hyphens have the first hyphen -converted to a space." - (setq end (vm-marker end)) - (save-excursion - (goto-char start) - (while (and (< (point) end) - (re-search-forward "^------------------------------$" end t)) - (replace-match " -----------------------------" t t))) - (set-marker end nil)) - -(defun vm-rfc1153-char-unstuff-region (start end) - "Unquote lines in between START and END as per RFC 1153. -START and END are buffer positions in the current buffer. -Lines consisting only of a space following by 29 hyphens have the space -converted to a hyphen." - (setq end (vm-marker end)) - (save-excursion - (goto-char start) - (while (and (< (point) end) - (re-search-forward "^ -----------------------------$" end t)) - (replace-match "------------------------------" t t))) - (set-marker end nil)) - -(defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp) - "Encapsulate the messages in MESSAGE-LIST as per RFC 1153. -The resulting digest is inserted at point in the current buffer. -Point is not moved. - -MESSAGE-LIST should be a list of message structs (real or virtual). -These are the messages that will be encapsulated. -KEEP-LIST should be a list of regexps matching headers to keep. -DISCARD-REGEXP should be a regexp that matches headers to be discarded. -KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers -to be forwarded. See the docs for vm-reorder-message-headers -to find out how KEEP-LIST and DISCARD-REGEXP are used." - (if message-list - (let ((target-buffer (current-buffer)) - (mime-keep-list (append keep-list vm-mime-header-list)) - (mlist message-list) - source-buffer m start) - (save-restriction - ;; narrow to a zero length region to avoid interacting - ;; with anything that might have already been inserted - ;; into the buffer. - (narrow-to-region (point) (point)) - (setq start (point)) - (while mlist - (insert "---------------\n\n") - (setq m (vm-real-message-of (car mlist)) - source-buffer (vm-buffer-of m)) - (save-excursion - (set-buffer source-buffer) - (save-restriction - (widen) - (save-excursion - (set-buffer target-buffer) - (let ((beg (point))) - (insert-buffer-substring source-buffer (vm-headers-of m) - (vm-text-end-of m)) - (goto-char beg) - (vm-reorder-message-headers nil nil - "\\(X-VM-\\|Status:\\)") - (vm-reorder-message-headers - nil (if (vm-mime-plain-message-p m) - keep-list - mime-keep-list) - discard-regexp) - (vm-rfc1153-char-stuff-region beg (point-max)))))) - (goto-char (point-max)) - (insert "\n---------------") - (setq mlist (cdr mlist))) - (insert "---------------\n\nEnd of this Digest\n******************\n") - (goto-char start) - (delete-region (point) (progn (forward-line 1) (point))) - (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" ""))) - (goto-char start))))) - -(defun vm-rfc1153-or-rfc934-burst-message (m rfc1153) - "Burst messages from the digest message M. -M should be a message struct for a real message. -If RFC1153 is non-nil, assume the digest is of the form specified by -RFC 1153. Otherwise assume RFC 934 digests." - (let ((work-buffer nil) - (match t) - (prev-sep nil) - (ident-header nil) - after-prev-sep prologue-separator-regexp separator-regexp - (folder-type vm-folder-type)) - (if vm-digest-identifier-header-format - (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m))) - (if rfc1153 - (setq prologue-separator-regexp "^----------------------------------------------------------------------\n" - separator-regexp "^------------------------------\n") - (setq prologue-separator-regexp "\\(^-[^ ].*\n+\\)+" - separator-regexp "\\(^-[^ ].*\n+\\)+")) - (vm-save-restriction - (save-excursion - (widen) - (unwind-protect - (catch 'done - (setq work-buffer (generate-new-buffer "*vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - (insert-buffer-substring (vm-buffer-of m) - (vm-text-of m) - (vm-text-end-of m)) - (goto-char (point-min)) - (if (not (re-search-forward prologue-separator-regexp nil t)) - (throw 'done nil)) - ;; think of this as a do-while loop. - (while match - (cond ((null prev-sep) - ;; from (point-min) to end of match - ;; is the digest prologue, devour it and - ;; carry on. - (delete-region (point-min) (match-end 0))) - (t - ;; munge previous messages message separators - (let ((md (match-data))) - (unwind-protect - (vm-munge-message-separators - folder-type - after-prev-sep - (match-beginning 0)) - (store-match-data md))))) - ;; there should be at least one valid header at - ;; the beginning of an encapsulated message. If - ;; there isn't a valid header, then assume that - ;; the digest was packed improperly and that this - ;; isn't a real boundary. - (if (not - (save-excursion - (save-match-data - (skip-chars-forward "\n") - (or (and (vm-match-header) - (vm-digest-get-header-contents "From")) - (not (re-search-forward separator-regexp - nil t)))))) - (setq prev-sep (point) - after-prev-sep (point)) - ;; if this isn't the first message, delete the - ;; digest separator goop and insert a trailing message - ;; separator of the proper type. - (if prev-sep - (progn - ;; eat preceding newlines - (while (= (preceding-char) ?\n) - (delete-char -1)) - ;; put one back - (insert ?\n) - ;; delete the digest separator - (delete-region (match-beginning 0) (point)) - ;; insert a trailing message separator - (insert (vm-trailing-message-separator folder-type)))) - (setq prev-sep (point)) - ;; insert the leading separator - (insert (vm-leading-message-separator folder-type)) - (setq after-prev-sep (point)) - ;; eat trailing newlines - (while (= (following-char) ?\n) - (delete-char 1)) - (insert ident-header)) - ;; try to match message separator and repeat. - (setq match (re-search-forward separator-regexp nil t))) - ;; from the last separator to eof is the digest epilogue. - ;; discard it. - (delete-region (or prev-sep (point-min)) (point-max)) - ;; Undo the quoting of the embedded message - ;; separators. This must be done before header - ;; conversions, else the Content-Length offsets might be - ;; rendered invalid by buffer size changes. - (if rfc1153 - (vm-rfc1153-char-unstuff-region (point-min) (point-max)) - (vm-rfc934-char-unstuff-region (point-min) (point-max))) - ;; do header conversions. - (let ((vm-folder-type folder-type)) - (goto-char (point-min)) - (while (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (vm-convert-folder-type-headers folder-type folder-type) - (vm-find-trailing-message-separator) - (vm-skip-past-trailing-message-separator))) - ;; now insert the messages into the folder buffer - (cond ((not (zerop (buffer-size))) - (set-buffer (vm-buffer-of m)) - (let ((old-buffer-modified-p (buffer-modified-p)) - (buffer-read-only nil) - (inhibit-quit t)) - (goto-char (point-max)) - (insert-buffer-substring work-buffer) - (set-buffer-modified-p old-buffer-modified-p) - ;; return non-nil so caller knows we found some messages - t )) - ;; return nil so the caller knows we didn't find anything - (t nil))) - (and work-buffer (kill-buffer work-buffer))))))) - -(defun vm-rfc934-burst-message (m) - "Burst messages from the RFC 934 digest message M. -M should be a message struct for a real message." - (vm-rfc1153-or-rfc934-burst-message m nil)) - -(defun vm-rfc1153-burst-message (m) - "Burst messages from the RFC 1153 digest message M. -M should be a message struct for a real message." - (vm-rfc1153-or-rfc934-burst-message m t)) - -(defun vm-burst-digest (&optional digest-type) - "Burst the current message (a digest) into its individual messages. -The digest's messages are assimilated into the folder as new mail -would be. - -Optional argument DIGEST-TYPE is a string that tells VM what kind -of digest the current message is. If it is not given the value -defaults to the value of vm-digest-burst-type. When called -interactively DIGEST-TYPE will be read from the minibuffer. - -If invoked on marked messages (via vm-next-command-uses-marks), -all marked messages will be burst." - (interactive - (list - (let ((type nil) - (this-command this-command) - (last-command last-command)) - (setq type (completing-read (format "Digest type: (default %s) " - vm-digest-burst-type) - (append vm-digest-type-alist - (list '("guess"))) - 'identity nil)) - (if (string= type "") - vm-digest-burst-type - type )))) - (or digest-type (setq digest-type vm-digest-burst-type)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((start-buffer (current-buffer)) m totals-blurb - (mlist (vm-select-marked-or-prefixed-messages 1))) - (while mlist - (if (vm-virtual-message-p (car mlist)) - (progn - (setq m (vm-real-message-of (car mlist))) - (set-buffer (vm-buffer-of m))) - (setq m (car mlist))) - (vm-error-if-folder-read-only) - (if (equal digest-type "guess") - (progn - (setq digest-type (vm-guess-digest-type m)) - (if (null digest-type) - (error "Couldn't guess digest type.")))) - (message "Bursting %s digest..." digest-type) - (cond - ((cond ((equal digest-type "mime") - (vm-mime-burst-message m)) - ((equal digest-type "rfc934") - (vm-rfc934-burst-message m)) - ((equal digest-type "rfc1153") - (vm-rfc1153-burst-message m)) - (t (error "Unknown digest type: %s" digest-type))) - (message "Bursting %s digest... done" digest-type) - (vm-clear-modification-flag-undos) - (vm-set-buffer-modified-p t) - (vm-increment vm-modification-counter) - (and vm-delete-after-bursting - ;; if start folder was virtual, we're now in the wrong - ;; buffer. switch back. - (save-excursion - (set-buffer start-buffer) - ;; don't move message pointer when deleting the message - (let ((vm-move-after-deleting nil)) - (vm-delete-message 1)))) - (vm-assimilate-new-messages t nil (vm-labels-of (car mlist))) - ;; do this now so if we error later in another iteration - ;; of the loop the summary and mode line will be correct. - (vm-update-summary-and-mode-line))) - (setq mlist (cdr mlist))) - ;; collect this data NOW, before the non-previewers read a - ;; message, alter the new message count and confuse - ;; themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-burst-digest - vm-burst-mime-digest - vm-burst-rfc934-digest - vm-burst-rfc1153-digest) - (list this-command)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb))) - -(defun vm-burst-rfc934-digest () - "Burst an RFC 934 style digest" - (interactive) - (vm-burst-digest "rfc934")) - -(defun vm-burst-rfc1153-digest () - "Burst an RFC 1153 style digest" - (interactive) - (vm-burst-digest "rfc1153")) - -(defun vm-burst-mime-digest () - "Burst a MIME digest" - (interactive) - (vm-burst-digest "mime")) - -(defun vm-guess-digest-type (m) - "Guess the digest type of the message M. -M should be the message struct of a real message. -Returns either \"rfc934\", \"rfc1153\" or \"mime\"." - (catch 'return-value - (save-excursion - (set-buffer (vm-buffer-of m)) - (let ((layout (vm-mm-layout m))) - (if (and (vectorp layout) - (or (vm-mime-layout-contains-type - layout - "multipart/digest") - (vm-mime-layout-contains-type - layout - "message/rfc822") - (vm-mime-layout-contains-type - layout - "message/news"))) - (throw 'return-value "mime")))) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-text-of m)) - (cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t) - "rfc1153") - (t "rfc934")))))) - -(defun vm-digest-get-header-contents (header-name-regexp) - (let ((contents nil) - regexp) - (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) - (save-excursion - (let ((case-fold-search t)) - (if (and (re-search-forward regexp nil t) - (match-beginning 1) - (progn (goto-char (match-beginning 0)) - (vm-match-header))) - (vm-matched-header-contents) - nil )))))
--- a/lisp/vm/vm-easymenu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,225 +0,0 @@ -;;; easymenu.el --- support the easymenu interface for defining a menu. - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Keywords: emulations -;; Author: rms - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; This is compatible with easymenu.el by Per Abrahamsen -;;; but it is much simpler as it doesn't try to support other Emacs versions. -;;; The code was mostly derived from lmenu.el. - -;;; Changed 17-May-1995, Kyle Jones -;;; Made easy-menu-create-keymaps handle the -;;; [ NAME CALLBACK ENABLE ] -;;; case properly. Previously the enabler function was not -;;; being put on the property list of the command. -;;; Changed 20-May-1995, Kyle Jones -;;; Made easy-menu-create-keymaps handle the -;;; [ NAME CALLBACK ENABLE SUFFIX ] -;;; case properly. -;;; Changed 25-May-1995, Kyle Jones -;;; Renamed easy-menu- functions to vm-easy-menu- to avoid -;;; non-vm compatible versions. -;;; Changed 2-July-1995, Kyle Jones -;;; If callback is a symbol use it in the menu keymap instead -;;; of the uninterned menu-function-XXX symbols. This allows -;;; Emacs' menu code to set this-command properly when -;;; launching a command from the menubar. -;;; -;;; Code: - -(provide 'vm-easymenu) - -;;;###autoload -(defmacro vm-easy-menu-define (symbol maps doc menu) - "Define a menu bar submenu in maps MAPS, according to MENU. -The menu keymap is stored in symbol SYMBOL, both as its value -and as its function definition. DOC is used as the doc string for SYMBOL. - -The first element of MENU must be a string. It is the menu bar item name. -The rest of the elements are menu items. - -A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] - -NAME is a string--the menu item name. - -CALLBACK is a command to run when the item is chosen, -or a list to evaluate when the item is chosen. - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - -Alternatively, a menu item may have the form: - - [ NAME CALLBACK [ KEYWORD ARG ] ... ] - -Where KEYWORD is one of the symbol defined below. - - :keys KEYS - -KEYS is a string; a complex keyboard equivalent to this menu item. -This is normally not needed because keyboard equivalents are usually -computed automatically. - - :active ENABLE - -ENABLE is an expression; the item is enabled for selection -whenever this expression's value is non-nil. - - :suffix NAME - -NAME is a string; the name of an argument to CALLBACK. - - :style - -STYLE is a symbol describing the type of menu item. The following are -defined: - -toggle: A checkbox. - Currently just prepend the name with the string \"Toggle \". -radio: A radio button. -nil: An ordinary menu item. - - :selected SELECTED - -SELECTED is an expression; the checkbox or radio button is selected -whenever this expression's value is non-nil. -Currently just disable radio buttons, no effect on checkboxes. - -A menu item can be a string. Then that string appears in the menu as -unselectable text. A string consisting solely of hyphens is displayed -as a solid horizontal line. - -A menu item can be a list. It is treated as a submenu. -The first element should be the submenu name. That's used as the -menu item in the top-level menu. The cdr of the submenu list -is a list of menu items, as above." - (` (progn - (defvar (, symbol) nil (, doc)) - (vm-easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) - -(defun vm-easy-menu-do-define (symbol maps doc menu) - ;; We can't do anything that might differ between Emacs dialects in - ;; `vm-easy-menu-define' in order to make byte compiled files - ;; compatible. Therefore everything interesting is done in this - ;; function. - (set symbol (vm-easy-menu-create-keymaps (car menu) (cdr menu))) - (fset symbol (` (lambda (event) (, doc) (interactive "@e") - (easy-popup-menu event (, symbol))))) - (mapcar (function (lambda (map) - (define-key map (vector 'menu-bar (intern (car menu))) - (cons (car menu) (symbol-value symbol))))) - (if (keymapp maps) (list maps) maps))) - -(defvar vm-easy-menu-item-count 0) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -;;;###autoload -(defun vm-easy-menu-create-keymaps (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name))) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let* ((item (car menu-items)) - (callback (if (vectorp item) (aref item 1))) - command enabler name) - (cond ((stringp item) - (setq command nil) - (setq name (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (vm-easy-menu-create-keymaps (car item) (cdr item))) - (setq name (car item))) - ((vectorp item) - (if (symbolp callback) - (setq command callback) - (setq command (make-symbol (format "menu-function-%d" - vm-easy-menu-item-count))) - (setq vm-easy-menu-item-count (1+ vm-easy-menu-item-count))) - (setq name (aref item 0)) - (let ((keyword (aref item 2))) - (if (and (symbolp keyword) - (= ?: (aref (symbol-name keyword) 0))) - (let ((count 2) - style selected active keys - arg) - (while (> (length item) count) - (setq keyword (aref item count)) - (setq arg (aref item (1+ count))) - (setq count (+ 2 count)) - (cond ((eq keyword ':keys) - (setq keys arg)) - ((eq keyword ':active) - (setq active arg)) - ((eq keyword ':suffix) - (setq name (concat name " " arg))) - ((eq keyword ':style) - (setq style arg)) - ((eq keyword ':selected) - (setq selected arg)))) - (if keys - (setq name (concat name " (" keys ")"))) - (if (eq style 'toggle) - ;; Simulate checkboxes. - (setq name (concat "Toggle " name))) - (if active - (put command 'menu-enable active) - (and (eq style 'radio) - selected - ;; Simulate radio buttons with menu-enable. - (put command 'menu-enable - (list 'not selected))))) - (if (= (length item) 4) - (setq name (concat name " " (aref item 3)))) - (put command 'menu-enable keyword))) - (if (keymapp callback) - (setq name (concat name " ..."))) - (if (symbolp callback) - nil ;;(fset command callback) - (fset command (list 'lambda () '(interactive) callback))))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil name) (cdr menu))) - (if name - (define-key menu (vector (intern name)) (cons name command))))) - (setq menu-items (cdr menu-items))) - menu)) - -(defun vm-easy-menu-change (path name items) - "Change menu found at PATH as item NAME to contain ITEMS. -PATH is a list of strings for locating the menu containing NAME in the -menu bar. ITEMS is a list of menu items, as in `vm-easy-menu-define'. -These items entirely replace the previous items in that map. - -Call this from `activate-menubar-hook' to implement dynamic menus." - (let ((map (key-binding (apply 'vector - 'menu-bar - (mapcar 'intern (append path (list name))))))) - (if (keymapp map) - (setcdr map (cdr (vm-easy-menu-create-keymaps name items))) - (error "Malformed menu in `vm-easy-menu-change'")))) - -(defun vm-easy-menu-remove (menu)) - -(defun vm-easy-menu-add (menu &optional map)) - -;;; vm-easymenu.el ends here
--- a/lisp/vm/vm-edit.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,246 +0,0 @@ -;;; Editing VM messages -;;; Copyright (C) 1990, 1991, 1993, 1994, 1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-edit) - -(defun vm-edit-message (&optional prefix-argument) - "Edit the current message. Prefix arg means mark as unedited instead. -If editing, the current message is copied into a temporary buffer, and -this buffer is selected for editing. The major mode of this buffer is -controlled by the variable vm-edit-message-mode. The hooks specified -in vm-edit-message-hook are run just prior to returning control to the user -for editing. - -Use C-c ESC when you have finished editing the message. The message -will be inserted into its folder replacing the old version of the -message. If you don't want your edited version of the message to -replace the original, use C-c C-] and the edit will be aborted." - (interactive "P") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (if (and (vm-virtual-message-p (car vm-message-pointer)) - (null (vm-virtual-messages-of (car vm-message-pointer)))) - (error "Can't edit unmirrored virtual messages.")) - (if prefix-argument - (if (vm-edited-flag (car vm-message-pointer)) - (progn - (vm-set-edited-flag-of (car vm-message-pointer) nil) - (vm-update-summary-and-mode-line))) - (let ((mp vm-message-pointer) - (offset (save-excursion - (if vm-presentation-buffer - (set-buffer vm-presentation-buffer)) - (- (point) (vm-headers-of (car vm-message-pointer))))) - (edit-buf (vm-edit-buffer-of (car vm-message-pointer))) - (folder-buffer (current-buffer))) - (if (not (and edit-buf (buffer-name edit-buf))) - (progn - (vm-save-restriction - (widen) - (setq edit-buf - (generate-new-buffer - (format "edit of %s's note re: %s" - (vm-su-full-name (car vm-message-pointer)) - (vm-su-subject (car vm-message-pointer))))) - (vm-set-edit-buffer-of (car mp) edit-buf) - (copy-to-buffer edit-buf - (vm-headers-of (car mp)) - (vm-text-end-of (car mp)))) - (set-buffer edit-buf) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (if (< offset 0) - (search-forward "\n\n" nil t) - (forward-char offset)) - (funcall (or vm-edit-message-mode 'text-mode)) - (use-local-map vm-edit-message-map) - ;; (list (car mp)) because a different message may - ;; later be stuffed into a cons linked that is linked - ;; into the folder's message list. - (setq vm-message-pointer (list (car mp)) - vm-mail-buffer folder-buffer - vm-system-state 'editing) - (run-hooks 'vm-edit-message-hook) - (message - (substitute-command-keys - "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change."))) - (set-buffer edit-buf)) - (if (and vm-mutable-frames vm-frame-per-edit - (vm-multiple-frames-possible-p)) - (let ((w (vm-get-buffer-window edit-buf))) - (if (null w) - (progn - (vm-goto-new-frame 'edit) - (vm-set-hooks-for-frame-deletion)) - (save-excursion - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))) - (vm-display edit-buf t '(vm-edit-message vm-edit-message-other-frame) - (list this-command 'editing-message))))) - -(defun vm-edit-message-other-frame (&optional prefix) - "Like vm-edit-message, but run in a newly created frame." - (interactive "P") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'edit)) - (let ((vm-search-other-frames nil) - (vm-frame-per-edit nil)) - (vm-edit-message prefix)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-discard-cached-data (&optional count) - "Discard cached information about the current message. -When VM gathers information from the headers of a message, it stores it -internally for future reference. This command causes VM to forget this -information, and VM will be forced to search the headers of the message -again for these data. VM will also have to decide again which headers -should be displayed and which should not. Therefore this command is -useful if you change the value of vm-visible-headers or -vm-invisible-header-regexp in the midst of a VM session. - -Numeric prefix argument N means to discard data from the current message -plus the next N-1 messages. A negative N means discard data from the -current message and the previous N-1 messages. - -When invoked on marked messages (via vm-next-command-uses-marks), -data is discarded only from the marked messages in the current folder." - (interactive "p") - (or count (setq count 1)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-empty) - (let ((mlist (vm-select-marked-or-prefixed-messages count)) m) - (while mlist - (setq m (vm-real-message-of (car mlist))) - (if vm-thread-obarray - (vm-unthread-message m t)) - (fillarray (vm-cache-of m) nil) - (vm-set-vheaders-of m nil) - (vm-set-vheaders-regexp-of m nil) - (vm-set-text-of m nil) - (vm-set-mime-layout-of m nil) - (if (and vm-presentation-buffer (eq (car vm-message-pointer) m)) - (save-excursion (vm-preview-current-message))) - (if vm-thread-obarray - (vm-build-threads (list m))) - (if vm-summary-show-threads - (vm-sort-messages "thread")) - (let ((v-list (vm-virtual-messages-of m))) - (save-excursion - (while v-list - (set-buffer (vm-buffer-of (car v-list))) - (if (and vm-presentation-buffer - (eq (car vm-message-pointer) (car v-list))) - (save-excursion (vm-preview-current-message))) - (if vm-thread-obarray - (vm-build-threads (list (car v-list)))) - (if vm-summary-show-threads - (vm-sort-messages "thread")) - (setq v-list (cdr v-list))))) - (vm-mark-for-summary-update m) - (setq mlist (cdr mlist)))) - (vm-display nil nil '(vm-discard-cached-data) '(vm-discard-cached-data)) - (vm-update-summary-and-mode-line)) - -(defun vm-edit-message-end () - "End the edit of a message and copy the result to its folder." - (interactive) - (if (null vm-message-pointer) - (error "This is not a VM message edit buffer.")) - (if (null (buffer-name (vm-buffer-of (car vm-message-pointer)))) - (error "The folder buffer for this message has been killed.")) - ;; make sure the message ends with a newline - (goto-char (point-max)) - (and (/= (preceding-char) ?\n) (insert ?\n)) - ;; munge message separators found in the edited message to - ;; prevent message from being split into several messages. - (vm-munge-message-separators (vm-message-type-of (car vm-message-pointer)) - (point-min) (point-max)) - ;; for From_-with-Content-Length recompute the Content-Length header - (if (eq (vm-message-type-of (car vm-message-pointer)) - 'From_-with-Content-Length) - (let ((buffer-read-only nil) - length) - (goto-char (point-min)) - ;; first delete all copies of Content-Length - (while (and (re-search-forward vm-content-length-search-regexp nil t) - (null (match-beginning 1)) - (progn (goto-char (match-beginning 0)) - (vm-match-header vm-content-length-header))) - (delete-region (vm-matched-header-start) (vm-matched-header-end))) - ;; now compute the message body length - (goto-char (point-min)) - (search-forward "\n\n" nil 0) - (setq length (- (point-max) (point))) - ;; insert the header - (goto-char (point-min)) - (insert vm-content-length-header " " (int-to-string length) "\n"))) - (let ((edit-buf (current-buffer)) - (mp vm-message-pointer)) - (if (buffer-modified-p) - (progn - (widen) - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of (car mp)))) - (if (not (memq (vm-real-message-of (car mp)) vm-message-list)) - (error "The original copy of this message has been expunged.")) - (vm-save-restriction - (widen) - (goto-char (vm-headers-of (vm-real-message-of (car mp)))) - (let ((vm-message-pointer mp) - opoint - (buffer-read-only nil)) - (setq opoint (point)) - (insert-buffer-substring edit-buf) - (delete-region - (point) (vm-text-end-of (vm-real-message-of (car mp)))) - (vm-discard-cached-data)) - (vm-set-edited-flag-of (car mp) t) - (vm-set-edit-buffer-of (car mp) nil)) - (set-buffer (vm-buffer-of (car mp))) - (if (eq (vm-real-message-of (car mp)) - (vm-real-message-of (car vm-message-pointer))) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)))) - (message "No change.")) - (vm-display edit-buf nil '(vm-edit-message-end) - '(vm-edit-message-end reading-message startup)) - (set-buffer-modified-p nil) - (kill-buffer edit-buf))) - -(defun vm-edit-message-abort () - "Abort the edit of a message, forgetting changes to the message." - (interactive) - (if (null vm-message-pointer) - (error "This is not a VM message edit buffer.")) - (if (null (buffer-name (vm-buffer-of (vm-real-message-of (car vm-message-pointer))))) - (error "The folder buffer for this message has been killed.")) - (vm-set-edit-buffer-of (car vm-message-pointer) nil) - (vm-display (current-buffer) nil - '(vm-edit-message-abort) - '(vm-edit-message-abort reading-message startup)) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer)) - (message "Aborted, no change."))
--- a/lisp/vm/vm-folder.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3347 +0,0 @@ -;;; VM folder related functions -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-folder) - -(defun vm-number-messages (&optional start-point end-point) - "Set the number-of and padded-number-of slots of messages -in vm-message-list. - -If non-nil, START-POINT should point to a cons cell in -vm-message-list and the numbering will begin there, else the -numbering will begin at the head of vm-message-list. If -START-POINT is non-nil the reverse-link-of slot of the message in -the cons must be valid and the message pointed to (if any) must -have a non-nil number-of slot, because it is used to determine -what the starting message number should be. - -If non-nil, END-POINT should point to a cons cell in -vm-message-list and the numbering will end with the message just -before this cell. A nil value means numbering will be done until -the end of vm-message-list is reached." - (let ((n 1) (message-list (or start-point vm-message-list))) - (if (and start-point (vm-reverse-link-of (car start-point))) - (setq n (1+ (string-to-int - (vm-number-of - (car - (vm-reverse-link-of - (car start-point)))))))) - (while (not (eq message-list end-point)) - (vm-set-number-of (car message-list) (int-to-string n)) - (vm-set-padded-number-of (car message-list) (format "%3d" n)) - (setq n (1+ n) message-list (cdr message-list))) - (or end-point (setq vm-ml-highest-message-number (int-to-string (1- n)))) - (if vm-summary-buffer - (vm-copy-local-variables vm-summary-buffer - 'vm-ml-highest-message-number)))) - -(defun vm-set-numbering-redo-start-point (start-point) - "Set vm-numbering-redo-start-point to START-POINT if appropriate. -Also mark the current buffer as needing a display update. - -START-POINT should be a cons in vm-message-list or just t. - (t means start from the beginning of vm-message-list.) -If START-POINT is closer to the head of vm-message-list than -vm-numbering-redo-start-point or is equal to t, then -vm-numbering-redo-start-point is set to match it." - (intern (buffer-name) vm-buffers-needing-display-update) - (if (eq vm-numbering-redo-start-point t) - nil - (if (and (consp start-point) (consp vm-numbering-redo-start-point)) - (let ((mp vm-message-list)) - (while (and mp (not (or (eq mp start-point) - (eq mp vm-numbering-redo-start-point)))) - (setq mp (cdr mp))) - (if (null mp) - (error "Something is wrong in vm-set-numbering-redo-start-point")) - (if (eq mp start-point) - (setq vm-numbering-redo-start-point start-point))) - (setq vm-numbering-redo-start-point start-point)))) - -(defun vm-set-numbering-redo-end-point (end-point) - "Set vm-numbering-redo-end-point to END-POINT if appropriate. -Also mark the current buffer as needing a display update. - -END-POINT should be a cons in vm-message-list or just t. - (t means number all the way to the end of vm-message-list.) -If END-POINT is closer to the end of vm-message-list or is equal -to t, then vm-numbering-redo-start-point is set to match it. -The number-of slot is used to determine proximity to the end of -vm-message-list, so this slot must be valid in END-POINT's message -and the message in the cons pointed to by vm-numbering-redo-end-point." - (intern (buffer-name) vm-buffers-needing-display-update) - (cond ((eq end-point t) - (setq vm-numbering-redo-end-point t)) - ((and (consp end-point) - (> (string-to-int - (vm-number-of - (car end-point))) - (string-to-int - (vm-number-of - (car vm-numbering-redo-end-point))))) - (setq vm-numbering-redo-end-point end-point)) - ((null end-point) - (setq vm-numbering-redo-end-point end-point)))) - -(defun vm-do-needed-renumbering () - "Number messages in vm-message-list as specified by -vm-numbering-redo-start-point and vm-numbering-redo-end-point. - -vm-numbering-redo-start-point = t means start at the head -of vm-message-list. -vm-numbering-redo-end-point = t means number all the way to the -end of vm-message-list. - -Otherwise the variables' values should be conses in vm-message-list -or nil." - (if vm-numbering-redo-start-point - (progn - (vm-number-messages (and (consp vm-numbering-redo-start-point) - vm-numbering-redo-start-point) - vm-numbering-redo-end-point) - (setq vm-numbering-redo-start-point nil - vm-numbering-redo-end-point nil)))) - -(defun vm-set-summary-redo-start-point (start-point) - "Set vm-summary-redo-start-point to START-POINT if appropriate. -Also mark the current buffer as needing a display update. - -START-POINT should be a cons in vm-message-list or just t. - (t means start from the beginning of vm-message-list.) -If START-POINT is closer to the head of vm-message-list than -vm-summary-redo-start-point or is equal to t, then -vm-summary-redo-start-point is set to match it." - (intern (buffer-name) vm-buffers-needing-display-update) - (if (eq vm-summary-redo-start-point t) - nil - (if (and (consp start-point) (consp vm-summary-redo-start-point)) - (let ((mp vm-message-list)) - (while (and mp (not (or (eq mp start-point) - (eq mp vm-summary-redo-start-point)))) - (setq mp (cdr mp))) - (if (null mp) - (error "Something is wrong in vm-set-summary-redo-start-point")) - (if (eq mp start-point) - (setq vm-summary-redo-start-point start-point))) - (setq vm-summary-redo-start-point start-point)))) - -(defun vm-mark-for-summary-update (m &optional dont-kill-cache) - "Mark message M for a summary update. -Also mark M's buffer as needing a display update. Any virtual -messages of M and their buffers are similarly marked for update. -If M is a virtual message and virtual mirroring is in effect for -M (i.e. attribute-of eq attributes-of M's real message), M's real -message and its buffer are scheduled for an update. - -Optional arg DONT-KILL-CACHE non-nil means don't invalidate the -summary-of slot for any messages marked for update. This is -meant to be used by functions that update message information -that is not cached in the summary-of slot, e.g. message numbers -and thread indentation." - (cond ((eq m (vm-real-message-of m)) - ;; this is a real message. - ;; its summary and modeline need to be updated. - (if (not dont-kill-cache) - ;; toss the cache. this also tosses the cache of any - ;; virtual messages mirroring this message. the summary - ;; entry cache must be cleared when an attribute of a - ;; message that could appear in the summary has changed. - (vm-set-summary-of m nil)) - (if (vm-su-start-of m) - (setq vm-messages-needing-summary-update - (cons m vm-messages-needing-summary-update))) - (intern (buffer-name (vm-buffer-of m)) - vm-buffers-needing-display-update) - ;; find the virtual messages of this real message that - ;; need a summary update. - (let ((m-list (vm-virtual-messages-of m))) - (while m-list - (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list))) - (progn - (and (vm-su-start-of (car m-list)) - (setq vm-messages-needing-summary-update - (cons (car m-list) - vm-messages-needing-summary-update))) - (intern (buffer-name (vm-buffer-of (car m-list))) - vm-buffers-needing-display-update))) - (setq m-list (cdr m-list))))) - (t - ;; this is a virtual message. - ;; - ;; if this message has virtual messages then we need to - ;; schedule updates for all the virtual messages that - ;; share a cache with this message and we need to - ;; schedule an update for the underlying real message - ;; since we are mirroring it. - ;; - ;; if there are no virtual messages, then this virtual - ;; message is not mirroring its real message so we need - ;; only take care of this one message. - (if (vm-virtual-messages-of m) - (let ((m-list (vm-virtual-messages-of m))) - ;; schedule updates for all the virtual message who share - ;; the same cache as this message. - (while m-list - (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list))) - (progn - (and (vm-su-start-of (car m-list)) - (setq vm-messages-needing-summary-update - (cons (car m-list) - vm-messages-needing-summary-update))) - (intern (buffer-name (vm-buffer-of (car m-list))) - vm-buffers-needing-display-update))) - (setq m-list (cdr m-list))) - ;; now take care of the real message - (if (not dont-kill-cache) - ;; toss the cache. this also tosses the cache of - ;; any virtual messages sharing the same cache as - ;; this message. - (vm-set-summary-of m nil)) - (and (vm-su-start-of (vm-real-message-of m)) - (setq vm-messages-needing-summary-update - (cons (vm-real-message-of m) - vm-messages-needing-summary-update))) - (intern (buffer-name (vm-buffer-of (vm-real-message-of m))) - vm-buffers-needing-display-update)) - (if (not dont-kill-cache) - (vm-set-virtual-summary-of m nil)) - (and (vm-su-start-of m) - (setq vm-messages-needing-summary-update - (cons m vm-messages-needing-summary-update))) - (intern (buffer-name (vm-buffer-of m)) - vm-buffers-needing-display-update))))) - -(defun vm-force-mode-line-update () - "Force a mode line update in all frames." - (if (fboundp 'force-mode-line-update) - (force-mode-line-update t) - (save-excursion - (set-buffer (other-buffer)) - (set-buffer-modified-p (buffer-modified-p))))) - -(defun vm-do-needed-mode-line-update () - "Do a modeline update for the current folder buffer. -This means setting up all the various vm-ml attribute variables -in the folder buffer and copying necessary variables to the -folder buffer's summary and presentation buffers, and then -forcing Emacs to update all modelines. - -If a virtual folder being updated has no messages, then -erase-buffer is called on its buffer. - -If any type of folder is empty, erase-buffer is called -on its presentation buffer, if any." - ;; XXX This last bit should probably should be moved to - ;; XXX vm-expunge-folder. - - (if (null vm-message-pointer) - (progn - ;; erase the leftover message if the folder is really empty. - (if (eq major-mode 'vm-virtual-mode) - (let ((buffer-read-only nil) - (omodified (buffer-modified-p))) - (unwind-protect - (erase-buffer) - (set-buffer-modified-p omodified)))) - (if vm-presentation-buffer - (let ((omodified (buffer-modified-p))) - (unwind-protect - (save-excursion - (set-buffer vm-presentation-buffer) - (let ((buffer-read-only nil)) - (erase-buffer))) - (set-buffer-modified-p omodified))))) - ;; try to avoid calling vm-su-labels if possible so as to - ;; avoid loading vm-summary.el. - (if (vm-labels-of (car vm-message-pointer)) - (setq vm-ml-labels (vm-su-labels (car vm-message-pointer))) - (setq vm-ml-labels nil)) - (setq vm-ml-message-number (vm-number-of (car vm-message-pointer))) - (setq vm-ml-message-new (vm-new-flag (car vm-message-pointer))) - (setq vm-ml-message-unread (vm-unread-flag (car vm-message-pointer))) - (setq vm-ml-message-read - (and (not (vm-new-flag (car vm-message-pointer))) - (not (vm-unread-flag (car vm-message-pointer))))) - (setq vm-ml-message-edited (vm-edited-flag (car vm-message-pointer))) - (setq vm-ml-message-filed (vm-filed-flag (car vm-message-pointer))) - (setq vm-ml-message-written (vm-written-flag (car vm-message-pointer))) - (setq vm-ml-message-replied (vm-replied-flag (car vm-message-pointer))) - (setq vm-ml-message-forwarded (vm-forwarded-flag (car vm-message-pointer))) - (setq vm-ml-message-redistributed (vm-redistributed-flag (car vm-message-pointer))) - (setq vm-ml-message-deleted (vm-deleted-flag (car vm-message-pointer))) - (setq vm-ml-message-marked (vm-mark-of (car vm-message-pointer)))) - (if vm-summary-buffer - (let ((modified (buffer-modified-p))) - (save-excursion - (vm-copy-local-variables vm-summary-buffer - 'vm-ml-message-new - 'vm-ml-message-unread - 'vm-ml-message-read - 'vm-ml-message-edited - 'vm-ml-message-replied - 'vm-ml-message-forwarded - 'vm-ml-message-filed - 'vm-ml-message-written - 'vm-ml-message-deleted - 'vm-ml-message-marked - 'vm-ml-message-number - 'vm-ml-highest-message-number - 'vm-folder-read-only - 'vm-folder-type - 'vm-virtual-folder-definition - 'vm-virtual-mirror - 'vm-ml-sort-keys - 'vm-ml-labels - 'vm-spooled-mail-waiting - 'vm-message-list) - (set-buffer vm-summary-buffer) - (set-buffer-modified-p modified)))) - (if vm-presentation-buffer - (let ((modified (buffer-modified-p))) - (save-excursion - (vm-copy-local-variables vm-presentation-buffer - 'vm-ml-message-new - 'vm-ml-message-unread - 'vm-ml-message-read - 'vm-ml-message-edited - 'vm-ml-message-replied - 'vm-ml-message-forwarded - 'vm-ml-message-filed - 'vm-ml-message-written - 'vm-ml-message-deleted - 'vm-ml-message-marked - 'vm-ml-message-number - 'vm-ml-highest-message-number - 'vm-folder-read-only - 'vm-folder-type - 'vm-virtual-folder-definition - 'vm-virtual-mirror - 'vm-ml-labels - 'vm-spooled-mail-waiting - 'vm-message-list) - (set-buffer vm-presentation-buffer) - (set-buffer-modified-p modified)))) - (vm-force-mode-line-update)) - -(defun vm-update-summary-and-mode-line () - "Update summary and mode line for all VM folder and summary buffers. -Really this updates all the visible status indicators. - -Message lists are renumbered. -Summary entries are wiped and regenerated. -Mode lines are updated. -Toolbars are updated." - (save-excursion - (mapatoms (function - (lambda (b) - (setq b (get-buffer (symbol-name b))) - (if b - (progn - (set-buffer b) - (vm-check-for-killed-summary) - (and vm-use-toolbar - (vm-toolbar-support-possible-p) - (vm-toolbar-update-toolbar)) - (vm-do-needed-renumbering) - (if vm-summary-buffer - (vm-do-needed-summary-rebuild)) - (vm-do-needed-mode-line-update))))) - vm-buffers-needing-display-update) - (fillarray vm-buffers-needing-display-update 0)) - (if vm-messages-needing-summary-update - (progn - (mapcar (function vm-update-message-summary) - vm-messages-needing-summary-update) - (setq vm-messages-needing-summary-update nil))) - (vm-force-mode-line-update)) - -(defun vm-reverse-link-messages () - "Set reverse links for all messages in vm-message-list." - (let ((mp vm-message-list) - (prev nil)) - (while mp - (vm-set-reverse-link-of (car mp) prev) - (setq prev mp mp (cdr mp))))) - -(defun vm-match-ordered-header (alist) - "Try to match a header in ALIST and return the matching cell. -This is used by header ordering code. - -ALIST looks like this ((\"From\") (\"To\")). This function returns -the alist element whose car matches the header starting at point. -The header ordering code uses the cdr of the element -returned to hold headers to be output later." - (let ((case-fold-search t)) - (catch 'match - (while alist - (if (looking-at (car (car alist))) - (throw 'match (car alist))) - (setq alist (cdr alist))) - nil))) - -(defun vm-match-header (&optional header-name) - "Match a header and save some state information about the matched header. -Optional first arg HEADER-NAME means match the header only -if it matches HEADER-NAME. HEADER-NAME should be a string -containing a header name. The string should end with a colon if just -that name should be matched. A string that does not end in a colon -will match all headers that begin with that string. - -State information is stored in vm-matched-header-vector bound to a vector -of this form. - - [ header-start header-end - header-name-start header-name-end - header-contents-start header-contents-end ] - -Elements are integers. -There are functions to access and use this info." - (let ((case-fold-search t) - (header-name-regexp "\\([^ \t\n:]+\\):")) - (if (if header-name - (and (looking-at header-name) (looking-at header-name-regexp)) - (looking-at header-name-regexp)) - (save-excursion - (aset vm-matched-header-vector 0 (point)) - (aset vm-matched-header-vector 2 (point)) - (aset vm-matched-header-vector 3 (match-end 1)) - (goto-char (match-end 0)) - ;; skip leading whitespace - (skip-chars-forward " \t") - (aset vm-matched-header-vector 4 (point)) - (forward-line 1) - (while (looking-at "[ \t]") - (forward-line 1)) - (aset vm-matched-header-vector 1 (point)) - ;; drop the trailing newline - (aset vm-matched-header-vector 5 (1- (point))))))) - -(defun vm-matched-header () - "Returns the header last matched by vm-match-header. -Trailing newline is included." - (vm-buffer-substring-no-properties (aref vm-matched-header-vector 0) - (aref vm-matched-header-vector 1))) - -(defun vm-matched-header-name () - "Returns the name of the header last matched by vm-match-header." - (vm-buffer-substring-no-properties (aref vm-matched-header-vector 2) - (aref vm-matched-header-vector 3))) - -(defun vm-matched-header-contents () - "Returns the contents of the header last matched by vm-match-header. -Trailing newline is not included." - (vm-buffer-substring-no-properties (aref vm-matched-header-vector 4) - (aref vm-matched-header-vector 5))) - -(defun vm-matched-header-start () - "Returns the start position of the header last matched by vm-match-header." - (aref vm-matched-header-vector 0)) - -(defun vm-matched-header-end () - "Returns the end position of the header last matched by vm-match-header." - (aref vm-matched-header-vector 1)) - -(defun vm-matched-header-name-start () - "Returns the start position of the name of the header last matched -by vm-match-header." - (aref vm-matched-header-vector 2)) - -(defun vm-matched-header-name-end () - "Returns the end position of the name of the header last matched -by vm-match-header." - (aref vm-matched-header-vector 3)) - -(defun vm-matched-header-contents-start () - "Returns the start position of the contents of the header last matched -by vm-match-header." - (aref vm-matched-header-vector 4)) - -(defun vm-matched-header-contents-end () - "Returns the end position of the contents of the header last matched -by vm-match-header." - (aref vm-matched-header-vector 5)) - -(defun vm-get-folder-type (&optional file start end) - "Return a symbol indicating the folder type of the current buffer. -This function works by examining the beginning of a folder. -If optional arg FILE is present the type of FILE is returned instead. -If optional second and third arg START and END are provided, -vm-get-folder-type will examine the text between those buffer -positions. START and END default to 1 and (buffer-size) + 1. - -Returns - nil if folder has no type (empty) - unknown if the type is not known to VM - mmdf for MMDF folders - babyl for BABYL folders - From_ for UNIX From_ folders - -If vm-trust-From_-with-Content-Length is non-nil, -From_-with-Content-Length is returned if the first message in the -folder has a Content-Length header and the folder otherwise looks -like a From_ folder." - (let ((temp-buffer nil) - b - (case-fold-search nil)) - (unwind-protect - (save-excursion - (if file - (progn - (setq b (vm-get-file-buffer file)) - (if b - (set-buffer b) - (setq temp-buffer (generate-new-buffer "*vm-work*")) - (set-buffer temp-buffer) - (if (file-readable-p file) - (condition-case nil - (let ((coding-system-for-read 'binary)) - (insert-file-contents file nil 0 4096)) - (wrong-number-of-arguments - (call-process "sed" file temp-buffer nil - "-n" "1,/^$/p"))))))) - (save-excursion - (save-restriction - (or start (setq start 1)) - (or end (setq end (1+ (buffer-size)))) - (widen) - (narrow-to-region start end) - (goto-char (point-min)) - (cond ((zerop (buffer-size)) nil) - ((looking-at "\n*From ") - (if (not vm-trust-From_-with-Content-Length) - 'From_ - (let ((case-fold-search t)) - (re-search-forward vm-content-length-search-regexp - nil t)) - (cond ((match-beginning 1) - 'From_) - ((match-beginning 0) - 'From_-with-Content-Length) - (t 'From_)))) - ((looking-at "\001\001\001\001\n") 'mmdf) - ((looking-at "BABYL OPTIONS:") 'babyl) - (t 'unknown))))) - (and temp-buffer (kill-buffer temp-buffer))))) - -(defun vm-convert-folder-type (old-type new-type) - "Convert buffer from OLD-TYPE to NEW-TYPE. -OLD-TYPE and NEW-TYPE should be symbols returned from vm-get-folder-type. -This should be called on non-live buffers like crash boxes. -This will confuse VM if called on a folder buffer in vm-mode." - (let ((vm-folder-type old-type) - (pos-list nil) - beg end) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (while (vm-find-leading-message-separator) - (setq pos-list (cons (point-marker) pos-list)) - (vm-skip-past-leading-message-separator) - (setq pos-list (cons (point-marker) pos-list)) - (vm-find-trailing-message-separator) - (setq pos-list (cons (point-marker) pos-list)) - (vm-skip-past-trailing-message-separator) - (setq pos-list (cons (point-marker) pos-list))) - (setq pos-list (nreverse pos-list)) - (goto-char (point-min)) - (vm-convert-folder-header old-type new-type) - (while pos-list - (setq beg (car pos-list)) - (goto-char (car pos-list)) - (insert-before-markers (vm-leading-message-separator new-type)) - (delete-region (car pos-list) (car (cdr pos-list))) - (vm-convert-folder-type-headers old-type new-type) - (setq pos-list (cdr (cdr pos-list))) - (setq end (marker-position (car pos-list))) - (goto-char (car pos-list)) - (insert-before-markers (vm-trailing-message-separator new-type)) - (delete-region (car pos-list) (car (cdr pos-list))) - (goto-char beg) - (vm-munge-message-separators new-type beg end) - (setq pos-list (cdr (cdr pos-list)))))) - -(defun vm-convert-folder-header (old-type new-type) - "Convert the folder header form OLD-TYPE to NEW-TYPE. -The folder header is the text at the beginning of a folder that -is a legal part of the folder but is not part of the first -message. This is for dealing with BABYL files." - (if (eq old-type 'babyl) - (save-excursion - (let ((beg (point)) - (case-fold-search t)) - (cond ((and (looking-at "BABYL OPTIONS:") - (search-forward "\037" nil t)) - (delete-region beg (point))))))) - (if (eq new-type 'babyl) - ;; insert before markers so that message location markers - ;; for the first message get moved forward. - (insert-before-markers "BABYL OPTIONS:\nVersion: 5\n\037"))) - -(defun vm-skip-past-folder-header () - "Move point past the folder header. -The folder header is the text at the beginning of a folder that -is a legal part of the folder but is not part of the first -message. This is for dealing with BABYL files." - (cond ((eq vm-folder-type 'babyl) - (search-forward "\037" nil 0)))) - -(defun vm-convert-folder-type-headers (old-type new-type) - "Convert headers in the message around point from OLD-TYPE to NEW-TYPE. -This means to add/delete Content-Length and any other -headers related to folder-type as needed for folder type -conversions. This function expects point to be at the beginning -of the header section of a message, and it only deals with that -message." - (let (length) - ;; get the length now before the content-length headers are - ;; removed. - (if (eq new-type 'From_-with-Content-Length) - (let (start) - (save-excursion - (save-excursion - (search-forward "\n\n" nil 0) - (setq start (point))) - (let ((vm-folder-type old-type)) - (vm-find-trailing-message-separator)) - (setq length (- (point) start))))) - ;; chop out content-length header if new format doesn't need - ;; it or if the new format computed his own copy. - (if (or (eq old-type 'From_-with-Content-Length) - (eq new-type 'From_-with-Content-Length)) - (save-excursion - (while (and (let ((case-fold-search t)) - (re-search-forward vm-content-length-search-regexp - nil t)) - (null (match-beginning 1)) - (progn (goto-char (match-beginning 0)) - (vm-match-header vm-content-length-header))) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - ;; insert the content-length header if needed - (if (eq new-type 'From_-with-Content-Length) - (save-excursion - (insert vm-content-length-header " " (int-to-string length) "\n"))))) - -(defun vm-munge-message-separators (folder-type start end) - "Munge message separators of FOLDER-TYPE found between START and END. -This function is used to eliminate message separators for a particular -folder type that happen to occur in a message. \">\" is prepended to such -separators." - (save-excursion - (let ((vm-folder-type folder-type)) - (cond ((memq folder-type '(From_ From_-with-Content-Length mmdf babyl)) - (setq end (vm-marker end)) - (goto-char start) - (while (and (vm-find-leading-message-separator) - (< (point) end)) - (insert ">")) - (set-marker end nil)))))) - -(defun vm-compatible-folder-p (file) - "Return non-nil if FILE is a compatible folder with the current buffer. -The current folder must have vm-folder-type initialized. -FILE is compatible if - - it is empty - - the current folder is empty - - the two folder types are equal" - (let ((type (vm-get-folder-type file))) - (or (not (and vm-folder-type type)) - (eq vm-folder-type type)))) - -(defun vm-leading-message-separator (&optional folder-type message - for-other-folder) - "Returns a leading message separator for the current folder. -Defaults to returning a separator for the current folder type. - -Optional first arg FOLDER-TYPE means return a separator for that -folder type instead. - -Optional second arg MESSAGE should be a message struct. This is used -generating BABYL separators, because they contain message attributes -and labels that must must be copied from the message. - -Optional third arg FOR-OTHER-FOLDER non-nil means that this separator will -be used a `foreign' folder. This means that the `deleted' -attributes should not be copied for BABYL folders." - (let ((type (or folder-type vm-folder-type))) - (cond ((memq type '(From_ From_-with-Content-Length)) - (concat "From VM " (current-time-string) "\n")) - ((eq type 'mmdf) - "\001\001\001\001\n") - ((eq type 'babyl) - (cond (message - (concat "\014\n0," - (vm-babyl-attributes-string message for-other-folder) - ",\n*** EOOH ***\n")) - (t "\014\n0, recent, unseen,,\n*** EOOH ***\n")))))) - -(defun vm-trailing-message-separator (&optional folder-type) - "Returns a leading message separator for the current folder. -Defaults to returning a separator for the current folder type. - -Optional first arg FOLDER-TYPE means return a separator for that -folder type instead." - (let ((type (or folder-type vm-folder-type))) - (cond ((eq type 'From_) "\n") - ((eq type 'From_-with-Content-Length) "") - ((eq type 'mmdf) "\001\001\001\001\n") - ((eq type 'babyl) "\037")))) - -(defun vm-folder-header (&optional folder-type label-obarray) - "Returns a folder header for the current folder. -Defaults to returning a folder header for the current folder type. - -Optional first arg FOLDER-TYPE means return a folder header for that -folder type instead. - -Optional second arg LABEL-OBARRAY should be an obarray of labels -that have been used in this folder. This is used for BABYL folders." - (let ((type (or folder-type vm-folder-type))) - (cond ((eq type 'babyl) - (let ((list nil)) - (if label-obarray - (mapatoms (function - (lambda (sym) - (setq list (cons sym list)))) - label-obarray)) - (if list - (format "BABYL OPTIONS:\nVersion: 5\nLabels: %s\n\037" - (mapconcat (function symbol-name) list ", ")) - "BABYL OPTIONS:\nVersion: 5\n\037"))) - (t "")))) - -(defun vm-find-leading-message-separator () - "Find the next leading message separator in a folder. -Returns non-nil if the separator is found, nil otherwise." - (cond - ((eq vm-folder-type 'From_) - (let ((reg1 "^From ") - (reg2 "^>From ") - (case-fold-search nil)) - (catch 'done - (while (re-search-forward reg1 nil 'no-error) - (goto-char (match-beginning 0)) - ;; remove the requirement that there be two - ;; consecutive newlines (or the beginning of the - ;; buffer) before "From ". Hopefully this will not - ;; break more than it fixes. (18 August 1995) - (if ;; (and (or (< (point) 3) - ;; (equal (char-after (- (point) 2)) ?\n)) - (save-excursion - (and (= 0 (forward-line 1)) - (or (vm-match-header) - (looking-at reg2)))) - ;; ) - (throw 'done t) - (forward-char 1))) - nil ))) - ((eq vm-folder-type 'From_-with-Content-Length) - (let ((reg1 "\\(^\\|\n+\\)From ") - (case-fold-search nil)) - (if (re-search-forward reg1 nil 'no-error) - (progn (goto-char (match-end 1)) t) - nil ))) - ((eq vm-folder-type 'mmdf) - (let ((reg1 "^\001\001\001\001") - (case-fold-search nil)) - (if (re-search-forward reg1 nil 'no-error) - (progn - (goto-char (match-beginning 0)) - t ) - nil ))) - ((eq vm-folder-type 'babyl) - (let ((reg1 "\014\n[01],") - (case-fold-search nil)) - (catch 'done - (while (re-search-forward reg1 nil 'no-error) - (goto-char (match-beginning 0)) - (if (and (not (bobp)) (= (preceding-char) ?\037)) - (throw 'done t) - (forward-char 1))) - nil ))))) - -(defun vm-find-trailing-message-separator () - "Find the next trailing message separator in a folder." - (cond - ((eq vm-folder-type 'From_) - (vm-find-leading-message-separator) - (forward-char -1)) - ((eq vm-folder-type 'From_-with-Content-Length) - (let ((reg1 "^From ") - content-length - (start-point (point)) - (case-fold-search nil)) - (if (and (let ((case-fold-search t)) - (re-search-forward vm-content-length-search-regexp nil t)) - (null (match-beginning 1)) - (progn (goto-char (match-beginning 0)) - (vm-match-header vm-content-length-header))) - (progn - (setq content-length - (string-to-int (vm-matched-header-contents))) - ;; if search fails, we'll be at point-max - ;; if specified content-length is too long, go to point-max - (if (search-forward "\n\n" nil 0) - (if (>= (- (point-max) (point)) content-length) - (forward-char content-length) - (goto-char (point-max)))) - ;; Some systems seem to add a trailing newline that's - ;; not counted in the Content-Length header. Allow - ;; any number of them to avoid trouble. - (skip-chars-forward "\n"))) - (if (or (eobp) (looking-at reg1)) - nil - (goto-char start-point) - (if (re-search-forward reg1 nil 0) - (forward-char -5))))) - ((eq vm-folder-type 'mmdf) - (vm-find-leading-message-separator)) - ((eq vm-folder-type 'babyl) - (vm-find-leading-message-separator) - (forward-char -1)))) - -(defun vm-skip-past-leading-message-separator () - "Move point past a leading message separator at point." - (cond - ((memq vm-folder-type '(From_ From_-with-Content-Length)) - (let ((reg1 "^>From ") - (case-fold-search nil)) - (forward-line 1) - (while (looking-at reg1) - (forward-line 1)))) - ((eq vm-folder-type 'mmdf) - (forward-char 5) - ;; skip >From. Either SCO's MMDF implementation leaves this - ;; stuff in the message, or many sysadmins have screwed up - ;; their mail configuration. Either way I'm tired of getting - ;; bug reports about it. - (let ((reg1 "^>From ") - (case-fold-search nil)) - (while (looking-at reg1) - (forward-line 1)))) - ((eq vm-folder-type 'babyl) - (search-forward "\n*** EOOH ***\n" nil 0)))) - -(defun vm-skip-past-trailing-message-separator () - "Move point past a trailing message separator at point." - (cond - ((eq vm-folder-type 'From_) - (forward-char 1)) - ((eq vm-folder-type 'From_-with-Content-Length)) - ((eq vm-folder-type 'mmdf) - (forward-char 5)) - ((eq vm-folder-type 'babyl) - (forward-char 1)))) - -(defun vm-build-message-list () - "Build a chain of message structures, stored them in vm-message-list. -Finds the start and end of each message and fills in the relevant -fields in the message structures. - -Also finds the beginning of the header section and the end of the -text section and fills in these fields in the message structures. - -vm-text-of and vm-vheaders-of field don't get filled until they -are needed. - -If vm-message-list already contained messages, the end of the last -known message is found and then the parsing of new messages begins -there and the message are appended to vm-message-list. - -vm-folder-type is initialized here." - (setq vm-folder-type (vm-get-folder-type)) - (save-excursion - (let ((tail-cons nil) - (n 0) - ;; Just for yucks, make the update interval vary. - (modulus (+ (% (vm-abs (random)) 11) 25)) - message last-end) - (if vm-message-list - ;; there are already messages, therefore we're supposed - ;; to add to this list. - (let ((mp vm-message-list) - (end (point-min))) - ;; first we have to find physical end of the folder - ;; prior to the new messages that just came in. - (while mp - (if (< end (vm-end-of (car mp))) - (setq end (vm-end-of (car mp)))) - (if (not (consp (cdr mp))) - (setq tail-cons mp)) - (setq mp (cdr mp))) - (goto-char end)) - ;; there are no messages so we're building the whole list. - ;; start from the beginning of the folder. - (goto-char (point-min)) - ;; whine about newlines at the beginning of the folder. - ;; technically I think this is corruption, but there are - ;; too many busted mail-do-fcc's installed out there to - ;; do more than whine. - (if (and (memq vm-folder-type '(From_ From_-with-Content-Length)) - (= (following-char) ?\n)) - (progn - (message "Warning: newline found at beginning of folder, %s" - (or buffer-file-name (buffer-name))) - (sleep-for 2))) - (vm-skip-past-folder-header)) - (setq last-end (point)) - ;; parse the messages, set the markers that specify where - ;; things are. - (while (vm-find-leading-message-separator) - (setq message (vm-make-message)) - (vm-set-message-type-of message vm-folder-type) - (vm-set-start-of message (vm-marker (point))) - (vm-skip-past-leading-message-separator) - (vm-set-headers-of message (vm-marker (point))) - (vm-find-trailing-message-separator) - (vm-set-text-end-of message (vm-marker (point))) - (vm-skip-past-trailing-message-separator) - (setq last-end (point)) - (vm-set-end-of message (vm-marker (point))) - (vm-set-reverse-link-of message tail-cons) - (if (null tail-cons) - (setq vm-message-list (list message) - tail-cons vm-message-list) - (setcdr tail-cons (list message)) - (setq tail-cons (cdr tail-cons))) - (vm-increment n) - (if (zerop (% n modulus)) - (message "Parsing messages... %d" n))) - (if (>= n modulus) - (message "Parsing messages... done")) - (if (and (not (= last-end (point-max))) - (not (eq vm-folder-type 'unknown))) - (progn - (message "Warning: garbage found at end of folder, %s" - (or buffer-file-name (buffer-name))) - (sleep-for 2)))))) - -(defun vm-build-header-order-alist (vheaders) - (let ((order-alist (cons nil nil)) - list) - (setq list order-alist) - (while vheaders - (setcdr list (cons (cons (car vheaders) nil) nil)) - (setq list (cdr list) vheaders (cdr vheaders))) - (cdr order-alist))) - -;; Reorder the headers in a message. -;; -;; If a message struct is passed into this function, then we're -;; operating on a message in a folder buffer. Headers are -;; grouped so that the headers that the user wants to see are at -;; the end of the headers section so we can narrow to them. This -;; is done according to the preferences specified in -;; vm-visible-header and vm-invisible-header-regexp. The -;; vheaders field of the message struct is also set. This -;; function is called on demand whenever a vheaders field is -;; discovered to be nil for a particular message. -;; -;; If the message argument is nil, then we are operating on a -;; freestanding message that is not part of a folder buffer. The -;; keep-list and discard-regexp parameters are used in this case. -;; Headers not matched by the keep list or matched by the discard -;; list are stripped from the message. The remaining headers -;; are ordered according to the order of the keep list. - -(defun vm-reorder-message-headers (message keep-list discard-regexp) - (save-excursion - (if message - (progn - (set-buffer (vm-buffer-of message)) - (setq keep-list vm-visible-headers - discard-regexp vm-invisible-header-regexp))) - (save-excursion - (save-restriction - (widen) - ;; if there is a cached regexp that points to the already - ;; ordered headers then use it and avoid a lot of work. - (if (and message (vm-vheaders-regexp-of message)) - (save-excursion - (goto-char (vm-headers-of message)) - (let ((case-fold-search t)) - (re-search-forward (vm-vheaders-regexp-of message) - (vm-text-of message) t)) - (vm-set-vheaders-of message (vm-marker (match-beginning 0)))) - ;; oh well, we gotta do it the hard way. - ;; - ;; header-alist will contain an assoc list version of - ;; keep-list. For messages associated with a folder - ;; buffer: when a matching header is found, the - ;; header's start and end positions are added to its - ;; corresponding assoc cell. The positions of unwanted - ;; headers are remember also so that they can be copied - ;; to the top of the message, to be out of sight after - ;; narrowing. Once the positions have all been - ;; recorded a new copy of the headers is inserted in - ;; the proper order and the old headers are deleted. - ;; - ;; For free standing messages, unwanted headers are - ;; stripped from the message, unremembered. - (vm-save-restriction - (let ((header-alist (vm-build-header-order-alist keep-list)) - (buffer-read-only nil) - (work-buffer nil) - (extras nil) - list end-of-header vheader-offset - (folder-buffer (current-buffer)) - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock directory - ;; is on a slow device. We don't need locking here because - ;; in a mail context reordering headers is harmless. - (buffer-file-name nil) - (case-fold-search t) - (unwanted-list nil) - unwanted-tail - new-header-start - old-header-start - (old-buffer-modified-p (buffer-modified-p))) - (unwind-protect - (progn - (if message - (progn - ;; for babyl folders, keep an untouched - ;; copy of the headers between the - ;; attributes line and the *** EOOH *** - ;; line. - (if (and (eq vm-folder-type 'babyl) - (null (vm-babyl-frob-flag-of message))) - (progn - (goto-char (vm-start-of message)) - (forward-line 2) - (vm-set-babyl-frob-flag-of message t) - (insert-buffer-substring - (current-buffer) - (vm-headers-of message) - (1- (vm-text-of message))))) - (setq work-buffer (generate-new-buffer "*vm-work*")) - (set-buffer work-buffer) - (insert-buffer-substring - folder-buffer - (vm-headers-of message) - (vm-text-of message)) - (goto-char (point-min)))) - (setq old-header-start (point)) - ;; as we loop through the headers, skip >From - ;; lines. these can occur anywhere in the - ;; header section if the message has been - ;; manhandled by some dumb delivery agents - ;; (SCO and Solaris are the usual suspects.) - ;; it's a tough ol' world. - (while (progn (while (looking-at ">From ") - (forward-line)) - (and (not (= (following-char) ?\n)) - (vm-match-header))) - (setq end-of-header (vm-matched-header-end) - list (vm-match-ordered-header header-alist)) - ;; don't display/keep this header if - ;; keep-list not matched - ;; and discard-regexp is nil - ;; or - ;; discard-regexp is matched - (if (or (and (null list) (null discard-regexp)) - (and discard-regexp (looking-at discard-regexp))) - ;; delete the unwanted header if not doing - ;; work for a folder buffer, otherwise - ;; remember the start and end of the - ;; unwanted header so we can copy it - ;; later. - (if (not message) - (delete-region (point) end-of-header) - (if (null unwanted-list) - (setq unwanted-list - (cons (point) (cons end-of-header nil)) - unwanted-tail unwanted-list) - (if (= (point) (car (cdr unwanted-tail))) - (setcar (cdr unwanted-tail) - end-of-header) - (setcdr (cdr unwanted-tail) - (cons (point) - (cons end-of-header nil))) - (setq unwanted-tail (cdr (cdr unwanted-tail))))) - (goto-char end-of-header)) - ;; got a match - ;; stuff the start and end of the header - ;; into the cdr of the returned alist - ;; element. - (if list - ;; reverse point and end-of-header. - ;; list will be nreversed later. - (setcdr list (cons end-of-header - (cons (point) - (cdr list)))) - ;; reverse point and end-of-header. - ;; list will be nreversed later. - (setq extras - (cons end-of-header - (cons (point) extras)))) - (goto-char end-of-header))) - (setq new-header-start (point)) - (while unwanted-list - (insert-buffer-substring (current-buffer) - (car unwanted-list) - (car (cdr unwanted-list))) - (setq unwanted-list (cdr (cdr unwanted-list)))) - ;; remember the offset of where the visible - ;; header start so we can initialize the - ;; vm-vheaders-of field later. - (if message - (setq vheader-offset (- (point) new-header-start))) - (while header-alist - (setq list (nreverse (cdr (car header-alist)))) - (while list - (insert-buffer-substring (current-buffer) - (car list) - (car (cdr list))) - (setq list (cdr (cdr list)))) - (setq header-alist (cdr header-alist))) - ;; now the headers that were not explicitly - ;; undesirable, if any. - (setq extras (nreverse extras)) - (while extras - (insert-buffer-substring (current-buffer) - (car extras) - (car (cdr extras))) - (setq extras (cdr (cdr extras)))) - (delete-region old-header-start new-header-start) - ;; update the folder buffer if we're supposed to. - ;; lock out interrupts. - (if message - (let ((inhibit-quit t)) - (set-buffer (vm-buffer-of message)) - (goto-char (vm-headers-of message)) - (insert-buffer-substring work-buffer) - (delete-region (point) (vm-text-of message)) - (set-buffer-modified-p old-buffer-modified-p)))) - (and work-buffer (kill-buffer work-buffer))) - (if message - (progn - (vm-set-vheaders-of message - (vm-marker (+ (vm-headers-of message) - vheader-offset))) - ;; cache a regular expression that can be used to - ;; find the start of the reordered header the next - ;; time this folder is visited. - (goto-char (vm-vheaders-of message)) - (if (vm-match-header) - (vm-set-vheaders-regexp-of - message - (concat "^" (vm-matched-header-name) ":")))))))))))) - -;; Reads the message attributes and cached header information from the -;; header portion of the each message, if our X-VM- attributes header is -;; present. If the header is not present, assume the message is new, -;; unless we are being compatible with Berkeley Mail in which case we -;; also check for a Status header. -;; -;; If a message already has attributes don't bother checking the -;; headers. -;; -;; This function also discovers and stores the position where the -;; message text begins. -;; -;; Totals are gathered for use by vm-emit-totals-blurb. -;; -;; Supports version 4 format of attribute storage, for backward compatibility. - -(defun vm-read-attributes (message-list) - (save-excursion - (let ((mp (or message-list vm-message-list)) - (vm-new-count 0) - (vm-unread-count 0) - (vm-deleted-count 0) - (vm-total-count 0) - (modulus (+ (% (vm-abs (random)) 11) 25)) - (case-fold-search t) - oldpoint data) - (while mp - (vm-increment vm-total-count) - (if (vm-attributes-of (car mp)) - () - (goto-char (vm-headers-of (car mp))) - ;; find start of text section and save it - (search-forward "\n\n" (vm-text-end-of (car mp)) 0) - (vm-set-text-of (car mp) (point-marker)) - ;; now look for our header - (goto-char (vm-headers-of (car mp))) - (cond - ((re-search-forward vm-attributes-header-regexp - (vm-text-of (car mp)) t) - (goto-char (match-beginning 2)) - (condition-case () - (progn - (setq oldpoint (point) - data (read (current-buffer))) - (if (and (or (not (listp data)) (not (= 3 (length data)))) - (not (vectorp data))) - (progn - (error "Bad x-vm-v5-data at %d in buffer %s" - oldpoint (buffer-name)))) - data ) - (error - (message "Bad x-vm-v5-data header at %d in buffer %s, ignoring" - oldpoint (buffer-name)) - (setq data - (list - (make-vector vm-attributes-vector-length nil) - (make-vector vm-cache-vector-length nil) - nil)) - ;; In lieu of a valid attributes header - ;; assume the message is new. avoid - ;; vm-set-new-flag because it asks for a - ;; summary update. - (vm-set-new-flag-in-vector (car data) t))) - ;; support version 4 format - (cond ((vectorp data) - (setq data (vm-convert-v4-attributes data)) - ;; tink the message modflag so that if the - ;; user saves we get rid of the old v4 - ;; attributes header. otherwise we could be - ;; dealing with these things for all eternity. - (vm-set-modflag-of (car mp) t)) - (t - ;; extend vectors if necessary to accomodate - ;; more caching and attributes without alienating - ;; other version 5 folders. - (cond ((< (length (car data)) - vm-attributes-vector-length) - ;; tink the message modflag so that if - ;; the user saves we get rid of the old - ;; short vector. otherwise we could be - ;; dealing with these things for all - ;; eternity. - (vm-set-modflag-of (car mp) t) - (setcar data (vm-extend-vector - (car data) - vm-attributes-vector-length)))) - (cond ((< (length (car (cdr data))) - vm-cache-vector-length) - ;; tink the message modflag so that if - ;; the user saves we get rid of the old - ;; short vector. otherwise we could be - ;; dealing with these things for all - ;; eternity. - (vm-set-modflag-of (car mp) t) - (setcar (cdr data) - (vm-extend-vector - (car (cdr data)) - vm-cache-vector-length)))))) - (vm-set-labels-of (car mp) (nth 2 data)) - (vm-set-cache-of (car mp) (car (cdr data))) - (vm-set-attributes-of (car mp) (car data))) - ((and vm-berkeley-mail-compatibility - (re-search-forward vm-berkeley-mail-status-header-regexp - (vm-text-of (car mp)) t)) - (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length - nil)) - (goto-char (match-beginning 1)) - (vm-set-attributes-of - (car mp) - (make-vector vm-attributes-vector-length nil)) - (vm-set-unread-flag (car mp) (not (looking-at ".*R.*")) t)) - (t - (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length - nil)) - (vm-set-attributes-of - (car mp) - (make-vector vm-attributes-vector-length nil)) - ;; In lieu of a valid attributes header - ;; assume the message is new. avoid - ;; vm-set-new-flag because it asks for a - ;; summary update. - (vm-set-new-flag-of (car mp) t))) - ;; let babyl attributes override the normal VM - ;; attributes header. - (cond ((eq vm-folder-type 'babyl) - (vm-read-babyl-attributes (car mp))))) - (cond ((vm-deleted-flag (car mp)) - (vm-increment vm-deleted-count)) - ((vm-new-flag (car mp)) - (vm-increment vm-new-count)) - ((vm-unread-flag (car mp)) - (vm-increment vm-unread-count))) - (if (zerop (% vm-total-count modulus)) - (message "Reading attributes... %d" vm-total-count)) - (setq mp (cdr mp))) - (if (>= vm-total-count modulus) - (message "Reading attributes... done")) - (if (null message-list) - (setq vm-totals (list vm-modification-counter - vm-total-count - vm-new-count - vm-unread-count - vm-deleted-count)))))) - -(defun vm-read-babyl-attributes (message) - (let ((case-fold-search t) - (labels nil) - (vect (make-vector vm-attributes-vector-length nil))) - (vm-set-attributes-of message vect) - (save-excursion - (goto-char (vm-start-of message)) - ;; skip past ^L\n - (forward-char 2) - (vm-set-babyl-frob-flag-of message (if (= (following-char) ?1) t nil)) - ;; skip past 0, - (forward-char 2) - ;; loop, noting attributes as we go. - (while (and (not (eobp)) (not (looking-at ","))) - (cond ((looking-at " unseen,") - (vm-set-unread-flag-of message t)) - ((looking-at " recent,") - (vm-set-new-flag-of message t)) - ((looking-at " deleted,") - (vm-set-deleted-flag-of message t)) - ((looking-at " answered,") - (vm-set-replied-flag-of message t)) - ((looking-at " forwarded,") - (vm-set-forwarded-flag-of message t)) - ((looking-at " filed,") - (vm-set-filed-flag-of message t)) - ((looking-at " redistributed,") - (vm-set-redistributed-flag-of message t)) - ;; only VM knows about these, as far as I know. - ((looking-at " edited,") - (vm-set-forwarded-flag-of message t)) - ((looking-at " written,") - (vm-set-forwarded-flag-of message t))) - (skip-chars-forward "^,") - (and (not (eobp)) (forward-char 1))) - (and (not (eobp)) (forward-char 1)) - (while (looking-at " \\([^\000-\040,\177-\377]+\\),") - (setq labels (cons (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1)) - labels)) - (goto-char (match-end 0))) - (vm-set-labels-of message labels)))) - -(defun vm-set-default-attributes (message-list) - (let ((mp (or message-list vm-message-list)) attr cache) - (while mp - (setq attr (make-vector vm-attributes-vector-length nil) - cache (make-vector vm-cache-vector-length nil)) - (vm-set-cache-of (car mp) cache) - (vm-set-attributes-of (car mp) attr) - ;; make message be new by default, but avoid vm-set-new-flag - ;; because it asks for a summary update for the message. - (vm-set-new-flag-of (car mp) t) - ;; since this function is usually called in lieu of reading - ;; attributes from the buffer, the attributes may be - ;; untrustworthy. tink the message modflag to force the - ;; new attributes out if the user saves. - (vm-set-modflag-of (car mp) t) - (setq mp (cdr mp))))) - -(defun vm-emit-totals-blurb () - (save-excursion - (vm-select-folder-buffer) - (if (not (equal (nth 0 vm-totals) vm-modification-counter)) - (let ((mp vm-message-list) - (vm-new-count 0) - (vm-unread-count 0) - (vm-deleted-count 0) - (vm-total-count 0)) - (while mp - (vm-increment vm-total-count) - (cond ((vm-deleted-flag (car mp)) - (vm-increment vm-deleted-count)) - ((vm-new-flag (car mp)) - (vm-increment vm-new-count)) - ((vm-unread-flag (car mp)) - (vm-increment vm-unread-count))) - (setq mp (cdr mp))) - (setq vm-totals (list vm-modification-counter - vm-total-count - vm-new-count - vm-unread-count - vm-deleted-count)))) - (if (equal (nth 1 vm-totals) 0) - (message "No messages.") - (message "%d message%s, %d new, %d unread, %d deleted" - (nth 1 vm-totals) (if (= (nth 1 vm-totals) 1) "" "s") - (nth 2 vm-totals) - (nth 3 vm-totals) - (nth 4 vm-totals))))) - -(defun vm-convert-v4-attributes (data) - (list (apply 'vector - (nconc (vm-vector-to-list data) - (make-list (- vm-attributes-vector-length - (length data)) - nil))) - (make-vector vm-cache-vector-length nil))) - -(defun vm-gobble-labels () - (let ((case-fold-search t) - lim) - (save-excursion - (vm-save-restriction - (widen) - (if (eq vm-folder-type 'babyl) - (progn - (goto-char (point-min)) - (vm-skip-past-folder-header) - (setq lim (point)) - (goto-char (point-min)) - (if (re-search-forward "^Labels:" lim t) - (let (string list) - (setq string (buffer-substring - (point) - (progn (end-of-line) (point))) - list (vm-parse string -"[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*")) - (mapcar (function - (lambda (s) - (intern (downcase s) vm-label-obarray))) - list)))) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (if (re-search-forward vm-labels-header-regexp lim t) - (let ((oldpoint (point)) - list) - (condition-case () - (progn - (setq list (read (current-buffer))) - (if (not (listp list)) - (error "Bad global label list at %d in buffer %s" - oldpoint (buffer-name))) - list ) - (error - (message "Bad global label list at %d in buffer %s, ignoring" - oldpoint (buffer-name)) - (setq list nil) )) - (mapcar (function - (lambda (s) - (intern s vm-label-obarray))) - list)))))) - t )) - -;; Go to the message specified in a bookmark and eat the bookmark. -;; Returns non-nil if successful, nil otherwise. -(defun vm-gobble-bookmark () - (let ((case-fold-search t) - (n nil) - lim oldpoint) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (if (re-search-forward vm-bookmark-header-regexp lim t) - (condition-case () - (progn - (setq oldpoint (point) - n (read (current-buffer))) - (if (not (natnump n)) - (error "Bad bookmark at %d in buffer %s" - oldpoint (buffer-name))) - n ) - (error - (message "Bad bookmark at %d in buffer %s, ignoring" - oldpoint (buffer-name)) - (setq n 1)))))) - (if n - (vm-record-and-change-message-pointer - vm-message-pointer - (nthcdr (1- n) vm-message-list))) - t )) - -(defun vm-gobble-visible-header-variables () - (save-excursion - (vm-save-restriction - (let ((case-fold-search t) - lim) - (widen) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (if (re-search-forward vm-vheader-header-regexp lim t) - (let (vis invis (got nil)) - (condition-case () - (setq vis (read (current-buffer)) - invis (read (current-buffer)) - got t) - (error nil)) - ;; if the variables don't match the values stored when this - ;; folder was saved, then we have to discard any cached - ;; vheader info so the user will see the right headers. - (and got (or (not (equal vis vm-visible-headers)) - (not (equal invis vm-invisible-header-regexp))) - (let ((mp vm-message-list)) - (message "Discarding visible header info...") - (while mp - (vm-set-vheaders-regexp-of (car mp) nil) - (vm-set-vheaders-of (car mp) nil) - (setq mp (cdr mp))))))))))) - -;; Read and delete the header that gives the folder's desired -;; message order. -(defun vm-gobble-message-order () - (let ((case-fold-search t) - lim v order - (mp vm-message-list) - list-length) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (if (re-search-forward vm-message-order-header-regexp lim t) - (let ((oldpoint (point))) - (message "Reordering messages...") - (condition-case nil - (progn - (setq order (read (current-buffer))) - (if (not (listp order)) - (error "Bad order header at %d in buffer %s" - oldpoint (buffer-name))) - order ) - (error - (message "Bad order header at %d in buffer %s, ignoring" - oldpoint (buffer-name)) - (setq order nil))) - (setq list-length (length vm-message-list) - v (make-vector (max list-length (length order)) nil)) - (while (and order mp) - (condition-case nil - (aset v (1- (car order)) (car mp)) - (args-out-of-range nil)) - (setq order (cdr order) mp (cdr mp))) - ;; lock out interrupts while the message list is in - ;; an inconsistent state. - (let ((inhibit-quit t)) - (setq vm-message-list (delq nil (append v mp)) - vm-message-order-changed nil - vm-message-order-header-present t - vm-message-pointer (memq (car vm-message-pointer) - vm-message-list)) - (vm-set-numbering-redo-start-point t) - (vm-reverse-link-messages)) - (message "Reordering messages... done"))))))) - -;; Read the header that gives the folder's cached summary format -;; If the current summary format is different, then the cached -;; summary lines are discarded. -(defun vm-gobble-summary () - (let ((case-fold-search t) - summary lim - (mp vm-message-list)) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (if (re-search-forward vm-summary-header-regexp lim t) - (let ((oldpoint (point))) - (condition-case () - (setq summary (read (current-buffer))) - (error - (message "Bad summary header at %d in buffer %s, ignoring" - oldpoint (buffer-name)) - (setq summary ""))) - (if (not (equal summary vm-summary-format)) - (while mp - (vm-set-summary-of (car mp) nil) - ;; force restuffing of cache to clear old - ;; summary entry cache. - (vm-set-modflag-of (car mp) t) - (setq mp (cdr mp)))))))))) - -;; Stuff the message attributes back into the message as headers. -(defun vm-stuff-attributes (m &optional for-other-folder) - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - attributes cache - (case-fold-search t) - (buffer-read-only nil) - opoint - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil) - (delflag (vm-deleted-flag m))) - (unwind-protect - (progn - ;; don't put this folder's summary entry into another folder. - (if for-other-folder - (vm-set-summary-of m nil) - (if (vm-su-start-of m) - ;; fill the summary cache if it's not done already. - (vm-su-summary m))) - (setq attributes (vm-attributes-of m) - cache (vm-cache-of m)) - (and delflag for-other-folder - (vm-set-deleted-flag-in-vector - (setq attributes (copy-sequence attributes)) nil)) - (if (eq vm-folder-type 'babyl) - (vm-stuff-babyl-attributes m for-other-folder)) - (goto-char (vm-headers-of m)) - (while (re-search-forward vm-attributes-header-regexp - (vm-text-of m) t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (vm-headers-of m)) - (setq opoint (point)) - (insert-before-markers - vm-attributes-header " (" - (let ((print-escape-newlines t)) - (prin1-to-string attributes)) - "\n\t" - (let ((print-escape-newlines t)) - (prin1-to-string cache)) - "\n\t" - (let ((print-escape-newlines t)) - (prin1-to-string (vm-labels-of m))) - ")\n") - (set-marker (vm-headers-of m) opoint) - (cond ((and (eq vm-folder-type 'From_) - vm-berkeley-mail-compatibility) - (goto-char (vm-headers-of m)) - (while (re-search-forward - vm-berkeley-mail-status-header-regexp - (vm-text-of m) t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (vm-headers-of m)) - (cond ((not (vm-new-flag m)) - (insert-before-markers - vm-berkeley-mail-status-header - (if (vm-unread-flag m) "" "R") - "O\n") - (set-marker (vm-headers-of m) opoint))))) - (vm-set-modflag-of m nil)) - (set-buffer-modified-p old-buffer-modified-p)))))) - -(defun vm-stuff-folder-attributes (&optional abort-if-input-pending) - (let ((newlist nil) mp) - ;; stuff the attributes of messages that need it. - ;; build a list of messages that need their attributes stuffed - (setq mp vm-message-list) - (while mp - (if (vm-modflag-of (car mp)) - (setq newlist (cons (car mp) newlist))) - (setq mp (cdr mp))) - ;; now sort the list by physical order so that we - ;; reduce the amount of gap motion induced by modifying - ;; the buffer. what we want to avoid is updating - ;; message 3, then 234, then 10, then 500, thus causing - ;; large chunks of memory to be copied repeatedly as - ;; the gap moves to accomodate the insertions. - (let ((vm-key-functions '(vm-sort-compare-physical-order-r))) - (setq mp (sort newlist 'vm-sort-compare-xxxxxx))) - (while (and mp (or (not abort-if-input-pending) (not (input-pending-p)))) - (vm-stuff-attributes (car mp)) - (setq mp (cdr mp))) - (if mp nil t))) - -;; we can be a bit lazy in this function since it's only called -;; from within vm-stuff-attributes. we don't worry about -;; restoring the modified flag, setting buffer-read-only, or -;; about not moving point. -(defun vm-stuff-babyl-attributes (m for-other-folder) - (goto-char (vm-start-of m)) - (forward-char 2) - (if (vm-babyl-frob-flag-of m) - (insert "1") - (insert "0")) - (delete-char 1) - (forward-char 1) - (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+") - (delete-region (match-beginning 0) (match-end 0))) - (if (vm-new-flag m) - (insert " recent, unseen,") - (if (vm-unread-flag m) - (insert " unseen,"))) - (if (and (not for-other-folder) (vm-deleted-flag m)) - (insert " deleted,")) - (if (vm-replied-flag m) - (insert " answered,")) - (if (vm-forwarded-flag m) - (insert " forwarded,")) - (if (vm-redistributed-flag m) - (insert " redistributed,")) - (if (vm-filed-flag m) - (insert " filed,")) - (if (vm-edited-flag m) - (insert " edited,")) - (if (vm-written-flag m) - (insert " written,")) - (forward-char 1) - (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+") - (delete-region (match-beginning 0) (match-end 0))) - (mapcar (function (lambda (label) (insert " " label ","))) - (vm-labels-of m))) - -(defun vm-babyl-attributes-string (m for-other-folder) - (concat - (if (vm-new-flag m) - " recent, unseen," - (if (vm-unread-flag m) - " unseen,")) - (if (and (not for-other-folder) (vm-deleted-flag m)) - " deleted,") - (if (vm-replied-flag m) - " answered,") - (if (vm-forwarded-flag m) - " forwarded,") - (if (vm-redistributed-flag m) - " redistributed,") - (if (vm-filed-flag m) - " filed,") - (if (vm-edited-flag m) - " edited,") - (if (vm-written-flag m) - " written,"))) - -(defun vm-babyl-labels-string (m) - (let ((list nil) - (labels (vm-labels-of m))) - (while labels - (setq list (cons "," (cons (car labels) (cons " " list))) - labels (cdr labels))) - (apply 'concat (nreverse list)))) - -(defun vm-stuff-virtual-attributes (message) - (let ((virtual (vm-virtual-message-p message))) - (if (or (not virtual) (and virtual (vm-virtual-messages-of message))) - (save-excursion - (set-buffer - (vm-buffer-of - (vm-real-message-of message))) - (vm-stuff-attributes (vm-real-message-of message)))))) - -(defun vm-stuff-labels () - (if vm-message-pointer - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - (case-fold-search t) - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil) - (buffer-read-only nil) - lim) - (if (eq vm-folder-type 'babyl) - (progn - (goto-char (point-min)) - (vm-skip-past-folder-header) - (delete-region (point) (point-min)) - (insert-before-markers (vm-folder-header vm-folder-type - vm-label-obarray)))) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (while (re-search-forward vm-labels-header-regexp lim t) - (progn (goto-char (match-beginning 0)) - (if (vm-match-header vm-labels-header) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - ;; To insert or to insert-before-markers, that is the question. - ;; - ;; If we insert-before-markers we push a header behind - ;; vm-headers-of, which is clearly undesirable. So we - ;; just insert. This will cause the summary header - ;; to be visible if there are no non-visible headers, - ;; oh well, no way around this. - (insert vm-labels-header " " - (let ((print-escape-newlines t) - (list nil)) - (mapatoms (function - (lambda (sym) - (setq list (cons (symbol-name sym) list)))) - vm-label-obarray) - (prin1-to-string list)) - "\n") - (set-buffer-modified-p old-buffer-modified-p)))))) - -;; Insert a bookmark into the first message in the folder. -(defun vm-stuff-bookmark () - (if vm-message-pointer - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - (case-fold-search t) - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil) - (buffer-read-only nil) - lim) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (if (re-search-forward vm-bookmark-header-regexp lim t) - (progn (goto-char (match-beginning 0)) - (if (vm-match-header vm-bookmark-header) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - ;; To insert or to insert-before-markers, that is the question. - ;; - ;; If we insert-before-markers we push a header behind - ;; vm-headers-of, which is clearly undesirable. So we - ;; just insert. This will cause the bookmark header - ;; to be visible if there are no non-visible headers, - ;; oh well, no way around this. - (insert vm-bookmark-header " " - (vm-number-of (car vm-message-pointer)) - "\n") - (set-buffer-modified-p old-buffer-modified-p)))))) - -;; Insert the summary format variable header into the first message. -(defun vm-stuff-summary () - (if vm-message-pointer - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - (case-fold-search t) - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil) - (buffer-read-only nil) - lim) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (while (re-search-forward vm-summary-header-regexp lim t) - (progn (goto-char (match-beginning 0)) - (if (vm-match-header vm-summary-header) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - ;; To insert or to insert-before-markers, that is the question. - ;; - ;; If we insert-before-markers we push a header behind - ;; vm-headers-of, which is clearly undesirable. So we - ;; just insert. This will cause the summary header - ;; to be visible if there are no non-visible headers, - ;; oh well, no way around this. - (insert vm-summary-header " " - (let ((print-escape-newlines t)) - (prin1-to-string vm-summary-format)) - "\n") - (set-buffer-modified-p old-buffer-modified-p)))))) - -;; stuff the current values of the header variables for future messages. -(defun vm-stuff-header-variables () - (if vm-message-pointer - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - (case-fold-search t) - (print-escape-newlines t) - lim - (buffer-read-only nil) - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (while (re-search-forward vm-vheader-header-regexp lim t) - (progn (goto-char (match-beginning 0)) - (if (vm-match-header vm-vheader-header) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - ;; To insert or to insert-before-markers, that is the question. - ;; - ;; If we insert-before-markers we push a header behind - ;; vm-headers-of, which is clearly undesirable. So we - ;; just insert. This header will be visible if there - ;; are no non-visible headers, oh well, no way around this. - (insert vm-vheader-header " " - (prin1-to-string vm-visible-headers) " " - (prin1-to-string vm-invisible-header-regexp) - "\n") - (set-buffer-modified-p old-buffer-modified-p)))))) - -;; Insert a header into the first message of the folder that lists -;; the folder's message order. -(defun vm-stuff-message-order () - (if (cdr vm-message-list) - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - (case-fold-search t) - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil) - lim n - (buffer-read-only nil) - (mp (copy-sequence vm-message-list))) - (setq mp - (sort mp - (function - (lambda (p q) - (< (vm-start-of p) (vm-start-of q)))))) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-find-leading-message-separator) - (vm-skip-past-leading-message-separator) - (while (re-search-forward vm-message-order-header-regexp lim t) - (progn (goto-char (match-beginning 0)) - (if (vm-match-header vm-message-order-header) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - ;; To insert or to insert-before-markers, that is the question. - ;; - ;; If we insert-before-markers we push a header behind - ;; vm-headers-of, which is clearly undesirable. So we - ;; just insert. This header will be visible if there - ;; are no non-visible headers, oh well, no way around this. - (insert vm-message-order-header "\n\t(") - (setq n 0) - (while mp - (insert (vm-number-of (car mp))) - (setq n (1+ n) mp (cdr mp)) - (and mp (insert - (if (zerop (% n 15)) - "\n\t " - " ")))) - (insert ")\n") - (setq vm-message-order-changed nil - vm-message-order-header-present t) - (set-buffer-modified-p old-buffer-modified-p)))))) - -;; Remove the message order header. -(defun vm-remove-message-order () - (if (cdr vm-message-list) - (save-excursion - (vm-save-restriction - (widen) - (let ((old-buffer-modified-p (buffer-modified-p)) - (case-fold-search t) - lim - ;; This prevents file locking from occuring. Disabling - ;; locking can speed things noticeably if the lock - ;; directory is on a slow device. We don't need locking - ;; here because the user shouldn't care about VM stuffing - ;; its own status headers. - (buffer-file-name nil) - (buffer-read-only nil)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (search-forward "\n\n" nil t) - (setq lim (point)) - (goto-char (point-min)) - (vm-skip-past-folder-header) - (vm-skip-past-leading-message-separator) - (while (re-search-forward vm-message-order-header-regexp lim t) - (progn (goto-char (match-beginning 0)) - (if (vm-match-header vm-message-order-header) - (delete-region (vm-matched-header-start) - (vm-matched-header-end))))) - (setq vm-message-order-header-present nil) - (set-buffer-modified-p old-buffer-modified-p)))))) - -(defun vm-change-all-new-to-unread () - (let ((mp vm-message-list)) - (while mp - (if (vm-new-flag (car mp)) - (progn - (vm-set-new-flag (car mp) nil) - (vm-set-unread-flag (car mp) t))) - (setq mp (cdr mp))))) - -(defun vm-unread-message (&optional count) - "Set the `unread' attribute for the current message. If the message is -already new or unread, then it is left unchanged. - -Numeric prefix argument N means to unread the current message plus the -next N-1 messages. A negative N means unread the current message and -the previous N-1 messages. - -When invoked on marked messages (via vm-next-command-uses-marks), -all marked messages are affected, other messages are ignored." - (interactive "p") - (or count (setq count 1)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((mlist (vm-select-marked-or-prefixed-messages count))) - (while mlist - (if (and (not (vm-unread-flag (car mlist))) - (not (vm-new-flag (car mlist)))) - (vm-set-unread-flag (car mlist) t)) - (setq mlist (cdr mlist)))) - (vm-display nil nil '(vm-unread-message) '(vm-unread-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-quit-just-bury () - "Bury the current VM folder and summary buffers. -The folder is not altered and Emacs is still visiting it. You -can switch back to it with switch-to-buffer or by using the -Buffer Menu." - (interactive) - (vm-select-folder-buffer) - (if (not (memq major-mode '(vm-mode vm-virtual-mode))) - (error "%s must be invoked from a VM buffer." this-command)) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - - (save-excursion (run-hooks 'vm-quit-hook)) - - (vm-garbage-collect-message) - - (vm-display nil nil '(vm-quit-just-bury) - '(vm-quit-just-bury quitting)) - (if vm-summary-buffer - (vm-display vm-summary-buffer nil nil nil)) - (if vm-summary-buffer - (vm-bury-buffer vm-summary-buffer)) - (if vm-presentation-buffer-handle - (vm-display vm-presentation-buffer-handle nil nil nil)) - (if vm-presentation-buffer-handle - (vm-bury-buffer vm-presentation-buffer-handle)) - (vm-display (current-buffer) nil nil nil) - (vm-bury-buffer (current-buffer))) - -(defun vm-quit-just-iconify () - "Iconify the frame and bury the current VM folder and summary buffers. -The folder is not altered and Emacs is still visiting it." - (interactive) - (vm-select-folder-buffer) - (if (not (memq major-mode '(vm-mode vm-virtual-mode))) - (error "%s must be invoked from a VM buffer." this-command)) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - - (save-excursion (run-hooks 'vm-quit-hook)) - - (vm-garbage-collect-message) - - (vm-display nil nil '(vm-quit-just-iconify) - '(vm-quit-just-iconify quitting)) - (let ((summary-buffer vm-summary-buffer) - (pres-buffer vm-presentation-buffer-handle)) - (vm-bury-buffer (current-buffer)) - (if summary-buffer - (vm-bury-buffer summary-buffer)) - (if pres-buffer - (vm-bury-buffer pres-buffer)) - (vm-iconify-frame))) - -(defun vm-quit-no-change () - "Quit visiting the current folder without saving changes made to the folder." - (interactive) - (vm-quit t)) - -(defun vm-quit (&optional no-change) - "Quit visiting the current folder, saving changes. Deleted messages are not expunged." - (interactive) - (vm-select-folder-buffer) - (if (not (memq major-mode '(vm-mode vm-virtual-mode))) - (error "%s must be invoked from a VM buffer." this-command)) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-display nil nil '(vm-quit vm-quit-no-change) - (list this-command 'quitting)) - (let ((virtual (eq major-mode 'vm-virtual-mode))) - (cond - ((and (not virtual) no-change (buffer-modified-p) - (or buffer-file-name buffer-offer-save) - (not (zerop vm-messages-not-on-disk)) - ;; Folder may have been saved with C-x C-s and attributes may have - ;; been changed after that; in that case vm-messages-not-on-disk - ;; would not have been zeroed. However, all modification flag - ;; undos are cleared if VM actually modifies the folder buffer - ;; (as opposed to the folder's attributes), so this can be used - ;; to verify that there are indeed unsaved messages. - (null (assq 'vm-set-buffer-modified-p vm-undo-record-list)) - (not - (y-or-n-p - (format - "%d message%s have not been saved to disk, quit anyway? " - vm-messages-not-on-disk - (if (= 1 vm-messages-not-on-disk) "" "s"))))) - (error "Aborted")) - ((and (not virtual) - no-change - (or buffer-file-name buffer-offer-save) - (buffer-modified-p) - vm-confirm-quit - (not (y-or-n-p "There are unsaved changes, quit anyway? "))) - (error "Aborted")) - ((and (eq vm-confirm-quit t) - (not (y-or-n-p "Do you really want to quit? "))) - (error "Aborted"))) - - (save-excursion (run-hooks 'vm-quit-hook)) - - (vm-garbage-collect-message) - (vm-garbage-collect-folder) - - (vm-virtual-quit) - (if (and (not no-change) (not virtual)) - (progn - ;; this could take a while, so give the user some feedback - (message "Quitting...") - (or vm-folder-read-only (eq major-mode 'vm-virtual-mode) - (vm-change-all-new-to-unread)))) - (if (and (buffer-modified-p) - (or buffer-file-name buffer-offer-save) - (not no-change) - (not virtual)) - (vm-save-folder)) - (message "") - (let ((summary-buffer vm-summary-buffer) - (pres-buffer vm-presentation-buffer-handle) - (mail-buffer (current-buffer))) - (if summary-buffer - (progn - (vm-display summary-buffer nil nil nil) - (kill-buffer summary-buffer))) - (if pres-buffer - (progn - (vm-display pres-buffer nil nil nil) - (kill-buffer pres-buffer))) - (set-buffer mail-buffer) - (vm-display mail-buffer nil nil nil) - ;; vm-display is not supposed to change the current buffer. - ;; still it's better to be safe here. - (set-buffer mail-buffer) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (vm-update-summary-and-mode-line))) - -(defun vm-start-itimers-if-needed () - (cond ((and (not (natnump vm-flush-interval)) - (not (natnump vm-auto-get-new-mail)) - (not (natnump vm-mail-check-interval)))) - ((condition-case data - (progn (require 'itimer) t) - (error nil)) - (and (natnump vm-flush-interval) (not (get-itimer "vm-flush")) - (start-itimer "vm-flush" 'vm-flush-itimer-function - vm-flush-interval nil)) - (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail")) - (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function - vm-auto-get-new-mail nil)) - (and (natnump vm-mail-check-interval) - (not (get-itimer "vm-check-mail")) - (start-itimer "vm-check-mail" 'vm-check-mail-itimer-function - vm-mail-check-interval nil))) - ((condition-case data - (progn (require 'timer) t) - (error nil)) - (let (timer) - (and (natnump vm-flush-interval) - (not (vm-timer-using 'vm-flush-itimer-function)) - (setq timer (run-at-time vm-flush-interval vm-flush-interval - 'vm-flush-itimer-function nil)) - (timer-set-function timer 'vm-flush-itimer-function - (list timer))) - (and (natnump vm-mail-check-interval) - (not (vm-timer-using 'vm-check-mail-itimer-function)) - (setq timer (run-at-time vm-mail-check-interval - vm-mail-check-interval - 'vm-check-mail-itimer-function nil)) - (timer-set-function timer 'vm-check-mail-itimer-function - (list timer))) - (and (natnump vm-auto-get-new-mail) - (not (vm-timer-using 'vm-get-mail-itimer-function)) - (setq timer (run-at-time vm-auto-get-new-mail - vm-auto-get-new-mail - 'vm-get-mail-itimer-function nil)) - (timer-set-function timer 'vm-get-mail-itimer-function - (list timer))))) - (t - (setq vm-flush-interval t - vm-auto-get-new-mail t)))) - -(defun vm-timer-using (fun) - (let ((p timer-list) - (done nil)) - (while (and p (not done)) - (if (eq (aref (car p) 5) fun) - (setq done t) - (setq p (cdr p)))) - p )) - -;; support for vm-mail-check-interval -;; if timer argument is present, this means we're using the Emacs -;; 'timer package rather than the 'itimer package. -(defun vm-check-mail-itimer-function (&optional timer) - ;; FSF Emacs sets this non-nil, which means the user can't - ;; interrupt the check. Bogus. - (setq inhibit-quit nil) - (if (integerp vm-mail-check-interval) - (if timer - (timer-set-time timer (current-time) vm-mail-check-interval) - (set-itimer-restart current-itimer vm-mail-check-interval)) - ;; user has changed the variable value to something that - ;; isn't a number, make the timer go away. - (if timer - (cancel-timer timer) - (set-itimer-restart current-itimer nil))) - (let ((b-list (buffer-list)) - (found-one nil) - oldval) - (while (and (not (input-pending-p)) b-list) - (save-excursion - (set-buffer (car b-list)) - (if (and (eq major-mode 'vm-mode) - (setq found-one t) - ;; to avoid reentrance into the pop code - (not vm-block-new-mail) - ;; Don't bother checking if we already know from - ;; a previous check that there's mail waiting - ;; and the user hasn't retrieved it yet. Not - ;; completely accurate, but saves network - ;; connection build and tear down which is slow - ;; for some users. - (not vm-spooled-mail-waiting)) - (progn - (setq oldval vm-spooled-mail-waiting) - (vm-check-for-spooled-mail nil) - (if (not (eq oldval vm-spooled-mail-waiting)) - (progn - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line)))))) - (setq b-list (cdr b-list))) - ;; make the timer go away if we didn't encounter a vm-mode buffer. - (if (and (not found-one) (null b-list)) - (if timer - (cancel-timer timer) - (set-itimer-restart current-itimer nil))))) - -;; support for numeric vm-auto-get-new-mail -;; if timer argument is present, this means we're using the Emacs -;; 'timer package rather than the 'itimer package. -(defun vm-get-mail-itimer-function (&optional timer) - ;; FSF Emacs sets this non-nil, which means the user can't - ;; interrupt mail retrieval. Bogus. - (setq inhibit-quit nil) - (if (integerp vm-auto-get-new-mail) - (if timer - (timer-set-time timer (current-time) vm-auto-get-new-mail) - (set-itimer-restart current-itimer vm-auto-get-new-mail)) - ;; user has changed the variable value to something that - ;; isn't a number, make the timer go away. - (if timer - (cancel-timer timer) - (set-itimer-restart current-itimer nil))) - (let ((b-list (buffer-list)) - (found-one nil)) - (while (and (not (input-pending-p)) b-list) - (save-excursion - (set-buffer (car b-list)) - (if (and (eq major-mode 'vm-mode) - (setq found-one t) - (not (and (not (buffer-modified-p)) - buffer-file-name - (file-newer-than-file-p - (make-auto-save-file-name) - buffer-file-name))) - (not vm-block-new-mail) - (not vm-folder-read-only) - (vm-get-spooled-mail nil) - (vm-assimilate-new-messages t)) - (progn - ;; don't move the message pointer unless the folder - ;; was empty. - (if (and (null vm-message-pointer) - (vm-thoughtfully-select-message)) - (vm-preview-current-message) - (vm-update-summary-and-mode-line))))) - (setq b-list (cdr b-list))) - ;; make the timer go away if we didn't encounter a vm-mode buffer. - (if (and (not found-one) (null b-list)) - (if timer - (cancel-timer timer) - (set-itimer-restart current-itimer nil))))) - -;; support for numeric vm-flush-interval -;; if timer argument is present, this means we're using the Emacs -;; 'timer package rather than the 'itimer package. -(defun vm-flush-itimer-function (&optional timer) - (if (integerp vm-flush-interval) - (if timer - (timer-set-time timer (current-time) vm-flush-interval) - (set-itimer-restart current-itimer vm-flush-interval))) - ;; if no vm-mode buffers are found, we might as well shut down the - ;; flush itimer. - (if (not (vm-flush-cached-data)) - (if timer - (cancel-timer timer) - (set-itimer-restart current-itimer nil)))) - -;; flush cached data in all vm-mode buffers. -;; returns non-nil if any vm-mode buffers were found. -(defun vm-flush-cached-data () - (save-excursion - (let ((buf-list (buffer-list)) - (found-one nil)) - (while (and buf-list (not (input-pending-p))) - (set-buffer (car buf-list)) - (cond ((and (eq major-mode 'vm-mode) vm-message-list) - (setq found-one t) - (if (not (eq vm-modification-counter - vm-flushed-modification-counter)) - (progn - (vm-stuff-summary) - (vm-stuff-labels) - (and vm-message-order-changed - (vm-stuff-message-order)) - (and (vm-stuff-folder-attributes t) - (setq vm-flushed-modification-counter - vm-modification-counter)))))) - (setq buf-list (cdr buf-list))) - ;; if we haven't checked them all return non-nil so - ;; the flusher won't give up trying. - (or buf-list found-one) ))) - -;; This allows C-x C-s to do the right thing for VM mail buffers. -;; Note that deleted messages are not expunged. -(defun vm-write-file-hook () - (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook)) - ;; The vm-save-restriction isn't really necessary here, since - ;; the stuff routines clean up after themselves, but should remain - ;; as a safeguard against the time when other stuff is added here. - (vm-save-restriction - (let ((buffer-read-only)) - (vm-stuff-folder-attributes nil) - (if vm-message-list - (progn - ;; get summary cache up-to-date - (vm-update-summary-and-mode-line) - (vm-stuff-bookmark) - (vm-stuff-header-variables) - (vm-stuff-labels) - (vm-stuff-summary) - (and vm-message-order-changed - (vm-stuff-message-order)))) - nil )))) - -(defun vm-save-buffer (prefix) - (interactive "P") - (vm-select-folder-buffer) - (vm-error-if-virtual-folder) - (save-buffer prefix) - (intern (buffer-name) vm-buffers-needing-display-update) - (setq vm-block-new-mail nil) - (vm-display nil nil '(vm-save-buffer) '(vm-save-buffer)) - (vm-update-summary-and-mode-line)) - -(defun vm-write-file () - (interactive) - (vm-select-folder-buffer) - (vm-error-if-virtual-folder) - (call-interactively 'write-file) - (intern (buffer-name) vm-buffers-needing-display-update) - (setq vm-block-new-mail nil) - (vm-display nil nil '(vm-write-file) '(vm-write-file)) - (vm-update-summary-and-mode-line)) - -(defun vm-save-folder (&optional prefix) - "Save current folder to disk. -Deleted messages are not expunged. -Prefix arg is handled the same as for the command save-buffer. - -When applied to a virtual folder, this command runs itself on -each of the underlying real folders associated with the virtual -folder." - (interactive (list current-prefix-arg)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-save-folder) '(vm-save-folder)) - (if (eq major-mode 'vm-virtual-mode) - (vm-virtual-save-folder prefix) - (if (buffer-modified-p) - (let (mp (newlist nil)) - ;; stuff the attributes of messages that need it. - (message "Stuffing attributes...") - (vm-stuff-folder-attributes nil) - ;; stuff bookmark and header variable values - (if vm-message-list - (progn - ;; get summary cache up-to-date - (vm-update-summary-and-mode-line) - (vm-stuff-bookmark) - (vm-stuff-header-variables) - (vm-stuff-labels) - (vm-stuff-summary) - (and vm-message-order-changed - (vm-stuff-message-order)))) - (message "Saving...") - (let ((vm-inhibit-write-file-hook t)) - (save-buffer prefix)) - (vm-set-buffer-modified-p nil) - (vm-clear-modification-flag-undos) - (setq vm-messages-not-on-disk 0) - (setq vm-block-new-mail nil) - (and (zerop (buffer-size)) - vm-delete-empty-folders - buffer-file-name - (or (eq vm-delete-empty-folders t) - (y-or-n-p (format "%s is empty, remove it? " - (or buffer-file-name (buffer-name))))) - (condition-case () - (progn - (delete-file buffer-file-name) - (clear-visited-file-modtime) - (message "%s removed" buffer-file-name)) - ;; no can do, oh well. - (error nil))) - (vm-update-summary-and-mode-line)) - (message "No changes need to be saved")))) - -(defun vm-save-and-expunge-folder (&optional prefix) - "Expunge folder, then save it to disk. -Prefix arg is handled the same as for the command save-buffer. -Expunge won't be done if folder is read-only. - -When applied to a virtual folder, this command works as if you had -run vm-expunge-folder followed by vm-save-folder." - (interactive (list current-prefix-arg)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-save-and-expunge-folder) - '(vm-save-and-expunge-folder)) - (if (not vm-folder-read-only) - (progn - (message "Expunging...") - (vm-expunge-folder t))) - (vm-save-folder prefix)) - -(defun vm-handle-file-recovery-or-reversion (recovery) - (if (and vm-summary-buffer (buffer-name vm-summary-buffer)) - (kill-buffer vm-summary-buffer)) - (vm-virtual-quit) - ;; reset major mode, this will cause vm to start from scratch. - (setq major-mode 'fundamental-mode) - ;; If this is a recovery, we can't allow the user to get new - ;; mail until a real save is performed. Until then the buffer - ;; and the disk don't match. - (if recovery - (setq vm-block-new-mail t)) - (vm buffer-file-name)) - -;; detect if a recover-file is being performed -;; and handle things properly. -(defun vm-handle-file-recovery () - (if (and (buffer-modified-p) - (eq major-mode 'vm-mode) - vm-message-list - (= (vm-end-of (car vm-message-list)) 1)) - (vm-handle-file-recovery-or-reversion t))) - -;; detect if a revert-buffer is being performed -;; and handle things properly. -(defun vm-handle-file-reversion () - (if (and (not (buffer-modified-p)) - (eq major-mode 'vm-mode) - vm-message-list - (= (vm-end-of (car vm-message-list)) 1)) - (vm-handle-file-recovery-or-reversion nil))) - -;; FSF v19.23 revert-buffer doesn't mash all the markers together -;; like v18 and prior v19 versions, so the check in -;; vm-handle-file-reversion doesn't work. However v19.23 has a -;; hook we can use, after-revert-hook. -(defun vm-after-revert-buffer-hook () - (if (eq major-mode 'vm-mode) - (vm-handle-file-recovery-or-reversion nil))) - -(defun vm-help () - "Display help for various VM activities." - (interactive) - (if (eq major-mode 'vm-summary-mode) - (vm-select-folder-buffer)) - (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))) - (pop-up-frames (and vm-mutable-frames vm-frame-per-help))) - (cond - ((eq last-command 'vm-help) - (describe-function major-mode)) - ((eq vm-system-state 'previewing) - (message "Type SPC to read message, n previews next message (? gives more help)")) - ((memq vm-system-state '(showing reading)) - (message "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply (? gives more help)")) - ((eq vm-system-state 'editing) - (message - (substitute-command-keys - "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change."))) - ((eq major-mode 'mail-mode) - (message - (substitute-command-keys - "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this composition"))) - (t (describe-mode))))) - -(defun vm-spool-move-mail (source destination) - (let ((handler (and (fboundp 'find-file-name-handler) - (condition-case () - (find-file-name-handler source 'vm-spool-move-mail) - (wrong-number-of-arguments - (find-file-name-handler source))))) - status error-buffer) - (if handler - (funcall handler 'vm-spool-move-mail source destination) - (setq error-buffer - (get-buffer-create - (format "*output of %s %s %s*" - vm-movemail-program source destination))) - (save-excursion - (set-buffer error-buffer) - (erase-buffer)) - (setq status - (call-process vm-movemail-program nil error-buffer t - source destination)) - (save-excursion - (set-buffer error-buffer) - (if (and (numberp status) (not (= 0 status))) - (insert (format "\n%s exited with code %s\n" - vm-movemail-program status))) - (if (> (buffer-size) 0) - (progn - (vm-display-buffer error-buffer) - (if (and (numberp status) (not (= 0 status))) - (error "Failed getting new mail from %s" source) - (message "Warning: unexpected output from %s" - vm-movemail-program) - (sleep-for 2))) - ;; nag, nag, nag. - (kill-buffer error-buffer)) - t )))) - -(defun vm-gobble-crash-box (crash-box) - (save-excursion - (vm-save-restriction - (widen) - (let ((opoint-max (point-max)) crash-buf - (buffer-read-only nil) - (inbox-buffer-file buffer-file-name) - (inbox-folder-type vm-folder-type) - (inbox-empty (zerop (buffer-size))) - got-mail crash-folder-type - (old-buffer-modified-p (buffer-modified-p))) - (setq crash-buf - ;; crash box could contain a letter bomb... - ;; force user notification of file variables for v18 Emacses - ;; enable-local-variables == nil disables them for newer Emacses - (let ((inhibit-local-variables t) - (enable-local-variables nil) - (coding-system-for-read 'no-conversion)) - (find-file-noselect crash-box))) - (save-excursion - (set-buffer crash-buf) - (setq crash-folder-type (vm-get-folder-type)) - (if (and crash-folder-type vm-check-folder-types) - (cond ((eq crash-folder-type 'unknown) - (error "crash box %s's type is unrecognized" crash-box)) - ((eq inbox-folder-type 'unknown) - (error "inbox %s's type is unrecognized" - inbox-buffer-file)) - ((null inbox-folder-type) - (if vm-default-folder-type - (if (not (eq vm-default-folder-type - crash-folder-type)) - (if vm-convert-folder-types - (progn - (vm-convert-folder-type - crash-folder-type - vm-default-folder-type) - ;; so that kill-buffer won't ask a - ;; question later... - (set-buffer-modified-p nil)) - (error "crash box %s mismatches vm-default-folder-type: %s, %s" - crash-box crash-folder-type - vm-default-folder-type))))) - ((not (eq inbox-folder-type crash-folder-type)) - (if vm-convert-folder-types - (progn - (vm-convert-folder-type crash-folder-type - inbox-folder-type) - ;; so that kill-buffer won't ask a - ;; question later... - (set-buffer-modified-p nil)) - (error "crash box %s mismatches %s's folder type: %s, %s" - crash-box inbox-buffer-file - crash-folder-type inbox-folder-type))))) - ;; toss the folder header if the inbox is not empty - (goto-char (point-min)) - (if (not inbox-empty) - (progn - (vm-convert-folder-header (or inbox-folder-type - vm-default-folder-type) - nil) - (set-buffer-modified-p nil)))) - (goto-char (point-max)) - (insert-buffer-substring crash-buf - 1 (1+ (save-excursion - (set-buffer crash-buf) - (widen) - (buffer-size)))) - (setq got-mail (/= opoint-max (point-max))) - (if (not got-mail) - nil - (write-region opoint-max (point-max) buffer-file-name t t) - (vm-increment vm-modification-counter) - (set-buffer-modified-p old-buffer-modified-p)) - (kill-buffer crash-buf) - (if (not (stringp vm-keep-crash-boxes)) - (vm-error-free-call 'delete-file crash-box) - (let ((time (decode-time (current-time))) - name) - (setq name - (expand-file-name (format "Z-%02d-%02d-%05d" - (nth 4 time) - (nth 3 time) - (% (vm-abs (random)) 100000)) - vm-keep-crash-boxes)) - (while (file-exists-p name) - (setq name - (expand-file-name (format "Z-%02d-%02d-%05d" - (nth 4 time) - (nth 3 time) - (% (vm-abs (random)) 100000)) - vm-keep-crash-boxes))) - (rename-file crash-box name))) - got-mail )))) - -(defun vm-compute-spool-files () - (let ((fallback-triples nil) - triples) - (cond ((and buffer-file-name - (consp vm-spool-file-suffixes) - (stringp vm-crash-box-suffix)) - (setq fallback-triples - (mapcar (function - (lambda (suffix) - (list buffer-file-name - (concat buffer-file-name suffix) - (concat buffer-file-name - vm-crash-box-suffix)))) - vm-spool-file-suffixes)))) - (cond ((and buffer-file-name - vm-make-spool-file-name vm-make-crash-box-name) - (setq fallback-triples - (nconc fallback-triples - (list (list buffer-file-name - (save-excursion - (funcall vm-make-spool-file-name - buffer-file-name)) - (save-excursion - (funcall vm-make-crash-box-name - buffer-file-name)))))))) - (cond ((null (vm-spool-files)) - (setq triples (list - (list vm-primary-inbox - (concat vm-spool-directory (user-login-name)) - vm-crash-box)))) - ((stringp (car (vm-spool-files))) - (setq triples - (mapcar (function - (lambda (s) (list vm-primary-inbox s vm-crash-box))) - (vm-spool-files)))) - ((consp (car (vm-spool-files))) - (setq triples (vm-spool-files)))) - (setq triples (append triples fallback-triples)) - triples )) - -(defun vm-spool-check-mail (source) - (let ((handler (and (fboundp 'find-file-name-handler) - (condition-case () - (find-file-name-handler source 'vm-spool-check-mail) - (wrong-number-of-arguments - (find-file-name-handler source)))))) - (if handler - (funcall handler 'vm-spool-check-mail source) - (and (not (equal 0 (nth 7 (file-attributes source)))) - (file-readable-p source))))) - -(defun vm-check-for-spooled-mail (&optional interactive) - (if vm-block-new-mail - nil - (let ((triples (vm-compute-spool-files)) - ;; since we could accept-process-output here (POP code), - ;; a timer process might try to start retrieving mail - ;; before we finish. block these attempts. - (vm-block-new-mail t) - (vm-pop-ok-to-ask interactive) - (done nil) - crash in maildrop popdrop - (mail-waiting nil)) - (while (and triples (not done)) - (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory) - maildrop (nth 1 (car triples)) - crash (nth 2 (car triples))) - (if (eq (current-buffer) (vm-get-file-buffer in)) - (progn - (if (file-exists-p crash) - (progn - (setq mail-waiting t - done t)) - (setq popdrop (and vm-recognize-pop-maildrops - (string-match vm-recognize-pop-maildrops - maildrop))) - (if (not interactive) - ;; allow no error to be signaled - (condition-case nil - (setq mail-waiting - (or mail-waiting - (if popdrop - (vm-pop-check-mail maildrop) - (vm-spool-check-mail maildrop)))) - (error nil)) - (setq mail-waiting (or mail-waiting - (if popdrop - (vm-pop-check-mail maildrop) - (vm-spool-check-mail maildrop))))) - (if mail-waiting - (setq done t))))) - (setq triples (cdr triples))) - (setq vm-spooled-mail-waiting mail-waiting) - mail-waiting ))) - -(defun vm-get-spooled-mail (&optional interactive) - (if vm-block-new-mail - (error "Can't get new mail until you save this folder.")) - (let ((triples (vm-compute-spool-files)) - ;; since we could accept-process-output here (POP code), - ;; a timer process might try to start retrieving mail - ;; before we finish. block these attempts. - (vm-block-new-mail t) - (vm-pop-ok-to-ask interactive) - crash in maildrop popdrop - (got-mail nil)) - (if (and (not (verify-visited-file-modtime (current-buffer))) - (or (null interactive) - (not (yes-or-no-p - (format - "Folder %s changed on disk, discard those changes? " - (buffer-name (current-buffer))))))) - (progn - (message "Folder %s changed on disk, consider M-x revert-buffer" - (buffer-name (current-buffer))) - (sleep-for 1) - nil ) - (while triples - (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory) - maildrop (nth 1 (car triples)) - crash (nth 2 (car triples))) - (if (eq (current-buffer) (vm-get-file-buffer in)) - (let (retrieval-function) - (if (file-exists-p crash) - (progn - (message "Recovering messages from %s..." crash) - (setq got-mail (or (vm-gobble-crash-box crash) got-mail)) - (message "Recovering messages from %s... done" crash))) - (setq popdrop (and vm-recognize-pop-maildrops - (string-match vm-recognize-pop-maildrops - maildrop) - ;; maildrop with password clipped - (vm-safe-popdrop-string maildrop))) - (if (or popdrop - (and (not (equal 0 (nth 7 (file-attributes maildrop)))) - (file-readable-p maildrop))) - (progn - (setq crash (expand-file-name crash vm-folder-directory)) - (if (not popdrop) - (setq maildrop (expand-file-name maildrop) - retrieval-function 'vm-spool-move-mail) - (setq retrieval-function 'vm-pop-move-mail)) - (if (if got-mail - ;; don't allow errors to be signaled unless no - ;; mail has been appended to the incore - ;; copy of the folder. otherwise the - ;; user will wonder where the mail is, - ;; since it is not in the crash box or - ;; the spool file and doesn't _appear_ to - ;; be in the folder either. - (condition-case error-data - (funcall retrieval-function maildrop crash) - (error (message "%s signaled: %s" - (if popdrop - 'vm-pop-move-mail - 'vm-spool-move-mail) - error-data) - (sleep-for 2) - ;; we don't know if mail was - ;; put into the crash box or - ;; not, so return t just to be - ;; safe. - t ) - (quit (message "quitting from %s..." - (if popdrop - 'vm-pop-move-mail - 'vm-spool-move-mail)) - (sleep-for 1) - ;; we don't know if mail was - ;; put into the crash box or - ;; not, so return t just to be - ;; safe. - t )) - (funcall retrieval-function maildrop crash)) - (if (vm-gobble-crash-box crash) - (progn - (setq got-mail t) - (message "Got mail from %s." - (or popdrop maildrop))))))))) - (setq triples (cdr triples))) - ;; not really correct, but it is what the user expects to see. - (if got-mail - (setq vm-spooled-mail-waiting nil)) - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line) - (if got-mail - (run-hooks 'vm-retrieved-spooled-mail-hook)) - got-mail ))) - -(defun vm-safe-popdrop-string (drop) - (or (and (string-match "^\\([^:]+\\):[^:]+:[^:]+:\\([^:]+\\):[^:]+" drop) - (concat (substring drop (match-beginning 2) (match-end 2)) - "@" - (substring drop (match-beginning 1) (match-end 1)))) - "???")) - -(defun vm-get-new-mail (&optional arg) - "Move any new mail that has arrived in any of the spool files for the -current folder into the folder. New mail is appended to the disk -and buffer copies of the folder. - -Prefix arg means to gather mail from a user specified folder, instead of -the usual spool files. The file name will be read from the minibuffer. -Unlike when getting mail from a spool file, the source file is left -undisturbed after its messages have been copied. - -When applied to a virtual folder, this command runs itself on -each of the underlying real folders associated with this virtual folder. -A prefix argument has no effect; mail is always gathered from the -spool files." - (interactive "P") - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (cond ((eq major-mode 'vm-virtual-mode) - (vm-virtual-get-new-mail)) - ((null arg) - (if (not (eq major-mode 'vm-mode)) - (vm-mode)) - (if (consp (car (vm-spool-files))) - (message "Checking for new mail for %s..." - (or buffer-file-name (buffer-name))) - (message "Checking for new mail...")) - (let (totals-blurb) - (if (and (vm-get-spooled-mail t) (vm-assimilate-new-messages t)) - (progn - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb)) - (if (consp (car (vm-spool-files))) - (message "No new mail for %s" - (or buffer-file-name (buffer-name))) - (message "No new mail.")) - (and (interactive-p) (sit-for 4) (message ""))))) - (t - (let ((buffer-read-only nil) - folder mcount totals-blurb) - (setq folder (read-file-name "Gather mail from folder: " - vm-folder-directory t)) - (if (and vm-check-folder-types - (not (vm-compatible-folder-p folder))) - (error "Folder %s is not the same format as this folder." - folder)) - (save-excursion - (vm-save-restriction - (widen) - (goto-char (point-max)) - (let ((coding-system-for-read 'binary)) - (insert-file-contents folder)))) - (setq mcount (length vm-message-list)) - (if (vm-assimilate-new-messages) - (progn - ;; say this NOW, before the non-previewers read - ;; a message, alter the new message count and - ;; confuse themselves. - (setq totals-blurb (vm-emit-totals-blurb)) - (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message totals-blurb) - ;; The gathered messages are actually still on disk - ;; unless the user deletes the folder himself. - ;; However, users may not understand what happened if - ;; the messages go away after a "quit, no save". - (setq vm-messages-not-on-disk - (+ vm-messages-not-on-disk - (- (length vm-message-list) - mcount)))) - (message "No messages gathered.")))))) - -;; returns non-nil if there were any new messages -(defun vm-assimilate-new-messages (&optional - dont-read-attributes - gobble-order - labels) - (let ((tail-cons (vm-last vm-message-list)) - b-list new-messages) - (save-excursion - (vm-save-restriction - (widen) - (vm-build-message-list) - (if (or (null tail-cons) (cdr tail-cons)) - (progn - (setq vm-ml-sort-keys nil) - (if dont-read-attributes - (vm-set-default-attributes (cdr tail-cons)) - (vm-read-attributes (cdr tail-cons))) - ;; Yuck. This has to be done here instead of in the - ;; vm function because this needs to be done before - ;; any initial thread sort (so that if the thread - ;; sort matches the saved order the folder won't be - ;; modified) but after the message list is created. - ;; Since thread sorting is done here this has to be - ;; done here too. - (if gobble-order - (vm-gobble-message-order)) - (if vm-thread-obarray - (vm-build-threads (cdr tail-cons)))))) - (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list)) - (vm-set-numbering-redo-start-point new-messages) - (vm-set-summary-redo-start-point new-messages)) - ;; copy the new-messages list because sorting might scramble - ;; it. Also something the user does when - ;; vm-arrived-message-hook is run might affect it. - ;; vm-assimilate-new-messages returns this value so it must - ;; not be mangled. - (setq new-messages (copy-sequence new-messages)) - ;; add the labels - (if (and labels vm-burst-digest-messages-inherit-labels) - (let ((mp new-messages)) - (while mp - (vm-set-labels-of (car mp) (copy-sequence labels)) - (setq mp (cdr mp))))) - (if vm-summary-show-threads - (progn - ;; get numbering and summary of new messages done now - ;; so that the sort code only has to worry about the - ;; changes it needs to make. - (vm-update-summary-and-mode-line) - (vm-sort-messages "thread"))) - (if (and vm-arrived-message-hook - new-messages - ;; tail-cons == nil means vm-message-list was empty. - ;; Thus new-messages == vm-message-list. In this - ;; case, run the hooks only if this is not the first - ;; time vm-assimilate-new-messages has been called - ;; in this folder. gobble-order non-nil is a good - ;; indicator that this is the first time because the - ;; order is gobbled only once per visit and always - ;; the first time vm-assimilate-new-messages is - ;; called. - (or tail-cons (null gobble-order))) - (let ((new-messages new-messages)) - ;; seems wise to do this so that if the user runs VM - ;; command here they start with as much of a clean - ;; slate as we can provide, given we're currently deep - ;; in the guts of VM. - (vm-update-summary-and-mode-line) - (while new-messages - (vm-run-message-hook (car new-messages) 'vm-arrived-message-hook) - (setq new-messages (cdr new-messages))))) - (vm-update-summary-and-mode-line) - (run-hooks 'vm-arrived-messages-hook) - (if (and new-messages vm-virtual-buffers) - (save-excursion - (setq b-list vm-virtual-buffers) - (while b-list - ;; buffer might be dead - (if (buffer-name (car b-list)) - (let (tail-cons) - (set-buffer (car b-list)) - (setq tail-cons (vm-last vm-message-list)) - (vm-build-virtual-message-list new-messages) - (if (or (null tail-cons) (cdr tail-cons)) - (progn - (setq vm-ml-sort-keys nil) - (if vm-thread-obarray - (vm-build-threads (cdr tail-cons))) - (vm-set-summary-redo-start-point - (or (cdr tail-cons) vm-message-list)) - (vm-set-numbering-redo-start-point - (or (cdr tail-cons) vm-message-list)) - (if (null vm-message-pointer) - (progn (setq vm-message-pointer vm-message-list - vm-need-summary-pointer-update t) - (if vm-message-pointer - (vm-preview-current-message)))) - (if vm-summary-show-threads - (progn - (vm-update-summary-and-mode-line) - (vm-sort-messages "thread"))))))) - (setq b-list (cdr b-list))))) - new-messages )) - -;; return a list of all marked messages or the messages indicated by a -;; prefix argument. -(defun vm-select-marked-or-prefixed-messages (prefix) - (let (mlist) - (if (eq last-command 'vm-next-command-uses-marks) - (setq mlist (vm-marked-messages)) - (let ((direction (if (< prefix 0) 'backward 'forward)) - (count (vm-abs prefix)) - (vm-message-pointer vm-message-pointer)) - (if (not (eq vm-circular-folders t)) - (vm-check-count prefix)) - (while (not (zerop count)) - (setq mlist (cons (car vm-message-pointer) mlist)) - (vm-decrement count) - (if (not (zerop count)) - (vm-move-message-pointer direction)))) - (nreverse mlist)))) - -(defun vm-display-startup-message () - (if (sit-for 5) - (let ((lines vm-startup-message-lines)) - (message "VM %s, Copyright (C) 1997 Kyle E. Jones; type ? for help" - vm-version) - (setq vm-startup-message-displayed t) - (while (and (sit-for 4) lines) - (message (substitute-command-keys (car lines))) - (setq lines (cdr lines))))) - (message "")) - -(defun vm-load-init-file (&optional interactive) - (interactive "p") - (if (or (not vm-init-file-loaded) interactive) - (progn - (and vm-init-file - (load vm-init-file (not interactive) (not interactive) t)) - (and vm-preferences-file (load vm-preferences-file t t t)))) - (setq vm-init-file-loaded t) - (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file))) - -(defun vm-session-initialization () - ;; If this is the first time VM has been run in this Emacs session, - ;; do some necessary preparations. - (if (or (not (boundp 'vm-session-beginning)) - vm-session-beginning) - (progn - (random t) - (vm-load-init-file) - (if (not vm-window-configuration-file) - (setq vm-window-configurations vm-default-window-configuration) - (or (vm-load-window-configurations vm-window-configuration-file) - (setq vm-window-configurations vm-default-window-configuration))) - (setq vm-buffers-needing-display-update (make-vector 29 0)) - (setq vm-session-beginning nil)))) - -(defun vm-toggle-read-only () - (interactive) - (vm-select-folder-buffer) - (setq vm-folder-read-only (not vm-folder-read-only)) - (intern (buffer-name) vm-buffers-needing-display-update) - (message "Folder is now %s" - (if vm-folder-read-only "read-only" "modifiable")) - (vm-display nil nil '(vm-toggle-read-only) '(vm-toggle-read-only)) - (vm-update-summary-and-mode-line)) - -(defvar scroll-in-place) - -;; this does the real major mode scutwork. -(defun vm-mode-internal () - (widen) - (make-local-variable 'require-final-newline) - ;; don't kill local variables, as there is some state we'd like to - ;; keep. rather than non-portably marking the variables we - ;; want to keep, just avoid calling kill-local-variables and - ;; reset everything that needs to be reset. - (setq - major-mode 'vm-mode - mode-line-format vm-mode-line-format - mode-name "VM" - ;; must come after the setting of major-mode - mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 - (vm-menu-support-possible-p) - (vm-menu-mode-menu)) - buffer-read-only t - ;; If the user quits a vm-mode buffer, the default action is - ;; to kill the buffer. Make a note that we should offer to - ;; save this buffer even if it has no file associated with it. - ;; We have no idea of the value of the data in the buffer - ;; before it was put into vm-mode. - buffer-offer-save t - require-final-newline nil - vm-thread-obarray nil - vm-thread-subject-obarray nil - vm-label-obarray (make-vector 29 0) - vm-last-message-pointer nil - vm-modification-counter 0 - vm-message-list nil - vm-message-pointer nil - vm-message-order-changed nil - vm-message-order-header-present nil - vm-summary-buffer nil - vm-system-state nil - vm-undo-record-list nil - vm-undo-record-pointer nil - vm-virtual-buffers (vm-link-to-virtual-buffers) - vm-folder-type (vm-get-folder-type)) - (use-local-map vm-mode-map) - (and (vm-menu-support-possible-p) - (vm-menu-install-menus)) - (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder) - (add-hook 'kill-buffer-hook 'vm-garbage-collect-message) - ;; avoid the XEmacs file dialog box. - (defvar use-dialog-box) - (make-local-variable 'use-dialog-box) - (setq use-dialog-box nil) - ;; mail folders are precious. protect them by default. - (make-local-variable 'file-precious-flag) - (setq file-precious-flag t) - ;; scroll in place messes with scroll-up and this loses - (make-local-variable 'scroll-in-place) - (setq scroll-in-place nil) - (run-hooks 'vm-mode-hook) - ;; compatibility - (run-hooks 'vm-mode-hooks)) - -(defun vm-link-to-virtual-buffers () - (let ((b-list (buffer-list)) - (vbuffers nil) - (folder-buffer (current-buffer)) - folders clauses) - (save-excursion - (while b-list - (set-buffer (car b-list)) - (cond ((eq major-mode 'vm-virtual-mode) - (setq clauses (cdr vm-virtual-folder-definition)) - (while clauses - (setq folders (car (car clauses))) - (while folders - (if (eq folder-buffer (vm-get-file-buffer - (expand-file-name - (car folders) - vm-folder-directory))) - (setq vbuffers (cons (car b-list) vbuffers) - vm-real-buffers (cons folder-buffer - vm-real-buffers) - folders nil - clauses nil)) - (setq folders (cdr folders))) - (setq clauses (cdr clauses))))) - (setq b-list (cdr b-list))) - vbuffers ))) - -(defun vm-change-folder-type (type) - "Change folder type to TYPE. -TYPE may be one of the following symbol values: - - From_ - From_-with-Content-Length - mmdf - babyl - -Interactively TYPE will be read from the minibuffer." - (interactive - (let ((this-command this-command) - (last-command last-command) - (types vm-supported-folder-types)) - (vm-select-folder-buffer) - (vm-error-if-virtual-folder) - (setq types (vm-delqual (symbol-name vm-folder-type) - (copy-sequence types))) - (list (intern (vm-read-string "Change folder to type: " types))))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-virtual-folder) - (vm-error-if-folder-empty) - (if (not (memq type '(From_ From_-with-Content-Length mmdf babyl))) - (error "Unknown folder type: %s" type)) - (if (or (null vm-folder-type) - (eq vm-folder-type 'unknown)) - (error "Current folder's type is unknown, can't change it.")) - (let ((mp vm-message-list) - (buffer-read-only nil) - (old-type vm-folder-type) - ;; no interruptions - (inhibit-quit t) - (n 0) - ;; Just for laughs, make the update interval vary. - (modulus (+ (% (vm-abs (random)) 11) 5)) - text-end opoint) - (save-excursion - (vm-save-restriction - (widen) - (setq vm-folder-type type) - (goto-char (point-min)) - (vm-convert-folder-header old-type type) - (while mp - (goto-char (vm-start-of (car mp))) - (setq opoint (point)) - (insert (vm-leading-message-separator type (car mp))) - (if (> (vm-headers-of (car mp)) (vm-start-of (car mp))) - (delete-region (point) (vm-headers-of (car mp))) - (set-marker (vm-headers-of (car mp)) (point)) - ;; if headers-of == start-of then so could vheaders-of - ;; and text-of. clear them to force a recompute. - (vm-set-vheaders-of (car mp) nil) - (vm-set-text-of (car mp) nil)) - (vm-convert-folder-type-headers old-type type) - (goto-char (vm-text-end-of (car mp))) - (setq text-end (point)) - (insert-before-markers (vm-trailing-message-separator type)) - (delete-region (vm-text-end-of (car mp)) (vm-end-of (car mp))) - (set-marker (vm-text-end-of (car mp)) text-end) - (goto-char (vm-headers-of (car mp))) - (vm-munge-message-separators type (vm-headers-of (car mp)) - (vm-text-end-of (car mp))) - (vm-set-byte-count-of (car mp) nil) - (vm-set-babyl-frob-flag-of (car mp) nil) - (vm-set-message-type-of (car mp) type) - ;; Technically we should mark each message for a - ;; summary update since the message byte counts might - ;; have changed. But I don't think anyone cares that - ;; much and the summary regeneration would make this - ;; process slower. - (setq mp (cdr mp) n (1+ n)) - (if (zerop (% n modulus)) - (message "Converting... %d" n)))))) - (vm-clear-modification-flag-undos) - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line) - (message "Conversion complete.") - ;; message separator strings may have leaked into view - (if (> (point-max) (vm-text-end-of (car vm-message-pointer))) - (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer)))) - (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type))) - -(defun vm-garbage-collect-folder () - (save-excursion - (while vm-folder-garbage-alist - (condition-case nil - (funcall (cdr (car vm-folder-garbage-alist)) - (car (car vm-folder-garbage-alist))) - (error nil)) - (setq vm-folder-garbage-alist (cdr vm-folder-garbage-alist))))) - -(defun vm-garbage-collect-message () - (save-excursion - (while vm-message-garbage-alist - (condition-case nil - (funcall (cdr (car vm-message-garbage-alist)) - (car (car vm-message-garbage-alist))) - (error nil)) - (setq vm-message-garbage-alist (cdr vm-message-garbage-alist))))) - -(if (not (memq 'vm-write-file-hook write-file-hooks)) - (setq write-file-hooks - (cons 'vm-write-file-hook write-file-hooks))) - -(if (not (memq 'vm-handle-file-recovery find-file-hooks)) - (setq find-file-hooks - (nconc find-file-hooks - '(vm-handle-file-recovery - vm-handle-file-reversion)))) - -;; after-revert-hook is new to FSF v19.23 -(defvar after-revert-hook) -(if (boundp 'after-revert-hook) - (setq after-revert-hook - (cons 'vm-after-revert-buffer-hook after-revert-hook)) - (setq after-revert-hook (list 'vm-after-revert-buffer-hook)))
--- a/lisp/vm/vm-license.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -;;; Code to show VM's warranty and copying restrictions -;;; Copyright (C) 1989, 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-license) - -(defun vm-show-copying-restrictions (&optional warranty) - (interactive) - (require 'info) - (let ((pop-up-windows (eq vm-mutable-windows t)) - (pop-up-frames (and vm-mutable-frames vm-frame-per-help))) - (or - (condition-case () - (progn (Info-goto-node "(vm)License") t) - (error nil)) - (condition-case () - (progn (Info-goto-node "(vm.info)License") t) - (error nil)) - (error "VM Info documentation appears not to be installed")) - (vm-display (current-buffer) t nil nil) - (vm-display nil nil '(vm-show-copying-restrictions vm-show-no-warranty) - (list this-command)) - (if warranty - (let ((case-fold-search nil)) - (search-forward "NO WARRANTY\n" nil t) - (forward-line -1) - (set-window-start (selected-window) (point)))))) - -(defun vm-show-no-warranty () - "Display \"NO WARRANTY\" section of the GNU General Public License." - (interactive) - (vm-show-copying-restrictions t))
--- a/lisp/vm/vm-mark.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,370 +0,0 @@ -;;; Commands for handling messages marks -;;; Copyright (C) 1990, 1993, 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-mark) - -(defun vm-clear-all-marks () - "Removes all message marks in the current folder." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (message "Clearing all marks...") - (let ((mp vm-message-list)) - (while mp - (if (vm-mark-of (car mp)) - (progn - (vm-set-mark-of (car mp) nil) - (vm-mark-for-summary-update (car mp) t))) - (setq mp (cdr mp)))) - (vm-display nil nil '(vm-clear-all-marks) - '(vm-clear-all-marks marking-message)) - (vm-update-summary-and-mode-line) - (message "Clearing all marks... done")) - -(defun vm-mark-all-messages () - "Mark all messages in the current folder." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (message "Marking all messages...") - (let ((mp vm-message-list)) - (while mp - (vm-set-mark-of (car mp) t) - (vm-mark-for-summary-update (car mp) t) - (setq mp (cdr mp)))) - (vm-display nil nil '(vm-mark-all-messages) - '(vm-mark-all-messages marking-message)) - (vm-update-summary-and-mode-line) - (message "Marking all messages... done")) - -(defun vm-mark-message (count) - "Mark the current message. -Numeric prefix argument N means mark the current message and the next -N-1 messages. A negative N means mark the current message and the -previous N-1 messages." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((direction (if (< count 0) 'backward 'forward)) - (count (vm-abs count)) - (oldmp vm-message-pointer) - (vm-message-pointer vm-message-pointer)) - (while (not (zerop count)) - (if (not (vm-mark-of (car vm-message-pointer))) - (progn - (vm-set-mark-of (car vm-message-pointer) t) - (vm-mark-for-summary-update (car vm-message-pointer) t))) - (vm-decrement count) - (if (not (zerop count)) - (vm-move-message-pointer direction)))) - (vm-display nil nil '(vm-mark-message) - '(vm-mark-message marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-unmark-message (count) - "Remove the mark from the current message. -Numeric prefix argument N means unmark the current message and the next -N-1 messages. A negative N means unmark the current message and the -previous N-1 messages." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((mlist (vm-select-marked-or-prefixed-messages count))) - (while mlist - (if (vm-mark-of (car mlist)) - (progn - (vm-set-mark-of (car mlist) nil) - (vm-mark-for-summary-update (car mlist) t))) - (setq mlist (cdr mlist)))) - (vm-display nil nil '(vm-unmark-message) - '(vm-unmark-message marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-mark-summary-region () - "Mark all messages with summary lines contained in the region." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (if (null vm-summary-buffer) - (error "No summary.")) - (set-buffer vm-summary-buffer) - (if (not (mark)) - (error "The region is not active now")) - (vm-mark-or-unmark-summary-region t) - (vm-display nil nil '(vm-mark-summary-region) - '(vm-mark-summary-region marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-unmark-summary-region () - "Remove marks from messages with summary lines contained in the region." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (if (null vm-summary-buffer) - (error "No summary.")) - (set-buffer vm-summary-buffer) - (if (not (mark)) - (error "The region is not active now")) - (vm-mark-or-unmark-summary-region nil) - (vm-display nil nil '(vm-unmark-summary-region) - '(vm-unmark-summary-region marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-mark-or-unmark-summary-region (markit) - ;; The folder buffers copy of vm-message-list has already been - ;; propagated to the summary buffer. - (let ((mp vm-message-list) - (beg (point)) - (end (mark)) - tmp m) - (if (> beg end) - (setq tmp beg beg end end tmp)) - (while mp - (setq m (car mp)) - (if (not (eq (not markit) (not (vm-mark-of m)))) - (if (or (and (> (vm-su-end-of m) beg) - (< (vm-su-end-of m) end)) - (and (>= (vm-su-start-of m) beg) - (< (vm-su-start-of m) end)) - (and (>= beg (vm-su-start-of m)) - (< beg (vm-su-end-of m)))) - (progn - (vm-set-mark-of m markit) - (vm-mark-for-summary-update m t)))) - (setq mp (cdr mp))))) - -(defun vm-mark-or-unmark-messages-with-selector (val selector arg) - (let ((mlist vm-message-list) - (virtual (eq major-mode 'vm-virtual-mode)) - (arglist (if arg (list arg) nil)) - (count 0)) - (setq selector (intern (concat "vm-vs-" (symbol-name selector)))) - (while mlist - (if (if virtual - (save-excursion - (set-buffer - (vm-buffer-of - (vm-real-message-of - (car mlist)))) - (apply selector (vm-real-message-of (car mlist)) arglist)) - (apply selector (car mlist) arglist)) - (progn - (vm-set-mark-of (car mlist) val) - (vm-mark-for-summary-update (car mlist) t) - (vm-increment count))) - (setq mlist (cdr mlist))) - (vm-display nil nil - '(vm-mark-matching-messages vm-unmark-matching-messages) - (list this-command 'marking-message)) - (vm-update-summary-and-mode-line) - (message "%d message%s %smarked" - count - (if (= 1 count) "" "s") - (if val "" "un")))) - -(defun vm-mark-matching-messages (selector &optional arg) - "Mark messages matching some criterion. -You can use any of the virtual folder selectors, except for the -`and', `or' and `not' selectors. See the documentation for the -variable vm-virtual-folder-alist for more information." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (vm-select-folder-buffer) - (vm-read-virtual-selector "Mark messages: "))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-messages-with-selector t selector arg)) - -(defun vm-unmark-matching-messages (selector &optional arg) - "Unmark messages matching some criterion. -You can use any of the virtual folder selectors, except for the -`and', `or' and `not' selectors. See the documentation for the -variable vm-virtual-folder-alist for more information." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (vm-select-folder-buffer) - (vm-read-virtual-selector "Unmark messages: "))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-messages-with-selector nil selector arg)) - -(defun vm-mark-thread-subtree () - "Mark all messages in the thread tree rooted at the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-thread-subtree t)) - -(defun vm-unmark-thread-subtree () - "Unmark all messages in the thread tree rooted at the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-thread-subtree nil)) - -(defun vm-mark-or-unmark-thread-subtree (mark) - (vm-build-threads-if-unbuilt) - (let ((list (list (car vm-message-pointer))) - (loop-obarray (make-vector 29 0)) - subject-sym id-sym) - (while list - (if (not (eq (vm-mark-of (car list)) mark)) - (progn - (vm-set-mark-of (car list) mark) - (vm-mark-for-summary-update (car list)))) - (setq id-sym (car (vm-last (vm-th-thread-list (car list))))) - (if (null (intern-soft (symbol-name id-sym) loop-obarray)) - (progn - (intern (symbol-name id-sym) loop-obarray) - (nconc list (copy-sequence (get id-sym 'children))) - (setq subject-sym (intern (vm-so-sortable-subject (car list)) - vm-thread-subject-obarray)) - (if (and (boundp subject-sym) - (eq id-sym (aref (symbol-value subject-sym) 0))) - (nconc list (copy-sequence - (aref (symbol-value subject-sym) 2)))))) - (setq list (cdr list)))) - (vm-display nil nil - '(vm-mark-thread-subtree vm-unmark-thread-subtree) - (list this-command 'marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-mark-messages-same-subject () - "Mark all messages with the same subject as the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-messages-same-subject t)) - -(defun vm-unmark-messages-same-subject () - "Unmark all messages with the same subject as the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-messages-same-subject nil)) - -(defun vm-mark-or-unmark-messages-same-subject (mark) - (let ((mp vm-message-list) - (mark-count 0) - (subject (vm-so-sortable-subject (car vm-message-pointer)))) - (while mp - (if (and (not (eq (vm-mark-of (car mp)) mark)) - (string-equal subject (vm-so-sortable-subject (car mp)))) - (progn - (vm-set-mark-of (car mp) mark) - (vm-increment mark-count) - (vm-mark-for-summary-update (car mp) t))) - (setq mp (cdr mp))) - (if (zerop mark-count) - (message "No messages %smarked" (if mark "" "un")) - (message "%d message%s %smarked" - mark-count - (if (= 1 mark-count) "" "s") - (if mark "" "un")))) - (vm-display nil nil - '(vm-mark-messages-same-subject - vm-unmark-messages-same-subject) - (list this-command 'marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-mark-messages-same-author () - "Mark all messages with the same author as the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-messages-same-author t)) - -(defun vm-unmark-messages-same-author () - "Unmark all messages with the same author as the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-mark-or-unmark-messages-same-author nil)) - -(defun vm-mark-or-unmark-messages-same-author (mark) - (let ((mp vm-message-list) - (mark-count 0) - (author (vm-su-from (car vm-message-pointer)))) - (while mp - (if (and (not (eq (vm-mark-of (car mp)) mark)) - (string-equal author (vm-su-from (car mp)))) - (progn - (vm-set-mark-of (car mp) mark) - (vm-increment mark-count) - (vm-mark-for-summary-update (car mp) t))) - (setq mp (cdr mp))) - (if (zerop mark-count) - (message "No messages %smarked" (if mark "" "un")) - (message "%d message%s %smarked" - mark-count - (if (= 1 mark-count) "" "s") - (if mark "" "un")))) - (vm-display nil nil - '(vm-mark-messages-same-author - vm-unmark-messages-same-author) - (list this-command 'marking-message)) - (vm-update-summary-and-mode-line)) - -(defun vm-next-command-uses-marks () - "Does nothing except insure that the next VM command will operate only -on the marked messages in the current folder. This only works for -commands bound to key, menu or button press events. M-x vm-command will -not work." - (interactive) - (setq this-command 'vm-next-command-uses-marks) - (message "Next command uses marks...") - (vm-display nil nil '(vm-next-command-uses-marks) - '(vm-next-command-uses-marks))) - -(defun vm-marked-messages () - (let (list (mp vm-message-list)) - (while mp - (if (vm-mark-of (car mp)) - (setq list (cons (car mp) list))) - (setq mp (cdr mp))) - (nreverse list))) - -(defun vm-mark-help () - (interactive) - (vm-display nil nil '(vm-mark-help) '(vm-mark-help)) - (message "MM = mark, MU = unmark, Mm = mark all, Mu = unmark all, MN = use marks, ..."))
--- a/lisp/vm/vm-menu.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1412 +0,0 @@ -;;; Menu related functions and commands -;;; Copyright (C) 1995, 1997 Kyle E. Jones -;;; -;;; Folders menu derived from -;;; vm-folder-menu.el -;;; v1.10; 03-May-1994 -;;; Copyright (C) 1994 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; Used with permission and my thanks. -;;; Changed 18-May-1995, Kyle Jones -;;; Cosmetic string changes, changed some variable names -;;; and interfaced it with FSF Emacs via easymenu.el. -;;; -;;; Tree menu code is essentially tree-menu.el with renamed functions -;;; tree-menu.el -;;; v1.20; 10-May-1994 -;;; Copyright (C) 1994 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; Changed 18-May-1995, Kyle Jones -;;; Removed the need for the utils.el package and references thereto. -;;; Changed file-truename calls to tree-menu-file-truename so -;;; the calls could be made compatible with FSF Emacs 19's -;;; file-truename function. -;;; Changed 30-May-1995, Kyle Jones -;;; Renamed functions: tree- -> vm-menu-hm-tree. -;;; Changed 5-July-1995, Kyle Jones -;;; Removed the need for -A in ls flags. -;;; Some systems' ls don't support -A. -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-menu) - -;; copied from vm-vars.el because vm-xemacs-p, vm-xemacs-mule-p -;; and vm-fsfemacs-19-p are needed below at load time and -;; vm-note-emacs-version may not be autoloadable. -(or (fboundp 'vm-note-emacs-version) - (defun vm-note-emacs-version () - (setq vm-xemacs-p (string-match "XEmacs" emacs-version) - vm-xemacs-mule-p (and vm-xemacs-p (featurep 'mule) - ;; paranoia - (fboundp 'set-file-coding-system)) - vm-fsfemacs-19-p (not vm-xemacs-p)))) - -;; make sure the emacs/xemacs version variables are set, as they -;; are needed below at load time. -(vm-note-emacs-version) - -(defun vm-menu-fsfemacs-menus-p () - (and vm-fsfemacs-19-p - (fboundp 'menu-bar-mode))) - -(defun vm-menu-xemacs-menus-p () - (and vm-xemacs-p - (fboundp 'set-buffer-menubar))) - -(defun vm-fsfemacs-19-p () - (and (string-match "^19" emacs-version) - (not (string-match "XEmacs\\|Lucid" emacs-version)))) - -(defvar vm-menu-folders-menu - '("Manipulate Folders" - ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]) - "VM folder menu list.") - -(defconst vm-menu-folder-menu - (list - "Folder" - (if vm-fsfemacs-19-p - ["Manipulate Folders" ignore (ignore)] - vm-menu-folders-menu) - "---" - ["Display Summary" vm-summarize t] - ["Toggle Threading" vm-toggle-threads-display t] - "---" - ["Get New Mail" vm-get-new-mail (vm-menu-can-get-new-mail-p)] - "---" - ["Search" vm-isearch-forward vm-message-list] - "---" - ["Auto-Archive" vm-auto-archive-messages vm-message-list] - ["Expunge" vm-expunge-folder vm-message-list] - "---" - ["Visit Folder" vm-visit-folder t] - ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)] - ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)] - ["Save" vm-save-folder (vm-menu-can-save-p)] - ["Save As..." vm-write-file t] - ["Quit" vm-quit-no-change t] - ["Save & Quit" vm-quit t] - "---" - "---" - ;; special string that marks the tail of this menu for - ;; vm-menu-install-visited-folders-menu. - "-------" - )) - -(defconst vm-menu-dispose-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Dispose" - "Dispose" - "---" - "---") - (list "Dispose")))) - (append - title - (list - ["Reply to Author" vm-reply vm-message-list] - ["Reply to All" vm-followup vm-message-list] - ["Reply to Author (citing original)" vm-reply-include-text vm-message-list] - ["Reply to All (citing original)" vm-followup-include-text vm-message-list] - ["Forward" vm-forward-message vm-message-list] - ["Resend" vm-resend-message vm-message-list] - ["Retry Bounce" vm-resend-bounced-message vm-message-list] - "---" - ["File" vm-save-message vm-message-list] - ["Delete" vm-delete-message vm-message-list] - ["Undelete" vm-undelete-message vm-message-list] - ["Kill Current Subject" vm-kill-subject vm-message-list] - ["Mark Unread" vm-unread-message vm-message-list] - ["Edit" vm-edit-message vm-message-list] - ["Print" vm-print-message vm-message-list] - ["Pipe to Command" vm-pipe-message-to-command vm-message-list] - "---" - ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list] - ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)] - )))) - -(defconst vm-menu-motion-menu - '("Motion" - ["Page Up" vm-scroll-backward vm-message-list] - ["Page Down" vm-scroll-forward vm-message-list] - "----" - ["Beginning" vm-beginning-of-message vm-message-list] - ["End" vm-end-of-message vm-message-list] - "----" - ["Expose/Hide Headers" vm-expose-hidden-headers vm-message-list] - "----" - "----" - ["Next Message" vm-next-message t] - ["Previous Message" vm-previous-message t] - "---" - ["Next, Same Subject" vm-next-message-same-subject t] - ["Previous, Same Subject" vm-previous-message-same-subject t] - "---" - ["Next Unread" vm-next-unread-message t] - ["Previous Unread" vm-previous-unread-message t] - "---" - ["Next Message (no skip)" vm-next-message-no-skip t] - ["Previous Message (no skip)" vm-previous-message-no-skip t] - "---" - ["Go to Last Seen Message" vm-goto-message-last-seen t] - ["Go to Message" vm-goto-message t] - ["Go to Parent Message" vm-goto-parent-message t] - )) - -(defconst vm-menu-virtual-menu - '("Virtual" - ["Visit Virtual Folder" vm-visit-virtual-folder t] - ["Create Virtual Folder" vm-create-virtual-folder t] - ["Apply Virtual Folder" vm-apply-virtual-folder t] - "---" - "---" - ;; special string that marks the tail of this menu for - ;; vm-menu-install-known-virtual-folders-menu. - "-------" - )) - -(defconst vm-menu-send-menu - '("Send" - ["Compose" vm-mail t] - ["Continue Composing" vm-continue-composing-message vm-message-list] - ["Reply to Author" vm-reply vm-message-list] - ["Reply to All" vm-followup vm-message-list] - ["Reply to Author (citing original)" vm-reply-include-text vm-message-list] - ["Reply to All (citing original)" vm-followup-include-text vm-message-list] - ["Forward Message" vm-forward-message vm-message-list] - ["Resend Message" vm-resend-message vm-message-list] - ["Retry Bounced Message" vm-resend-bounced-message vm-message-list] - ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list] - ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list] - ["Send MIME Digest" vm-send-mime-digest vm-message-list] - )) - -(defconst vm-menu-mark-menu - '("Mark" - ["Next Command Uses Marks..." vm-next-command-uses-marks - :active vm-message-list - :style radio - :selected (eq last-command 'vm-next-command-uses-marks)] - "----" - ["Mark" vm-mark-message vm-message-list] - ["Unmark" vm-unmark-message vm-message-list] - ["Mark All" vm-mark-all-messages vm-message-list] - ["Clear All Marks" vm-clear-all-marks vm-message-list] - ["Mark Region in Summary" vm-mark-summary-region vm-message-list] - ["Unmark Region in Summary" vm-unmark-summary-region vm-message-list] - "----" - ["Mark Same Subject" vm-mark-messages-same-subject vm-message-list] - ["Unmark Same Subject" vm-unmark-messages-same-subject vm-message-list] - ["Mark Same Author" vm-mark-messages-same-author vm-message-list] - ["Unmark Same Author" vm-unmark-messages-same-author vm-message-list] - ["Mark Messages Matching..." vm-mark-matching-messages vm-message-list] - ["Unmark Messages Matching..." vm-unmark-matching-messages vm-message-list] - ["Mark Thread Subtree" vm-mark-thread-subtree vm-message-list] - ["Unmark Thread Subtree" vm-unmark-thread-subtree vm-message-list] - )) - -(defconst vm-menu-label-menu - '("Label" - ["Add Label" vm-add-message-labels vm-message-list] - ["Remove Label" vm-delete-message-labels vm-message-list] - )) - -(defconst vm-menu-sort-menu - '("Sort" - ["By Multiple Fields..." vm-sort-messages vm-message-list] - "---" - ["By Date" (vm-sort-messages "date") vm-message-list] - ["By Subject" (vm-sort-messages "subject") vm-message-list] - ["By Author" (vm-sort-messages "author") vm-message-list] - ["By Recipients" (vm-sort-messages "recipients") vm-message-list] - ["By Lines" (vm-sort-messages "line-count") vm-message-list] - ["By Bytes" (vm-sort-messages "byte-count") vm-message-list] - "---" - ["By Date (backward)" (vm-sort-messages "reversed-date") vm-message-list] - ["By Subject (backward)" (vm-sort-messages "reversed-subject") vm-message-list] - ["By Author (backward)" (vm-sort-messages "reversed-author") vm-message-list] - ["By Recipients (backward)" (vm-sort-messages "reversed-recipients") vm-message-list] - ["By Lines (backwards)" (vm-sort-messages "reversed-line-count") vm-message-list] - ["By Bytes (backward)" (vm-sort-messages "reversed-byte-count") vm-message-list] - "---" - ["Toggle Threading" vm-toggle-threads-display t] - "---" - ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list] - )) - -(defconst vm-menu-help-menu - '("Help!" - ["What Now?" vm-help t] - ["Describe Mode" describe-mode t] - ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)] - ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)] - "---" - ["Save Folder & Quit" vm-quit t] - ["Quit Without Saving" vm-quit-no-change t] - )) - -(defconst vm-menu-undo-menu - ["Undo" vm-undo (vm-menu-can-undo-p)] - ) - -(defconst vm-menu-emacs-button - ["XEmacs" vm-menu-toggle-menubar t] - ) - -(defconst vm-menu-vm-button - ["VM" vm-menu-toggle-menubar t] - ) - -(defconst vm-menu-mail-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Mail Commands" - "Mail Commands" - "---" - "---") - (list "Mail Commands")))) - (append - title - (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)] - ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)] - ["Cancel" kill-buffer t] - "----" - ["Yank Original" vm-menu-yank-original vm-reply-list] - "----" - (append - (if (vm-menu-fsfemacs-menus-p) - (list "Send Using MIME..." - "Send Using MIME..." - "---" - "---") - (list "Send Using MIME...")) - (list - ["Use MIME" - (set (make-local-variable 'vm-send-using-mime) t) - :active t - :style radio - :selected vm-send-using-mime] - ["Don't use MIME" - (set (make-local-variable 'vm-send-using-mime) nil) - :active t - :style radio - :selected (not vm-send-using-mime)])) - (append - (if (vm-menu-fsfemacs-menus-p) - (list "Fragment Messages Larger Than ..." - "Fragment Messages Larger Than ..." - "---" - "---") - (list "Fragment Messages Larger Than ...")) - (list ["Infinity, i.e., don't fragment" - (set (make-local-variable 'vm-mime-max-message-size) nil) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size nil)] - ["50000 bytes" - (set (make-local-variable 'vm-mime-max-message-size) - 50000) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size 50000)] - ["100000 bytes" - (set (make-local-variable 'vm-mime-max-message-size) - 100000) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size 100000)] - ["200000 bytes" - (set (make-local-variable 'vm-mime-max-message-size) - 200000) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size 200000)] - ["500000 bytes" - (set (make-local-variable 'vm-mime-max-message-size) - 500000) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size 500000)] - ["1000000 bytes" - (set (make-local-variable 'vm-mime-max-message-size) - 1000000) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size 1000000)] - ["2000000 bytes" - (set (make-local-variable 'vm-mime-max-message-size) - 2000000) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-max-message-size 2000000)])) - (append - (if (vm-menu-fsfemacs-menus-p) - (list "Encode 8-bit Characters Using ..." - "Encode 8-bit Characters Using ..." - "---" - "---") - (list "Encode 8-bit Characters Using ...")) - (list - ["Nothing, i.e., send unencoded" - (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding) - '8bit) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-8bit-text-transfer-encoding '8bit)] - ["Quoted-Printable" - (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding) - 'quoted-printable) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-8bit-text-transfer-encoding - 'quoted-printable)] - ["BASE64" - (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding) - 'base64) - :active vm-send-using-mime - :style radio - :selected (eq vm-mime-8bit-text-transfer-encoding 'base64)])) - "----" - ["Attach File..." vm-mime-attach-file vm-send-using-mime] -;; ["Attach MIME Message..." vm-mime-attach-mime-file -;; vm-send-using-mime] - ["Encode MIME, But Don't Send" vm-mime-encode-composition - (and vm-send-using-mime - (null (vm-mail-mode-get-header-contents "MIME-Version:")))] - ["Preview MIME Before Sending" vm-mime-preview-composition - vm-send-using-mime] - )))) - -(defconst vm-menu-mime-dispose-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Take Action on MIME body ..." - "Take Action on MIME body ..." - "---" - "---") - (list "Take Action on MIME body ...")))) - (append - title - (list ["Display as US-ASCII Text" - (vm-mime-run-display-function-at-point - 'vm-mime-display-body-as-text) t] - ["Display using External Viewer" - (vm-mime-run-display-function-at-point - 'vm-mime-display-body-using-external-viewer) t] - "---" - ["Save to File" (vm-mime-run-display-function-at-point - 'vm-mime-send-body-to-file) t] - ["Send to Printer" (vm-mime-run-display-function-at-point - 'vm-mime-send-body-to-printer) t] - ["Feed to Shell Pipeline (display output)" - (vm-mime-run-display-function-at-point - 'vm-mime-pipe-body-to-queried-command) t] - ["Feed to Shell Pipeline (discard output)" - (vm-mime-run-display-function-at-point - 'vm-mime-pipe-body-to-queried-command-discard-output) t])))) - -(defconst vm-menu-url-browser-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Send URL to ..." - "Send URL to ..." - "---" - "---") - (list "Send URL to ..."))) - (w3 (cond ((fboundp 'w3-fetch-other-frame) - 'w3-fetch-other-frame) - ((fboundp 'w3-fetch) - 'w3-fetch) - (t 'w3-fetch-other-frame)))) - (append - title - (list (vector "Emacs W3" - (list 'vm-mouse-send-url-at-position - '(point) - (list 'quote w3)) - (list 'fboundp (list 'quote w3))) - ["Mosaic" - (vm-mouse-send-url-at-position (point) - 'vm-mouse-send-url-to-mosaic) - t] - ["Netscape" - (vm-mouse-send-url-at-position (point) - 'vm-mouse-send-url-to-netscape) - t])))) - -(defconst vm-menu-mailto-url-browser-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Send Mail using ..." - "Send Mail using ..." - "---" - "---") - (list "Send Mail using ...")))) - (append - title - (list ["VM" (vm-mouse-send-url-at-position (point) 'ignore) t])))) - -(defconst vm-menu-subject-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Take Action on Subject..." - "Take Action on Subject..." - "---" - "---") - (list "Take Action on Subject...")))) - (append - title - (list - ["Kill Subject" vm-kill-subject vm-message-list] - ["Next Message, Same Subject" vm-next-message-same-subject - vm-message-list] - ["Previous Message, Same Subject" vm-previous-message-same-subject - vm-message-list] - ["Mark Messages, Same Subject" vm-mark-messages-same-subject - vm-message-list] - ["Unmark Messages, Same Subject" vm-unmark-messages-same-subject - vm-message-list] - ["Virtual Folder, Matching Subject" vm-menu-create-subject-virtual-folder - vm-message-list] - )))) - -(defconst vm-menu-author-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Take Action on Author..." - "Take Action on Author..." - "---" - "---") - (list "Take Action on Author...")))) - (append - title - (list - ["Mark Messages, Same Author" vm-mark-messages-same-author - vm-message-list] - ["Unmark Messages, Same Author" vm-unmark-messages-same-author - vm-message-list] - ["Virtual Folder, Matching Author" vm-menu-create-author-virtual-folder - vm-message-list] - )))) - -(defconst vm-menu-content-disposition-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "Set Content Disposition" - "Set Content Disposition" - "---" - "---") - (list "Set Content Disposition")))) - (append - title - (list ["Unspecified" - (vm-mime-set-attachment-disposition-at-point 'unspecified) - :active vm-send-using-mime - :style radio - :selected (eq (vm-mime-attachment-disposition-at-point) - 'unspecified)] - ["Inline" - (vm-mime-set-attachment-disposition-at-point 'inline) - :active vm-send-using-mime - :style radio - :selected (eq (vm-mime-attachment-disposition-at-point) 'inline)] - ["Attachment" - (vm-mime-set-attachment-disposition-at-point 'attachment) - :active vm-send-using-mime - :style radio - :selected (eq (vm-mime-attachment-disposition-at-point) - 'attachment)])))) - -(defvar vm-menu-vm-menubar nil) - -(defconst vm-menu-vm-menu - (let ((title (if (vm-menu-fsfemacs-menus-p) - (list "VM" - "VM" - "---" - "---") - (list "VM")))) - (append title - (list vm-menu-folder-menu - vm-menu-motion-menu - vm-menu-send-menu - vm-menu-mark-menu - vm-menu-label-menu - vm-menu-sort-menu - vm-menu-virtual-menu -;; vm-menu-undo-menu - vm-menu-dispose-menu - "---" - "---" - vm-menu-help-menu)))) - -(defvar vm-mode-menu-map nil) - -(defun vm-menu-run-command (command &rest args) - "Run COMMAND almost interactively, with ARGS. -call-interactive can't be used unfortunately, but this-command is -set to the command name so that window configuration will be done." - (setq this-command command) - (apply command args)) - -(defun vm-menu-can-revert-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (and (buffer-modified-p) buffer-file-name)) - (error nil))) - -(defun vm-menu-can-recover-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (and buffer-file-name - buffer-auto-save-file-name - (file-newer-than-file-p - buffer-auto-save-file-name - buffer-file-name))) - (error nil))) - -(defun vm-menu-can-save-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (or (eq major-mode 'vm-virtual-mode) - (buffer-modified-p))) - (error nil))) - -(defun vm-menu-can-get-new-mail-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (or (eq major-mode 'vm-virtual-mode) - (and (not vm-block-new-mail) (not vm-folder-read-only)))) - (error nil))) - -(defun vm-menu-can-undo-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - vm-undo-record-list) - (error nil))) - -(defun vm-menu-can-decode-mime-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (and vm-display-using-mime - vm-message-pointer - vm-presentation-buffer - (not vm-mime-decoded) - (not (vm-mime-plain-message-p (car vm-message-pointer))))) - (error nil))) - -(defun vm-menu-yank-original () - (interactive) - (save-excursion - (let ((mlist vm-reply-list)) - (while mlist - (vm-yank-message (car mlist)) - (goto-char (point-max)) - (setq mlist (cdr mlist)))))) - -(defun vm-menu-can-send-mail-p () - (save-match-data - (catch 'done - (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc")) - h) - (while headers - (setq h (vm-mail-mode-get-header-contents (car headers))) - (and (stringp h) (string-match "[^ \t\n,]" h) - (throw 'done t)) - (setq headers (cdr headers))) - nil )))) - -(defun vm-menu-create-subject-virtual-folder () - (interactive) - (vm-select-folder-buffer) - (setq this-command 'vm-create-virtual-folder) - (vm-create-virtual-folder 'subject (regexp-quote - (vm-so-sortable-subject - (car vm-message-pointer))))) - -(defun vm-menu-create-author-virtual-folder () - (interactive) - (vm-select-folder-buffer) - (setq this-command 'vm-create-virtual-folder) - (vm-create-virtual-folder 'author (regexp-quote - (vm-su-from (car vm-message-pointer))))) - -(defun vm-menu-xemacs-global-menubar () - (save-excursion - (set-buffer (get-buffer-create "*scratch*")) - current-menubar)) - -(defun vm-menu-fsfemacs-global-menubar () - (lookup-key (current-global-map) [menu-bar])) - -(defun vm-menu-initialize-vm-mode-menu-map () - (if (null vm-mode-menu-map) - (let ((map (make-sparse-keymap)) - (dummy (make-sparse-keymap))) - ;; initialize all the vm-menu-fsfemacs-*-menu variables - ;; with the menus. - (vm-easy-menu-define vm-menu-fsfemacs-help-menu (list dummy) nil - vm-menu-help-menu) - (vm-easy-menu-define vm-menu-fsfemacs-dispose-menu (list dummy) nil - (cons "Dispose" (nthcdr 4 vm-menu-dispose-menu))) - (vm-easy-menu-define vm-menu-fsfemacs-dispose-popup-menu (list dummy) nil - vm-menu-dispose-menu) -;; (vm-easy-menu-define vm-menu-fsfemacs-undo-menu (list dummy) nil -;; (list "Undo" vm-menu-undo-menu)) - (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu (list dummy) nil - vm-menu-virtual-menu) - (vm-easy-menu-define vm-menu-fsfemacs-sort-menu (list dummy) nil - vm-menu-sort-menu) - (vm-easy-menu-define vm-menu-fsfemacs-label-menu (list dummy) nil - vm-menu-label-menu) - (vm-easy-menu-define vm-menu-fsfemacs-mark-menu (list dummy) nil - vm-menu-mark-menu) - (vm-easy-menu-define vm-menu-fsfemacs-send-menu (list dummy) nil - vm-menu-send-menu) - (vm-easy-menu-define vm-menu-fsfemacs-motion-menu (list dummy) nil - vm-menu-motion-menu) -;; (vm-easy-menu-define vm-menu-fsfemacs-folders-menu (list dummy) nil -;; vm-menu-folders-menu) - (vm-easy-menu-define vm-menu-fsfemacs-folder-menu (list dummy) nil - vm-menu-folder-menu) - (vm-easy-menu-define vm-menu-fsfemacs-vm-menu (list dummy) nil - vm-menu-vm-menu) - ;; for mail mode - (vm-easy-menu-define vm-menu-fsfemacs-mail-menu (list dummy) nil - vm-menu-mail-menu) - ;; subject menu - (vm-easy-menu-define vm-menu-fsfemacs-subject-menu (list dummy) nil - vm-menu-subject-menu) - ;; author menu - (vm-easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil - vm-menu-author-menu) - ;; url browser menu - (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil - vm-menu-url-browser-menu) - ;; mailto url browser menu - (vm-easy-menu-define vm-menu-fsfemacs-mailto-url-browser-menu - (list dummy) nil - vm-menu-url-browser-menu) - ;; mime dispose menu - (vm-easy-menu-define vm-menu-fsfemacs-mime-dispose-menu - (list dummy) nil - vm-menu-mime-dispose-menu) - ;; content disposition menu - (vm-easy-menu-define vm-menu-fsfemacs-content-disposition-menu - (list dummy) nil - vm-menu-content-disposition-menu) - ;; block the global menubar entries in the map so that VM - ;; can take over the menubar if necessary. - (define-key map [rootmenu] (make-sparse-keymap)) - (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM"))) - (define-key map [rootmenu vm file] 'undefined) - (define-key map [rootmenu vm files] 'undefined) - (define-key map [rootmenu vm search] 'undefined) - (define-key map [rootmenu vm edit] 'undefined) - (define-key map [rootmenu vm options] 'undefined) - (define-key map [rootmenu vm buffer] 'undefined) - (define-key map [rootmenu vm tools] 'undefined) - (define-key map [rootmenu vm help] 'undefined) - ;; 19.29 changed the tag for the Help menu. - (define-key map [rootmenu vm help-menu] 'undefined) - ;; now build VM's menu tree. - (let ((menu-alist - '((dispose - (cons "Dispose" vm-menu-fsfemacs-dispose-menu)) - (folder - (cons "Folder" vm-menu-fsfemacs-folder-menu)) - (help - (cons "Help!" vm-menu-fsfemacs-help-menu)) - (label - (cons "Label" vm-menu-fsfemacs-label-menu)) - (mark - (cons "Mark" vm-menu-fsfemacs-mark-menu)) - (motion - (cons "Motion" vm-menu-fsfemacs-motion-menu)) - (send - (cons "Send" vm-menu-fsfemacs-send-menu)) - (sort - (cons "Sort" vm-menu-fsfemacs-sort-menu)) - (virtual - (cons "Virtual" vm-menu-fsfemacs-virtual-menu)) - (emacs - (cons "[Emacs]" 'vm-menu-toggle-menubar)) - (undo - (cons "[Undo]" 'vm-undo)))) - cons - (vec (vector 'rootmenu 'vm nil)) - ;; menus appear in the opposite order that we - ;; define-key them. - (menu-list - (if (consp vm-use-menus) - (reverse vm-use-menus) - (list 'help nil 'dispose 'virtual 'sort - 'label 'mark 'send 'motion 'folder)))) - (while menu-list - (if (null (car menu-list)) - nil;; no flushright support in FSF Emacs - (aset vec 2 (intern (concat "vm-menubar-" - (symbol-name - (car menu-list))))) - (setq cons (assq (car menu-list) menu-alist)) - (if cons - (define-key map vec (eval (car (cdr cons)))))) - (setq menu-list (cdr menu-list)))) - (setq vm-mode-menu-map map) - (run-hooks 'vm-menu-setup-hook)))) - -(defun vm-menu-make-xemacs-menubar () - (let ((menu-alist - '((dispose . vm-menu-dispose-menu) - (folder . vm-menu-folder-menu) - (help . vm-menu-help-menu) - (label . vm-menu-label-menu) - (mark . vm-menu-mark-menu) - (motion . vm-menu-motion-menu) - (send . vm-menu-send-menu) - (sort . vm-menu-sort-menu) - (virtual . vm-menu-virtual-menu) - (emacs . vm-menu-emacs-button) - (undo . vm-menu-undo-menu))) - cons - (menubar nil) - (menu-list vm-use-menus)) - (while menu-list - (if (null (car menu-list)) - (setq menubar (cons nil menubar)) - (setq cons (assq (car menu-list) menu-alist)) - (if cons - (setq menubar (cons (symbol-value (cdr cons)) menubar)))) - (setq menu-list (cdr menu-list))) - (nreverse menubar) )) - -(defun vm-menu-popup-mode-menu (event) - (interactive "e") - (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) - (set-buffer (window-buffer (event-window event))) - (and (event-point event) (goto-char (event-point event))) - (popup-mode-menu)) - ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))) - (vm-menu-popup-fsfemacs-menu event)))) - -(defvar vm-menu-fsfemacs-content-disposition-menu) -(defun vm-menu-popup-context-menu (event) - (interactive "e") - ;; We should not need to do anything here for XEmacs. The - ;; default binding of mouse-3 is popup-mode-menu which does - ;; what we want for the normal case. For special contexts, - ;; like when the mouse is over an URL, XEmacs has local keymap - ;; support for extents. Any context sensitive area should be - ;; contained in an extent with a keymap that has mouse-3 bound - ;; to a function that will pop up a context sensitive menu. - (cond ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))) - (if (get-text-property (point) 'vm-mime-object) - (vm-menu-popup-fsfemacs-menu - event vm-menu-fsfemacs-content-disposition-menu) - (let (o-list o menu (found nil)) - (setq o-list (overlays-at (point))) - (while (and o-list (not found)) - (cond ((overlay-get (car o-list) 'vm-url) - (setq found t) - (vm-menu-popup-url-browser-menu event)) - ((setq menu (overlay-get (car o-list) 'vm-header)) - (setq found t) - (vm-menu-popup-fsfemacs-menu event menu)) - ((overlay-get (car o-list) 'vm-mime-layout) - (setq found t) - (vm-menu-popup-mime-dispose-menu event))) - (setq o-list (cdr o-list))) - (and (not found) (vm-menu-popup-fsfemacs-menu event))))))) - -;; to quiet the byte-compiler -(defvar vm-menu-fsfemacs-url-browser-menu) -(defvar vm-menu-fsfemacs-mailto-url-browser-menu) -(defvar vm-menu-fsfemacs-mime-dispose-menu) - -(defun vm-menu-goto-event (event) - (cond ((vm-menu-xemacs-menus-p) - ;; Must select window instead of just set-buffer because - ;; popup-menu returns before the user has made a - ;; selection. This will cause the command loop to - ;; resume which might undo what set-buffer does. - (select-window (event-window event)) - (and (event-closest-point event) - (goto-char (event-closest-point event)))) - ((vm-menu-fsfemacs-menus-p) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event)))))) - -(defun vm-menu-popup-url-browser-menu (event) - (interactive "e") - (vm-menu-goto-event event) - (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) - (popup-menu vm-menu-url-browser-menu)) - ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) - (vm-menu-popup-fsfemacs-menu - event vm-menu-fsfemacs-url-browser-menu)))) - -(defun vm-menu-popup-mailto-url-browser-menu (event) - (interactive "e") - (vm-menu-goto-event event) - (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) - (popup-menu vm-menu-mailto-url-browser-menu)) - ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) - (vm-menu-popup-fsfemacs-menu - event vm-menu-fsfemacs-mailto-url-browser-menu)))) - -(defun vm-menu-popup-mime-dispose-menu (event) - (interactive "e") - (vm-menu-goto-event event) - (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) - (popup-menu vm-menu-mime-dispose-menu)) - ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) - (vm-menu-popup-fsfemacs-menu - event vm-menu-fsfemacs-mime-dispose-menu)))) - -(defun vm-menu-popup-content-disposition-menu (event) - (interactive "e") - (vm-menu-goto-event event) - (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) - (popup-menu vm-menu-content-disposition-menu)) - ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) - (vm-menu-popup-fsfemacs-menu - event vm-menu-fsfemacs-content-disposition-menu)))) - -;; to quiet the byte-compiler -(defvar vm-menu-fsfemacs-mail-menu) -(defvar vm-menu-fsfemacs-dispose-popup-menu) -(defvar vm-menu-fsfemacs-vm-menu) - -(defun vm-menu-popup-fsfemacs-menu (event &optional menu) - (interactive "e") - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))) - (let ((map (or menu mode-popup-menu)) - key command func) - (setq key (x-popup-menu event map) - key (apply 'vector key) - command (lookup-key map key) - func (and (symbolp command) (symbol-function command))) - (cond ((null func) (setq this-command last-command)) - ((symbolp func) - (setq this-command func) - (call-interactively this-command)) - (t - (call-interactively command))))) - -(defun vm-menu-mode-menu () - (if (vm-menu-xemacs-menus-p) - (cond ((eq major-mode 'mail-mode) - vm-menu-mail-menu) - ((memq major-mode '(vm-mode vm-presentation-mode - vm-summary-mode vm-virtual-mode)) - vm-menu-dispose-menu) - (t vm-menu-vm-menu)) - (cond ((eq major-mode 'mail-mode) - vm-menu-fsfemacs-mail-menu) - ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode)) - vm-menu-fsfemacs-dispose-popup-menu) - (t vm-menu-fsfemacs-vm-menu)))) - -(defun vm-menu-set-menubar-dirty-flag () - (cond ((vm-menu-xemacs-menus-p) - (set-menubar-dirty-flag)) - ((vm-menu-fsfemacs-menus-p) - (force-mode-line-update)))) - -(defun vm-menu-toggle-menubar (&optional buffer) - (interactive) - (if buffer - (set-buffer buffer) - (vm-select-folder-buffer)) - (cond ((vm-menu-xemacs-menus-p) - (if (null (car (find-menu-item current-menubar '("XEmacs")))) - (set-buffer-menubar vm-menu-vm-menubar) - ;; copy the current menubar in case it has been changed. - (make-local-variable 'vm-menu-vm-menubar) - (setq vm-menu-vm-menubar (copy-sequence current-menubar)) - (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) - (condition-case nil - (add-menu-button nil vm-menu-vm-button nil) - (void-function - (add-menu-item nil "VM" 'vm-menu-toggle-menubar t)))) - (vm-menu-set-menubar-dirty-flag) - (vm-check-for-killed-summary) - (and vm-summary-buffer - (save-excursion - (vm-menu-toggle-menubar vm-summary-buffer))) - (vm-check-for-killed-presentation) - (and vm-presentation-buffer-handle - (save-excursion - (vm-menu-toggle-menubar vm-presentation-buffer-handle)))) - ((vm-menu-fsfemacs-menus-p) - (if (not (eq (lookup-key vm-mode-map [menu-bar]) - (lookup-key vm-mode-menu-map [rootmenu vm]))) - (define-key vm-mode-map [menu-bar] - (lookup-key vm-mode-menu-map [rootmenu vm])) - (define-key vm-mode-map [menu-bar] - (make-sparse-keymap)) - (define-key vm-mode-map [menu-bar vm] - (cons "[VM]" 'vm-menu-toggle-menubar))) - (vm-menu-set-menubar-dirty-flag)))) - -(defun vm-menu-install-menubar () - (cond ((vm-menu-xemacs-menus-p) - (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar)) - (set-buffer-menubar vm-menu-vm-menubar) - (run-hooks 'vm-menu-setup-hook) - (setq vm-menu-vm-menubar current-menubar)) - ((and (vm-menu-fsfemacs-menus-p) - ;; menus only need to be installed once for FSF Emacs - (not (fboundp 'vm-menu-undo-menu))) - (vm-menu-initialize-vm-mode-menu-map) - (define-key vm-mode-map [menu-bar] - (lookup-key vm-mode-menu-map [rootmenu vm]))))) - -(defun vm-menu-install-menubar-item () - (cond ((and (vm-menu-xemacs-menus-p) (vm-menu-xemacs-global-menubar)) - (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) - (add-menu nil "VM" (cdr vm-menu-vm-menu))) - ((and (vm-menu-fsfemacs-menus-p) - ;; menus only need to be installed once for FSF Emacs - (not (fboundp 'vm-menu-undo-menu))) - (vm-menu-initialize-vm-mode-menu-map) - (define-key vm-mode-map [menu-bar] - (lookup-key vm-mode-menu-map [rootmenu]))))) - -(defun vm-menu-install-vm-mode-menu () - ;; nothing to do here. - ;; handled in vm-mouse.el - (cond ((vm-menu-xemacs-menus-p) - t ) - ((vm-menu-fsfemacs-menus-p) - t ))) - -(defun vm-menu-install-mail-mode-menu () - (cond ((vm-menu-xemacs-menus-p) - ;; mail-mode doesn't have mode-popup-menu bound to - ;; mouse-3 by default. fix that. - (if vm-popup-menu-on-mouse-3 - (define-key vm-mail-mode-map 'button3 'popup-mode-menu)) - ;; put menu on menubar also. - (if (vm-menu-xemacs-global-menubar) - (progn - (set-buffer-menubar - (copy-sequence (vm-menu-xemacs-global-menubar))) - (add-menu nil "Mail" (cdr vm-menu-mail-menu)))) - t ) - ((vm-menu-fsfemacs-menus-p) - ;; I'd like to do this, but the result is a combination - ;; of the Emacs and VM Mail menus glued together. - ;; Poorly. - ;;(define-key vm-mail-mode-map [menu-bar mail] - ;; (cons "Mail" vm-menu-fsfemacs-mail-menu)) - (defvar mail-mode-map) - (define-key mail-mode-map [menu-bar mail] - (cons "Mail" vm-menu-fsfemacs-mail-menu)) - (if vm-popup-menu-on-mouse-3 - (define-key vm-mail-mode-map [down-mouse-3] - 'vm-menu-popup-context-menu))))) - -(defun vm-menu-install-menus () - (cond ((consp vm-use-menus) - (vm-menu-install-vm-mode-menu) - (vm-menu-install-menubar) - (vm-menu-install-known-virtual-folders-menu)) - ((eq vm-use-menus 1) - (vm-menu-install-vm-mode-menu) - (vm-menu-install-menubar-item) - (vm-menu-install-known-virtual-folders-menu)) - (t nil))) - -(defun vm-menu-install-known-virtual-folders-menu () - (let ((folders (sort (mapcar 'car vm-virtual-folder-alist) - (function string-lessp))) - (menu nil) - tail - ;; special string indicating tail of Virtual menu - (special "-------")) - (while folders - (setq menu (cons (vector " " - (list 'vm-menu-run-command - ''vm-visit-virtual-folder (car folders)) - t - (car folders)) - menu) - folders (cdr folders))) - (and menu (setq menu (nreverse menu) - menu (nconc (list "Visit:" "---") menu))) - (setq tail (vm-member special vm-menu-virtual-menu)) - (if (and menu tail) - (progn - (setcdr tail menu) - (vm-menu-set-menubar-dirty-flag) - (cond ((vm-menu-fsfemacs-menus-p) - (makunbound 'vm-menu-fsfemacs-virtual-menu) - (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu - (list (make-sparse-keymap)) - nil - vm-menu-virtual-menu) - (define-key vm-mode-menu-map [rootmenu vm vm-menubar-virtual] - (cons "Virtual" vm-menu-fsfemacs-virtual-menu)))))))) - -(defun vm-menu-install-visited-folders-menu () - (let ((folders (vm-delete-duplicates (copy-sequence vm-folder-history))) - (menu nil) - tail - spool-files - (i 0) - ;; special string indicating tail of Folder menu - (special "-------")) - (while (and folders (< i 10)) - (setq menu (cons (vector " " - (list 'vm-menu-run-command - ''vm-visit-folder (car folders)) - t - (car folders)) - menu) - folders (cdr folders) - i (1+ i))) - (and menu (setq menu (nreverse menu) - menu (nconc (list "Visit:" "---") menu))) - (setq spool-files (vm-spool-files) - folders (cond ((and (consp spool-files) - (consp (car spool-files))) - (mapcar (function car) spool-files)) - ((and (consp spool-files) - (stringp (car spool-files)) - (stringp vm-primary-inbox)) - (list vm-primary-inbox)) - (t nil))) - (if (and menu folders) - (nconc menu (list "---" "---"))) - (while folders - (setq menu (nconc menu - (list (vector " " - (list 'vm-menu-run-command - ''vm-visit-folder (car folders)) - t - (car folders)))) - folders (cdr folders))) - (setq tail (vm-member special vm-menu-folder-menu)) - (if (and menu tail) - (progn - (setcdr tail menu) - (vm-menu-set-menubar-dirty-flag) - (cond ((vm-menu-fsfemacs-menus-p) - (makunbound 'vm-menu-fsfemacs-folder-menu) - (vm-easy-menu-define vm-menu-fsfemacs-folder-menu - (list (make-sparse-keymap)) - nil - vm-menu-folder-menu) - (define-key vm-mode-menu-map [rootmenu vm vm-menubar-folder] - (cons "Folder" vm-menu-fsfemacs-folder-menu)))))))) - - -;;; Muenkel Folders menu code - -(defvar vm-menu-hm-no-hidden-dirs t - "*Hidden directories are suppressed in the folder menus, if non nil.") - -(defvar vm-menu-hm-hidden-file-list '("^\\..*" ".*\\.~[0-9]+~")) - -(defun vm-menu-hm-delete-folder (folder) - "Query deletes a folder." - (interactive "fDelete folder: ") - (if (file-exists-p folder) - (if (y-or-n-p (concat "Delete the folder " folder " ? ")) - (progn - (if (file-directory-p folder) - (delete-directory folder) - (delete-file folder)) - (message "Folder deleted.") - (vm-menu-hm-make-folder-menu) - (vm-menu-hm-install-menu) - ) - (message "Aborted")) - (error "Folder %s does not exist." folder) - (vm-menu-hm-make-folder-menu) - (vm-menu-hm-install-menu) - )) - - -(defun vm-menu-hm-rename-folder (folder) - "Rename a folder." - (interactive "fRename folder: ") - (if (file-exists-p folder) - (rename-file folder - (read-file-name (concat "Rename " - folder - " to ") - (directory-file-name folder) - folder)) - (error "Folder %s does not exist." folder)) - (vm-menu-hm-make-folder-menu) - (vm-menu-hm-install-menu) - ) - - -(defun vm-menu-hm-create-dir (parent-dir) - "Create a subdir in PARENT-DIR." - (interactive "DCreate new directory in: ") - (make-directory - (expand-file-name (read-file-name "Create directory in %s called: " - (concat parent-dir - "/"))) - t) - (vm-menu-hm-make-folder-menu) - (vm-menu-hm-install-menu) - ) - - -(defun vm-menu-hm-make-folder-menu () - "Makes a menu with the mail folders of the directory `vm-folder-directory'." - (interactive) - (message "Building folders menu...") - (let ((folder-list (vm-menu-hm-tree-make-file-list vm-folder-directory)) - (inbox-list (if (listp (car vm-spool-files)) - (mapcar 'car vm-spool-files) - (list vm-primary-inbox)))) - (setq vm-menu-folders-menu - (cons "Manipulate Folders" - (list (cons "Visit Inboxes " - (vm-menu-hm-tree-make-menu - inbox-list - 'vm-visit-folder - t)) - (cons "Visit Folder " - (vm-menu-hm-tree-make-menu - folder-list - 'vm-visit-folder - t - vm-menu-hm-no-hidden-dirs - vm-menu-hm-hidden-file-list)) - (cons "Save Message " - (vm-menu-hm-tree-make-menu - folder-list - 'vm-save-message - t - vm-menu-hm-no-hidden-dirs - vm-menu-hm-hidden-file-list)) - "----" - (cons "Delete Folder " - (vm-menu-hm-tree-make-menu - folder-list - 'vm-menu-hm-delete-folder - t - nil - nil - t - )) - (cons "Rename Folder " - (vm-menu-hm-tree-make-menu - folder-list - 'vm-menu-hm-rename-folder - t - nil - nil - t - )) - (cons "Make New Directory in..." - (vm-menu-hm-tree-make-menu - (cons (list ".") folder-list) - 'vm-menu-hm-create-dir - t - nil - '(".*") - t - )) - "----" - ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory] - )))) - (message "Building folders menu... done") - (vm-menu-hm-install-menu)) - -(defun vm-menu-hm-install-menu () - (cond ((vm-menu-xemacs-menus-p) - (cond ((car (find-menu-item current-menubar '("VM"))) - (add-menu '("VM") "Folders" - (cdr vm-menu-folders-menu) "Motion")) - ((car (find-menu-item current-menubar - '("Folder" "Manipulate Folders"))) - (add-menu '("Folder") "Manipulate Folders" - (cdr vm-menu-folders-menu) "Motion")))) - ((vm-menu-fsfemacs-menus-p) - (vm-easy-menu-define vm-menu-fsfemacs-folders-menu - (list (make-sparse-keymap)) - nil - vm-menu-folders-menu) - (define-key vm-mode-menu-map [rootmenu vm folder folders] - (cons "Manipulate Folders" vm-menu-fsfemacs-folders-menu))))) - - -;;; Muenkel tree-menu code - -(defvar vm-menu-hm-tree-ls-flags "-aFLR" - "*A String with the flags used in the function -vm-menu-hm-tree-ls-in-temp-buffer for the ls command. -Be careful if you want to change this variable. -The ls command must append a / on all files which are directories. -The original flags are -aFLR.") - - -(defun vm-menu-hm-tree-ls-in-temp-buffer (dir temp-buffer) -"List the directory DIR in the TEMP-BUFFER." - (switch-to-buffer temp-buffer) - (erase-buffer) - (let ((process-connection-type nil)) - (call-process "ls" nil temp-buffer nil vm-menu-hm-tree-ls-flags dir)) - (goto-char (point-min)) - (while (search-forward "//" nil t) - (replace-match "/")) - (goto-char (point-min)) - (while (re-search-forward "\\.\\.?/\n" nil t) - (replace-match "")) - (goto-char (point-min))) - - -(defvar vm-menu-hm-tree-temp-buffername "*tree*" - "Name of the temp buffers in tree.") - - -(defun vm-menu-hm-tree-make-file-list-1 (root list) - (let ((filename (buffer-substring (point) (progn - (end-of-line) - (point))))) - (while (not (string= filename "")) - (setq - list - (append - list - (list - (cond ((char-equal (char-after (- (point) 1)) ?/) - ;; Directory - (setq filename (substring filename 0 (1- (length filename)))) - (save-excursion - (search-forward (concat root filename ":")) - (forward-line) - (vm-menu-hm-tree-make-file-list-1 (concat root filename "/") - (list (vm-menu-hm-tree-menu-file-truename - filename - root))))) - ((char-equal (char-after (- (point) 1)) ?*) - ;; Executable - (setq filename (substring filename 0 (1- (length filename)))) - (vm-menu-hm-tree-menu-file-truename filename root)) - (t (vm-menu-hm-tree-menu-file-truename filename root)))))) - (forward-line) - (setq filename (buffer-substring (point) (progn - (end-of-line) - (point))))) - list)) - - -(defun vm-menu-hm-tree-menu-file-truename (file &optional root) - (file-truename (expand-file-name file root))) - -(defun vm-menu-hm-tree-make-file-list (dir) - "Makes a list with the files and subdirectories of DIR. -The list looks like: ((dirname1 file1 file2) - file3 - (dirname2 (dirname3 file4 file5) file6))" - (save-window-excursion - (setq dir (expand-file-name dir)) - (if (not (string= (substring dir -1) "/")) - (setq dir (concat dir "/"))) -;; (while (string-match "/$" dir) -;; (setq dir (substring dir 0 -1))) - (vm-menu-hm-tree-ls-in-temp-buffer dir - (generate-new-buffer-name - vm-menu-hm-tree-temp-buffername)) - (let ((list nil)) - (setq list (vm-menu-hm-tree-make-file-list-1 dir nil)) - (kill-buffer (current-buffer)) - list))) - - -(defun vm-menu-hm-tree-hide-file-p (filename re-hidden-file-list) - "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME." - (cond ((not re-hidden-file-list) nil) - ((string-match (car re-hidden-file-list) - (vm-menu-hm-tree-menu-file-truename filename))) - (t (vm-menu-hm-tree-hide-file-p filename (cdr re-hidden-file-list))))) - - -(defun vm-menu-hm-tree-make-menu (dirlist - function - selectable - &optional - no-hidden-dirs - re-hidden-file-list - include-current-dir) - "Returns a menu list. -Each item of the menu list has the form - [\"subdir\" (FUNCTION \"dir\") SELECTABLE]. -Hidden directories (with a leading point) are suppressed, -if NO-HIDDEN-DIRS are non nil. Also all files which are -matching a regexp in RE-HIDDEN-FILE-LIST are suppressed. -If INCLUDE-CURRENT-DIR non nil, then an additional command -for the current directory (.) is inserted." - (let ((subdir nil) - (menulist nil)) - (while (setq subdir (car dirlist)) - (setq dirlist (cdr dirlist)) - (cond ((and (stringp subdir) - (not (vm-menu-hm-tree-hide-file-p subdir re-hidden-file-list))) - (setq menulist - (append menulist - (list - (vector (file-name-nondirectory subdir) - (list function subdir) - selectable))))) - ((and (listp subdir) - (or (not no-hidden-dirs) - (not (char-equal - ?. - (string-to-char - (file-name-nondirectory (car subdir)))))) - (setq menulist - (append - menulist - (list - (cons (file-name-nondirectory (car subdir)) - (if include-current-dir - (cons - (vector "." - (list function - (car subdir)) - selectable) - (vm-menu-hm-tree-make-menu (cdr subdir) - function - selectable - no-hidden-dirs - re-hidden-file-list - include-current-dir - )) - (vm-menu-hm-tree-make-menu (cdr subdir) - function - selectable - no-hidden-dirs - re-hidden-file-list - )))))))) - (t nil)) - ) - menulist - ) - )
--- a/lisp/vm/vm-message.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,323 +0,0 @@ -;;; Macros and functions dealing with accessing VM message struct fields -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-message) - -;; data that is always shared with virtual folders -(defmacro vm-location-data-of (message) (list 'aref message 0)) -;; where message begins starting at the message separator in the folder -(defmacro vm-start-of (message) (list 'aref (list 'aref message 0) 0)) -;; where headers start (From_ line) -(defmacro vm-headers-of (message) (list 'aref (list 'aref message 0) 1)) -;; where visible headers start -(defun vm-vheaders-of (message) - (or (aref (aref message 0) 2) - (progn (vm-reorder-message-headers message nil nil) - (aref (aref message 0) 2)))) -;; where text section starts -(defun vm-text-of (message) - (or (aref (aref message 0) 3) (progn (vm-find-and-set-text-of message) - (aref (aref message 0) 3)))) -;; where text portion of message ends -(defmacro vm-text-end-of (message) (list 'aref (list 'aref message 0) 4)) -;; where message ends -(defmacro vm-end-of (message) (list 'aref (list 'aref message 0) 5)) -;; soft data vector -(defmacro vm-softdata-of (message) (list 'aref message 1)) -(defmacro vm-number-of (message) (list 'aref (list 'aref message 1) 0)) -(defmacro vm-padded-number-of (message) (list 'aref (list 'aref message 1) 1)) -(defmacro vm-mark-of (message) (list 'aref (list 'aref message 1) 2)) -;; start of summary line -(defmacro vm-su-start-of (message) (list 'aref (list 'aref message 1) 3)) -;; end of summary line -(defmacro vm-su-end-of (message) (list 'aref (list 'aref message 1) 4)) -;; symbol whose value is the real message. -(defmacro vm-real-message-sym-of (message) - (list 'aref (list 'aref message 1) 5)) -;; real message -(defmacro vm-real-message-of (message) - (list 'symbol-value (list 'aref (list 'aref message 1) 5))) -;; link to previous message in the message list -(defmacro vm-reverse-link-of (message) - (list 'symbol-value (list 'aref (list 'aref message 1) 6))) -;; message type -(defmacro vm-message-type-of (message) (list 'aref (list 'aref message 1) 7)) -;; number that uniquely identifies each message -;; this is for the set handling stuff -(defmacro vm-message-id-number-of (message) - (list 'aref (list 'aref message 1) 8)) -;; folder buffer of this message -(defmacro vm-buffer-of (message) - (list 'aref (list 'aref message 1) 9)) -;; cache thread indentation value -(defmacro vm-thread-indentation-of (message) - (list 'aref (list 'aref message 1) 10)) -;; list of symbols from vm-thread-obarray that give this message's lineage -(defmacro vm-thread-list-of (message) - (list 'aref (list 'aref message 1) 11)) -;; babyl header frob flag (0 or 1 at beginning of message) -(defmacro vm-babyl-frob-flag-of (message) - (list 'aref (list 'aref message 1) 12)) -;; saved attributes, if message was switched from unmirrored to mirrored -(defmacro vm-saved-virtual-attributes-of (message) - (list 'aref (list 'aref message 1) 13)) -;; saved mirror data, if message was switched from unmirrored to mirrored -(defmacro vm-saved-virtual-mirror-data-of (message) - (list 'aref (list 'aref message 1) 14)) -;; summary for unmirrored virtual message -(defmacro vm-virtual-summary-of (message) - (list 'aref (list 'aref message 1) 15)) -;; MIME layout information; types, ids, positions, etc. of all MIME entities -(defmacro vm-mime-layout-of (message) - (list 'aref (list 'aref message 1) 16)) -(defmacro vm-mime-encoded-header-flag-of (message) - (list 'aref (list 'aref message 1) 17)) -;; message attribute vector -(defmacro vm-attributes-of (message) (list 'aref message 2)) -(defmacro vm-new-flag (message) (list 'aref (list 'aref message 2) 0)) -(defmacro vm-unread-flag (message) (list 'aref (list 'aref message 2) 1)) -(defmacro vm-deleted-flag (message) (list 'aref (list 'aref message 2) 2)) -(defmacro vm-filed-flag (message) (list 'aref (list 'aref message 2) 3)) -(defmacro vm-replied-flag (message) (list 'aref (list 'aref message 2) 4)) -(defmacro vm-written-flag (message) (list 'aref (list 'aref message 2) 5)) -(defmacro vm-forwarded-flag (message) (list 'aref (list 'aref message 2) 6)) -(defmacro vm-edited-flag (message) (list 'aref (list 'aref message 2) 7)) -(defmacro vm-redistributed-flag (message) (list 'aref (list 'aref message 2) 8)) -;; message cached data -(defmacro vm-cache-of (message) (list 'aref message 3)) -;; message size in bytes (as a string) -(defmacro vm-byte-count-of (message) (list 'aref (list 'aref message 3) 0)) -;; weekday sent -(defmacro vm-weekday-of (message) (list 'aref (list 'aref message 3) 1)) -;; month day -(defmacro vm-monthday-of (message) (list 'aref (list 'aref message 3) 2)) -;; month sent -(defmacro vm-month-of (message) (list 'aref (list 'aref message 3) 3)) -;; year sent -(defmacro vm-year-of (message) (list 'aref (list 'aref message 3) 4)) -;; hour sent -(defmacro vm-hour-of (message) (list 'aref (list 'aref message 3) 5)) -;; timezone -(defmacro vm-zone-of (message) (list 'aref (list 'aref message 3) 6)) -;; message author's full name (Full-Name: or gouged from From:) -(defmacro vm-full-name-of (message) (list 'aref (list 'aref message 3) 7)) -;; message author address (gouged from From:) -(defmacro vm-from-of (message) (list 'aref (list 'aref message 3) 8)) -;; message ID (Message-Id:) -(defmacro vm-message-id-of (message) (list 'aref (list 'aref message 3) 9)) -;; number of lines in message (as a string) -(defmacro vm-line-count-of (message) (list 'aref (list 'aref message 3) 10)) -;; message subject (Subject:) -(defmacro vm-subject-of (message) (list 'aref (list 'aref message 3) 11)) -;; Regexp that can be used to find the start of the already ordered headers. -(defmacro vm-vheaders-regexp-of (message) - (list 'aref (list 'aref message 3) 12)) -;; Addresses of recipients in a comma separated list -(defmacro vm-to-of (message) (list 'aref (list 'aref message 3) 13)) -;; Full names of recipients in a comma separated list. Addresses if -;; full names not available. -(defmacro vm-to-names-of (message) (list 'aref (list 'aref message 3) 14)) -;; numeric month sent -(defmacro vm-month-number-of (message) (list 'aref (list 'aref message 3) 15)) -;; sortable date string (used for easy sorting, naturally) -(defmacro vm-sortable-datestring-of (message) - (list 'aref (list 'aref message 3) 16)) -;; sortable subject, re: garbage removed -(defmacro vm-sortable-subject-of (message) - (list 'aref (list 'aref message 3) 17)) -;; tokenized summary entry -(defmacro vm-summary-of (message) - (list 'aref (list 'aref message 3) 18)) -;; parent of this message, as determined by threading -(defmacro vm-parent-of (message) - (list 'aref (list 'aref message 3) 19)) -;; message IDs parsed from References header -(defmacro vm-references-of (message) - (list 'aref (list 'aref message 3) 20)) -;; extra data shared by virtual messages if vm-virtual-mirror is non-nil -(defmacro vm-mirror-data-of (message) (list 'aref message 4)) -;; if message is being edited, this is the buffer being used. -(defmacro vm-edit-buffer-of (message) (list 'aref (list 'aref message 4) 0)) -;; list of virtual messages mirroring the underlying real message -(defmacro vm-virtual-messages-of (message) - (list 'symbol-value (list 'aref (list 'aref message 4) 1))) -;; modification flag for this message -;; nil if all attribute changes have been stuffed into the folder buffer -(defmacro vm-modflag-of (message) (list 'aref (list 'aref message 4) 2)) -;; list of labels attached to this message -(defmacro vm-labels-of (message) (list 'aref (list 'aref message 4) 3)) -;; comma list of labels -(defmacro vm-label-string-of (message) (list 'aref (list 'aref message 4) 4)) - -(defmacro vm-set-location-data-of (message vdata) (list 'aset message 0 vdata)) -(defmacro vm-set-start-of (message start) - (list 'aset (list 'aref message 0) 0 start)) -(defmacro vm-set-headers-of (message h) - (list 'aset (list 'aref message 0) 1 h)) -(defmacro vm-set-vheaders-of (message vh) - (list 'aset (list 'aref message 0) 2 vh)) -(defmacro vm-set-text-of (message text) - (list 'aset (list 'aref message 0) 3 text)) -(defmacro vm-set-text-end-of (message text) - (list 'aset (list 'aref message 0) 4 text)) -(defmacro vm-set-end-of (message end) - (list 'aset (list 'aref message 0) 5 end)) -(defmacro vm-set-softdata-of (message data) - (list 'aset message 1 data)) -(defmacro vm-set-number-of (message n) - (list 'aset (list 'aref message 1) 0 n)) -(defmacro vm-set-padded-number-of (message n) - (list 'aset (list 'aref message 1) 1 n)) -(defmacro vm-set-mark-of (message val) - (list 'aset (list 'aref message 1) 2 val)) -(defmacro vm-set-su-start-of (message pos) - (list 'aset (list 'aref message 1) 3 pos)) -(defmacro vm-set-su-end-of (message pos) - (list 'aset (list 'aref message 1) 4 pos)) -(defmacro vm-set-real-message-sym-of (message sym) - (list 'aset (list 'aref message 1) 5 sym)) -(defmacro vm-set-reverse-link-of (message link) - (list 'set (list 'aref (list 'aref message 1) 6) link)) -(defmacro vm-set-reverse-link-sym-of (message sym) - (list 'aset (list 'aref message 1) 6 sym)) -(defmacro vm-set-message-type-of (message type) - (list 'aset (list 'aref message 1) 7 type)) -(defmacro vm-set-message-id-number-of (message number) - (list 'aset (list 'aref message 1) 8 number)) -(defmacro vm-set-buffer-of (message buffer) - (list 'aset (list 'aref message 1) 9 buffer)) -(defmacro vm-set-thread-indentation-of (message val) - (list 'aset (list 'aref message 1) 10 val)) -(defmacro vm-set-thread-list-of (message list) - (list 'aset (list 'aref message 1) 11 list)) -(defmacro vm-set-babyl-frob-flag-of (message flag) - (list 'aset (list 'aref message 1) 12 flag)) -(defmacro vm-set-saved-virtual-attributes-of (message attrs) - (list 'aset (list 'aref message 1) 13 attrs)) -(defmacro vm-set-saved-virtual-mirror-data-of (message data) - (list 'aset (list 'aref message 1) 14 data)) -(defmacro vm-set-virtual-summary-of (message summ) - (list 'aset (list 'aref message 1) 15 summ)) -(defmacro vm-set-mime-layout-of (message layout) - (list 'aset (list 'aref message 1) 16 layout)) -(defmacro vm-set-mime-encoded-header-flag-of (message flag) - (list 'aset (list 'aref message 1) 17 flag)) -(defmacro vm-set-attributes-of (message attrs) (list 'aset message 2 attrs)) -;; The other routines in attributes group are part of the undo system. -(defun vm-set-edited-flag-of (message flag) - (aset (aref message 2) 7 flag) - (vm-mark-for-summary-update message) - (if (eq vm-flush-interval t) - (vm-stuff-virtual-attributes message) - (vm-set-modflag-of message t)) - (and (not (buffer-modified-p)) (vm-set-buffer-modified-p t)) - (vm-clear-modification-flag-undos)) -(defmacro vm-set-cache-of (message cache) (list 'aset message 3 cache)) -(defmacro vm-set-byte-count-of (message count) - (list 'aset (list 'aref message 3) 0 count)) -(defmacro vm-set-weekday-of (message val) - (list 'aset (list 'aref message 3) 1 val)) -(defmacro vm-set-monthday-of (message val) - (list 'aset (list 'aref message 3) 2 val)) -(defmacro vm-set-month-of (message val) - (list 'aset (list 'aref message 3) 3 val)) -(defmacro vm-set-year-of (message val) - (list 'aset (list 'aref message 3) 4 val)) -(defmacro vm-set-hour-of (message val) - (list 'aset (list 'aref message 3) 5 val)) -(defmacro vm-set-zone-of (message val) - (list 'aset (list 'aref message 3) 6 val)) -(defmacro vm-set-full-name-of (message author) - (list 'aset (list 'aref message 3) 7 author)) -(defmacro vm-set-from-of (message author) - (list 'aset (list 'aref message 3) 8 author)) -(defmacro vm-set-message-id-of (message id) - (list 'aset (list 'aref message 3) 9 id)) -(defmacro vm-set-line-count-of (message count) - (list 'aset (list 'aref message 3) 10 count)) -(defmacro vm-set-subject-of (message subject) - (list 'aset (list 'aref message 3) 11 subject)) -(defmacro vm-set-vheaders-regexp-of (message regexp) - (list 'aset (list 'aref message 3) 12 regexp)) -(defmacro vm-set-to-of (message recips) - (list 'aset (list 'aref message 3) 13 recips)) -(defmacro vm-set-to-names-of (message recips) - (list 'aset (list 'aref message 3) 14 recips)) -(defmacro vm-set-month-number-of (message val) - (list 'aset (list 'aref message 3) 15 val)) -(defmacro vm-set-sortable-datestring-of (message val) - (list 'aset (list 'aref message 3) 16 val)) -(defmacro vm-set-sortable-subject-of (message val) - (list 'aset (list 'aref message 3) 17 val)) -(defmacro vm-set-summary-of (message val) - (list 'aset (list 'aref message 3) 18 val)) -(defmacro vm-set-parent-of (message val) - (list 'aset (list 'aref message 3) 19 val)) -(defmacro vm-set-references-of (message val) - (list 'aset (list 'aref message 3) 20 val)) -(defmacro vm-set-mirror-data-of (message data) - (list 'aset message 4 data)) -(defmacro vm-set-edit-buffer-of (message buf) - (list 'aset (list 'aref message 4) 0 buf)) -(defmacro vm-set-virtual-messages-of (message list) - (list 'set (list 'aref (list 'aref message 4) 1) list)) -(defmacro vm-set-virtual-messages-sym-of (message sym) - (list 'aset (list 'aref message 4) 1 sym)) -(defmacro vm-set-modflag-of (message val) - (list 'aset (list 'aref message 4) 2 val)) -(defmacro vm-set-labels-of (message labels) - (list 'aset (list 'aref message 4) 3 labels)) -(defmacro vm-set-label-string-of (message string) - (list 'aset (list 'aref message 4) 4 string)) - -(defun vm-make-message () - (let ((v (make-vector 5 nil)) sym) - (vm-set-softdata-of v (make-vector vm-softdata-vector-length nil)) - (vm-set-location-data-of - v (make-vector vm-location-data-vector-length nil)) - (vm-set-mirror-data-of v (make-vector vm-mirror-data-vector-length nil)) - (vm-set-message-id-number-of v (int-to-string vm-message-id-number)) - (vm-increment vm-message-id-number) - (vm-set-buffer-of v (current-buffer)) - ;; We use an uninterned symbol here as a level of indirection - ;; from a purely self-referential structure. This is - ;; necessary so that Emacs debugger can be used on this - ;; program. - (setq sym (make-symbol "<<>>")) - (set sym v) - (vm-set-real-message-sym-of v sym) - ;; Another uninterned symbol for the virtual messages list. - (setq sym (make-symbol "<v>")) - (set sym nil) - (vm-set-virtual-messages-sym-of v sym) - ;; Another uninterned symbol for the reverse link - ;; into the message list. - (setq sym (make-symbol "<--")) - (vm-set-reverse-link-sym-of v sym) - v )) - -(defun vm-find-and-set-text-of (m) - (save-excursion - (set-buffer (vm-buffer-of m)) - (save-restriction - (widen) - (goto-char (vm-headers-of m)) - (search-forward "\n\n" (vm-text-end-of m) 0) - (vm-set-text-of m (point-marker))))) - -(defun vm-virtual-message-p (m) - (not (eq m (vm-real-message-of m))))
--- a/lisp/vm/vm-mime.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3300 +0,0 @@ -;;; MIME support functions -;;; Copyright (C) 1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-mime) - -(defun vm-mime-error (&rest args) - (signal 'vm-mime-error (list (apply 'format args))) - (error "can't return from vm-mime-error")) - -(if (fboundp 'define-error) - (define-error 'vm-mime-error "MIME error") - (put 'vm-mime-error 'error-conditions '(vm-mime-error error)) - (put 'vm-mime-error 'error-message "MIME error")) - -(defun vm-mm-layout-type (e) (aref e 0)) -(defun vm-mm-layout-qtype (e) (aref e 1)) -(defun vm-mm-layout-encoding (e) (aref e 2)) -(defun vm-mm-layout-id (e) (aref e 3)) -(defun vm-mm-layout-description (e) (aref e 4)) -(defun vm-mm-layout-disposition (e) (aref e 5)) -(defun vm-mm-layout-qdisposition (e) (aref e 6)) -(defun vm-mm-layout-header-start (e) (aref e 7)) -(defun vm-mm-layout-body-start (e) (aref e 8)) -(defun vm-mm-layout-body-end (e) (aref e 9)) -(defun vm-mm-layout-parts (e) (aref e 10)) -(defun vm-mm-layout-cache (e) (aref e 11)) -;; if display of MIME part fails, error string will be here. -(defun vm-mm-layout-display-error (e) (aref e 12)) - -(defun vm-set-mm-layout-type (e type) (aset e 0 type)) -(defun vm-set-mm-layout-cache (e c) (aset e 11 c)) -(defun vm-set-mm-layout-display-error (e c) (aset e 12 c)) - -(defun vm-mm-layout (m) - (or (vm-mime-layout-of m) - (progn (vm-set-mime-layout-of - m - (condition-case data - (vm-mime-parse-entity m) - (vm-mime-error (message "%s" (car (cdr data)))))) - (vm-mime-layout-of m)))) - -(defun vm-mm-encoded-header (m) - (or (vm-mime-encoded-header-flag-of m) - (progn (setq m (vm-real-message-of m)) - (vm-set-mime-encoded-header-flag-of - m - (save-excursion - (set-buffer (vm-buffer-of m)) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-headers-of m)) - (or (re-search-forward vm-mime-encoded-word-regexp - (vm-text-of m) t) - 'none))))) - (vm-mime-encoded-header-flag-of m)))) - -(defun vm-mime-Q-decode-region (start end) - (let ((buffer-read-only nil)) - (subst-char-in-region start end ?_ (string-to-char " ") t) - (vm-mime-qp-decode-region start end))) - -(fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region) - -(defun vm-mime-Q-encode-region (start end) - (let ((buffer-read-only nil)) - (subst-char-in-region start end (string-to-char " ") ?_ t) - (vm-mime-qp-encode-region start end t))) - -(defun vm-mime-B-encode-region (start end) - (vm-mime-base64-encode-region start end nil t)) - -(defun vm-mime-crlf-to-lf-region (start end) - (let ((buffer-read-only nil)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (while (search-forward "\r\n" nil t) - (delete-char -2) - (insert "\n")))))) - -(defun vm-mime-lf-to-crlf-region (start end) - (let ((buffer-read-only nil)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (while (search-forward "\n" nil t) - (delete-char -1) - (insert "\r\n")))))) - -(defun vm-mime-charset-decode-region (charset start end) - (or (markerp end) (setq end (vm-marker end))) - (cond (vm-xemacs-mule-p - (if (eq (device-type) 'x) - (let ((buffer-read-only nil) - (cell (cdr (vm-string-assoc - charset - vm-mime-mule-charset-to-coding-alist))) - (oend (marker-position end)) - (opoint (point))) - (if cell - (progn - (set-marker end (+ start - (or (decode-coding-region - start end (car cell)) - (- oend start)))) - (put-text-property start end 'vm-string t) - (put-text-property start end 'vm-charset charset) - (put-text-property start end 'vm-coding (car cell)))) - ;; In XEmacs 20.0 beta93 decode-coding-region moves point. - (goto-char opoint)))) - ((not (vm-multiple-fonts-possible-p)) nil) - ((vm-string-member charset vm-mime-default-face-charsets) nil) - (t - (let ((font (cdr (vm-string-assoc - charset - vm-mime-charset-font-alist))) - (face (make-face (make-symbol "temp-face"))) - (e (vm-make-extent start end))) - (put-text-property start end 'vm-string t) - (put-text-property start end 'vm-charset charset) - (if font - (condition-case data - (progn (set-face-font face font) - (vm-set-extent-property e 'face face)) - (error nil))))))) - -(defun vm-mime-transfer-decode-region (layout start end) - (let ((case-fold-search t) (crlf nil)) - (cond ((string-match "^base64$" (vm-mm-layout-encoding layout)) - (cond ((vm-mime-types-match "text" - (car (vm-mm-layout-type layout))) - (setq crlf t)) - ((vm-mime-types-match "message" - (car (vm-mm-layout-type layout))) - (setq crlf t))) - (vm-mime-base64-decode-region start end crlf)) - ((string-match "^quoted-printable$" - (vm-mm-layout-encoding layout)) - (vm-mime-qp-decode-region start end))))) - -(defun vm-mime-base64-decode-region (start end &optional crlf) - (message "Decoding base64...") - (let ((work-buffer nil) - (done nil) - (counter 0) - (bits 0) - (lim 0) inputpos - (non-data-chars (concat "^=" vm-mime-base64-alphabet))) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (if vm-mime-base64-decoder-program - (let* ((binary-process-output t) ; any text already has CRLFs - (status (apply 'vm-run-command-on-region - start end work-buffer - vm-mime-base64-decoder-program - vm-mime-base64-decoder-switches))) - (if (not (eq status t)) - (vm-mime-error "%s" (cdr status)))) - (goto-char start) - (skip-chars-forward non-data-chars end) - (while (not done) - (setq inputpos (point)) - (cond - ((> (skip-chars-forward vm-mime-base64-alphabet end) 0) - (setq lim (point)) - (while (< inputpos lim) - (setq bits (+ bits - (aref vm-mime-base64-alphabet-decoding-vector - (char-after inputpos)))) - (vm-increment counter) - (vm-increment inputpos) - (cond ((= counter 4) - (vm-insert-char (lsh bits -16) 1 nil work-buffer) - (vm-insert-char (logand (lsh bits -8) 255) 1 nil - work-buffer) - (vm-insert-char (logand bits 255) 1 nil work-buffer) - (setq bits 0 counter 0)) - (t (setq bits (lsh bits 6))))))) - (cond - ((= (point) end) - (if (not (zerop counter)) - (vm-mime-error "at least %d bits missing at end of base64 encoding" - (* (- 4 counter) 6))) - (setq done t)) - ((= (char-after (point)) 61) ; 61 is ASCII equals - (setq done t) - (cond ((= counter 1) - (vm-mime-error "at least 2 bits missing at end of base64 encoding")) - ((= counter 2) - (vm-insert-char (lsh bits -10) 1 nil work-buffer)) - ((= counter 3) - (vm-insert-char (lsh bits -16) 1 nil work-buffer) - (vm-insert-char (logand (lsh bits -8) 255) - 1 nil work-buffer)) - ((= counter 0) t))) - (t (skip-chars-forward non-data-chars end))))) - (and crlf - (save-excursion - (set-buffer work-buffer) - (vm-mime-crlf-to-lf-region (point-min) (point-max)))) - (or (markerp end) (setq end (vm-marker end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end)) - (and work-buffer (kill-buffer work-buffer)))) - (message "Decoding base64... done")) - -(defun vm-mime-base64-encode-region (start end &optional crlf B-encoding) - (and (> (- end start) 200) - (message "Encoding base64...")) - (let ((work-buffer nil) - (counter 0) - (cols 0) - (bits 0) - (alphabet vm-mime-base64-alphabet) - inputpos) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (if crlf - (progn - (or (markerp end) (setq end (vm-marker end))) - (vm-mime-lf-to-crlf-region start end))) - (if vm-mime-base64-encoder-program - (let ((status (apply 'vm-run-command-on-region - start end work-buffer - vm-mime-base64-encoder-program - vm-mime-base64-encoder-switches))) - (if (not (eq status t)) - (vm-mime-error "%s" (cdr status))) - (if B-encoding - (progn - ;; if we're B encoding, strip out the line breaks - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (delete-char -1))))) - (setq inputpos start) - (while (< inputpos end) - (setq bits (+ bits (char-after inputpos))) - (vm-increment counter) - (cond ((= counter 3) - (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil - work-buffer) - (vm-insert-char (aref alphabet (logand (lsh bits -12) 63)) - 1 nil work-buffer) - (vm-insert-char (aref alphabet (logand (lsh bits -6) 63)) - 1 nil work-buffer) - (vm-insert-char (aref alphabet (logand bits 63)) 1 nil - work-buffer) - (setq cols (+ cols 4)) - (cond ((= cols 72) - (setq cols 0) - (if (not B-encoding) - (vm-insert-char ?\n 1 nil work-buffer)))) - (setq bits 0 counter 0)) - (t (setq bits (lsh bits 8)))) - (vm-increment inputpos)) - ;; write out any remaining bits with appropriate padding - (if (= counter 0) - nil - (setq bits (lsh bits (- 16 (* 8 counter)))) - (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil - work-buffer) - (vm-insert-char (aref alphabet (logand (lsh bits -12) 63)) - 1 nil work-buffer) - (if (= counter 1) - (vm-insert-char ?= 2 nil work-buffer) - (vm-insert-char (aref alphabet (logand (lsh bits -6) 63)) - 1 nil work-buffer) - (vm-insert-char ?= 1 nil work-buffer))) - (if (> cols 0) - (vm-insert-char ?\n 1 nil work-buffer))) - (or (markerp end) (setq end (vm-marker end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end) - (and (> (- end start) 200) - (message "Encoding base64... done")) - (- end start)) - (and work-buffer (kill-buffer work-buffer))))) - -(defun vm-mime-qp-decode-region (start end) - (and (> (- end start) 200) - (message "Decoding quoted-printable...")) - (let ((work-buffer nil) - (buf (current-buffer)) - (case-fold-search nil) - (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) - (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) - (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) - (?C . 12) (?D . 13) (?E . 14) (?F . 15))) - inputpos stop-point copy-point) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (goto-char start) - (setq inputpos start) - (while (< inputpos end) - (skip-chars-forward "^=\n" end) - (setq stop-point (point)) - (cond ((looking-at "\n") - ;; spaces or tabs before a hard line break must be ignored - (skip-chars-backward " \t") - (setq copy-point (point)) - (goto-char stop-point)) - (t (setq copy-point stop-point))) - (save-excursion - (set-buffer work-buffer) - (insert-buffer-substring buf inputpos copy-point)) - (cond ((= (point) end) t) - ((looking-at "\n") - (vm-insert-char ?\n 1 nil work-buffer) - (forward-char)) - (t ;; looking at = - (forward-char) - (cond ((looking-at "[0-9A-F][0-9A-F]") - (vm-insert-char (+ (* (cdr (assq (char-after (point)) - hex-digit-alist)) - 16) - (cdr (assq (char-after - (1+ (point))) - hex-digit-alist))) - 1 nil work-buffer) - (forward-char 2)) - ((looking-at "\n") ; soft line break - (forward-char)) - ((looking-at "\r") - ;; assume the user's goatloving - ;; delivery software didn't convert - ;; from Internet's CRLF newline - ;; convention to the local LF - ;; convention. - (forward-char)) - ((looking-at "[ \t]") - ;; garbage added in transit - (skip-chars-forward " \t" end)) - (t (vm-mime-error "something other than line break or hex digits after = in quoted-printable encoding"))))) - (setq inputpos (point))) - (or (markerp end) (setq end (vm-marker end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end)) - (and work-buffer (kill-buffer work-buffer)))) - (and (> (- end start) 200) - (message "Decoding quoted-printable... done"))) - -(defun vm-mime-qp-encode-region (start end &optional Q-encoding quote-from) - (and (> (- end start) 200) - (message "Encoding quoted-printable...")) - (let ((work-buffer nil) - (buf (current-buffer)) - (cols 0) - (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) - (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) - (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) - (?C . 12) (?D . 13) (?E . 14) (?F . 15))) - char inputpos) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (setq inputpos start) - (while (< inputpos end) - (setq char (char-after inputpos)) - (cond ((= char ?\n) - (vm-insert-char char 1 nil work-buffer) - (setq cols 0)) - ((and (= char 32) - (not (= (1+ inputpos) end)) - (not (= ?\n (char-after (1+ inputpos))))) - (vm-insert-char char 1 nil work-buffer) - (vm-increment cols)) - ((or (< char 33) (> char 126) (= char 61) - (and quote-from (= cols 0) (let ((case-fold-search nil)) - (looking-at "From "))) - (and (= cols 0) (= char ?.) - (looking-at "\\.\\(\n\\|\\'\\)"))) - (vm-insert-char ?= 1 nil work-buffer) - (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist)) - 1 nil work-buffer) - (vm-insert-char (car (rassq (logand char 15) - hex-digit-alist)) - 1 nil work-buffer) - (setq cols (+ cols 3))) - (t (vm-insert-char char 1 nil work-buffer) - (vm-increment cols))) - (cond ((> cols 70) - (setq cols 0) - (if Q-encoding - nil - (vm-insert-char ?= 1 nil work-buffer) - (vm-insert-char ?\n 1 nil work-buffer)))) - (vm-increment inputpos)) - (or (markerp end) (setq end (vm-marker end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end) - (and (> (- end start) 200) - (message "Encoding quoted-printable... done")) - (- end start)) - (and work-buffer (kill-buffer work-buffer))))) - -(defun vm-decode-mime-message-headers (m) - (let ((case-fold-search t) - (buffer-read-only nil) - charset encoding match-start match-end start end) - (save-excursion - (goto-char (vm-headers-of m)) - (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t) - (setq match-start (match-beginning 0) - match-end (match-end 0) - charset (buffer-substring (match-beginning 1) (match-end 1)) - encoding (buffer-substring (match-beginning 2) (match-end 2)) - start (match-beginning 3) - end (vm-marker (match-end 3))) - ;; don't change anything if we can't display the - ;; character set properly. - (if (not (vm-mime-charset-internally-displayable-p charset)) - nil - (delete-region end match-end) - (condition-case data - (cond ((string-match "B" encoding) - (vm-mime-B-decode-region start end)) - ((string-match "Q" encoding) - (vm-mime-Q-decode-region start end)) - (t (vm-mime-error "unknown encoded word encoding, %s" - encoding))) - (vm-mime-error (apply 'message (cdr data)) - (goto-char start) - (insert "**invalid encoded word**") - (delete-region (point) end))) - (vm-mime-charset-decode-region charset start end) - (delete-region match-start start)))))) - -(defun vm-decode-mime-encoded-words () - (let ((case-fold-search t) - (buffer-read-only nil) - charset encoding match-start match-end start end) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward vm-mime-encoded-word-regexp nil t) - (setq match-start (match-beginning 0) - match-end (match-end 0) - charset (buffer-substring (match-beginning 1) (match-end 1)) - encoding (buffer-substring (match-beginning 2) (match-end 2)) - start (match-beginning 3) - end (vm-marker (match-end 3))) - ;; don't change anything if we can't display the - ;; character set properly. - (if (not (vm-mime-charset-internally-displayable-p charset)) - nil - (delete-region end match-end) - (condition-case data - (cond ((string-match "B" encoding) - (vm-mime-B-decode-region start end)) - ((string-match "Q" encoding) - (vm-mime-Q-decode-region start end)) - (t (vm-mime-error "unknown encoded word encoding, %s" - encoding))) - (vm-mime-error (apply 'message (cdr data)) - (goto-char start) - (insert "**invalid encoded word**") - (delete-region (point) end))) - (vm-mime-charset-decode-region charset start end) - (delete-region match-start start)))))) - -(defun vm-decode-mime-encoded-words-in-string (string) - (if (and vm-display-using-mime - (string-match vm-mime-encoded-word-regexp string)) - (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words) - string )) - -(defun vm-reencode-mime-encoded-words () - (let ((charset nil) - start coding pos q-encoding - old-size - (case-fold-search t) - (done nil)) - (save-excursion - (setq start (point-min)) - (while (not done) - (setq charset (get-text-property start 'vm-charset)) - (setq pos (next-single-property-change start 'vm-charset)) - (or pos (setq pos (point-max) done t)) - (if charset - (progn - (if (setq coding (get-text-property start 'vm-coding)) - (progn - (setq old-size (buffer-size)) - (encode-coding-region start pos coding) - (setq pos (+ pos (- (buffer-size) old-size))))) - (setq pos - (+ start - (if (setq q-encoding - (string-match "^iso-8859-\\|^us-ascii" - charset)) - (vm-mime-Q-encode-region start pos) - (vm-mime-B-encode-region start pos)))) - (goto-char pos) - (insert "?=") - (setq pos (point)) - (goto-char start) - (insert "=?" charset "?" (if q-encoding "Q" "B") "?"))) - (setq start pos))))) - -(defun vm-reencode-mime-encoded-words-in-string (string) - (if (and vm-display-using-mime - (text-property-any 0 (length string) 'vm-string t string)) - (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words) - string )) - -(fset 'vm-mime-parse-content-header 'vm-parse-structured-header) - -(defun vm-mime-get-header-contents (header-name-regexp) - (let ((contents nil) - regexp) - (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) - (save-excursion - (let ((case-fold-search t)) - (if (and (re-search-forward regexp nil t) - (match-beginning 1) - (progn (goto-char (match-beginning 0)) - (vm-match-header))) - (vm-matched-header-contents) - nil ))))) - -(defun vm-mime-parse-entity (&optional m default-type default-encoding) - (let ((case-fold-search t) version type qtype encoding id description - disposition qdisposition boundary boundary-regexp start - multipart-list c-t c-t-e done p returnval) - (catch 'return-value - (save-excursion - (if m - (progn - (setq m (vm-real-message-of m)) - (set-buffer (vm-buffer-of m)))) - (save-excursion - (save-restriction - (if m - (progn - (setq version (vm-get-header-contents m "MIME-Version:") - version (car (vm-mime-parse-content-header version)) - type (vm-get-header-contents m "Content-Type:") - qtype (vm-mime-parse-content-header type ?\; t) - type (vm-mime-parse-content-header type ?\;) - encoding (or (vm-get-header-contents - m "Content-Transfer-Encoding:") - "7bit") - encoding (or (car - (vm-mime-parse-content-header encoding)) - "7bit") - id (vm-get-header-contents m "Content-ID:") - id (car (vm-mime-parse-content-header id)) - description (vm-get-header-contents - m "Content-Description:") - description (and description - (if (string-match "^[ \t\n]$" - description) - nil - description)) - disposition (vm-get-header-contents - m "Content-Disposition:") - qdisposition (and disposition - (vm-mime-parse-content-header - disposition ?\; t)) - disposition (and disposition - (vm-mime-parse-content-header - disposition ?\;))) - (widen) - (narrow-to-region (vm-headers-of m) (vm-text-end-of m))) - (goto-char (point-min)) - (setq type (vm-mime-get-header-contents "Content-Type:") - qtype (or (vm-mime-parse-content-header type ?\; t) - default-type) - type (or (vm-mime-parse-content-header type ?\;) - default-type) - encoding (or (vm-mime-get-header-contents - "Content-Transfer-Encoding:") - default-encoding) - encoding (or (car (vm-mime-parse-content-header encoding)) - default-encoding) - id (vm-mime-get-header-contents "Content-ID:") - id (car (vm-mime-parse-content-header id)) - description (vm-mime-get-header-contents - "Content-Description:") - description (and description (if (string-match "^[ \t\n]+$" - description) - nil - description)) - disposition (vm-mime-get-header-contents - "Content-Disposition:") - qdisposition (and disposition - (vm-mime-parse-content-header - disposition ?\; t)) - disposition (and disposition - (vm-mime-parse-content-header - disposition ?\;)))) - (cond ((null m) t) - ((null version) - (throw 'return-value 'none)) - ((or vm-mime-ignore-mime-version (string= version "1.0")) t) - (t (vm-mime-error "Unsupported MIME version: %s" version))) - (cond ((and m (null type)) - (throw 'return-value - (vector '("text/plain" "charset=us-ascii") - '("text/plain" "charset=us-ascii") - encoding id description - disposition qdisposition - (vm-headers-of m) - (vm-text-of m) - (vm-text-end-of m) - nil nil nil ))) - ((null type) - (goto-char (point-min)) - (or (re-search-forward "^\n\\|\n\\'" nil t) - (vm-mime-error "MIME part missing header/body separator line")) - (vector default-type default-type - encoding id description - disposition qdisposition - (vm-marker (point-min)) - (vm-marker (point)) - (vm-marker (point-max)) - nil nil nil )) - ((null (string-match "[^/ ]+/[^/ ]+" (car type))) - (vm-mime-error "Malformed MIME content type: %s" (car type))) - ((and (string-match "^multipart/\\|^message/" (car type)) - (null (string-match "^\\(7bit\\|8bit\\|binary\\)$" - encoding))) - (vm-mime-error "Opaque transfer encoding used with multipart or message type: %s, %s" (car type) encoding)) - ((and (string-match "^message/partial$" (car type)) - (null (string-match "^7bit$" encoding))) - (vm-mime-error "Non-7BIT transfer encoding used with message/partial message: %s" encoding)) - ((string-match "^multipart/digest" (car type)) - (setq c-t '("message/rfc822") - c-t-e "7bit")) - ((string-match "^multipart/" (car type)) - (setq c-t '("text/plain" "charset=us-ascii") - c-t-e "7bit")) ; below - ((string-match "^message/\\(rfc822\\|news\\)" (car type)) - (setq c-t '("text/plain" "charset=us-ascii") - c-t-e "7bit") - (goto-char (point-min)) - (or (re-search-forward "^\n\\|\n\\'" nil t) - (vm-mime-error "MIME part missing header/body separator line")) - (throw 'return-value - (vector type qtype encoding id description - disposition qdisposition - (vm-marker (point-min)) - (vm-marker (point)) - (vm-marker (point-max)) - (list - (save-restriction - (narrow-to-region (point) (point-max)) - (vm-mime-parse-entity-safe nil c-t - c-t-e))) - nil nil ))) - (t - (goto-char (point-min)) - (or (re-search-forward "^\n\\|\n\\'" nil t) - (vm-mime-error "MIME part missing header/body separator line")) - (throw 'return-value - (vector type qtype encoding id description - disposition qdisposition - (vm-marker (point-min)) - (vm-marker (point)) - (vm-marker (point-max)) - nil nil nil )))) - (setq p (cdr type) - boundary nil) - (while p - (if (string-match "^boundary=" (car p)) - (setq boundary (car (vm-parse (car p) "=\\(.+\\)")) - p nil) - (setq p (cdr p)))) - (or boundary - (vm-mime-error - "Boundary parameter missing in %s type specification" - (car type))) - ;; the \' in the regexp is to "be liberal" in the - ;; face of broken software that does not add a line - ;; break after the final boundary of a nested - ;; multipart entity. - (setq boundary-regexp - (concat "^--" (regexp-quote boundary) - "\\(--\\)?[ \t]*\\(\n\\|\\'\\)")) - (goto-char (point-min)) - (setq start nil - multipart-list nil - done nil) - (while (and (not done) (re-search-forward boundary-regexp nil t)) - (cond ((null start) - (setq start (match-end 0))) - (t - (and (match-beginning 1) - (setq done t)) - (save-excursion - (save-restriction - (narrow-to-region start (1- (match-beginning 0))) - (setq start (match-end 0)) - (setq multipart-list - (cons (vm-mime-parse-entity-safe nil c-t c-t-e) - multipart-list))))))) - (if (not done) - (vm-mime-error "final %s boundary missing" boundary)) - (goto-char (point-min)) - (or (re-search-forward "^\n\\|\n\\'" nil t) - (vm-mime-error "MIME part missing header/body separator line")) - (vector type qtype encoding id description - disposition qdisposition - (vm-marker (point-min)) - (vm-marker (point)) - (vm-marker (point-max)) - (nreverse multipart-list) - nil nil ))))))) - -(defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) - (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) - ;; don't let subpart parse errors make the whole parse fail. use default - ;; type if the parse fails. - (condition-case error-data - (vm-mime-parse-entity nil c-t c-t-e) - (vm-mime-error - (let ((header (if m - (vm-headers-of m) - (vm-marker (point-min)))) - (text (if m - (vm-text-of m) - (save-excursion - (re-search-forward "^\n\\|\n\\'" - nil 0) - (vm-marker (point))))) - (text-end (if m - (vm-text-end-of m) - (vm-marker (point-max))))) - (vector c-t c-t - (vm-determine-proper-content-transfer-encoding text text-end) - nil - ;; cram the error message into the description slot - (car (cdr error-data)) - ;; mark as an attachment to improve the chance that the user - ;; will see the description. - '("attachment") '("attachment") - header - text - text-end - nil nil nil))))) - -(defun vm-mime-get-xxx-parameter (layout name param-list) - (let ((match-end (1+ (length name))) - (name-regexp (concat (regexp-quote name) "=")) - (case-fold-search t) - (done nil)) - (while (and param-list (not done)) - (if (and (string-match name-regexp (car param-list)) - (= (match-end 0) match-end)) - (setq done t) - (setq param-list (cdr param-list)))) - (and (car param-list) (car (vm-parse (car param-list) "=\\(.*\\)"))))) - -(defun vm-mime-get-parameter (layout name) - (vm-mime-get-xxx-parameter layout name (cdr (vm-mm-layout-type layout)))) - -(defun vm-mime-get-disposition-parameter (layout name) - (vm-mime-get-xxx-parameter layout name - (cdr (vm-mm-layout-disposition layout)))) - -(defun vm-mime-insert-mime-body (layout) - (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout)) - (vm-mm-layout-body-start layout) - (vm-mm-layout-body-end layout))) - -(defun vm-mime-insert-mime-headers (layout) - (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout)) - (vm-mm-layout-header-start layout) - (vm-mm-layout-body-start layout)) - (if (and (not (bobp)) (char-equal (char-after (1- (point))) ?\n)) - (delete-char -1))) - -(defun vm-make-presentation-copy (m) - (let ((mail-buffer (current-buffer)) - b mm - (real-m (vm-real-message-of m)) - (modified (buffer-modified-p))) - (cond ((or (null vm-presentation-buffer-handle) - (null (buffer-name vm-presentation-buffer-handle))) - (setq b (generate-new-buffer (concat (buffer-name) - " Presentation"))) - (save-excursion - (set-buffer b) - (if (fboundp 'buffer-disable-undo) - (buffer-disable-undo (current-buffer)) - ;; obfuscation to make the v19 compiler not whine - ;; about obsolete functions. - (let ((x 'buffer-flush-undo)) - (funcall x (current-buffer)))) - (setq mode-name "VM Presentation" - major-mode 'vm-presentation-mode - vm-message-pointer (list nil) - vm-mail-buffer mail-buffer - mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 - (vm-menu-support-possible-p) - (vm-menu-mode-menu)) - ;; Default to binary file type for DOS/NT. - buffer-file-type t - ;; Tell XEmacs/MULE not to mess with the text on writes. - buffer-read-only t - mode-line-format vm-mode-line-format) - ;; scroll in place messes with scroll-up and this loses - (defvar scroll-in-place) - (make-local-variable 'scroll-in-place) - (setq scroll-in-place nil) - (and vm-xemacs-mule-p - (set-buffer-file-coding-system 'binary t)) - (cond (vm-fsfemacs-19-p - ;; need to do this outside the let because - ;; loading disp-table initializes - ;; standard-display-table. - (require 'disp-table) - (let* ((standard-display-table - (copy-sequence standard-display-table))) - (standard-display-european t) - (setq buffer-display-table standard-display-table)))) - (if (and vm-mutable-frames vm-frame-per-folder - (vm-multiple-frames-possible-p)) - (vm-set-hooks-for-frame-deletion)) - (use-local-map vm-mode-map) - (and (vm-toolbar-support-possible-p) vm-use-toolbar - (vm-toolbar-install-toolbar)) - (and (vm-menu-support-possible-p) - (vm-menu-install-menus)) - (run-hooks 'vm-presentation-mode-hook)) - (setq vm-presentation-buffer-handle b))) - (setq b vm-presentation-buffer-handle - vm-presentation-buffer vm-presentation-buffer-handle - vm-mime-decoded nil) - (save-excursion - (set-buffer (vm-buffer-of real-m)) - (save-restriction - (widen) - ;; must reference this now so that headers will be in - ;; their final position before the message is copied. - ;; otherwise the vheader offset computed below will be - ;; wrong. - (vm-vheaders-of real-m) - (set-buffer b) - (widen) - (let ((buffer-read-only nil) - ;; disable read-only text properties - (inhibit-read-only t) - (modified (buffer-modified-p))) - (unwind-protect - (progn - (erase-buffer) - (insert-buffer-substring (vm-buffer-of real-m) - (vm-start-of real-m) - (vm-end-of real-m))) - (set-buffer-modified-p modified))) - (setq mm (copy-sequence m)) - (vm-set-location-data-of mm (vm-copy (vm-location-data-of m))) - (set-marker (vm-start-of mm) (point-min)) - (set-marker (vm-headers-of mm) (+ (vm-start-of mm) - (- (vm-headers-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-vheaders-of mm) (+ (vm-start-of mm) - (- (vm-vheaders-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-text-of mm) (+ (vm-start-of mm) - (- (vm-text-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-text-end-of mm) (+ (vm-start-of mm) - (- (vm-text-end-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-end-of mm) (+ (vm-start-of mm) - (- (vm-end-of real-m) - (vm-start-of real-m)))) - (setcar vm-message-pointer mm))))) - -(fset 'vm-presentation-mode 'vm-mode) -(put 'vm-presentation-mode 'mode-class 'special) - -(defvar buffer-file-coding-system) - -(defun vm-determine-proper-charset (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (catch 'done - (goto-char (point-min)) - (if vm-xemacs-mule-p - (let ((charsets (delq 'ascii (charsets-in-region beg end)))) - (cond ((null charsets) - "us-ascii") - ((cdr charsets) - (or (car (cdr - (assq (coding-system-name - buffer-file-coding-system) - vm-mime-mule-coding-to-charset-alist))) - "iso-2022-jp")) - (t - (or (car (cdr - (assoc - (car charsets) - vm-mime-mule-charset-to-charset-alist))) - "unknown")))) - (and (re-search-forward "[^\000-\177]" nil t) - (throw 'done (or vm-mime-8bit-composition-charset - "iso-8859-1"))) - (throw 'done "us-ascii")))))) - -(defun vm-determine-proper-content-transfer-encoding (beg end) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (catch 'done - (goto-char (point-min)) - (and (re-search-forward "[\000\015]" nil t) - (throw 'done "binary")) - - (let ((toolong nil) bol) - (goto-char (point-min)) - (setq bol (point)) - (while (and (not (eobp)) (not toolong)) - (forward-line) - (setq toolong (> (- (point) bol) 998) - bol (point))) - (and toolong (throw 'done "binary"))) - - (goto-char (point-min)) - (and (re-search-forward "[\200-\377]" nil t) - (throw 'done "8bit")) - - "7bit")))) - -(defun vm-mime-types-match (type type/subtype) - (let ((case-fold-search t)) - (cond ((string-match "/" type) - (if (and (string-match (regexp-quote type) type/subtype) - (equal 0 (match-beginning 0)) - (equal (length type/subtype) (match-end 0))) - t - nil )) - ((and (string-match (regexp-quote type) type/subtype) - (equal 0 (match-beginning 0)) - (equal (save-match-data - (string-match "/" type/subtype (match-end 0))) - (match-end 0))))))) - -(defvar native-sound-only-on-console) - -(defun vm-mime-can-display-internal (layout) - (let ((type (car (vm-mm-layout-type layout)))) - (cond ((vm-mime-types-match "image/jpeg" type) - (and vm-xemacs-p - (featurep 'jpeg) - (eq (device-type) 'x))) - ((vm-mime-types-match "image/gif" type) - (and vm-xemacs-p - (featurep 'gif) - (eq (device-type) 'x))) - ((vm-mime-types-match "image/png" type) - (and vm-xemacs-p - (featurep 'png) - (eq (device-type) 'x))) - ((vm-mime-types-match "image/tiff" type) - (and vm-xemacs-p - (featurep 'tiff) - (eq (device-type) 'x))) - ((vm-mime-types-match "audio/basic" type) - (and vm-xemacs-p - (or (featurep 'native-sound) - (featurep 'nas-sound)) - (or (device-sound-enabled-p) - (and (featurep 'native-sound) - (not native-sound-only-on-console) - (eq (device-type) 'x))))) - ((vm-mime-types-match "multipart" type) t) - ((vm-mime-types-match "message/external-body" type) nil) - ((vm-mime-types-match "message" type) t) - ((or (vm-mime-types-match "text/plain" type) - (vm-mime-types-match "text/enriched" type)) - (let ((charset (or (vm-mime-get-parameter layout "charset") - "us-ascii"))) - (vm-mime-charset-internally-displayable-p charset))) - ((vm-mime-types-match "text/html" type) - (condition-case () - (progn (require 'w3) - (fboundp 'w3-region)) - (error nil))) - (t nil)))) - -(defun vm-mime-can-convert (type) - (let ((alist vm-mime-type-converter-alist) - ;; fake layout. make it the wrong length so an error will - ;; be signaled if vm-mime-can-display-internal ever asks - ;; for one of the other fields - (fake-layout (make-vector 1 (list nil))) - (done nil)) - (while (and alist (not done)) - (cond ((and (vm-mime-types-match (car (car alist)) type) - (or (progn - (setcar (aref fake-layout 0) (nth 1 (car alist))) - (vm-mime-can-display-internal fake-layout)) - (vm-mime-find-external-viewer (nth 1 (car alist))))) - (setq done t)) - (t (setq alist (cdr alist))))) - (and alist (car alist)))) - -(defun vm-mime-convert-undisplayable-layout (layout) - (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout))))) - (message "Converting %s to %s..." - (car (vm-mm-layout-type layout)) - (nth 1 ooo)) - (save-excursion - (set-buffer (generate-new-buffer " *mime object*")) - (setq vm-message-garbage-alist - (cons (cons (current-buffer) 'kill-buffer) - vm-message-garbage-alist)) - (vm-mime-insert-mime-body layout) - (vm-mime-transfer-decode-region layout (point-min) (point-max)) - (call-process-region (point-min) (point-max) shell-file-name - t t nil shell-command-switch (nth 2 ooo)) - (goto-char (point-min)) - (insert "Content-Type: " (nth 1 ooo) "\n") - (insert "Content-Transfer-Encoding: binary\n\n") - (set-buffer-modified-p nil) - (message "Converting %s to %s... done" - (car (vm-mm-layout-type layout)) - (nth 1 ooo)) - (vector (list (nth 1 ooo)) - (list (nth 1 ooo)) - "binary" - (vm-mm-layout-id layout) - (vm-mm-layout-description layout) - (vm-mm-layout-disposition layout) - (vm-mm-layout-qdisposition layout) - (vm-marker (point-min)) - (vm-marker (point)) - (vm-marker (point-max)) - nil - nil - nil)))) - -(defun vm-mime-should-display-button (layout dont-honor-content-disposition) - (if (and vm-honor-mime-content-disposition - (not dont-honor-content-disposition) - (vm-mm-layout-disposition layout)) - (let ((case-fold-search t)) - (string-match "^attachment$" (car (vm-mm-layout-disposition layout)))) - (let ((i-list vm-auto-displayed-mime-content-types) - (type (car (vm-mm-layout-type layout))) - (matched nil)) - (if (eq i-list t) - nil - (while (and i-list (not matched)) - (if (vm-mime-types-match (car i-list) type) - (setq matched t) - (setq i-list (cdr i-list)))) - (not matched) )))) - -(defun vm-mime-should-display-internal (layout dont-honor-content-disposition) - (if (and vm-honor-mime-content-disposition - (not dont-honor-content-disposition) - (vm-mm-layout-disposition layout)) - (let ((case-fold-search t)) - (string-match "^inline$" (car (vm-mm-layout-disposition layout)))) - (let ((i-list vm-mime-internal-content-types) - (type (car (vm-mm-layout-type layout))) - (matched nil)) - (if (eq i-list t) - t - (while (and i-list (not matched)) - (if (vm-mime-types-match (car i-list) type) - (setq matched t) - (setq i-list (cdr i-list)))) - matched )))) - -(defun vm-mime-find-external-viewer (type) - (let ((e-alist vm-mime-external-content-types-alist) - (matched nil)) - (while (and e-alist (not matched)) - (if (and (vm-mime-types-match (car (car e-alist)) type) - (cdr (car e-alist))) - (setq matched (cdr (car e-alist))) - (setq e-alist (cdr e-alist)))) - matched )) -(fset 'vm-mime-should-display-external 'vm-mime-find-external-viewer) - -(defun vm-mime-delete-button-maybe (extent) - (let ((buffer-read-only)) - ;; if displayed MIME object should replace the button - ;; remove the button now. - (cond ((vm-extent-property extent 'vm-mime-disposable) - (delete-region (vm-extent-start-position extent) - (vm-extent-end-position extent)) - (vm-detach-extent extent))))) - -(defun vm-decode-mime-message () - "Decode the MIME objects in the current message. - -The first time this command is run on a message, decoding is done. -The second time, buttons for all the objects are displayed instead. -The third time, the raw, undecoded data is displayed. - -If decoding, the decoded objects might be displayed immediately, or -buttons might be displayed that you need to activate to view the -object. See the documentation for the variables - - vm-auto-displayed-mime-content-types - vm-mime-internal-content-types - vm-mime-external-content-types-alist - -to see how to control whether you see buttons or objects. - -If the variable vm-mime-display-function is set, then its value -is called as a function with no arguments, and none of the -actions mentioned in the preceding paragraphs are done. At the -time of the call, the current buffer will be the presentation -buffer for the folder and a copy of the current message will be -in the buffer. The function is expected to make the message -`MIME presentable' to the user in whatever manner it sees fit." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-empty) - (if (and (not vm-display-using-mime) - (null vm-mime-display-function)) - (error "MIME display disabled, set vm-display-using-mime non-nil to enable.")) - (if vm-mime-display-function - (progn - (vm-make-presentation-copy (car vm-message-pointer)) - (set-buffer vm-presentation-buffer) - (funcall vm-mime-display-function)) - (if vm-mime-decoded - (if (eq vm-mime-decoded 'decoded) - (let ((vm-preview-read-messages nil) - (vm-auto-decode-mime-messages t) - (vm-honor-mime-content-disposition nil) - (vm-auto-displayed-mime-content-types '("multipart"))) - (setq vm-mime-decoded nil) - (intern (buffer-name) vm-buffers-needing-display-update) - (save-excursion - (vm-preview-current-message)) - (setq vm-mime-decoded 'buttons)) - (let ((vm-preview-read-messages nil) - (vm-auto-decode-mime-messages nil)) - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-preview-current-message))) - (let ((layout (vm-mm-layout (car vm-message-pointer))) - (m (car vm-message-pointer))) - (message "Decoding MIME message...") - (cond ((stringp layout) - (error "Invalid MIME message: %s" layout))) - (if (vm-mime-plain-message-p m) - (error "Message needs no decoding.")) - (or vm-presentation-buffer - ;; maybe user killed it - (error "No presentation buffer.")) - (set-buffer vm-presentation-buffer) - (if (and (interactive-p) (eq vm-system-state 'previewing)) - (let ((vm-display-using-mime nil)) - (vm-show-current-message))) - (setq m (car vm-message-pointer)) - (vm-save-restriction - (widen) - (goto-char (vm-text-of m)) - (let ((buffer-read-only nil) - (modified (buffer-modified-p))) - (unwind-protect - (save-excursion - (and (not (eq (vm-mm-encoded-header m) 'none)) - (vm-decode-mime-message-headers m)) - (if (vectorp layout) - (progn - (vm-decode-mime-layout layout) - (delete-region (point) (point-max)))) - (vm-energize-urls) - (vm-highlight-headers-maybe) - (vm-energize-headers-and-xfaces)) - (set-buffer-modified-p modified)))) - (save-excursion (set-buffer vm-mail-buffer) - (setq vm-mime-decoded 'decoded)) - (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line) - (message "Decoding MIME message... done")))) - (vm-display nil nil '(vm-decode-mime-message) - '(vm-decode-mime-message reading-message))) - -(defun vm-decode-mime-layout (layout &optional dont-honor-c-d) - (let ((modified (buffer-modified-p)) type type-no-subtype (extent nil)) - (unwind-protect - (progn - (if (not (vectorp layout)) - (progn - (setq extent layout - layout (vm-extent-property extent 'vm-mime-layout)) - (goto-char (vm-extent-start-position extent)))) - (setq type (downcase (car (vm-mm-layout-type layout))) - type-no-subtype (car (vm-parse type "\\([^/]+\\)"))) - (cond ((and (vm-mime-should-display-button layout dont-honor-c-d) - (or (condition-case nil - (funcall (intern - (concat "vm-mime-display-button-" - type)) - layout) - (void-function nil)) - (condition-case nil - (funcall (intern - (concat "vm-mime-display-button-" - type-no-subtype)) - layout) - (void-function nil))))) - ((and (vm-mime-should-display-internal layout dont-honor-c-d) - (condition-case nil - (funcall (intern - (concat "vm-mime-display-internal-" - type)) - layout) - (void-function nil)))) - ((vm-mime-types-match "multipart" type) - (or (condition-case nil - (funcall (intern - (concat "vm-mime-display-internal-" - type)) - layout) - (void-function nil)) - (vm-mime-display-internal-multipart/mixed layout))) - ((and (vm-mime-should-display-external type) - (vm-mime-display-external-generic layout)) - (and extent (vm-set-extent-property - extent 'vm-mime-disposable nil))) - ((vm-mime-can-convert type) - (vm-decode-mime-layout - (vm-mime-convert-undisplayable-layout layout))) - ((and (or (vm-mime-types-match "message" type) - (vm-mime-types-match "text" type)) - ;; display unmatched message and text types as - ;; text/plain. - (vm-mime-display-internal-text/plain layout))) - (t (and extent (vm-mime-rewrite-failed-button - extent - (or (vm-mm-layout-display-error layout) - "no external viewer defined for type"))) - (vm-mime-display-internal-application/octet-stream - (or extent layout)))) - (and extent (vm-mime-delete-button-maybe extent))) - (set-buffer-modified-p modified))) - t ) - -(defun vm-mime-display-button-text (layout) - (vm-mime-display-button-xxxx layout t)) - -(defun vm-mime-display-internal-text/html (layout) - (if (fboundp 'w3-region) - (let ((buffer-read-only nil) - (work-buffer nil)) - (message "Inlining text/html, be patient...") - ;; w3-region is not as tame as we would like. - ;; make sure the yoke is firmly attached. - (unwind-protect - (progn - (save-excursion - (set-buffer (setq work-buffer - (generate-new-buffer " *workbuf*"))) - (vm-mime-insert-mime-body layout) - (vm-mime-transfer-decode-region layout (point-min) (point-max)) - (save-excursion - (save-window-excursion - (w3-region (point-min) (point-max))))) - (insert-buffer-substring work-buffer)) - (and work-buffer (kill-buffer work-buffer))) - (message "Inlining text/html... done") - t ) - (vm-set-mm-layout-display-error layout "Need W3 to inline HTML") - nil )) - -(defun vm-mime-display-internal-text/plain (layout &optional no-highlighting) - (let ((start (point)) end old-size - (buffer-read-only nil) - (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) - (if (not (vm-mime-charset-internally-displayable-p charset)) - (progn - (vm-set-mm-layout-display-error - layout (concat "Undisplayable charset: " charset)) - nil) - (vm-mime-insert-mime-body layout) - (setq end (point-marker)) - (vm-mime-transfer-decode-region layout start end) - (setq old-size (buffer-size)) - (vm-mime-charset-decode-region charset start end) - (set-marker end (+ end (- (buffer-size) old-size))) - (or no-highlighting (vm-energize-urls-in-message-region start end)) - (goto-char end) - t ))) - -(defun vm-mime-display-internal-text/enriched (layout) - (require 'enriched) - (let ((start (point)) end - (buffer-read-only nil) - (enriched-verbose t)) - (message "Decoding text/enriched, be patient...") - (vm-mime-insert-mime-body layout) - (setq end (point-marker)) - (vm-mime-transfer-decode-region layout start end) - ;; enriched-decode expects a couple of headers at the top of - ;; the region and will remove anything that looks like a - ;; header. Put a header section here for it to eat so it - ;; won't eat message text instead. - (goto-char start) - (insert "Comment: You should not see this header\n\n") - (enriched-decode start end) - (vm-energize-urls-in-message-region start end) - (goto-char end) - (message "Decoding text/enriched... done") - t )) - -(defun vm-mime-display-external-generic (layout) - (let ((program-list (vm-mime-find-external-viewer - (car (vm-mm-layout-type layout)))) - (buffer-read-only nil) - (start (point)) - process tempfile cache end) - (setq cache (cdr (assq 'vm-mime-display-external-generic - (vm-mm-layout-cache layout))) - process (nth 0 cache) - tempfile (nth 1 cache)) - (if (and (processp process) (eq (process-status process) 'run)) - t - (cond ((or (null tempfile) (null (file-exists-p tempfile))) - (vm-mime-insert-mime-body layout) - (setq end (point-marker)) - (vm-mime-transfer-decode-region layout start end) - (setq tempfile (vm-make-tempfile-name)) - (let ((buffer-file-type buffer-file-type) - buffer-file-coding-system) - ;; Tell DOS/Windows NT whether the file is binary - (setq buffer-file-type (not (vm-mime-text-type-p layout))) - ;; Tell XEmacs/MULE not to mess with the bits unless - ;; this is a text type. - (if vm-xemacs-mule-p - (if (vm-mime-text-type-p layout) - (set-buffer-file-coding-system 'no-conversion nil) - (set-buffer-file-coding-system 'binary t))) - ;; Write an empty tempfile out to disk and set its - ;; permissions to 0600, then write the actual buffer - ;; contents to tempfile. - (write-region start start tempfile nil 0) - (set-file-modes tempfile 384) - (write-region start end tempfile nil 0)) - (delete-region start end) - (save-excursion - (vm-select-folder-buffer) - (setq vm-folder-garbage-alist - (cons (cons tempfile 'delete-file) - vm-folder-garbage-alist))))) - (message "Launching %s..." (mapconcat 'identity program-list " ")) - (setq process - (apply 'start-process - (format "view %25s" (vm-mime-layout-description layout)) - nil (append program-list (list tempfile)))) - (process-kill-without-query process t) - (message "Launching %s... done" (mapconcat 'identity - program-list - " ")) - (save-excursion - (vm-select-folder-buffer) - (setq vm-message-garbage-alist - (cons (cons process 'delete-process) - vm-message-garbage-alist))) - (vm-set-mm-layout-cache - layout - (nconc (vm-mm-layout-cache layout) - (list (cons 'vm-mime-display-external-generic - (list process tempfile))))))) - t ) - -(defun vm-mime-display-internal-application/octet-stream (layout) - (if (vectorp layout) - (let ((buffer-read-only nil) - (description (vm-mm-layout-description layout))) - (vm-mime-insert-button - (format "%-35.35s [%s to save to a file]" - (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-here-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (vm-mime-display-internal-application/octet-stream layout)))) - layout nil)) - (goto-char (vm-extent-start-position layout)) - (setq layout (vm-extent-property layout 'vm-mime-layout)) - ;; support old "name" paramater for application/octet-stream - ;; but don't override the "filename" parameter extracted from - ;; Content-Disposition, if any. - (let ((default-filename - (if (vm-mime-get-disposition-parameter layout "filename") - nil - (vm-mime-get-parameter layout "name")))) - (vm-mime-send-body-to-file layout default-filename))) - t ) -(fset 'vm-mime-display-button-application/octet-stream - 'vm-mime-display-internal-application/octet-stream) - -(defun vm-mime-display-button-application (layout) - (vm-mime-display-button-xxxx layout nil)) - -(defun vm-mime-display-button-image (layout) - (vm-mime-display-button-xxxx layout t)) - -(defun vm-mime-display-button-audio (layout) - (vm-mime-display-button-xxxx layout nil)) - -(defun vm-mime-display-button-video (layout) - (vm-mime-display-button-xxxx layout t)) - -(defun vm-mime-display-button-message (layout) - (vm-mime-display-button-xxxx layout t)) - -(defun vm-mime-display-button-multipart (layout) - (vm-mime-display-button-xxxx layout t)) - -(defun vm-mime-display-internal-multipart/mixed (layout) - (let ((part-list (vm-mm-layout-parts layout))) - (while part-list - (vm-decode-mime-layout (car part-list)) - (setq part-list (cdr part-list))) - t )) - -(defun vm-mime-display-internal-multipart/alternative (layout) - (let (best-layout) - (cond ((eq vm-mime-alternative-select-method 'best) - (let ((done nil) - (best nil) - part-list type) - (setq part-list (vm-mm-layout-parts layout) - part-list (nreverse (copy-sequence part-list))) - (while (and part-list (not done)) - (setq type (car (vm-mm-layout-type (car part-list)))) - (if (or (vm-mime-can-display-internal (car part-list)) - (vm-mime-find-external-viewer type)) - (setq best (car part-list) - done t) - (setq part-list (cdr part-list)))) - (setq best-layout (or best (car (vm-mm-layout-parts layout)))))) - ((eq vm-mime-alternative-select-method 'best-internal) - (let ((done nil) - (best nil) - (second-best nil) - part-list type) - (setq part-list (vm-mm-layout-parts layout) - part-list (nreverse (copy-sequence part-list))) - (while (and part-list (not done)) - (setq type (car (vm-mm-layout-type (car part-list)))) - (cond ((vm-mime-can-display-internal (car part-list)) - (setq best (car part-list) - done t)) - ((and (null second-best) - (vm-mime-find-external-viewer type)) - (setq second-best (car part-list)))) - (setq part-list (cdr part-list))) - (setq best-layout (or best second-best - (car (vm-mm-layout-parts layout))))))) - (vm-decode-mime-layout best-layout))) - -(defun vm-mime-display-button-multipart/parallel (layout) - (vm-mime-insert-button - (format "%-35.35s [%s to display in parallel]" - (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-here-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (let ((vm-auto-displayed-mime-content-types t)) - (vm-decode-mime-layout layout t))))) - layout t)) - -(fset 'vm-mime-display-internal-multipart/parallel - 'vm-mime-display-internal-multipart/mixed) - -(defun vm-mime-display-internal-multipart/digest (layout) - (if (vectorp layout) - (let ((buffer-read-only nil)) - (vm-mime-insert-button - (format "%-35.35s [%s to display]" - (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-here-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (vm-mime-display-internal-multipart/digest layout)))) - layout nil)) - (goto-char (vm-extent-start-position layout)) - (setq layout (vm-extent-property layout 'vm-mime-layout)) - (set-buffer (generate-new-buffer (format "digest from %s/%s" - (buffer-name vm-mail-buffer) - (vm-number-of - (car vm-message-pointer))))) - (setq vm-folder-type vm-default-folder-type) - (vm-mime-burst-layout layout nil) - (vm-save-buffer-excursion - (vm-goto-new-folder-frame-maybe 'folder) - (vm-mode)) - ;; temp buffer, don't offer to save it. - (setq buffer-offer-save nil) - (vm-display (or vm-presentation-buffer (current-buffer)) t - (list this-command) '(vm-mode startup))) - t ) -(fset 'vm-mime-display-button-multipart/digest - 'vm-mime-display-internal-multipart/digest) - -(defun vm-mime-display-button-message/rfc822 (layout) - (let ((buffer-read-only nil)) - (vm-mime-insert-button - (format "%-35.35s [%s to display]" - (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-here-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (vm-mime-display-internal-message/rfc822 layout)))) - layout nil))) -(fset 'vm-mime-display-button-message/news - 'vm-mime-display-button-message/rfc822) - -(defun vm-mime-display-internal-message/rfc822 (layout) - (if (vectorp layout) - (let ((start (point)) - (buffer-read-only nil)) - (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout))) - (insert ?\n) - (save-excursion - (goto-char start) - (vm-reorder-message-headers nil vm-visible-headers - vm-invisible-header-regexp)) - (save-restriction - (narrow-to-region start (point)) - (vm-decode-mime-encoded-words)) - (vm-mime-display-internal-multipart/mixed layout)) - (goto-char (vm-extent-start-position layout)) - (setq layout (vm-extent-property layout 'vm-mime-layout)) - (set-buffer (generate-new-buffer - (format "message from %s/%s" - (buffer-name vm-mail-buffer) - (vm-number-of - (car vm-message-pointer))))) - (setq vm-folder-type vm-default-folder-type) - (vm-mime-burst-layout layout nil) - (set-buffer-modified-p nil) - (vm-save-buffer-excursion - (vm-goto-new-folder-frame-maybe 'folder) - (vm-mode)) - ;; temp buffer, don't offer to save it. - (setq buffer-offer-save nil) - (vm-display (or vm-presentation-buffer (current-buffer)) t - (list this-command) '(vm-mode startup))) - t ) -(fset 'vm-mime-display-internal-message/news - 'vm-mime-display-internal-message/rfc822) - -(defun vm-mime-display-internal-message/partial (layout) - (if (vectorp layout) - (let ((buffer-read-only nil) - (number (vm-mime-get-parameter layout "number")) - (total (vm-mime-get-parameter layout "total"))) - (vm-mime-insert-button - (format "%-35.35s [%s to attempt assembly]" - (concat (vm-mime-layout-description layout) - (and number (concat ", part " number)) - (and number total (concat " of " total))) - (if (vm-mouse-support-possible-here-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (vm-mime-display-internal-message/partial layout)))) - layout nil)) - (message "Assembling message...") - (let ((parts nil) - (missing nil) - (work-buffer nil) - extent id o number total m i prev part-header-pos - p-id p-number p-total p-list) - (setq extent layout - layout (vm-extent-property extent 'vm-mime-layout) - id (vm-mime-get-parameter layout "id")) - (if (null id) - (vm-mime-error - "message/partial message missing id parameter")) - (save-excursion - (set-buffer (marker-buffer (vm-mm-layout-body-start layout))) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (and (search-forward id nil t) - (setq m (vm-message-at-point))) - (setq o (vm-mm-layout m)) - (if (not (vectorp o)) - nil - (setq p-list (vm-mime-find-message/partials o id)) - (while p-list - (setq p-id (vm-mime-get-parameter (car p-list) "id")) - (setq p-total (vm-mime-get-parameter (car p-list) "total")) - (if (null p-total) - nil - (setq p-total (string-to-int p-total)) - (if (< p-total 1) - (vm-mime-error "message/partial specified part total < 0, %d" p-total)) - (if total - (if (not (= total p-total)) - (vm-mime-error "message/partial speificed total differs between parts, (%d != %d)" p-total total)) - (setq total p-total))) - (setq p-number (vm-mime-get-parameter (car p-list) "number")) - (if (null p-number) - (vm-mime-error - "message/partial message missing number parameter")) - (setq p-number (string-to-int p-number)) - (if (< p-number 1) - (vm-mime-error "message/partial part number < 0, %d" - p-number)) - (if (and total (> p-number total)) - (vm-mime-error "message/partial part number greater than expected number of parts, (%d > %d)" p-number total)) - (setq parts (cons (list p-number (car p-list)) parts) - p-list (cdr p-list)))) - (goto-char (vm-mm-layout-body-end o)))))) - (if (null total) - (vm-mime-error "total number of parts not specified in any message/partial part")) - (setq parts (sort parts - (function - (lambda (p q) - (< (car p) - (car q)))))) - (setq i 0 - p-list parts) - (while p-list - (cond ((< i (car (car p-list))) - (vm-increment i) - (cond ((not (= i (car (car p-list)))) - (setq missing (cons i missing))) - (t (setq prev p-list - p-list (cdr p-list))))) - (t - ;; remove duplicate part - (setcdr prev (cdr p-list)) - (setq p-list (cdr p-list))))) - (while (< i total) - (vm-increment i) - (setq missing (cons i missing))) - (if missing - (vm-mime-error "part%s %s%s missing" - (if (cdr missing) "s" "") - (mapconcat - (function identity) - (nreverse (mapcar 'int-to-string - (or (cdr missing) missing))) - ", ") - (if (cdr missing) - (concat " and " (car missing)) - ""))) - (set-buffer (generate-new-buffer "assembled message")) - (setq vm-folder-type vm-default-folder-type) - (vm-mime-insert-mime-headers (car (cdr (car parts)))) - (goto-char (point-min)) - (vm-reorder-message-headers - nil nil -"\\(Encrypted\\|Content-\\|MIME-Version\\|Message-ID\\|Subject\\|X-VM-\\|Status\\)") - (goto-char (point-max)) - (setq part-header-pos (point)) - (while parts - (vm-mime-insert-mime-body (car (cdr (car parts)))) - (setq parts (cdr parts))) - (goto-char part-header-pos) - (vm-reorder-message-headers - nil '("Subject" "MIME-Version" "Content-" "Message-ID" "Encrypted") nil) - (vm-munge-message-separators vm-folder-type (point-min) (point-max)) - (goto-char (point-min)) - (insert (vm-leading-message-separator)) - (goto-char (point-max)) - (insert (vm-trailing-message-separator)) - (set-buffer-modified-p nil) - (message "Assembling message... done") - (vm-save-buffer-excursion - (vm-goto-new-folder-frame-maybe 'folder) - (vm-mode)) - ;; temp buffer, don't offer to save it. - (setq buffer-offer-save nil) - (vm-display (or vm-presentation-buffer (current-buffer)) t - (list this-command) '(vm-mode startup))) - t )) -(fset 'vm-mime-display-button-message/partial - 'vm-mime-display-internal-message/partial) - -(defun vm-mime-display-internal-image-xxxx (layout feature name) - (if (and vm-xemacs-p - (featurep feature) - (eq (device-type) 'x)) - (let ((start (point)) end tempfile g e - (buffer-read-only nil)) - (if (setq g (cdr (assq 'vm-mime-display-internal-image-xxxx - (vm-mm-layout-cache layout)))) - nil - (vm-mime-insert-mime-body layout) - (setq end (point-marker)) - (vm-mime-transfer-decode-region layout start end) - (setq tempfile (vm-make-tempfile-name)) - ;; Write an empty tempfile out to disk and set its - ;; permissions to 0600, then write the actual buffer - ;; contents to tempfile. - (write-region start start tempfile nil 0) - (set-file-modes tempfile 384) - ;; coding system for presentation buffer is binary so - ;; we don't need to set it here. - (write-region start end tempfile nil 0) - (message "Creating %s glyph..." name) - (setq g (make-glyph - (list - (cons (list 'win) - (vector feature ':file tempfile)) - (cons (list 'win) - (vector 'string - ':data - (format "[Unknown/Bad %s image encoding]\n" - name))) - (cons nil - (vector 'string - ':data - (format "[%s image]\n" name)))))) - (message "") - (vm-set-mm-layout-cache - layout - (nconc (vm-mm-layout-cache layout) - (list (cons 'vm-mime-display-internal-image-xxxx g)))) - (save-excursion - (vm-select-folder-buffer) - (setq vm-folder-garbage-alist - (cons (cons tempfile 'delete-file) - vm-folder-garbage-alist))) - (delete-region start end)) - (if (not (bolp)) - (insert-char ?\n 2) - (insert-char ?\n 1)) - (setq e (vm-make-extent (1- (point)) (point))) - (vm-set-extent-property e 'begin-glyph g) - t ))) - -(defun vm-mime-display-internal-image/gif (layout) - (vm-mime-display-internal-image-xxxx layout 'gif "GIF")) - -(defun vm-mime-display-internal-image/jpeg (layout) - (vm-mime-display-internal-image-xxxx layout 'jpeg "JPEG")) - -(defun vm-mime-display-internal-image/png (layout) - (vm-mime-display-internal-image-xxxx layout 'png "PNG")) - -(defun vm-mime-display-internal-image/tiff (layout) - (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF")) - -(defun vm-mime-display-internal-audio/basic (layout) - (if (and vm-xemacs-p - (or (featurep 'native-sound) - (featurep 'nas-sound)) - (or (device-sound-enabled-p) - (and (featurep 'native-sound) - (not native-sound-only-on-console) - (eq (device-type) 'x)))) - (let ((start (point)) end tempfile - (buffer-read-only nil)) - (if (setq tempfile (cdr (assq 'vm-mime-display-internal-audio/basic - (vm-mm-layout-cache layout)))) - nil - (vm-mime-insert-mime-body layout) - (setq end (point-marker)) - (vm-mime-transfer-decode-region layout start end) - (setq tempfile (vm-make-tempfile-name)) - ;; Write an empty tempfile out to disk and set its - ;; permissions to 0600, then write the actual buffer - ;; contents to tempfile. - (write-region start start tempfile nil 0) - (set-file-modes tempfile 384) - ;; coding system for presentation buffer is binary, so - ;; we don't need to set it here. - (write-region start end tempfile nil 0) - (vm-set-mm-layout-cache - layout - (nconc (vm-mm-layout-cache layout) - (list (cons 'vm-mime-display-internal-audio/basic - tempfile)))) - (save-excursion - (vm-select-folder-buffer) - (setq vm-folder-garbage-alist - (cons (cons tempfile 'delete-file) - vm-folder-garbage-alist))) - (delete-region start end)) - (start-itimer "audioplayer" - (list 'lambda nil (list 'play-sound-file tempfile)) - 1) - t ) - nil )) - -(defun vm-mime-display-button-xxxx (layout disposable) - (let ((description (vm-mime-layout-description layout))) - (vm-mime-insert-button - (format "%-35.35s [%s to attempt display]" - description - (if (vm-mouse-support-possible-here-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (let ((vm-auto-displayed-mime-content-types t)) - (vm-decode-mime-layout layout t))))) - layout disposable) - t )) - -(defun vm-mime-run-display-function-at-point (&optional function dispose) - (interactive) - ;; save excursion to keep point from moving. its motion would - ;; drag window point along, to a place arbitrarily far from - ;; where it was when the user triggered the button. - (save-excursion - (cond (vm-fsfemacs-19-p - (let (o-list o (found nil)) - (setq o-list (overlays-at (point))) - (while (and o-list (not found)) - (cond ((overlay-get (car o-list) 'vm-mime-layout) - (setq found t) - (funcall (or function (overlay-get (car o-list) - 'vm-mime-function)) - (car o-list)))) - (setq o-list (cdr o-list))))) - (vm-xemacs-p - (let ((e (extent-at (point) nil 'vm-mime-layout))) - (funcall (or function (extent-property e 'vm-mime-function)) - e)))))) - -;; for the karking compiler -(defvar vm-menu-mime-dispose-menu) - -(defun vm-mime-set-extent-glyph-for-type (e type) - (if (and vm-xemacs-p - (featurep 'xpm) - (eq (device-type) 'x) - (> (device-bitplanes) 7)) - (let ((dir vm-image-directory) - (colorful (> (device-bitplanes) 15)) - (tuples - '(("text" "document-simple.xpm" "document-colorful.xpm") - ("image" "mona_stamp-simple.xpm" "mona_stamp-colorful.xpm") - ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm") - ("video" "film-simple.xpm" "film-colorful.xpm") - ("message" "message-simple.xpm" "message-colorful.xpm") - ("application" "gear-simple.xpm" "gear-colorful.xpm") - ("multipart" "stuffed_box-simple.xpm" - "stuffed_box-colorful.xpm"))) - glyph file sym p) - (setq file (catch 'done - (while tuples - (if (vm-mime-types-match (car (car tuples)) type) - (throw 'done (car tuples)) - (setq tuples (cdr tuples)))) - nil) - file (and file (if colorful (nth 2 file) (nth 1 file))) - sym (and file (intern file vm-image-obarray)) - glyph (and sym (boundp sym) (symbol-value sym)) - glyph (or glyph - (and file - (make-glyph - (list - (vector 'xpm ':file - (expand-file-name file dir)) - [nothing]))))) - (and sym (not (boundp sym)) (set sym glyph)) - (and glyph (set-extent-begin-glyph e glyph))))) - -(defun vm-mime-insert-button (caption action layout disposable) - (let ((start (point)) e - (keymap (make-sparse-keymap)) - (buffer-read-only nil)) - (if (fboundp 'set-keymap-parents) - (if (current-local-map) - (set-keymap-parents keymap (list (current-local-map)))) - (setq keymap (nconc keymap (current-local-map)))) - (define-key keymap "\r" 'vm-mime-run-display-function-at-point) - (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3) - (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu)) - (if (not (bolp)) - (insert "\n")) - (insert caption "\n") - ;; we must use the same interface that the vm-extent functions - ;; use. if they use overlays, then we call make-overlay. - (if (eq (symbol-function 'vm-make-extent) 'make-overlay) - ;; we MUST have the five arg make-overlay. overlays must - ;; advance when text is inserted at their start position or - ;; inline text and graphics will seep into the button - ;; overlay and then be removed when the button is removed. - (setq e (make-overlay start (point) nil t nil)) - (setq e (make-extent start (point))) - (set-extent-property e 'start-open t) - (set-extent-property e 'end-open t)) - (vm-mime-set-extent-glyph-for-type e (car (vm-mm-layout-type layout))) - ;; for emacs - (vm-set-extent-property e 'mouse-face 'highlight) - (vm-set-extent-property e 'local-map keymap) - ;; for xemacs - (vm-set-extent-property e 'highlight t) - (vm-set-extent-property e 'keymap keymap) - (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help) - ;; for all - (vm-set-extent-property e 'vm-mime-disposable disposable) - (vm-set-extent-property e 'face vm-mime-button-face) - (vm-set-extent-property e 'vm-mime-layout layout) - (vm-set-extent-property e 'vm-mime-function action))) - -(defun vm-mime-rewrite-failed-button (button error-string) - (let* ((buffer-read-only nil) - (start (point))) - (goto-char (vm-extent-start-position button)) - (insert (format "DISPLAY FAILED -- %s\n" error-string)) - (vm-set-extent-endpoints button start (vm-extent-end-position button)) - (delete-region (point) (vm-extent-end-position button)))) - -(defun vm-mime-send-body-to-file (layout &optional default-filename) - (if (not (vectorp layout)) - (setq layout (vm-extent-property layout 'vm-mime-layout))) - (or default-filename - (setq default-filename - (vm-mime-get-disposition-parameter layout "filename"))) - (and default-filename - (setq default-filename (file-name-nondirectory default-filename))) - (let ((work-buffer nil) - ;; evade the XEmacs dialog box, yeccch. - (use-dialog-box nil) - (dir vm-mime-attachment-save-directory) - (done nil) - file) - (while (not done) - (setq file - (read-file-name - (if default-filename - (format "Write MIME body to file (default %s): " - default-filename) - "Write MIME body to file: ") - dir default-filename) - file (expand-file-name file dir)) - (if (not (file-directory-p file)) - (setq done t) - (if default-filename - (message "%s is a directory" file) - (error "%s is a directory" file)) - (sit-for 2) - (setq dir file - default-filename (if (string-match "/$" file) - (concat file default-filename) - (concat file "/" default-filename))))) - (save-excursion - (unwind-protect - (progn - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - ;; Tell DOS/Windows NT whether the file is binary - (setq buffer-file-type (not (vm-mime-text-type-p layout))) - ;; Tell XEmacs/MULE not to mess with the bits unless - ;; this is a text type. - (if vm-xemacs-mule-p - (if (vm-mime-text-type-p layout) - (set-buffer-file-coding-system 'no-conversion nil) - (set-buffer-file-coding-system 'binary t))) - (vm-mime-insert-mime-body layout) - (vm-mime-transfer-decode-region layout (point-min) (point-max)) - (or (not (file-exists-p file)) - (y-or-n-p "File exists, overwrite? ") - (error "Aborted")) - (write-region (point-min) (point-max) file nil nil)) - (and work-buffer (kill-buffer work-buffer)))))) - -(defun vm-mime-pipe-body-to-command (command layout &optional discard-output) - (if (not (vectorp layout)) - (setq layout (vm-extent-property layout 'vm-mime-layout))) - (let ((output-buffer (if discard-output - 0 - (get-buffer-create "*Shell Command Output*"))) - (work-buffer nil)) - (save-excursion - (if (bufferp output-buffer) - (progn - (set-buffer output-buffer) - (erase-buffer))) - (unwind-protect - (progn - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - (vm-mime-insert-mime-body layout) - (vm-mime-transfer-decode-region layout (point-min) (point-max)) - (let ((pop-up-windows (and pop-up-windows - (eq vm-mutable-windows t))) - ;; Tell DOS/Windows NT whether the input is binary - (binary-process-input (not (vm-mime-text-type-p layout)))) - (call-process-region (point-min) (point-max) - (or shell-file-name "sh") - nil output-buffer nil - shell-command-switch command))) - (and work-buffer (kill-buffer work-buffer))) - (if (bufferp output-buffer) - (progn - (set-buffer output-buffer) - (if (not (zerop (buffer-size))) - (vm-display output-buffer t (list this-command) - '(vm-pipe-message-to-command)) - (vm-display nil nil (list this-command) - '(vm-pipe-message-to-command))))))) - t ) - -(defun vm-mime-pipe-body-to-queried-command (layout &optional discard-output) - (let ((command (read-string "Pipe to command: "))) - (vm-mime-pipe-body-to-command command layout discard-output))) - -(defun vm-mime-pipe-body-to-queried-command-discard-output (layout) - (vm-mime-pipe-body-to-queried-command layout t)) - -(defun vm-mime-send-body-to-printer (layout) - (vm-mime-pipe-body-to-command (mapconcat (function identity) - (nconc (list vm-print-command) - vm-print-command-switches) - " ") - layout)) - -(defun vm-mime-display-body-as-text (button) - (let ((vm-auto-displayed-mime-content-types '("text/plain")) - (layout (copy-sequence (vm-extent-property button 'vm-mime-layout)))) - (vm-set-extent-property button 'vm-mime-disposable t) - (vm-set-extent-property button 'vm-mime-layout layout) - ;; not universally correct, but close enough. - (vm-set-mm-layout-type layout '("text/plain" "charset=us-ascii")) - (goto-char (vm-extent-start-position button)) - (vm-decode-mime-layout button t))) - -(defun vm-mime-display-body-using-external-viewer (button) - (let ((layout (vm-extent-property button 'vm-mime-layout))) - (goto-char (vm-extent-start-position button)) - (if (not (vm-mime-find-external-viewer (car (vm-mm-layout-type layout)))) - (error "No viewer defined for type %s" - (car (vm-mm-layout-type layout))) - (vm-mime-display-external-generic layout)))) - -(defun vm-mime-scrub-description (string) - (let ((work-buffer nil)) - (save-excursion - (unwind-protect - (progn - (setq work-buffer (generate-new-buffer " *vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - (insert string) - (while (re-search-forward "[ \t\n]+" nil t) - (replace-match " ")) - (buffer-string)) - (and work-buffer (kill-buffer work-buffer)))))) - -(defun vm-mime-layout-description (layout) - (let ((type (car (vm-mm-layout-type layout))) - description name) - (setq description - (if (vm-mm-layout-description layout) - (vm-mime-scrub-description (vm-mm-layout-description layout)))) - (concat - (if description description "") - (if description ", " "") - (cond ((vm-mime-types-match "multipart/digest" type) - (let ((n (length (vm-mm-layout-parts layout)))) - (format "digest (%d message%s)" n (if (= n 1) "" "s")))) - ((vm-mime-types-match "multipart/alternative" type) - "multipart alternative") - ((vm-mime-types-match "multipart" type) - (let ((n (length (vm-mm-layout-parts layout)))) - (format "multipart message (%d part%s)" n (if (= n 1) "" "s")))) - ((vm-mime-types-match "text/plain" type) - (format "plain text%s" - (let ((charset (vm-mime-get-parameter layout "charset"))) - (if charset - (concat ", " charset) - "")))) - ((vm-mime-types-match "text/enriched" type) - "enriched text") - ((vm-mime-types-match "text/html" type) - "HTML") - ((vm-mime-types-match "image/gif" type) - "GIF image") - ((vm-mime-types-match "image/jpeg" type) - "JPEG image") - ((and (vm-mime-types-match "application/octet-stream" type) - (setq name (vm-mime-get-parameter layout "name")) - (save-match-data (not (string-match "^[ \t]*$" name)))) - name) - (t type))))) - -(defun vm-mime-layout-contains-type (layout type) - (if (vm-mime-types-match type (car (vm-mm-layout-type layout))) - layout - (let ((p (vm-mm-layout-parts layout)) - (result nil) - (done nil)) - (while (and p (not done)) - (if (setq result (vm-mime-layout-contains-type (car p) type)) - (setq done t) - (setq p (cdr p)))) - result ))) - -;; breadth first traversal -(defun vm-mime-find-digests-in-layout (layout) - (let ((layout-list (list layout)) - layout-type - (result nil)) - (while layout-list - (setq layout-type (car (vm-mm-layout-type (car layout-list)))) - (cond ((string-match "^multipart/digest\\|message/\\(rfc822\\|news\\)" - layout-type) - (setq result (nconc result (list (car layout-list))))) - ((vm-mime-composite-type-p layout-type) - (setq layout-list (nconc layout-list - (copy-sequence - (vm-mm-layout-parts - (car layout-list))))))) - (setq layout-list (cdr layout-list))) - result )) - -(defun vm-mime-plain-message-p (m) - (save-match-data - (let ((o (vm-mm-layout m)) - (case-fold-search t)) - (and (eq (vm-mm-encoded-header m) 'none) - (or (not (vectorp o)) - (and (vm-mime-types-match "text/plain" - (car (vm-mm-layout-type o))) - (let* ((charset (or (vm-mime-get-parameter o "charset") - "us-ascii"))) - (vm-string-member charset vm-mime-default-face-charsets)) - (string-match "^\\(7bit\\|8bit\\|binary\\)$" - (vm-mm-layout-encoding o)))))))) - -(defun vm-mime-text-type-p (layout) - (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout))) - (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))) - -(defun vm-mime-charset-internally-displayable-p (name) - (cond ((and vm-xemacs-mule-p (eq (device-type) 'x)) - (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)) - ((vm-multiple-fonts-possible-p) - (or (vm-string-member name vm-mime-default-face-charsets) - (vm-string-assoc name vm-mime-charset-font-alist))) - (t - (vm-string-member name vm-mime-default-face-charsets)))) - -(defun vm-mime-find-message/partials (layout id) - (let ((list nil) - (type (vm-mm-layout-type layout))) - (cond ((vm-mime-types-match "multipart" (car type)) - (let ((parts (vm-mm-layout-parts layout)) o) - (while parts - (setq o (vm-mime-find-message/partials (car parts) id)) - (if o - (setq list (nconc o list))) - (setq parts (cdr parts))))) - ((vm-mime-types-match "message/partial" (car type)) - (if (equal (vm-mime-get-parameter layout "id") id) - (setq list (cons layout list))))) - list )) - -(defun vm-message-at-point () - (let ((mp vm-message-list) - (point (point)) - (done nil)) - (while (and mp (not done)) - (if (and (>= point (vm-start-of (car mp))) - (<= point (vm-end-of (car mp)))) - (setq done t) - (setq mp (cdr mp)))) - (car mp))) - -(defun vm-mime-make-multipart-boundary () - (let ((boundary (make-string 10 ?a)) - (i 0)) - (random t) - (while (< i (length boundary)) - (aset boundary i (aref vm-mime-base64-alphabet - (% (vm-abs (lsh (random) -8)) - (length vm-mime-base64-alphabet)))) - (vm-increment i)) - boundary )) - -(defun vm-mime-attach-file (file type &optional charset description) - "Attach a file to a VM composition buffer to be sent along with the message. -The file is not inserted into the buffer and MIME encoded until -you execute vm-mail-send or vm-mail-send-and-exit. A visible tag -indicating the existence of the attachment is placed in the -composition buffer. You can move the attachment around or remove -it entirely with normal text editing commands. If you remove the -attachment tag, the attachment will not be sent. - -First argument, FILE, is the name of the file to attach. Second -argument, TYPE, is the MIME Content-Type of the file. Optional -third argument CHARSET is the character set of the attached -document. This argument is only used for text types, and it is -ignored for other types. Optional fourth argument DESCRIPTION -should be a one line description of the file. - -When called interactively all arguments are read from the -minibuffer. - -This command is for attaching files that do not have a MIME -header section at the top. For files with MIME headers, you -should use vm-mime-attach-mime-file to attach such a file. VM -will extract the content type information from the headers in -this case and not prompt you for it in the minibuffer." - (interactive - ;; protect value of last-command and this-command - (let ((last-command last-command) - (this-command this-command) - (charset nil) - description file default-type type) - (if (null vm-send-using-mime) - (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) - (setq file (vm-read-file-name "Attach file: " nil nil t) - default-type (or (vm-mime-default-type-from-filename file) - "application/octet-stream") - type (completing-read - (format "Content type (default %s): " - default-type) - vm-mime-type-completion-alist) - type (if (> (length type) 0) type default-type)) - (if (vm-mime-types-match "text" type) - (setq charset (completing-read "Character set (default US-ASCII): " - vm-mime-charset-completion-alist) - charset (if (> (length charset) 0) charset))) - (setq description (read-string "One line description: ")) - (if (string-match "^[ \t]*$" description) - (setq description nil)) - (list file type charset description))) - (if (null vm-send-using-mime) - (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) - (if (file-directory-p file) - (error "%s is a directory, cannot attach" file)) - (if (not (file-exists-p file)) - (error "No such file: %s" file)) - (if (not (file-readable-p file)) - (error "You don't have permission to read %s" file)) - (and charset (setq charset (list (concat "charset=" charset)))) - (and description (setq description (vm-mime-scrub-description description))) - (vm-mime-attach-object file type charset description nil)) - -(defun vm-mime-attach-mime-file (file) - "Attach a MIME encoded file to a VM composition buffer to be sent -along with the message. - -The file is not inserted into the buffer until you execute -vm-mail-send or vm-mail-send-and-exit. A visible tag indicating -the existence of the attachment is placed in the composition -buffer. You can move the attachment around or remove it entirely -with normal text editing commands. If you remove the attachment -tag, the attachment will not be sent. - -The sole argument, FILE, is the name of the file to attach. -When called interactively the FILE argument is read from the -minibuffer. - -This command is for attaching files that have a MIME -header section at the top. For files without MIME headers, you -should use vm-mime-attach-file to attach such a file. VM -will interactively query you for the file type information." - (interactive - ;; protect value of last-command and this-command - (let ((last-command last-command) - (this-command this-command) - file) - (if (null vm-send-using-mime) - (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) - (setq file (vm-read-file-name "Attach file: " nil nil t)) - (list file))) - (if (null vm-send-using-mime) - (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) - (if (file-directory-p file) - (error "%s is a directory, cannot attach" file)) - (if (not (file-exists-p file)) - (error "No such file: %s" file)) - (if (not (file-readable-p file)) - (error "You don't have permission to read %s" file)) - (vm-mime-attach-object file nil nil nil t)) - -(defun vm-mime-attach-object (object type params description mimed) - (if (not (eq major-mode 'mail-mode)) - (error "Command must be used in a VM Mail mode buffer.")) - (let (start end e tag-string disposition) - (if (< (point) (save-excursion (mail-text) (point))) - (mail-text)) - (setq start (point) - tag-string (format "[ATTACHMENT %s, %s]" object - (or type "MIME file"))) - (insert tag-string "\n") - (setq end (1- (point))) - (if (and (stringp object) (not mimed)) - (progn - (if (or (vm-mime-types-match "application" type) - (vm-mime-types-match "model" type)) - (setq disposition (list "attachment")) - (setq disposition (list "inline"))) - (setq disposition (nconc disposition - (list - (concat "filename=\"" - (file-name-nondirectory object) - "\""))))) - (setq disposition (list "unspecified"))) - (cond (vm-fsfemacs-19-p - (put-text-property start end 'front-sticky nil) - (put-text-property start end 'rear-nonsticky t) -;; can't be intangible because menu clicking at a position needs -;; to set point inside the tag so that a command can access the -;; text properties there. -;; (put-text-property start end 'intangible object) - (put-text-property start end 'face vm-mime-button-face) - (put-text-property start end 'vm-mime-type type) - (put-text-property start end 'vm-mime-object object) - (put-text-property start end 'vm-mime-parameters params) - (put-text-property start end 'vm-mime-description description) - (put-text-property start end 'vm-mime-disposition disposition) - (put-text-property start end 'vm-mime-encoded mimed) - (put-text-property start end 'vm-mime-object object)) - (vm-xemacs-p - (setq e (make-extent start end)) - (vm-mime-set-extent-glyph-for-type e (or type "text/plain")) - (set-extent-property e 'start-open t) - (set-extent-property e 'face vm-mime-button-face) - (set-extent-property e 'duplicable t) - (let ((keymap (make-sparse-keymap))) - (if vm-popup-menu-on-mouse-3 - (define-key keymap 'button3 - 'vm-menu-popup-content-disposition-menu)) - (set-extent-property e 'keymap keymap) - (set-extent-property e 'balloon-help 'vm-mouse-3-help)) - (set-extent-property e 'vm-mime-type type) - (set-extent-property e 'vm-mime-object object) - (set-extent-property e 'vm-mime-parameters params) - (set-extent-property e 'vm-mime-description description) - (set-extent-property e 'vm-mime-disposition disposition) - (set-extent-property e 'vm-mime-encoded mimed))))) - -(defun vm-mime-attachment-disposition-at-point () - (cond (vm-fsfemacs-19-p - (let ((disp (get-text-property (point) 'vm-mime-disposition))) - (intern (car disp)))) - (vm-xemacs-p - (let* ((e (extent-at (point) nil 'vm-mime-disposition)) - (disp (extent-property e 'vm-mime-disposition))) - (intern (car disp)))))) - -(defun vm-mime-set-attachment-disposition-at-point (sym) - (cond (vm-fsfemacs-19-p - (let ((disp (get-text-property (point) 'vm-mime-disposition))) - (setcar disp (symbol-name sym)))) - (vm-xemacs-p - (let* ((e (extent-at (point) nil 'vm-mime-disposition)) - (disp (extent-property e 'vm-mime-disposition))) - (setcar disp (symbol-name sym)))))) - -(defun vm-disallow-overlay-endpoint-insertion (overlay after start end - &optional old-size) - (cond ((null after) nil) - ((= start (overlay-start overlay)) - (move-overlay overlay end (overlay-end overlay))) - ((= start (overlay-end overlay)) - (move-overlay overlay (overlay-start overlay) start)))) - -(defun vm-mime-fake-attachment-overlays (start end) - (let ((o-list nil) - (done nil) - (pos start) - object props o) - (save-excursion - (save-restriction - (narrow-to-region start end) - (while (not done) - (setq object (get-text-property pos 'vm-mime-object)) - (setq pos (next-single-property-change pos 'vm-mime-object)) - (or pos (setq pos (point-max) done t)) - (if object - (progn - (setq o (make-overlay start pos)) - (overlay-put o 'insert-in-front-hooks - '(vm-disallow-overlay-endpoint-insertion)) - (overlay-put o 'insert-behind-hooks - '(vm-disallow-overlay-endpoint-insertion)) - (setq props (text-properties-at start)) - (while props - (overlay-put o (car props) (car (cdr props))) - (setq props (cdr (cdr props)))) - (setq o-list (cons o o-list)))) - (setq start pos)) - o-list )))) - -(defun vm-mime-default-type-from-filename (file) - (let ((alist vm-mime-attachment-auto-type-alist) - (case-fold-search t) - (done nil)) - (while (and alist (not done)) - (if (string-match (car (car alist)) file) - (setq done t) - (setq alist (cdr alist)))) - (and alist (cdr (car alist))))) - -(defun vm-remove-mail-mode-header-separator () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (concat "^" mail-header-separator "$") nil t) - (progn - (delete-region (match-beginning 0) (match-end 0)) - t ) - nil ))) - -(defun vm-add-mail-mode-header-separator () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^$" nil t) - (replace-match mail-header-separator t t)))) - -(defun vm-mime-transfer-encode-region (encoding beg end crlf) - (let ((case-fold-search t) - (armor-from (and vm-mime-composition-armor-from-lines - (let ((case-fold-search nil)) - (save-excursion - (goto-char beg) - (re-search-forward "^From " nil t))))) - (armor-dot (let ((case-fold-search nil)) - (save-excursion - (goto-char beg) - (re-search-forward "^\\.\\n" nil t))))) - (cond ((string-match "^binary$" encoding) - (vm-mime-base64-encode-region beg end crlf) - (setq encoding "base64")) - ((and (not armor-from) (not armor-dot) - (string-match "^7bit$" encoding)) t) - ((string-match "^base64$" encoding) t) - ((string-match "^quoted-printable$" encoding) t) - ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable) - (vm-mime-qp-encode-region beg end nil armor-from) - (setq encoding "quoted-printable")) - ((eq vm-mime-8bit-text-transfer-encoding 'base64) - (vm-mime-base64-encode-region beg end crlf) - (setq encoding "base64")) - (armor-from (vm-mime-qp-encode-region beg end nil armor-from)) - ((eq vm-mime-8bit-text-transfer-encoding '8bit) t)) - encoding )) - -(defun vm-mime-transfer-encode-layout (layout) - (let ((list (vm-mm-layout-parts layout)) - (type (car (vm-mm-layout-type layout))) - (encoding "7bit") - (vm-mime-8bit-text-transfer-encoding - vm-mime-8bit-text-transfer-encoding)) - (cond ((vm-mime-composite-type-p type) - ;; MIME messages of type "message" and - ;; "multipart" are required to have a non-opaque - ;; content transfer encoding. This means that - ;; if the user only wants to send out 7bit data, - ;; then any subpart that contains 8bit data must - ;; have an opaque (qp or base64) 8->7bit - ;; conversion performed on it so that the - ;; enclosing entity can use a non-opaque - ;; encoding. - ;; - ;; message/partial requires a "7bit" encoding so - ;; force 8->7 conversion in that case. - (cond ((memq vm-mime-8bit-text-transfer-encoding - '(quoted-printable base64)) - t) - ((vm-mime-types-match "message/partial" type) - (setq vm-mime-8bit-text-transfer-encoding - 'quoted-printable))) - (while list - (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit") - (setq encoding "8bit")) - (setq list (cdr list)))) - (t - (if (and (vm-mime-types-match "message/partial" type) - (not (memq vm-mime-8bit-text-transfer-encoding - '(quoted-printable base64)))) - (setq vm-mime-8bit-text-transfer-encoding - 'quoted-printable)) - (setq encoding - (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) - (vm-mm-layout-body-start layout) - (vm-mm-layout-body-end layout) - (vm-mime-text-type-p layout))))) - (save-excursion - (save-restriction - (goto-char (vm-mm-layout-header-start layout)) - (narrow-to-region (point) (vm-mm-layout-body-start layout)) - (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:") - (if (not (equal encoding "7bit")) - (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n")) - encoding )))) - -(defun vm-mime-encode-composition () - "MIME encode the current mail composition buffer. -Attachment tags added to the buffer with vm-mime-attach-file are expanded -and the approriate content-type and boundary markup information is added." - (interactive) - (cond (vm-xemacs-mule-p - (vm-mime-xemacs-encode-composition)) - (vm-xemacs-p - (vm-mime-xemacs-encode-composition)) - (vm-fsfemacs-19-p - (vm-mime-fsfemacs-encode-composition)) - (t - (error "don't know how to MIME encode composition for %s" - (emacs-version))))) - -(defvar enriched-mode) - -(defun vm-mime-xemacs-encode-composition () - (save-restriction - (widen) - (if (not (eq major-mode 'mail-mode)) - (error "Command must be used in a VM Mail mode buffer.")) - (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) - (error "Message is already MIME encoded.")) - (let ((8bit nil) - (just-one nil) - (boundary-positions nil) - (enriched (and (boundp 'enriched-mode) enriched-mode)) - already-mimed layout e e-list boundary - type encoding charset params description disposition object - opoint-min) - (mail-text) - (setq e-list (extent-list nil (point) (point-max)) - e-list (vm-delete (function - (lambda (e) - (extent-property e 'vm-mime-object))) - e-list t) - e-list (sort e-list (function - (lambda (e1 e2) - (< (extent-end-position e1) - (extent-end-position e2)))))) - ;; If there's just one attachment and no other readable - ;; text in the buffer then make the message type just be - ;; the attachment type rather than sending a multipart - ;; message with one attachment - (setq just-one (and (= (length e-list) 1) - (looking-at "[ \t\n]*") - (= (match-end 0) - (extent-start-position (car e-list))) - (save-excursion - (goto-char (extent-end-position (car e-list))) - (looking-at "[ \t\n]*\\'")))) - (if (null e-list) - (progn - (narrow-to-region (point) (point-max)) - ;; support enriched-mode for text/enriched composition - (if enriched - (let ((enriched-initial-annotation "")) - (enriched-encode (point-min) (point-max)))) - (setq charset (vm-determine-proper-charset (point-min) - (point-max))) - (if vm-xemacs-mule-p - (encode-coding-region (point-min) (point-max) - buffer-file-coding-system)) - (setq encoding (vm-determine-proper-content-transfer-encoding - (point-min) - (point-max)) - encoding (vm-mime-transfer-encode-region encoding - (point-min) - (point-max) - t)) - (widen) - (vm-remove-mail-mode-header-separator) - (goto-char (point-min)) - (vm-reorder-message-headers - nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") - (insert "MIME-Version: 1.0\n") - (if enriched - (insert "Content-Type: text/enriched; charset=" charset "\n") - (insert "Content-Type: text/plain; charset=" charset "\n")) - (insert "Content-Transfer-Encoding: " encoding "\n") - (vm-add-mail-mode-header-separator)) - (while e-list - (setq e (car e-list)) - (if (or just-one (= (point) (extent-start-position e))) - nil - (narrow-to-region (point) (extent-start-position e)) - (if enriched - (let ((enriched-initial-annotation "")) - (enriched-encode (point-min) (point-max)))) - (setq charset (vm-determine-proper-charset (point-min) - (point-max))) - (if vm-xemacs-mule-p - (encode-coding-region (point-min) (point-max) - buffer-file-coding-system)) - (setq encoding (vm-determine-proper-content-transfer-encoding - (point-min) - (point-max)) - encoding (vm-mime-transfer-encode-region encoding - (point-min) - (point-max) - t)) - (setq boundary-positions (cons (point-marker) boundary-positions)) - (if enriched - (insert "Content-Type: text/enriched; charset=" charset "\n") - (insert "Content-Type: text/plain; charset=" charset "\n")) - (insert "Content-Transfer-Encoding: " encoding "\n\n") - (widen)) - (goto-char (extent-start-position e)) - (narrow-to-region (point) (point)) - (setq object (extent-property e 'vm-mime-object)) - ;; insert the object - (cond ((bufferp object) - (insert-buffer-substring object)) - ((stringp object) - (let ((coding-system-for-read 'no-conversion) - ;; don't let buffer-file-coding-system be changed - ;; by insert-file-contents-literally. The - ;; value we bind to it to here isn't important. - (buffer-file-coding-system 'no-conversion)) - (insert-file-contents-literally object)))) - ;; gather information about the object from the extent. - (if (setq already-mimed (extent-property e 'vm-mime-encoded)) - (setq layout (vm-mime-parse-entity - nil (list "text/plain" "charset=us-ascii") - "7bit") - type (or (extent-property e 'vm-mime-type) - (car (vm-mm-layout-type layout))) - params (or (extent-property e 'vm-mime-parameters) - (cdr (vm-mm-layout-qtype layout))) - description (extent-property e 'vm-mime-description) - disposition - (if (not - (equal - (car (extent-property e 'vm-mime-disposition)) - "unspecified")) - (extent-property e 'vm-mime-disposition) - (vm-mm-layout-qdisposition layout))) - (setq type (extent-property e 'vm-mime-type) - params (extent-property e 'vm-mime-parameters) - description (extent-property e 'vm-mime-description) - disposition - (if (not (equal - (car (extent-property e 'vm-mime-disposition)) - "unspecified")) - (extent-property e 'vm-mime-disposition) - nil))) - (cond ((vm-mime-types-match "text" type) - (setq encoding - (vm-determine-proper-content-transfer-encoding - (if already-mimed - (vm-mm-layout-body-start layout) - (point-min)) - (point-max)) - encoding (vm-mime-transfer-encode-region - encoding - (if already-mimed - (vm-mm-layout-body-start layout) - (point-min)) - (point-max) - t)) - (setq 8bit (or 8bit (equal encoding "8bit")))) - ((vm-mime-composite-type-p type) - (setq opoint-min (point-min)) - (if (not already-mimed) - (setq layout (vm-mime-parse-entity - nil (list "text/plain" "charset=us-ascii") - "7bit"))) - (setq encoding (vm-mime-transfer-encode-layout layout)) - (setq 8bit (or 8bit (equal encoding "8bit"))) - (goto-char (point-max)) - (widen) - (narrow-to-region opoint-min (point))) - (t - (vm-mime-base64-encode-region - (if already-mimed - (vm-mm-layout-body-start layout) - (point-min)) - (point-max)) - (setq encoding "base64"))) - (if just-one - nil - (goto-char (point-min)) - (setq boundary-positions (cons (point-marker) boundary-positions)) - (if (not already-mimed) - nil - ;; trim headers - (vm-reorder-message-headers - nil (nconc (list "Content-Disposition:" "Content-ID:") - (if description - (list "Content-Description:") - nil)) - nil) - ;; remove header/text separator - (goto-char (1- (vm-mm-layout-body-start layout))) - (if (looking-at "\n") - (delete-char 1))) - (insert "Content-Type: " type) - (if params - (if vm-mime-avoid-folding-content-type - (insert "; " (mapconcat 'identity params "; ") "\n") - (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) - (insert "\n")) - (and description - (insert "Content-Description: " description "\n")) - (if disposition - (progn - (insert "Content-Disposition: " (car disposition)) - (if (cdr disposition) - (insert ";\n\t" (mapconcat 'identity - (cdr disposition) - ";\n\t"))) - (insert "\n"))) - (insert "Content-Transfer-Encoding: " encoding "\n\n")) - (goto-char (point-max)) - (widen) - (save-excursion - (goto-char (extent-start-position e)) - (vm-assert (looking-at "\\[ATTACHMENT"))) - (delete-region (extent-start-position e) - (extent-end-position e)) - (detach-extent e) - (if (looking-at "\n") - (delete-char 1)) - (setq e-list (cdr e-list))) - ;; handle the remaining chunk of text after the last - ;; extent, if any. - (if (or just-one (= (point) (point-max))) - nil - (if enriched - (let ((enriched-initial-annotation "")) - (enriched-encode (point) (point-max)))) - (setq charset (vm-determine-proper-charset (point) - (point-max))) - (if vm-xemacs-mule-p - (encode-coding-region (point) (point-max) - buffer-file-coding-system)) - (setq encoding (vm-determine-proper-content-transfer-encoding - (point) - (point-max)) - encoding (vm-mime-transfer-encode-region encoding - (point) - (point-max) - t)) - (setq 8bit (or 8bit (equal encoding "8bit"))) - (setq boundary-positions (cons (point-marker) boundary-positions)) - (if enriched - (insert "Content-Type: text/enriched; charset=" charset "\n") - (insert "Content-Type: text/plain; charset=" charset "\n")) - (insert "Content-Transfer-Encoding: " encoding "\n\n") - (goto-char (point-max))) - (setq boundary (vm-mime-make-multipart-boundary)) - (mail-text) - (while (re-search-forward (concat "^--" - (regexp-quote boundary) - "\\(--\\)?$") - nil t) - (setq boundary (vm-mime-make-multipart-boundary)) - (mail-text)) - (goto-char (point-max)) - (or just-one (insert "\n--" boundary "--\n")) - (while boundary-positions - (goto-char (car boundary-positions)) - (insert "\n--" boundary "\n") - (setq boundary-positions (cdr boundary-positions))) - (if (and just-one already-mimed) - (progn - (goto-char (vm-mm-layout-header-start layout)) - ;; trim headers - (vm-reorder-message-headers - nil '("Content-Description:" "Content-ID:") nil) - ;; remove header/text separator - (goto-char (1- (vm-mm-layout-body-start layout))) - (if (looking-at "\n") - (delete-char 1)) - ;; copy remainder to enclosing entity's header section - (insert-buffer-substring (current-buffer) - (vm-mm-layout-header-start layout) - (vm-mm-layout-body-start layout)) - (delete-region (vm-mm-layout-header-start layout) - (vm-mm-layout-body-start layout)))) - (goto-char (point-min)) - (vm-remove-mail-mode-header-separator) - (vm-reorder-message-headers - nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") - (vm-add-mail-mode-header-separator) - (insert "MIME-Version: 1.0\n") - (if (not just-one) - (insert (if vm-mime-avoid-folding-content-type - "Content-Type: multipart/mixed; boundary=\"" - "Content-Type: multipart/mixed;\n\tboundary=\"") - boundary "\"\n") - (insert "Content-Type: " type) - (if params - (if vm-mime-avoid-folding-content-type - (insert "; " (mapconcat 'identity params "; ") "\n") - (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) - (insert "\n"))) - (if just-one - (and description - (insert "Content-Description: " description "\n"))) - (if (and just-one disposition) - (progn - (insert "Content-Disposition: " (car disposition)) - (if (cdr disposition) - (if vm-mime-avoid-folding-content-type - (insert "; " (mapconcat 'identity (cdr disposition) "; ") - "\n") - (insert ";\n\t" (mapconcat 'identity (cdr disposition) - ";\n\t"))) - (insert "\n")))) - (if just-one - (insert "Content-Transfer-Encoding: " encoding "\n") - (if 8bit - (insert "Content-Transfer-Encoding: 8bit\n") - (insert "Content-Transfer-Encoding: 7bit\n"))))))) - -(defun vm-mime-fsfemacs-encode-composition () - (save-restriction - (widen) - (if (not (eq major-mode 'mail-mode)) - (error "Command must be used in a VM Mail mode buffer.")) - (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) - (error "Message is already MIME encoded.")) - (let ((8bit nil) - (just-one nil) - (boundary-positions nil) - (enriched (and (boundp 'enriched-mode) enriched-mode)) - already-mimed layout o o-list boundary - type encoding charset params description disposition object - opoint-min) - (mail-text) - (setq o-list (vm-mime-fake-attachment-overlays (point) (point-max)) - o-list (vm-delete (function - (lambda (o) - (overlay-get o 'vm-mime-object))) - o-list t) - o-list (sort o-list (function - (lambda (e1 e2) - (< (overlay-end e1) - (overlay-end e2)))))) - ;; If there's just one attachment and no other readable - ;; text in the buffer then make the message type just be - ;; the attachment type rather than sending a multipart - ;; message with one attachment - (setq just-one (and (= (length o-list) 1) - (looking-at "[ \t\n]*") - (= (match-end 0) - (overlay-start (car o-list))) - (save-excursion - (goto-char (overlay-end (car o-list))) - (looking-at "[ \t\n]*\\'")))) - (if (null o-list) - (progn - (narrow-to-region (point) (point-max)) - ;; support enriched-mode for text/enriched composition - (if enriched - (let ((enriched-initial-annotation "")) - (enriched-encode (point-min) (point-max)))) - (setq charset (vm-determine-proper-charset (point-min) - (point-max))) - (setq encoding (vm-determine-proper-content-transfer-encoding - (point-min) - (point-max)) - encoding (vm-mime-transfer-encode-region encoding - (point-min) - (point-max) - t)) - (widen) - (vm-remove-mail-mode-header-separator) - (goto-char (point-min)) - (vm-reorder-message-headers - nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") - (insert "MIME-Version: 1.0\n") - (if enriched - (insert "Content-Type: text/enriched; charset=" charset "\n") - (insert "Content-Type: text/plain; charset=" charset "\n")) - (insert "Content-Transfer-Encoding: " encoding "\n") - (vm-add-mail-mode-header-separator)) - (while o-list - (setq o (car o-list)) - (if (or just-one (= (point) (overlay-start o))) - nil - (narrow-to-region (point) (overlay-start o)) - ;; support enriched-mode for text/enriched composition - (if enriched - (let ((enriched-initial-annotation "")) - (save-excursion - ;; insert/delete trick needed to avoid - ;; enriched-mode tags from seeping into the - ;; attachment overlays. I really wish - ;; front-advance / rear-advance overlay - ;; endpoint properties actually worked. - (goto-char (point-max)) - (insert-before-markers "\n") - (enriched-encode (point-min) (1- (point))) - (goto-char (point-max)) - (delete-char -1) - '(goto-char (point-min))))) - (setq charset (vm-determine-proper-charset (point-min) - (point-max))) - (setq encoding (vm-determine-proper-content-transfer-encoding - (point-min) - (point-max)) - encoding (vm-mime-transfer-encode-region encoding - (point-min) - (point-max) - t)) - (setq boundary-positions (cons (point-marker) boundary-positions)) - (if enriched - (insert "Content-Type: text/enriched; charset=" charset "\n") - (insert "Content-Type: text/plain; charset=" charset "\n")) - (insert "Content-Transfer-Encoding: " encoding "\n\n") - (widen)) - (goto-char (overlay-start o)) - (narrow-to-region (point) (point)) - (setq object (overlay-get o 'vm-mime-object)) - ;; insert the object - (cond ((bufferp object) - ;; as of FSF Emacs 19.34, even with the hooks - ;; we've attached to the attachment overlays, - ;; text STILL can be inserted into them when - ;; font-lock is enabled. Explaining why is - ;; beyond the scope of this comment and I - ;; don't know the answer anyway. This works - ;; to prevent it. - (insert-before-markers " ") - (forward-char -1) - (insert-buffer-substring object) - (delete-char 1)) - ((stringp object) - (insert-before-markers " ") - (forward-char -1) - (insert-file-contents object) - (goto-char (point-max)) - (delete-char -1))) - ;; gather information about the object from the extent. - (if (setq already-mimed (overlay-get o 'vm-mime-encoded)) - (setq layout (vm-mime-parse-entity - nil (list "text/plain" "charset=us-ascii") - "7bit") - type (or (overlay-get o 'vm-mime-type) - (car (vm-mm-layout-type layout))) - params (or (overlay-get o 'vm-mime-parameters) - (cdr (vm-mm-layout-qtype layout))) - description (overlay-get o 'vm-mime-description) - disposition - (if (not - (equal - (car (overlay-get o 'vm-mime-disposition)) - "unspecified")) - (overlay-get o 'vm-mime-disposition) - (vm-mm-layout-qdisposition layout))) - (setq type (overlay-get o 'vm-mime-type) - params (overlay-get o 'vm-mime-parameters) - description (overlay-get o 'vm-mime-description) - disposition - (if (not (equal - (car (overlay-get o 'vm-mime-disposition)) - "unspecified")) - (overlay-get o 'vm-mime-disposition) - nil))) - (cond ((vm-mime-types-match "text" type) - (setq encoding - (vm-determine-proper-content-transfer-encoding - (if already-mimed - (vm-mm-layout-body-start layout) - (point-min)) - (point-max)) - encoding (vm-mime-transfer-encode-region - encoding - (if already-mimed - (vm-mm-layout-body-start layout) - (point-min)) - (point-max) - t)) - (setq 8bit (or 8bit (equal encoding "8bit")))) - ((vm-mime-composite-type-p type) - (setq opoint-min (point-min)) - (if (not already-mimed) - (setq layout (vm-mime-parse-entity - nil (list "text/plain" "charset=us-ascii") - "7bit"))) - (setq encoding (vm-mime-transfer-encode-layout layout)) - (setq 8bit (or 8bit (equal encoding "8bit"))) - (goto-char (point-max)) - (widen) - (narrow-to-region opoint-min (point))) - (t - (vm-mime-base64-encode-region - (if already-mimed - (vm-mm-layout-body-start layout) - (point-min)) - (point-max)) - (setq encoding "base64"))) - (if just-one - nil - (goto-char (point-min)) - (setq boundary-positions (cons (point-marker) boundary-positions)) - (if (not already-mimed) - nil - ;; trim headers - (vm-reorder-message-headers - nil (nconc (list "Content-Disposition:" "Content-ID:") - (if description - (list "Content-Description:") - nil)) - nil) - ;; remove header/text separator - (goto-char (1- (vm-mm-layout-body-start layout))) - (if (looking-at "\n") - (delete-char 1))) - (insert "Content-Type: " type) - (if params - (if vm-mime-avoid-folding-content-type - (insert "; " (mapconcat 'identity params "; ") "\n") - (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) - (insert "\n")) - (and description - (insert "Content-Description: " description "\n")) - (if disposition - (progn - (insert "Content-Disposition: " (car disposition)) - (if (cdr disposition) - (insert ";\n\t" (mapconcat 'identity - (cdr disposition) - ";\n\t"))) - (insert "\n"))) - (insert "Content-Transfer-Encoding: " encoding "\n\n")) - (goto-char (point-max)) - (widen) - (save-excursion - (goto-char (overlay-start o)) - (vm-assert (looking-at "\\[ATTACHMENT"))) - (delete-region (overlay-start o) - (overlay-end o)) - (delete-overlay o) - (if (looking-at "\n") - (delete-char 1)) - (setq o-list (cdr o-list))) - ;; handle the remaining chunk of text after the last - ;; extent, if any. - (if (or just-one (= (point) (point-max))) - nil - ;; support enriched-mode for text/enriched composition - (if enriched - (let ((enriched-initial-annotation "")) - (enriched-encode (point) (point-max)))) - (setq charset (vm-determine-proper-charset (point) - (point-max))) - (setq encoding (vm-determine-proper-content-transfer-encoding - (point) - (point-max)) - encoding (vm-mime-transfer-encode-region encoding - (point) - (point-max) - t)) - (setq 8bit (or 8bit (equal encoding "8bit"))) - (setq boundary-positions (cons (point-marker) boundary-positions)) - (if enriched - (insert "Content-Type: text/enriched; charset=" charset "\n") - (insert "Content-Type: text/plain; charset=" charset "\n")) - (insert "Content-Transfer-Encoding: " encoding "\n\n") - (goto-char (point-max))) - (setq boundary (vm-mime-make-multipart-boundary)) - (mail-text) - (while (re-search-forward (concat "^--" - (regexp-quote boundary) - "\\(--\\)?$") - nil t) - (setq boundary (vm-mime-make-multipart-boundary)) - (mail-text)) - (goto-char (point-max)) - (or just-one (insert "\n--" boundary "--\n")) - (while boundary-positions - (goto-char (car boundary-positions)) - (insert "\n--" boundary "\n") - (setq boundary-positions (cdr boundary-positions))) - (if (and just-one already-mimed) - (progn - (goto-char (vm-mm-layout-header-start layout)) - ;; trim headers - (vm-reorder-message-headers - nil '("Content-Description:" "Content-ID:") nil) - ;; remove header/text separator - (goto-char (1- (vm-mm-layout-body-start layout))) - (if (looking-at "\n") - (delete-char 1)) - ;; copy remainder to enclosing entity's header section - (insert-buffer-substring (current-buffer) - (vm-mm-layout-header-start layout) - (vm-mm-layout-body-start layout)) - (delete-region (vm-mm-layout-header-start layout) - (vm-mm-layout-body-start layout)))) - (goto-char (point-min)) - (vm-remove-mail-mode-header-separator) - (vm-reorder-message-headers - nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") - (vm-add-mail-mode-header-separator) - (insert "MIME-Version: 1.0\n") - (if (not just-one) - (insert (if vm-mime-avoid-folding-content-type - "Content-Type: multipart/mixed; boundary=\"" - "Content-Type: multipart/mixed;\n\tboundary=\"") - boundary "\"\n") - (insert "Content-Type: " type) - (if params - (if vm-mime-avoid-folding-content-type - (insert "; " (mapconcat 'identity params "; ") "\n") - (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) - (insert "\n"))) - (if just-one - (and description - (insert "Content-Description: " description "\n"))) - (if (and just-one disposition) - (progn - (insert "Content-Disposition: " (car disposition)) - (if (cdr disposition) - (if vm-mime-avoid-folding-content-type - (insert "; " (mapconcat 'identity (cdr disposition) "; ") - "\n") - (insert ";\n\t" (mapconcat 'identity (cdr disposition) - ";\n\t"))) - (insert "\n")))) - (if just-one - (insert "Content-Transfer-Encoding: " encoding "\n") - (if 8bit - (insert "Content-Transfer-Encoding: 8bit\n") - (insert "Content-Transfer-Encoding: 7bit\n"))))))) - -(defun vm-mime-fragment-composition (size) - (save-restriction - (widen) - (message "Fragmenting message...") - (let ((buffers nil) - (id (vm-mime-make-multipart-boundary)) - (n 1) - (the-end nil) - b header-start header-end master-buffer start end) - (vm-remove-mail-mode-header-separator) - ;; message/partial must have "7bit" content transfer - ;; encoding, so force everything to be encoded for - ;; 7bit transmission. - (let ((vm-mime-8bit-text-transfer-encoding - (if (eq vm-mime-8bit-text-transfer-encoding '8bit) - 'quoted-printable - vm-mime-8bit-text-transfer-encoding))) - (vm-mime-transfer-encode-layout - (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") - "7bit"))) - (goto-char (point-min)) - (setq header-start (point)) - (search-forward "\n\n") - (setq header-end (1- (point))) - (setq master-buffer (current-buffer)) - (goto-char (point-min)) - (setq start (point)) - (while (not (eobp)) - (condition-case nil - (progn - (forward-char (max (- size 150) 2000)) - (beginning-of-line)) - (end-of-buffer (setq the-end t))) - (setq end (point)) - (setq b (generate-new-buffer (concat (buffer-name) " part " - (int-to-string n)))) - (setq buffers (cons b buffers)) - (set-buffer b) - (make-local-variable 'vm-send-using-mime) - (setq vm-send-using-mime nil) - (insert-buffer-substring master-buffer header-start header-end) - (goto-char (point-min)) - (vm-reorder-message-headers nil nil - "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") - (insert "MIME-Version: 1.0\n") - (insert (format - (if vm-mime-avoid-folding-content-type - "Content-Type: message/partial; id=%s; number=%d" - "Content-Type: message/partial;\n\tid=%s;\n\tnumber=%d") - id n)) - (if the-end - (if vm-mime-avoid-folding-content-type - (insert (format "; total=%d\n" n)) - (insert (format ";\n\ttotal=%d\n" n))) - (insert "\n")) - (insert "Content-Transfer-Encoding: 7bit\n") - (goto-char (point-max)) - (insert mail-header-separator "\n") - (insert-buffer-substring master-buffer start end) - (vm-increment n) - (set-buffer master-buffer) - (setq start (point))) - (vm-add-mail-mode-header-separator) - (message "Fragmenting message... done") - (nreverse buffers)))) - -(defun vm-mime-preview-composition () - "Show how the current composition buffer might be displayed -in a MIME-aware mail reader. VM copies and encodes the current -mail composition buffer and displays it as a mail folder. -Type `q' to quit this temp folder and return to composing your -message." - (interactive) - (if (not (eq major-mode 'mail-mode)) - (error "Command must be used in a VM Mail mode buffer.")) - (let ((temp-buffer nil) - (mail-buffer (current-buffer)) - (enriched (and (boundp 'enriched-mode) enriched-mode)) - e-list) - (unwind-protect - (progn - (setq temp-buffer (generate-new-buffer "composition preview")) - (set-buffer temp-buffer) - ;; so vm-mime-xxxx-encode-composition won't complain - (setq major-mode 'mail-mode) - (set (make-local-variable 'enriched-mode) enriched) - (vm-insert-region-from-buffer mail-buffer) - (goto-char (point-min)) - (or (vm-mail-mode-get-header-contents "From") - (insert "From: " (user-login-name) "\n")) - (or (vm-mail-mode-get-header-contents "Message-ID") - (insert "Message-ID: <fake@fake.fake>\n")) - (or (vm-mail-mode-get-header-contents "Date") - (insert "Date: " - (format-time-string "%a, %d %b %Y %H%M%S %Z" - (current-time)) - "\n")) - (and vm-send-using-mime - (null (vm-mail-mode-get-header-contents "MIME-Version:")) - (vm-mime-encode-composition)) - (vm-remove-mail-mode-header-separator) - (goto-char (point-min)) - (insert (vm-leading-message-separator 'From_)) - (goto-char (point-max)) - (insert (vm-trailing-message-separator 'From_)) - (set-buffer-modified-p nil) - ;; point of no return, don't kill it if the user quits - (setq temp-buffer nil) - (let ((vm-auto-decode-mime-messages t) - (vm-auto-displayed-mime-content-types t)) - (vm-save-buffer-excursion - (vm-goto-new-folder-frame-maybe 'folder) - (vm-mode))) - (message - (substitute-command-keys - "Type \\[vm-quit] to continue composing your message")) - ;; temp buffer, don't offer to save it. - (setq buffer-offer-save nil) - (vm-display (or vm-presentation-buffer (current-buffer)) t - (list this-command) '(vm-mode startup))) - (and temp-buffer (kill-buffer temp-buffer))))) - -(defun vm-mime-composite-type-p (type) - (or (and (vm-mime-types-match "message" type) - (not (vm-mime-types-match "message/partial" type)) - (not (vm-mime-types-match "message/external-body" type))) - (vm-mime-types-match "multipart" type))) - -;; Unused currrently. -;; -;;(defun vm-mime-map-atomic-layouts (function list) -;; (while list -;; (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) -;; (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) -;; (funcall function (car list))) -;; (setq list (cdr list))))
--- a/lisp/vm/vm-minibuf.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,400 +0,0 @@ -;;; Minibuffer read functions for VM -;;; Copyright (C) 1993, 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-minibuf) - -(defun vm-minibuffer-complete-word (&optional exiting) - (interactive) - (let ((opoint (point)) - trimmed-c-list c-list beg end diff word word-prefix-regexp completion) - ;; find the beginning and end of the word we're trying to complete - (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ ))) - (progn - (skip-chars-backward " \t\n") - (and (not (eobp)) (forward-char)) - (setq end (point))) - (skip-chars-forward "^ \t\n") - (setq end (point))) - (skip-chars-backward "^ \t\n") - (setq beg (point)) - (goto-char opoint) - ;; copy the word into a string - (setq word (buffer-substring beg end)) - ;; trim the completion list down to just likely candidates - ;; then convert it to an alist. - (setq word-prefix-regexp (concat "^" (regexp-quote word)) - trimmed-c-list (vm-delete-non-matching-strings - word-prefix-regexp - vm-minibuffer-completion-table) - trimmed-c-list (mapcar 'list trimmed-c-list) - c-list (mapcar 'list vm-minibuffer-completion-table)) - ;; Try the word against the completion list. - (and trimmed-c-list - (setq completion (try-completion word trimmed-c-list))) - ;; If completion is nil, figure out what prefix of the word would prefix - ;; something in the completion list... but only if the user is interested. - (if (and (null completion) vm-completion-auto-correct c-list) - (let ((i -1)) - (while (null (setq completion - (try-completion (substring word 0 i) c-list))) - (vm-decrement i)) - (setq completion (substring word 0 i)))) - ;; If completion is t, we had a perfect match already. - (if (eq completion t) - (cond ((and (cdr trimmed-c-list) - (not (eq last-command 'vm-minibuffer-complete-word))) - (and (not exiting) - (vm-minibuffer-completion-message - "[Complete, but not unique]"))) - (vm-completion-auto-space - (goto-char end) - (insert " ")) - (t - (and (not exiting) - (vm-minibuffer-completion-message "[Sole completion]")))) - ;; Compute the difference in length between the completion and the - ;; word. A negative difference means no match and the magnitude - ;; indicates the number of chars that need to be shaved off the end - ;; before a match will occur. A positive difference means a match - ;; occurred and the magnitude specifies the number of new chars that - ;; can be appended to the word as a completion. - ;; - ;; `completion' can be nil here, but the code works anyway because - ;; (length nil) still equals 0! - (setq diff (- (length completion) (length word))) - (cond - ;; We have some completion chars. Insert them. - ((> diff 0) - (goto-char end) - (insert (substring completion (- diff))) - (if (and vm-completion-auto-space - (null (cdr trimmed-c-list))) - (insert " "))) - ;; The word prefixed more than one string, but we can't complete - ;; any further. Either give help or say "Ambiguous". - ((zerop diff) - (and (not exiting) - (if (null completion-auto-help) - (vm-minibuffer-completion-message "[Ambiguous]") - (vm-minibuffer-show-completions (sort - (mapcar 'car trimmed-c-list) - 'string-lessp))))) - ;; The word didn't prefix anything... if vm-completion-auto-correct is - ;; non-nil strip the offending characters and try again. - (vm-completion-auto-correct - (goto-char end) - (delete-char diff) - (vm-minibuffer-complete-word exiting)) - ;; if we're not auto-correcting and we're doing - ;; multi-word, just let the user insert a space. - (vm-completion-auto-space - (insert " ")) - ;; completion utterly failed, tell the user so. - (t - (and (not exiting) - (vm-minibuffer-completion-message "[No match]"))))))) - -(defun vm-minibuffer-complete-word-and-exit () - (interactive) - (vm-minibuffer-complete-word t) - (exit-minibuffer)) - -(defun vm-minibuffer-completion-message (string &optional seconds) - "Briefly display STRING to the right of the current minibuffer input. -Optional second arg SECONDS specifies how long to keep the message visible; -the default is 2 seconds. - -A keypress causes the immediate erasure of the STRING, and return of control -to the calling program." - (let (omax (inhibit-quit t)) - (save-excursion - (goto-char (point-max)) - (setq omax (point)) - (insert " " string)) - (sit-for (or seconds 2)) - (delete-region omax (point-max)))) - -(defun vm-minibuffer-replace-word (word) - (goto-char (point-max)) - (skip-chars-backward "^ \t\n") - (delete-region (point) (point-max)) - (insert word)) - -(defun vm-minibuffer-show-completions (list) - "Display LIST in a multi-column listing in the \" *Completions*\" buffer. -LIST should be a list of strings." - (save-excursion - (set-buffer (get-buffer-create " *Completions*")) - (setq buffer-read-only nil) - (use-local-map (make-sparse-keymap)) - ;; ignore vm-mutable-* here. the user shouldn't mind - ;; because when they exit the minibuffer the windows will be - ;; set right again. - (display-buffer (current-buffer)) - (erase-buffer) - (insert "Possible completions are:\n") - (setq buffer-read-only t) - (vm-show-list list 'vm-minibuffer-replace-word - (list (current-local-map) minibuffer-local-map)) - (goto-char (point-min)))) - -(defun vm-show-list (list &optional function keymaps) - "Display LIST in a multi-column listing in the current buffer at point. -The current buffer must be displayed in some window at the time -this function is called. - -LIST should be a list of strings. - -Optional second argument FUNCTION will be called if the mouse is -clicked on one of the strings in the current buffer. The string -clicked upon will be passed to FUNCTION as its sole argument. - -Optional third argument KEYMAPS specifies a lists of keymaps -where the FUNCTION should be bound to the mouse clicks. By -default the local keymap of the current buffer is used." - (or keymaps (setq keymaps (and (current-local-map) - (list (current-local-map))))) - (save-excursion - (let ((buffer-read-only nil) - tab-stops longest rows columns list-length q i w start command - keymap) - (cond ((and function keymaps (vm-mouse-support-possible-p)) - (setq command - (list 'lambda '(e) '(interactive "e") - (list 'let - '((string (vm-mouse-get-mouse-track-string e))) - (list 'and 'string (list function 'string))))) - (while keymaps - (setq keymap (car keymaps)) - (cond ((vm-mouse-xemacs-mouse-p) - (define-key keymap 'button1 command) - (define-key keymap 'button2 command)) - ((vm-mouse-fsfemacs-mouse-p) - (define-key keymap [down-mouse-1] 'ignore) - (define-key keymap [drag-mouse-1] 'ignore) - (define-key keymap [mouse-1] command) - (define-key keymap [drag-mouse-2] 'ignore) - (define-key keymap [down-mouse-2] 'ignore) - (define-key keymap [mouse-2] command))) - (setq keymaps (cdr keymaps))))) - (setq w (vm-get-buffer-window (current-buffer))) - (setq q list - list-length 0 - longest 0) - (while q - (setq longest (max longest (length (car q))) - list-length (1+ list-length) - q (cdr q))) - ;; provide for separation between columns - (setq longest (+ 3 longest)) - (setq columns (max 1 (/ (- (window-width w) 2) longest)) - rows (/ list-length columns) - rows - (+ (if (zerop (% list-length columns)) 0 1) - rows)) - (setq i columns - tab-stops nil) - (while (not (zerop i)) - (setq tab-stops (cons (* longest i) tab-stops) - i (1- i))) - (setq q list - i 0) - (while q - (setq start (point)) - (insert (car q)) - (and function (vm-mouse-set-mouse-track-highlight start (point))) - (setq i (1+ i) - q (cdr q)) - (if (zerop (% i columns)) - (insert "\n") - (let ((tab-stop-list tab-stops)) - (tab-to-tab-stop))))))) - -(defun vm-minibuffer-completion-help () - (interactive) - (let ((opoint (point)) - c-list beg end word word-prefix-regexp) - ;; find the beginning and end of the word we're trying to complete - (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ ))) - (progn - (skip-chars-backward " \t\n") - (and (not (eobp)) (forward-char)) - (setq end (point))) - (skip-chars-forward "^ \t\n") - (setq end (point))) - (skip-chars-backward "^ \t\n") - (setq beg (point)) - (goto-char opoint) - ;; copy the word into a string - (setq word (buffer-substring beg end)) - ;; trim the completion list down to just likely candidates - ;; then convert it to an alist. - (setq word-prefix-regexp (concat "^" (regexp-quote word)) - c-list (vm-delete-non-matching-strings - word-prefix-regexp - vm-minibuffer-completion-table) - c-list (sort c-list (function string-lessp))) - (if c-list - (vm-minibuffer-show-completions c-list) - (vm-minibuffer-completion-message " [No match]")))) - -(defun vm-keyboard-read-string (prompt completion-list &optional multi-word) - (let ((minibuffer-local-map (copy-keymap minibuffer-local-map)) - (vm-completion-auto-space multi-word) - (vm-minibuffer-completion-table completion-list)) - (define-key minibuffer-local-map "\t" 'vm-minibuffer-complete-word) - (define-key minibuffer-local-map " " 'vm-minibuffer-complete-word) - (define-key minibuffer-local-map "?" 'vm-minibuffer-completion-help) - (if (not multi-word) - (define-key minibuffer-local-map "\r" - 'vm-minibuffer-complete-word-and-exit)) - ;; evade the XEmacs dialog box, yeccch. - (let ((use-dialog-box nil)) - (read-string prompt)))) - -(defvar last-nonmenu-event) - -(defun vm-read-string (prompt completion-list &optional multi-word) - ;; handle alist - (if (consp (car completion-list)) - (setq completion-list (nreverse (mapcar 'car completion-list)))) - (if (and completion-list (vm-mouse-support-possible-here-p)) - (cond ((and (vm-mouse-xemacs-mouse-p) - (or (button-press-event-p last-command-event) - (button-release-event-p last-command-event) - (menu-event-p last-command-event))) - (vm-mouse-read-string prompt completion-list multi-word)) - ((and (vm-mouse-fsfemacs-mouse-p) - (listp last-nonmenu-event)) - (vm-mouse-read-string prompt completion-list multi-word)) - (t - (vm-keyboard-read-string prompt completion-list multi-word))) - (vm-keyboard-read-string prompt completion-list multi-word))) - -(defun vm-read-number (prompt) - (let (result) - (while - (null - (string-match "^[ \t]*-?[0-9]+" (setq result (read-string prompt))))) - (string-to-int result))) - -(defun vm-read-password (prompt &optional confirm) - "Read and return a password from the minibuffer, prompting with PROMPT. -Optional second argument CONFIRM non-nil means that the user will be asked - to type the password a second time for confirmation and if there is a - mismatch, the process is repeated. - -Line editing keys are: - C-h, DEL rubout - C-u, C-x line kill - C-q, C-v literal next" - (catch 'return-value - (save-excursion - (let ((cursor-in-echo-area t) - (echo-keystrokes 0) - (input-buffer nil) - (help-form nil) - (xxx "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") - (string nil) - char done form) - (unwind-protect - (save-excursion - (setq input-buffer (get-buffer-create " *password*")) - (set-buffer input-buffer) - (while t - (erase-buffer) - (message "%s%s" prompt - (vm-truncate-string xxx (buffer-size))) - (while (not (memq (setq char (read-char)) '(?\C-m ?\C-j))) - (if (setq form - (cdr - (assq char - '((?\C-h . (delete-char -1)) - (?\C-? . (delete-char -1)) - (?\C-u . (delete-region 1 (point))) - (?\C-x . (delete-region 1 (point))) - (?\C-q . (quoted-insert 1)) - (?\C-v . (quoted-insert 1)))))) - (condition-case error-data - (eval form) - (error t)) - (insert char)) - (message "%s%s" prompt - (vm-truncate-string xxx (buffer-size)))) - (cond ((and confirm string) - (cond ((not (string= string (buffer-string))) - (message - (concat prompt - (vm-truncate-string xxx (buffer-size)) - " [Mismatch... try again.]")) - (ding) - (sit-for 2) - (setq string nil)) - (t (throw 'return-value string)))) - (confirm - (setq string (buffer-string)) - (message - (concat prompt - (vm-truncate-string xxx (buffer-size)) - " [Retype to confirm...]")) - (sit-for 2)) - (t - (message "") - (throw 'return-value (buffer-string)))))) - (and input-buffer (kill-buffer input-buffer))))))) - -(defun vm-keyboard-read-file-name (prompt &optional dir default - must-match initial history) - "Like read-file-name, except HISTORY's value is unaltered." - (let ((oldvalue (symbol-value history)) - ;; evade the XEmacs dialog box, yeccch. - (use-dialog-box nil)) - (unwind-protect - (condition-case nil - (read-file-name prompt dir default must-match initial history) - (wrong-number-of-arguments - (if history - (let ((file-name-history (symbol-value history)) - file) - (setq file - (read-file-name prompt dir default must-match initial)) - file ) - (read-file-name prompt dir default must-match initial)))) - (and history (set history oldvalue))))) - -(defun vm-read-file-name (prompt &optional dir default - must-match initial history) - "Like read-file-name, except a mouse interface is used if a mouse -click mouse triggered the current command." - (if (vm-mouse-support-possible-here-p) - (cond ((and (vm-mouse-xemacs-mouse-p) - (or (button-press-event-p last-command-event) - (button-release-event-p last-command-event) - (menu-event-p last-command-event))) - (vm-mouse-read-file-name prompt dir default - must-match initial history)) - ((and (vm-mouse-fsfemacs-mouse-p) - (listp last-nonmenu-event)) - (vm-mouse-read-file-name prompt dir default - must-match initial history)) - (t - (vm-keyboard-read-file-name prompt dir default - must-match initial history))) - (vm-keyboard-read-file-name prompt dir default - must-match initial history))) - -
--- a/lisp/vm/vm-misc.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,762 +0,0 @@ -;;; Miscellaneous functions for VM -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-misc) - -(defun vm-delete-non-matching-strings (regexp list &optional destructively) - "Delete strings matching REGEXP from LIST. -Optional third arg non-nil means to destructively alter LIST, instead of -working on a copy. - -The new version of the list, minus the deleted strings, is returned." - (or destructively (setq list (copy-sequence list))) - (let ((curr list) (prev nil)) - (while curr - (if (string-match regexp (car curr)) - (setq prev curr - curr (cdr curr)) - (if (null prev) - (setq list (cdr list) - curr list) - (setcdr prev (cdr curr)) - (setq curr (cdr curr))))) - list )) - -(defun vm-parse (string regexp &optional matchn) - (or matchn (setq matchn 1)) - (let (list) - (store-match-data nil) - (while (string-match regexp string (match-end 0)) - (setq list (cons (substring string (match-beginning matchn) - (match-end matchn)) list))) - (nreverse list))) - -(defun vm-parse-addresses (string) - (if (null string) - () - (let (work-buffer) - (save-excursion - (unwind-protect - (let (list start s char) - (setq work-buffer (generate-new-buffer "*vm-work*")) - (set-buffer work-buffer) - (insert string) - (goto-char (point-min)) - (skip-chars-forward "\t\f\n\r ") - (setq start (point)) - (while (not (eobp)) - (skip-chars-forward "^\"\\,(") - (setq char (following-char)) - (cond ((= char ?\\) - (forward-char 1) - (if (not (eobp)) - (forward-char 1))) - ((= char ?,) - (setq s (buffer-substring start (point))) - (if (or (null (string-match "^[\t\f\n\r ]+$" s)) - (not (string= s ""))) - (setq list (cons s list))) - (skip-chars-forward ",\t\f\n\r ") - (setq start (point))) - ((= char ?\") - (re-search-forward "[^\\]\"" nil 0)) - ((= char ?\() - (let ((parens 1)) - (forward-char 1) - (while (and (not (eobp)) (not (zerop parens))) - (re-search-forward "[()]" nil 0) - (cond ((or (eobp) - (= (char-after (- (point) 2)) ?\\))) - ((= (preceding-char) ?\() - (setq parens (1+ parens))) - (t - (setq parens (1- parens))))))))) - (setq s (buffer-substring start (point))) - (if (and (null (string-match "^[\t\f\n\r ]+$" s)) - (not (string= s ""))) - (setq list (cons s list))) - (nreverse list)) ; jwz: fixed order - (and work-buffer (kill-buffer work-buffer))))))) - -(defun vm-parse-structured-header (string &optional sepchar keep-quotes) - (if (null string) - () - (let ((work-buffer nil)) - (save-excursion - (unwind-protect - (let ((list nil) - (nonspecials "^\"\\( \t\n\r\f") - start s char sp+sepchar) - (if sepchar - (setq nonspecials (concat nonspecials (list sepchar)) - sp+sepchar (concat "\t\f\n\r " (list sepchar)))) - (setq work-buffer (generate-new-buffer "*vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - (insert string) - (goto-char (point-min)) - (skip-chars-forward "\t\f\n\r ") - (setq start (point)) - (while (not (eobp)) - (skip-chars-forward nonspecials) - (setq char (following-char)) - (cond ((looking-at "[ \t\n\r\f]") - (delete-char 1)) - ((= char ?\\) - (forward-char 1) - (if (not (eobp)) - (forward-char 1))) - ((and sepchar (= char sepchar)) - (setq s (buffer-substring start (point))) - (if (or (null (string-match "^[\t\f\n\r ]+$" s)) - (not (string= s ""))) - (setq list (cons s list))) - (skip-chars-forward sp+sepchar) - (setq start (point))) - ((looking-at " \t\n\r\f") - (skip-chars-forward " \t\n\r\f")) - ((= char ?\") - (let ((done nil)) - (if keep-quotes - (forward-char 1) - (delete-char 1)) - (while (not done) - (if (null (re-search-forward "[\\\"]" nil t)) - (setq done t) - (setq char (char-after (1- (point)))) - (cond ((char-equal char ?\\) - (delete-char -1) - (if (eobp) - (setq done t) - (forward-char 1))) - (t (if (not keep-quotes) - (delete-char -1)) - (setq done t))))))) - ((= char ?\() - (let ((done nil) - (pos (point)) - (parens 1)) - (forward-char 1) - (while (not done) - (if (null (re-search-forward "[\\()]" nil t)) - (setq done t) - (setq char (char-after (1- (point)))) - (cond ((char-equal char ?\\) - (if (eobp) - (setq done t) - (forward-char 1))) - ((char-equal char ?\() - (setq parens (1+ parens))) - (t - (setq parens (1- parens) - done (zerop parens)))))) - (delete-region pos (point)))))) - (setq s (buffer-substring start (point))) - (if (and (null (string-match "^[\t\f\n\r ]+$" s)) - (not (string= s ""))) - (setq list (cons s list))) - (nreverse list)) - (and work-buffer (kill-buffer work-buffer))))))) - -(defun vm-write-string (where string) - (if (bufferp where) - (vm-save-buffer-excursion - (set-buffer where) - (goto-char (point-max)) - (insert string)) - (let ((temp-buffer nil)) - (unwind-protect - (save-excursion - (setq temp-buffer (generate-new-buffer "*vm-work*")) - (set-buffer temp-buffer) - (insert string) - ;; correct for VM's uses of this function--- - ;; writing out message separators - (setq buffer-file-type nil) - ;; Tell XEmacs/MULE to pick the correct newline conversion. - (and vm-xemacs-mule-p - (set-file-coding-system 'no-conversion nil)) - (write-region (point-min) (point-max) where t 'quiet)) - (and temp-buffer (kill-buffer temp-buffer)))))) - -(defmacro vm-marker (pos &optional buffer) - (list 'set-marker '(make-marker) pos buffer)) - -(defmacro vm-increment (variable) - (list 'setq variable (list '1+ variable))) - -(defmacro vm-decrement (variable) - (list 'setq variable (list '1- variable))) - -(defmacro vm-select-folder-buffer () - '(and vm-mail-buffer - (or (buffer-name vm-mail-buffer) - (error "Folder buffer has been killed.")) - (set-buffer vm-mail-buffer))) - -(defun vm-check-for-killed-summary () - (and (bufferp vm-summary-buffer) (null (buffer-name vm-summary-buffer)) - (let ((mp vm-message-list)) - (setq vm-summary-buffer nil) - (while mp - (vm-set-su-start-of (car mp) nil) - (vm-set-su-end-of (car mp) nil) - (setq mp (cdr mp)))))) - -(defun vm-check-for-killed-presentation () - (and (bufferp vm-presentation-buffer-handle) - (null (buffer-name vm-presentation-buffer-handle)) - (progn - (setq vm-presentation-buffer-handle nil - vm-presentation-buffer nil)))) - -(defun vm-check-for-killed-folder () - (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer)) - (setq vm-mail-buffer nil))) - -(defmacro vm-error-if-folder-read-only () - '(while vm-folder-read-only - (signal 'folder-read-only (list (current-buffer))))) - -(put 'folder-read-only 'error-conditions '(folder-read-only error)) -(put 'folder-read-only 'error-message "Folder is read-only") - -(defmacro vm-error-if-virtual-folder () - '(and (eq major-mode 'vm-virtual-mode) - (error "%s cannot be applied to virtual folders." this-command))) - -(defmacro vm-build-threads-if-unbuilt () - '(if (null vm-thread-obarray) - (vm-build-threads nil))) - -(defun vm-abs (n) (if (< n 0) (- n) n)) - -;; save-restriction flubs restoring the clipping region if you -;; (widen) and modify text outside the old region. -;; This should do it right. -(defmacro vm-save-restriction (&rest forms) - (let ((vm-sr-clip (make-symbol "vm-sr-clip")) - (vm-sr-min (make-symbol "vm-sr-min")) - (vm-sr-max (make-symbol "vm-sr-max"))) - (list 'let (list (list vm-sr-clip '(> (buffer-size) - (- (point-max) (point-min)))) - ;; this shouldn't be necessary but the - ;; byte-compiler turns these into interned symbols - ;; which utterly defeats the purpose of the - ;; make-symbol calls above. Soooo, until the compiler - ;; is fixed, these must be made into (let ...) - ;; temporaries so that nested calls to this macros - ;; won't misbehave. - vm-sr-min vm-sr-max) - (list 'and vm-sr-clip - (list 'setq vm-sr-min '(set-marker (make-marker) (point-min))) - (list 'setq vm-sr-max '(set-marker (make-marker) (point-max)))) - (list 'unwind-protect (cons 'progn forms) - '(widen) - (list 'and vm-sr-clip - (list 'progn - (list 'narrow-to-region vm-sr-min vm-sr-max) - (list 'set-marker vm-sr-min nil) - (list 'set-marker vm-sr-max nil))))))) - -(defmacro vm-save-buffer-excursion (&rest forms) - (list 'let '((vm-sbe-buffer (current-buffer))) - (list 'unwind-protect - (cons 'progn forms) - '(and (not (eq vm-sbe-buffer (current-buffer))) - (buffer-name vm-sbe-buffer) - (set-buffer vm-sbe-buffer))))) - -(defun vm-last (list) (while (cdr-safe list) (setq list (cdr list))) list) - -(defun vm-vector-to-list (vector) - (let ((i (1- (length vector))) - list) - (while (>= i 0) - (setq list (cons (aref vector i) list)) - (vm-decrement i)) - list )) - -(defun vm-extend-vector (vector length &optional fill) - (let ((vlength (length vector))) - (if (< vlength length) - (apply 'vector (nconc (vm-vector-to-list vector) - (make-list (- length vlength) fill))) - vector ))) - -(defun vm-obarray-to-string-list (blobarray) - (let ((list nil)) - (mapatoms (function (lambda (s) (setq list (cons (symbol-name s) list)))) - blobarray) - list )) - -(defun vm-mapcar (function &rest lists) - (let (arglist result) - (while (car lists) - (setq arglist (mapcar 'car lists)) - (setq result (cons (apply function arglist) result)) - (setq lists (mapcar 'cdr lists))) - (nreverse result))) - -(defun vm-mapc (function &rest lists) - (let (arglist) - (while (car lists) - (setq arglist (mapcar 'car lists)) - (apply function arglist) - (setq lists (mapcar 'cdr lists))))) - -(defun vm-delete (predicate list &optional reverse) - (let ((p list) (reverse (if reverse 'not 'identity)) prev) - (while p - (if (funcall reverse (funcall predicate (car p))) - (if (null prev) - (setq list (cdr list) p list) - (setcdr prev (cdr p)) - (setq p (cdr p))) - (setq prev p p (cdr p)))) - list )) - -(defun vm-delete-directory-file-names (list) - (vm-delete 'file-directory-p list)) - -(defun vm-delete-backup-file-names (list) - (vm-delete 'backup-file-name-p list)) - -(defun vm-delete-auto-save-file-names (list) - (vm-delete 'auto-save-file-name-p list)) - -(defun vm-delete-duplicates (list &optional all hack-addresses) - "Delete duplicate equivalent strings from the list. -If ALL is t, then if there is more than one occurrence of a string in the list, - then all occurrences of it are removed instead of just the subsequent ones. -If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, - and only the address part is compared (so that \"Name <foo>\" and \"foo\" - would be considered to be equivalent.)" - (let ((hashtable vm-delete-duplicates-obarray) - (new-list nil) - sym-string sym) - (fillarray hashtable 0) - (while list - (setq sym-string - (if hack-addresses - (nth 1 (funcall vm-chop-full-name-function (car list))) - (car list)) - sym-string (or sym-string "-unparseable-garbage-") - sym (intern sym-string hashtable)) - (if (boundp sym) - (and all (setcar (symbol-value sym) nil)) - (setq new-list (cons (car list) new-list)) - (set sym new-list)) - (setq list (cdr list))) - (delq nil (nreverse new-list)))) - -(defun vm-member-0 (thing list) - (catch 'done - (while list - (and (equal (car list) thing) - (throw 'done list)) - (setq list (cdr list))) - nil )) - -(fset 'vm-member (symbol-function (if (fboundp 'member) 'member 'vm-member-0))) - -(defun vm-delqual (ob list) - (let ((prev nil) - (curr list)) - (while curr - (if (not (equal ob (car curr))) - (setq prev curr - curr (cdr curr)) - (if (null prev) - (setq list (cdr list) - curr list) - (setq curr (cdr curr)) - (setcdr prev curr)))) - list )) - -(defun vm-copy-local-variables (buffer &rest variables) - (let ((values (mapcar 'symbol-value variables))) - (save-excursion - (set-buffer buffer) - (vm-mapc 'set variables values)))) - -(put 'folder-empty 'error-conditions '(folder-empty error)) -(put 'folder-empty 'error-message "Folder is empty") -(put 'unrecognized-folder-type 'error-conditions - '(unrecognized-folder-type error)) -(put 'unrecognized-folder-type 'error-message "Unrecognized folder type") - -(defun vm-error-if-folder-empty () - (while (null vm-message-list) - (if vm-folder-type - (signal 'unrecognized-folder-type nil) - (signal 'folder-empty nil)))) - -(defun vm-copy (object) - (cond ((consp object) - (let (return-value cons) - (setq return-value (cons (vm-copy (car object)) nil) - cons return-value - object (cdr object)) - (while (consp object) - (setcdr cons (cons (vm-copy (car object)) nil)) - (setq cons (cdr cons) - object (cdr object))) - (setcdr cons object) - return-value )) - ((vectorp object) (apply 'vector (mapcar 'vm-copy object))) - ((stringp object) (copy-sequence object)) - ((markerp object) (copy-marker object)) - (t object))) - -(defun vm-multiple-frames-possible-p () - (cond (vm-xemacs-p - (or (memq 'win (device-matching-specifier-tag-list)) - (featurep 'tty-frames))) - (vm-fsfemacs-19-p - (fboundp 'make-frame)))) - -(defun vm-mouse-support-possible-p () - (cond (vm-xemacs-p - (featurep 'window-system)) - (vm-fsfemacs-19-p - (fboundp 'track-mouse)))) - -(defun vm-mouse-support-possible-here-p () - (cond (vm-xemacs-p - (memq 'win (device-matching-specifier-tag-list))) - (vm-fsfemacs-19-p - (eq window-system 'x)))) - -(defun vm-menu-support-possible-p () - (cond (vm-xemacs-p - (featurep 'menubar)) - (vm-fsfemacs-19-p - (fboundp 'menu-bar-mode)))) - -(defun vm-toolbar-support-possible-p () - (and vm-xemacs-p (featurep 'toolbar))) - -(defun vm-multiple-fonts-possible-p () - (cond (vm-xemacs-p - (eq (device-type) 'x)) - (vm-fsfemacs-19-p - (or (eq window-system 'x) - (eq window-system 'win32))))) - -(defun vm-run-message-hook (message &optional hook-variable) - (save-excursion - (set-buffer (vm-buffer-of message)) - (vm-save-restriction - (widen) - (save-excursion - (narrow-to-region (vm-headers-of message) (vm-text-end-of message)) - (run-hooks hook-variable))))) - -(defun vm-error-free-call (function &rest args) - (condition-case nil - (apply function args) - (error nil))) - -(put 'beginning-of-folder 'error-conditions '(beginning-of-folder error)) -(put 'beginning-of-folder 'error-message "Beginning of folder") -(put 'end-of-folder 'error-conditions '(end-of-folder error)) -(put 'end-of-folder 'error-message "End of folder") - -(defun vm-trace (&rest args) - (save-excursion - (set-buffer (get-buffer-create "*vm-trace*")) - (apply 'insert args))) - -(defun vm-timezone-make-date-sortable (string) - (or (cdr (assq string vm-sortable-date-alist)) - (let ((vect (vm-parse-date string)) - (date (vm-parse (current-time-string) " *\\([^ ]+\\)"))) - ;; if specified date is incomplete fill in the holes - ;; with useful information, defaulting to the current - ;; date and timezone for everything except hh:mm:ss which - ;; defaults to midnight. - (if (equal (aref vect 1) "") - (aset vect 1 (nth 2 date))) - (if (equal (aref vect 2) "") - (aset vect 2 (nth 1 date))) - (if (equal (aref vect 3) "") - (aset vect 3 (nth 4 date))) - (if (equal (aref vect 4) "") - (aset vect 4 "00:00:00")) - (if (equal (aref vect 5) "") - (aset vect 5 (vm-current-time-zone))) - ;; save this work so we won't have to do it again - (setq vm-sortable-date-alist - (cons (cons string - (condition-case nil - (timezone-make-date-sortable - (format "%s %s %s %s %s" - (aref vect 1) - (aref vect 2) - (aref vect 3) - (aref vect 4) - (aref vect 5))) - (error "1970010100:00:00"))) - vm-sortable-date-alist)) - ;; return result - (cdr (car vm-sortable-date-alist))))) - -(defun vm-current-time-zone () - (or (condition-case nil - (let* ((zone (car (current-time-zone))) - (absmin (/ (vm-abs zone) 60))) - (format "%c%02d%02d" (if (< zone 0) ?- ?+) - (/ absmin 60) (% absmin 60))) - (error nil)) - (let ((temp-buffer nil)) - (condition-case nil - (unwind-protect - (save-excursion - (setq temp-buffer (generate-new-buffer "*vm-work*")) - (set-buffer temp-buffer) - (call-process "date" nil temp-buffer nil) - (nth 4 (vm-parse (vm-buffer-string-no-properties) - " *\\([^ ]+\\)"))) - (and temp-buffer (kill-buffer temp-buffer))) - (error nil))) - "")) - -(defun vm-should-generate-summary () - (cond ((eq vm-startup-with-summary t) t) - ((integerp vm-startup-with-summary) - (let ((n vm-startup-with-summary)) - (cond ((< n 0) (null (nth (vm-abs n) vm-message-list))) - (t (nth (1- n) vm-message-list))))) - (vm-startup-with-summary t) - (t nil))) - -(defun vm-find-composition-buffer (&optional not-picky) - (let ((b-list (buffer-list)) choice alternate) - (save-excursion - (while b-list - (set-buffer (car b-list)) - (if (eq major-mode 'mail-mode) - (if (buffer-modified-p) - (setq choice (current-buffer) - b-list nil) - (and not-picky (null alternate) - (setq alternate (current-buffer))) - (setq b-list (cdr b-list))) - (setq b-list (cdr b-list)))) - (or choice alternate)))) - -(defun vm-get-file-buffer (file) - "Like get-file-buffer, but also checks buffers against FILE's truename" - (or (get-file-buffer file) - (and (fboundp 'file-truename) - (get-file-buffer (file-truename file))))) - -(defun vm-set-region-face (start end face) - (let ((e (vm-make-extent start end))) - (vm-set-extent-property e 'face face))) - -(defun vm-default-buffer-substring-no-properties (beg end &optional buffer) - (let ((s (if buffer - (save-excursion - (set-buffer buffer) - (buffer-substring beg end)) - (buffer-substring beg end)))) - (set-text-properties 0 (length s) nil s) - (copy-sequence s))) - -(fset 'vm-buffer-substring-no-properties - (cond ((fboundp 'buffer-substring-no-properties) - (function buffer-substring-no-properties)) - (vm-xemacs-p - (function buffer-substring)) - (t (function vm-default-buffer-substring-no-properties)))) - -(defun vm-buffer-string-no-properties () - (vm-buffer-substring-no-properties (point-min) (point-max))) - -(defun vm-insert-region-from-buffer (buffer &optional start end) - (let ((target-buffer (current-buffer))) - (set-buffer buffer) - (save-restriction - (widen) - (or start (setq start (point-min))) - (or end (setq end (point-max))) - (set-buffer target-buffer) - (insert-buffer-substring buffer start end) - (set-buffer buffer)) - (set-buffer target-buffer))) - -(if (not (fboundp 'vm-extent-property)) - (if (fboundp 'overlay-get) - (fset 'vm-extent-property 'overlay-get) - (fset 'vm-extent-property 'extent-property))) - -(if (not (fboundp 'vm-set-extent-property)) - (if (fboundp 'overlay-put) - (fset 'vm-set-extent-property 'overlay-put) - (fset 'vm-set-extent-property 'set-extent-property))) - -(if (not (fboundp 'vm-set-extent-endpoints)) - (if (fboundp 'move-overlay) - (fset 'vm-set-extent-endpoints 'move-overlay) - (fset 'vm-set-extent-endpoints 'set-extent-endpoints))) - -(if (not (fboundp 'vm-make-extent)) - (if (fboundp 'make-overlay) - (fset 'vm-make-extent 'make-overlay) - (fset 'vm-make-extent 'make-extent))) - -(if (not (fboundp 'vm-extent-end-position)) - (if (fboundp 'overlay-end) - (fset 'vm-extent-end-position 'overlay-end) - (fset 'vm-extent-end-position 'extent-end-position))) - -(if (not (fboundp 'vm-extent-start-position)) - (if (fboundp 'overlay-start) - (fset 'vm-extent-start-position 'overlay-start) - (fset 'vm-extent-start-position 'extent-start-position))) - -(if (not (fboundp 'vm-detach-extent)) - (if (fboundp 'delete-overlay) - (fset 'vm-detach-extent 'delete-overlay) - (fset 'vm-detach-extent 'detach-extent))) - -(if (not (fboundp 'vm-extent-properties)) - (if (fboundp 'overlay-properties) - (fset 'vm-extent-properties 'overlay-properties) - (fset 'vm-extent-properties 'extent-properties))) - -(defun vm-copy-extent (e) - (let ((props (vm-extent-properties e)) - (ee (vm-make-extent (vm-extent-start-position e) - (vm-extent-end-position e)))) - (while props - (vm-set-extent-property ee (car props) (car (cdr props))) - (setq props (cdr (cdr props)))))) - -(defun vm-make-tempfile-name () - (let ((done nil) (pid (emacs-pid)) filename) - (while (not done) - (setq filename (format "%s/vm%d.%d" vm-temp-file-directory pid - vm-tempfile-counter) - vm-tempfile-counter (1+ vm-tempfile-counter) - done (not (file-exists-p filename)))) - filename )) - -(defun vm-insert-char (char &optional count ignored buffer) - (condition-case nil - (progn - (insert-char char count ignored buffer) - (fset 'vm-insert-char 'insert-char)) - (wrong-number-of-arguments - (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char) - (vm-insert-char char count ignored buffer)))) - -(defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer) - (if (and buffer (eq buffer (current-buffer))) - (insert-char char count) - (save-excursion - (set-buffer buffer) - (insert-char char count)))) - -(defun vm-symbol-lists-intersect-p (list1 list2) - (catch 'done - (while list1 - (and (memq (car list1) list2) - (throw 'done t)) - (setq list1 (cdr list1))) - nil )) - -(defun vm-set-buffer-variable (buffer var value) - (save-excursion - (set-buffer buffer) - (set var value))) - -(defun vm-buffer-variable-value (buffer var) - (save-excursion - (set-buffer buffer) - (symbol-value var))) - -(defsubst vm-with-string-as-temp-buffer (string function) - (let ((work-buffer nil)) - (unwind-protect - (save-excursion - (setq work-buffer (generate-new-buffer " *work*")) - (set-buffer work-buffer) - (insert string) - (funcall function) - (buffer-string)) - (and work-buffer (kill-buffer work-buffer))))) - -(defmacro vm-with-virtual-selector-variables (&rest forms) - (append '(let ((any 'vm-vs-any) - (and 'vm-vs-and) - (or 'vm-vs-or) - (not 'vm-vs-not) - (header 'vm-vs-header) - (label 'vm-vs-label) - (text 'vm-vs-text) - (recipient 'vm-vs-recipient) - (author 'vm-vs-author) - (subject 'vm-vs-subject) - (sent-before 'vm-vs-sent-before) - (sent-after 'vm-vs-sent-after) - (more-chars-than 'vm-vs-more-chars-than) - (less-chars-than 'vm-vs-less-chars-than) - (more-lines-than 'vm-vs-more-lines-than) - (less-lines-than 'vm-vs-less-lines-than) - (new 'vm-vs-new) - (unread 'vm-vs-unread) - (read 'vm-vs-read) - (deleted 'vm-vs-deleted) - (replied 'vm-vs-replied) - (forwarded 'vm-vs-forwarded) - (filed 'vm-vs-filed) - (written 'vm-vs-written) - (edited 'vm-vs-edited) - (marked 'vm-vs-marked))) - forms)) - -(defun vm-string-assoc (elt list) - (let ((case-fold-search t) - (found nil) - (elt (regexp-quote elt))) - (while (and list (not found)) - (if (and (equal 0 (string-match elt (car (car list)))) - (= (match-end 0) (length (car (car list))))) - (setq found t) - (setq list (cdr list)))) - (car list))) - -(defun vm-string-member (elt list) - (let ((case-fold-search t) - (found nil) - (elt (regexp-quote elt))) - (while (and list (not found)) - (if (and (equal 0 (string-match elt (car list))) - (= (match-end 0) (length (car list)))) - (setq found t) - (setq list (cdr list)))) - list)) - -(defmacro vm-assert (expression) - (list 'or expression - (list 'progn - (list 'setq 'debug-on-error t) - (list 'error "assertion failed: %S" - (list 'quote expression)))))
--- a/lisp/vm/vm-motion.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,461 +0,0 @@ -;;; Commands to move around in a VM folder -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-motion) - -(defun vm-record-and-change-message-pointer (old new) - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-garbage-collect-message) - (setq vm-last-message-pointer old - vm-message-pointer new - vm-need-summary-pointer-update t)) - -(defun vm-goto-message (n) - "Go to the message numbered N. -Interactively N is the prefix argument. If no prefix arg is provided -N is prompted for in the minibuffer. - -If vm-follow-summary-cursor is non-nil this command will go to -the message under the cursor in the summary buffer if the summary -window is selected. This only happens if no prefix argument is -given." - (interactive - (list - (cond (current-prefix-arg (prefix-numeric-value current-prefix-arg)) - ((vm-follow-summary-cursor) nil) - (t - (let ((last-command last-command) - (this-command this-command)) - (vm-read-number "Go to message: ")))))) - (if (null n) - () ; nil means work has been done already - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-display nil nil '(vm-goto-message) '(vm-goto-message)) - (let ((cons (nthcdr (1- n) vm-message-list))) - (if (null cons) - (error "No such message.")) - (if (eq vm-message-pointer cons) - (vm-preview-current-message) - (vm-record-and-change-message-pointer vm-message-pointer cons) - (vm-preview-current-message))))) - -(defun vm-goto-message-last-seen () - "Go to the message last previewed." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-display nil nil '(vm-goto-message-last-seen) - '(vm-goto-message-last-seen)) - (if vm-last-message-pointer - (progn - (vm-record-and-change-message-pointer vm-message-pointer - vm-last-message-pointer) - (vm-preview-current-message)))) - -(defun vm-goto-parent-message () - "Go to the parent of the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-build-threads-if-unbuilt) - (vm-display nil nil '(vm-goto-parent-message) - '(vm-goto-parent-message)) - (let ((list (vm-th-thread-list (car vm-message-pointer))) - message) - (if (null (cdr list)) - (message "Message has no parent.") - (while (cdr (cdr list)) - (setq list (cdr list))) - (setq message (car (get (car list) 'messages))) - (if (null message) - (message "Parent message is not in this folder.") - (vm-record-and-change-message-pointer vm-message-pointer - (memq message vm-message-list)) - (vm-preview-current-message))))) - -(defun vm-check-count (count) - (if (>= count 0) - (if (< (length vm-message-pointer) count) - (signal 'end-of-folder nil)) - (if (< (1+ (- (length vm-message-list) (length vm-message-pointer))) - (vm-abs count)) - (signal 'beginning-of-folder nil)))) - -(defun vm-move-message-pointer (direction) - (let ((mp vm-message-pointer)) - (if (eq direction 'forward) - (progn - (setq mp (cdr mp)) - (if (null mp) - (if vm-circular-folders - (setq mp vm-message-list) - (signal 'end-of-folder nil)))) - (setq mp (vm-reverse-link-of (car mp))) - (if (null mp) - (if vm-circular-folders - (setq mp (vm-last vm-message-list)) - (signal 'beginning-of-folder nil)))) - (setq vm-message-pointer mp))) - -(defun vm-should-skip-message (mp &optional skip-dogmatically) - (if skip-dogmatically - (or (and vm-skip-deleted-messages - (vm-deleted-flag (car mp))) - (and vm-skip-read-messages - (or (vm-deleted-flag (car mp)) - (not (or (vm-new-flag (car mp)) - (vm-unread-flag (car mp)))))) - (and (eq last-command 'vm-next-command-uses-marks) - (null (vm-mark-of (car mp))))) - (or (and (eq vm-skip-deleted-messages t) - (vm-deleted-flag (car mp))) - (and (eq vm-skip-read-messages t) - (or (vm-deleted-flag (car mp)) - (not (or (vm-new-flag (car mp)) - (vm-unread-flag (car mp)))))) - (and (eq last-command 'vm-next-command-uses-marks) - (null (vm-mark-of (car mp))))))) - -(defun vm-next-message (&optional count retry signal-errors) - "Go forward one message and preview it. -With prefix arg (optional first argument) COUNT, go forward COUNT -messages. A negative COUNT means go backward. If the absolute -value of COUNT is greater than 1, then the values of the variables -vm-skip-deleted-messages and vm-skip-read-messages are ignored. - -When invoked on marked messages (via vm-next-command-uses-marks) -this command 'sees' marked messages as it moves." - ;; second arg RETRY non-nil means retry a failed move, giving - ;; not nil-or-t values of the vm-skip variables a chance to - ;; work. - ;; - ;; third arg SIGNAL-ERRORS non-nil means that if after - ;; everything we still have bashed into the end or beginning of - ;; folder before completing the move, signal - ;; beginning-of-folder or end-of-folder. Otherwise no error - ;; will be signaled. - ;; - ;; Note that interactively all args are 1, so error signaling - ;; and retries apply to all interactive moves. - (interactive "p\np\np") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - ;; include other commands that call vm-next-message so that the - ;; correct window configuration is applied for these particular - ;; non-interactive calls. - (vm-display nil nil '(vm-next-message - vm-delete-message - vm-undelete-message - vm-scroll-forward) - (list this-command)) - (and signal-errors (vm-error-if-folder-empty)) - (or count (setq count 1)) - (let ((oldmp vm-message-pointer) - (use-marks (eq last-command 'vm-next-command-uses-marks)) - (error) - (direction (if (> count 0) 'forward 'backward)) - (count (vm-abs count))) - (cond - ((null vm-message-pointer) - (setq vm-message-pointer vm-message-list)) - ((/= count 1) - (condition-case () - (let ((oldmp oldmp)) - (while (not (zerop count)) - (vm-move-message-pointer direction) - (if (and use-marks (null (vm-mark-of (car vm-message-pointer)))) - (progn - (while (and (not (eq vm-message-pointer oldmp)) - (null (vm-mark-of (car vm-message-pointer)))) - (vm-move-message-pointer direction)) - (if (eq vm-message-pointer oldmp) - ;; terminate the loop - (setq count 1) - ;; reset for next pass - (setq oldmp vm-message-pointer)))) - (vm-decrement count))) - (beginning-of-folder (setq error 'beginning-of-folder)) - (end-of-folder (setq error 'end-of-folder)))) - (t - (condition-case () - (progn - (vm-move-message-pointer direction) - (while (and (not (eq oldmp vm-message-pointer)) - (vm-should-skip-message vm-message-pointer t)) - (vm-move-message-pointer direction)) - ;; Retry the move if we've gone a complete circle and - ;; retries are allowed and there are other messages - ;; besides this one. - (and (eq vm-message-pointer oldmp) retry (cdr vm-message-list) - (progn - (vm-move-message-pointer direction) - (while (and (not (eq oldmp vm-message-pointer)) - (vm-should-skip-message vm-message-pointer)) - (vm-move-message-pointer direction))))) - (beginning-of-folder - ;; we bumped into the beginning of the folder without finding - ;; a suitable stopping point; retry the move if we're allowed. - (setq vm-message-pointer oldmp) - ;; if the retry fails, we make sure the message pointer - ;; is restored to its old value. - (if retry - (setq vm-message-pointer - (condition-case () - (let ((vm-message-pointer vm-message-pointer)) - (vm-move-message-pointer direction) - (while (vm-should-skip-message vm-message-pointer) - (vm-move-message-pointer direction)) - vm-message-pointer ) - (beginning-of-folder - (setq error 'beginning-of-folder) - oldmp ))) - (setq error 'beginning-of-folder))) - (end-of-folder - ;; we bumped into the end of the folder without finding - ;; a suitable stopping point; retry the move if we're allowed. - (setq vm-message-pointer oldmp) - ;; if the retry fails, we make sure the message pointer - ;; is restored to its old value. - (if retry - (setq vm-message-pointer - (condition-case () - (let ((vm-message-pointer vm-message-pointer)) - (vm-move-message-pointer direction) - (while (vm-should-skip-message vm-message-pointer) - (vm-move-message-pointer direction)) - vm-message-pointer ) - (end-of-folder - (setq error 'end-of-folder) - oldmp ))) - (setq error 'end-of-folder)))))) - (if (not (eq vm-message-pointer oldmp)) - (progn - (vm-record-and-change-message-pointer oldmp vm-message-pointer) - (vm-preview-current-message))) - (and error signal-errors - (signal error nil)))) - -(defun vm-previous-message (&optional count retry signal-errors) - "Go back one message and preview it. -With prefix arg COUNT, go backward COUNT messages. A negative COUNT -means go forward. If the absolute value of COUNT > 1 the values of the -variables vm-skip-deleted-messages and vm-skip-read-messages are -ignored." - (interactive "p\np\np") - (or count (setq count 1)) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-display nil nil '(vm-previous-message) '(vm-previous-message)) - (vm-next-message (- count) retry signal-errors)) - -(defun vm-next-message-no-skip (&optional count) - "Like vm-next-message but will not skip deleted or read messages." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-display nil nil '(vm-next-message-no-skip) - '(vm-next-message-no-skip)) - (let ((vm-skip-deleted-messages nil) - (vm-skip-read-messages nil)) - (vm-next-message count nil t))) -;; backward compatibility -(fset 'vm-Next-message 'vm-next-message-no-skip) - -(defun vm-previous-message-no-skip (&optional count) - "Like vm-previous-message but will not skip deleted or read messages." - (interactive "p") - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-display nil nil '(vm-previous-message-no-skip) - '(vm-previous-message-no-skip)) - (let ((vm-skip-deleted-messages nil) - (vm-skip-read-messages nil)) - (vm-previous-message count))) -;; backward compatibility -(fset 'vm-Previous-message 'vm-previous-message-no-skip) - -(defun vm-next-unread-message () - "Move forward to the nearest new or unread message, if there is one." - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-next-unread-message) '(vm-next-unread-message)) - (condition-case () - (let ((vm-skip-read-messages t) - (oldmp vm-message-pointer)) - (vm-next-message 1 nil t) - ;; in case vm-circular-folders is non-nil - (and (eq vm-message-pointer oldmp) (signal 'end-of-folder nil))) - (end-of-folder (message "No next unread message")))) - -(defun vm-previous-unread-message () - "Move backward to the nearest new or unread message, if there is one." - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-previous-unread-message) - '(vm-previous-unread-message)) - (condition-case () - (let ((vm-skip-read-messages t) - (oldmp vm-message-pointer)) - (vm-previous-message) - ;; in case vm-circular-folders is non-nil - (and (eq vm-message-pointer oldmp) (signal 'beginning-of-folder nil))) - (beginning-of-folder (message "No previous unread message")))) - -(defun vm-next-message-same-subject () - "Move forward to the nearest message with the same subject. -vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply -to the subject comparisons." - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-next-message-same-subject) - '(vm-next-message-same-subject)) - (let ((oldmp vm-message-pointer) - (done nil) - (subject (vm-so-sortable-subject (car vm-message-pointer)))) - (condition-case () - (progn - (while (not done) - (vm-move-message-pointer 'forward) - (if (eq oldmp vm-message-pointer) - (signal 'end-of-folder nil)) - (if (equal subject - (vm-so-sortable-subject (car vm-message-pointer))) - (setq done t))) - (vm-record-and-change-message-pointer oldmp vm-message-pointer) - (vm-preview-current-message)) - (end-of-folder - (setq vm-message-pointer oldmp) - (message "No next message with the same subject"))))) - -(defun vm-previous-message-same-subject () - "Move backward to the nearest message with the same subject. -vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply -to the subject comparisons." - (interactive) - (if (interactive-p) - (vm-follow-summary-cursor)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-previous-message-same-subject) - '(vm-previous-message-same-subject)) - (let ((oldmp vm-message-pointer) - (done nil) - (subject (vm-so-sortable-subject (car vm-message-pointer)))) - (condition-case () - (progn - (while (not done) - (vm-move-message-pointer 'backward) - (if (eq oldmp vm-message-pointer) - (signal 'beginning-of-folder nil)) - (if (equal subject - (vm-so-sortable-subject (car vm-message-pointer))) - (setq done t))) - (vm-record-and-change-message-pointer oldmp vm-message-pointer) - (vm-preview-current-message)) - (beginning-of-folder - (setq vm-message-pointer oldmp) - (message "No previous message with the same subject"))))) - -(defun vm-find-first-unread-message (new) - (let (mp unread-mp) - (setq mp vm-message-list) - (if new - (while mp - (if (and (vm-new-flag (car mp)) (not (vm-deleted-flag (car mp)))) - (setq unread-mp mp mp nil) - (setq mp (cdr mp)))) - (while mp - (if (and (or (vm-new-flag (car mp)) (vm-unread-flag (car mp))) - (not (vm-deleted-flag (car mp)))) - (setq unread-mp mp mp nil) - (setq mp (cdr mp))))) - unread-mp )) - -(defun vm-thoughtfully-select-message () - (let ((new (and vm-jump-to-new-messages (vm-find-first-unread-message t))) - (unread (and vm-jump-to-unread-messages - (vm-find-first-unread-message nil))) - fix mp) - (if (null vm-message-pointer) - (setq fix (vm-last vm-message-list))) - (setq mp (or new unread fix)) - (if (and mp (not (eq mp vm-message-pointer))) - (progn - (vm-record-and-change-message-pointer vm-message-pointer mp) - mp ) - nil ))) - -(defun vm-follow-summary-cursor () - (and vm-follow-summary-cursor (eq major-mode 'vm-summary-mode) - (let ((point (point)) - message-pointer message-list mp) - (save-excursion - (set-buffer vm-mail-buffer) - (setq message-pointer vm-message-pointer - message-list vm-message-list)) - (cond ((or (null message-pointer) - (and (>= point (vm-su-start-of (car message-pointer))) - (< point (vm-su-end-of (car message-pointer))))) - nil ) - ;; the position at eob belongs to the last message - ((and (eobp) (= (vm-su-end-of (car message-pointer)) point)) - nil ) - ;; make the position at eob belong to the last message - ((eobp) - (setq mp (vm-last message-pointer)) - (save-excursion - (set-buffer vm-mail-buffer) - (vm-record-and-change-message-pointer vm-message-pointer mp) - (vm-preview-current-message) - ;; return non-nil so the caller will know that - ;; a new message was selected. - t )) - (t - (if (< point (vm-su-start-of (car message-pointer))) - (setq mp message-list) - (setq mp (cdr message-pointer) message-pointer nil)) - (while (and (not (eq mp message-pointer)) - (>= point (vm-su-end-of (car mp)))) - (setq mp (cdr mp))) - (if (not (eq mp message-pointer)) - (save-excursion - (set-buffer vm-mail-buffer) - (vm-record-and-change-message-pointer - vm-message-pointer mp) - (vm-preview-current-message) - ;; return non-nil so the caller will know that - ;; a new message was selected. - t )))))))
--- a/lisp/vm/vm-mouse.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,492 +0,0 @@ -;;; Mouse related functions and commands -;;; Copyright (C) 1995-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-mouse) - -(defun vm-mouse-fsfemacs-mouse-p () - (and vm-fsfemacs-19-p - (fboundp 'set-mouse-position))) - -(defun vm-mouse-xemacs-mouse-p () - (and vm-xemacs-p - (fboundp 'set-mouse-position))) - -(defun vm-mouse-set-mouse-track-highlight (start end) - (cond (vm-fsfemacs-19-p - (let ((o (make-overlay start end))) - (overlay-put o 'mouse-face 'highlight))) - (vm-xemacs-p - (let ((o (make-extent start end))) - (set-extent-property o 'highlight t))))) - -(defun vm-mouse-button-2 (event) - (interactive "e") - ;; go to where the event occurred - (cond ((vm-mouse-xemacs-mouse-p) - (set-buffer (window-buffer (event-window event))) - (and (event-point event) (goto-char (event-point event)))) - ((vm-mouse-fsfemacs-mouse-p) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))))) - ;; now dispatch depending on where we are - (cond ((eq major-mode 'vm-summary-mode) - (mouse-set-point event) - (beginning-of-line) - (if (let ((vm-follow-summary-cursor t)) - (vm-follow-summary-cursor)) - nil - (setq this-command 'vm-scroll-forward) - (call-interactively 'vm-scroll-forward))) - ((memq major-mode '(vm-mode vm-virtual-mode vm-presentation-mode)) - (vm-mouse-popup-or-select event)))) - -(defun vm-mouse-button-3 (event) - (interactive "e") - (if vm-use-menus - (progn - ;; go to where the event occurred - (cond ((vm-mouse-xemacs-mouse-p) - (set-buffer (window-buffer (event-window event))) - (and (event-point event) (goto-char (event-point event)))) - ((vm-mouse-fsfemacs-mouse-p) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))))) - ;; now dispatch depending on where we are - (cond ((eq major-mode 'vm-summary-mode) - (vm-menu-popup-mode-menu event)) - ((eq major-mode 'vm-mode) - (vm-menu-popup-context-menu event)) - ((eq major-mode 'vm-presentation-mode) - (vm-menu-popup-context-menu event)) - ((eq major-mode 'vm-virtual-mode) - (vm-menu-popup-context-menu event)) - ((eq major-mode 'mail-mode) - (vm-menu-popup-context-menu event)))))) - -(defun vm-mouse-3-help (object) - nil - "Use mouse button 3 to see a menu of options.") - -(defun vm-mouse-get-mouse-track-string (event) - (save-excursion - ;; go to where the event occurred - (cond ((vm-mouse-xemacs-mouse-p) - (set-buffer (window-buffer (event-window event))) - (and (event-point event) (goto-char (event-point event)))) - ((vm-mouse-fsfemacs-mouse-p) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))))) - (cond (vm-fsfemacs-19-p - (let ((o-list (overlays-at (point))) - (string nil)) - (while o-list - (if (overlay-get (car o-list) 'mouse-face) - (setq string (vm-buffer-substring-no-properties - (overlay-start (car o-list)) - (overlay-end (car o-list))) - o-list nil) - (setq o-list (cdr o-list)))) - string )) - (vm-xemacs-p - (let ((e (extent-at (point) nil 'highlight))) - (if e - (buffer-substring (extent-start-position e) - (extent-end-position e)) - nil))) - (t nil)))) - -(defun vm-mouse-popup-or-select (event) - (interactive "e") - (cond ((vm-mouse-fsfemacs-mouse-p) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))) - (let (o-list (found nil)) - (setq o-list (overlays-at (point))) - (while (and o-list (not found)) - (cond ((overlay-get (car o-list) 'vm-url) - (setq found t) - (vm-mouse-send-url-at-event event)) - ((overlay-get (car o-list) 'vm-mime-function) - (setq found t) - (funcall (overlay-get (car o-list) 'vm-mime-function) - (car o-list)))) - (setq o-list (cdr o-list))) - (and (not found) (vm-menu-popup-context-menu event)))) - ;; The XEmacs code is not actually used now, since all - ;; selectable objects are handled by an extent keymap - ;; binding that points to a more specific function. But - ;; this might come in handy later if I want selectable - ;; objects that don't have an extent or extent keymap - ;; attached. - ((vm-mouse-xemacs-mouse-p) - (set-buffer (window-buffer (event-window event))) - (and (event-point event) (goto-char (event-point event))) - (let (e) - (cond ((extent-at (point) (current-buffer) 'vm-url) - (vm-mouse-send-url-at-event event)) - ((setq e (extent-at (point) nil 'vm-mime-function)) - (funcall (extent-property e 'vm-mime-function) e)) - (t (vm-menu-popup-context-menu event))))))) - -(defun vm-mouse-send-url-at-event (event) - (interactive "e") - (cond ((vm-mouse-xemacs-mouse-p) - (set-buffer (window-buffer (event-window event))) - (and (event-point event) (goto-char (event-point event))) - (vm-mouse-send-url-at-position (event-point event))) - ((vm-mouse-fsfemacs-mouse-p) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))) - (vm-mouse-send-url-at-position (posn-point (event-start event)))))) - -(defun vm-mouse-send-url-at-position (pos &optional browser) - (save-restriction - (widen) - (cond ((vm-mouse-xemacs-mouse-p) - (let ((e (extent-at pos (current-buffer) 'vm-url)) - url) - (if (null e) - nil - (setq url (buffer-substring (extent-start-position e) - (extent-end-position e))) - (vm-mouse-send-url url browser)))) - ((vm-mouse-fsfemacs-mouse-p) - (let (o-list url o) - (setq o-list (overlays-at pos)) - (while (and o-list (null (overlay-get (car o-list) 'vm-url))) - (setq o-list (cdr o-list))) - (if (null o-list) - nil - (setq o (car o-list)) - (setq url (vm-buffer-substring-no-properties - (overlay-start o) - (overlay-end o))) - (vm-mouse-send-url url browser))))))) - -(defun vm-mouse-send-url (url &optional browser) - (if (string-match "^mailto:" url) - (vm-mail-to-mailto-url url) - (let ((browser (or browser vm-url-browser))) - (cond ((symbolp browser) - (funcall browser url)) - ((stringp browser) - (message "Sending URL to %s..." browser) - (vm-run-background-command browser url) - (message "Sending URL to %s... done" browser)))))) - -(defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) - (message "Sending URL to Netscape...") - (if new-netscape - (apply 'vm-run-background-command vm-netscape-program - (append vm-netscape-program-switches (list url))) - (or (equal 0 (apply 'vm-run-command vm-netscape-program "-remote" - (append (list (concat "openURL(" url - (if new-window ", new-window" "") - ")")) - vm-netscape-program-switches))) - (vm-mouse-send-url-to-netscape url t new-window))) - (message "Sending URL to Netscape... done")) - -(defun vm-mouse-send-url-to-netscape-new-window (url) - (vm-mouse-send-url-to-netscape url nil t)) - -(defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window) - (message "Sending URL to Mosaic...") - (if (null new-mosaic) - (let ((pid-file "~/.mosaicpid") - (work-buffer " *mosaic work*") - pid) - (cond ((file-exists-p pid-file) - (set-buffer (get-buffer-create work-buffer)) - (erase-buffer) - (insert-file-contents pid-file) - (setq pid (int-to-string (string-to-int (buffer-string)))) - (erase-buffer) - (insert (if new-window "newwin" "goto") ?\n) - (insert url ?\n) - ;; newline convention used should be the local - ;; one, whatever that is. - (setq buffer-file-type nil) - (and vm-xemacs-mule-p - (set-buffer-file-coding-system 'no-conversion nil)) - (write-region (point-min) (point-max) - (concat "/tmp/Mosaic." pid) - nil 0) - (set-buffer-modified-p nil) - (kill-buffer work-buffer))) - (cond ((or (null pid) - (not (equal 0 (vm-run-command "kill" "-USR1" pid)))) - (setq new-mosaic t))))) - (if new-mosaic - (apply 'vm-run-background-command vm-mosaic-program - (append vm-mosaic-program-switches (list url)))) - (message "Sending URL to Mosaic... done")) - -(defun vm-mouse-send-url-to-mosaic-new-window (url) - (vm-mouse-send-url-to-mosaic url nil t)) - -(defun vm-mouse-install-mouse () - (cond ((vm-mouse-xemacs-mouse-p) - (if (null (lookup-key vm-mode-map 'button2)) - (define-key vm-mode-map 'button2 'vm-mouse-button-2))) - ((vm-mouse-fsfemacs-mouse-p) - (if (null (lookup-key vm-mode-map [mouse-2])) - (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2)) - (if vm-popup-menu-on-mouse-3 - (progn - (define-key vm-mode-map [mouse-3] 'ignore) - (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3)))))) - -(defun vm-run-background-command (command &rest arg-list) - (apply (function call-process) command nil 0 nil arg-list)) - -(defun vm-run-command (command &rest arg-list) - (apply (function call-process) command nil nil nil arg-list)) - -;; return t on zero exit status -;; return (exit-status . stderr-string) on nonzero exit status -(defun vm-run-command-on-region (start end output-buffer command - &rest arg-list) - (let ((tempfile nil) - ;; for DOS/Windows command to tell it that its input is - ;; binary. - (binary-process-input t) - status errstring) - (unwind-protect - (progn - (setq tempfile (vm-make-tempfile-name)) - (setq status - (apply 'call-process-region - start end command nil - (list output-buffer tempfile) - nil arg-list)) - (cond ((equal status 0) t) - ;; even if exit status non-zero, if there was no - ;; diagnostic output the command probably - ;; succeeded. I have tried to just use exit status - ;; as the failure criterion and users complained. - ((equal (nth 7 (file-attributes tempfile)) 0) - (message "%s exited non-zero (code %s)" command status) - t) - (t (save-excursion - (message "%s exited non-zero (code %s)" command status) - (set-buffer (find-file-noselect tempfile)) - (setq errstring (buffer-string)) - (kill-buffer nil) - (cons status errstring))))) - (vm-error-free-call 'delete-file tempfile)))) - -;; stupid yammering compiler -(defvar vm-mouse-read-file-name-prompt) -(defvar vm-mouse-read-file-name-dir) -(defvar vm-mouse-read-file-name-default) -(defvar vm-mouse-read-file-name-must-match) -(defvar vm-mouse-read-file-name-initial) -(defvar vm-mouse-read-file-name-history) -(defvar vm-mouse-read-file-name-return-value) - -(defun vm-mouse-read-file-name (prompt &optional dir default - must-match initial history) - "Like read-file-name, except uses a mouse driven interface. -HISTORY argument is ignored." - (save-excursion - (or dir (setq dir default-directory)) - (set-buffer (generate-new-buffer " *Files*")) - (use-local-map (make-sparse-keymap)) - (setq buffer-read-only t - default-directory dir) - (make-local-variable 'vm-mouse-read-file-name-prompt) - (make-local-variable 'vm-mouse-read-file-name-dir) - (make-local-variable 'vm-mouse-read-file-name-default) - (make-local-variable 'vm-mouse-read-file-name-must-match) - (make-local-variable 'vm-mouse-read-file-name-initial) - (make-local-variable 'vm-mouse-read-file-name-history) - (make-local-variable 'vm-mouse-read-file-name-return-value) - (setq vm-mouse-read-file-name-prompt prompt) - (setq vm-mouse-read-file-name-dir dir) - (setq vm-mouse-read-file-name-default default) - (setq vm-mouse-read-file-name-must-match must-match) - (setq vm-mouse-read-file-name-initial initial) - (setq vm-mouse-read-file-name-history history) - (setq vm-mouse-read-file-name-prompt prompt) - (setq vm-mouse-read-file-name-return-value nil) - (if (and vm-mutable-frames vm-frame-per-completion - (vm-multiple-frames-possible-p)) - (save-excursion - (vm-goto-new-frame 'completion))) - (switch-to-buffer (current-buffer)) - (vm-mouse-read-file-name-event-handler) - (save-excursion - (local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler) - (recursive-edit)) - ;; buffer could have been killed - (and (boundp 'vm-mouse-read-file-name-return-value) - (prog1 - vm-mouse-read-file-name-return-value - (kill-buffer (current-buffer)))))) - -(defun vm-mouse-read-file-name-event-handler (&optional string) - (let ((key-doc "Click here for keyboard interface.") - start list) - (if string - (cond ((equal string key-doc) - (condition-case nil - (save-excursion - (setq vm-mouse-read-file-name-return-value - (save-excursion - (vm-keyboard-read-file-name - vm-mouse-read-file-name-prompt - vm-mouse-read-file-name-dir - vm-mouse-read-file-name-default - vm-mouse-read-file-name-must-match - vm-mouse-read-file-name-initial - vm-mouse-read-file-name-history))) - (vm-mouse-read-file-name-quit-handler t)) - (quit (vm-mouse-read-file-name-quit-handler)))) - ((file-directory-p string) - (setq default-directory (expand-file-name string))) - (t (setq vm-mouse-read-file-name-return-value - (expand-file-name string)) - (vm-mouse-read-file-name-quit-handler t)))) - (setq buffer-read-only nil) - (erase-buffer) - (setq start (point)) - (insert vm-mouse-read-file-name-prompt) - (vm-set-region-face start (point) 'bold) - (cond ((and (not string) vm-mouse-read-file-name-default) - (setq start (point)) - (insert vm-mouse-read-file-name-default) - (vm-mouse-set-mouse-track-highlight start (point))) - ((not string) nil) - (t (insert default-directory))) - (insert ?\n ?\n) - (setq start (point)) - (insert key-doc) - (vm-mouse-set-mouse-track-highlight start (point)) - (vm-set-region-face start (point) 'italic) - (insert ?\n ?\n) - (setq list (vm-delete-backup-file-names - (vm-delete-auto-save-file-names - (directory-files default-directory)))) - (vm-show-list list 'vm-mouse-read-file-name-event-handler) - (setq buffer-read-only t))) - -(defun vm-mouse-read-file-name-quit-handler (&optional normal-exit) - (interactive) - (vm-maybe-delete-windows-or-frames-on (current-buffer)) - (if normal-exit - (throw 'exit nil) - (throw 'exit t))) - -(defvar vm-mouse-read-string-prompt) -(defvar vm-mouse-read-string-completion-list) -(defvar vm-mouse-read-string-multi-word) -(defvar vm-mouse-read-string-return-value) - -(defun vm-mouse-read-string (prompt completion-list &optional multi-word) - (save-excursion - (set-buffer (generate-new-buffer " *Choices*")) - (use-local-map (make-sparse-keymap)) - (setq buffer-read-only t) - (make-local-variable 'vm-mouse-read-string-prompt) - (make-local-variable 'vm-mouse-read-string-completion-list) - (make-local-variable 'vm-mouse-read-string-multi-word) - (make-local-variable 'vm-mouse-read-string-return-value) - (setq vm-mouse-read-string-prompt prompt) - (setq vm-mouse-read-string-completion-list completion-list) - (setq vm-mouse-read-string-multi-word multi-word) - (setq vm-mouse-read-string-return-value nil) - (if (and vm-mutable-frames vm-frame-per-completion - (vm-multiple-frames-possible-p)) - (save-excursion - (vm-goto-new-frame 'completion))) - (switch-to-buffer (current-buffer)) - (vm-mouse-read-string-event-handler) - (save-excursion - (local-set-key "\C-g" 'vm-mouse-read-string-quit-handler) - (recursive-edit)) - ;; buffer could have been killed - (and (boundp 'vm-mouse-read-string-return-value) - (prog1 - (if (listp vm-mouse-read-string-return-value) - (mapconcat 'identity vm-mouse-read-string-return-value " ") - vm-mouse-read-string-return-value) - (kill-buffer (current-buffer)))))) - -(defun vm-mouse-read-string-event-handler (&optional string) - (let ((key-doc "Click here for keyboard interface.") - (bs-doc " .... to go back one word.") - (done-doc " .... when you're done.") - start list) - (if string - (cond ((equal string key-doc) - (condition-case nil - (save-excursion - (setq vm-mouse-read-string-return-value - (vm-keyboard-read-string - vm-mouse-read-string-prompt - vm-mouse-read-string-completion-list - vm-mouse-read-string-multi-word)) - (vm-mouse-read-string-quit-handler t)) - (quit (vm-mouse-read-string-quit-handler)))) - ((equal string bs-doc) - (setq vm-mouse-read-string-return-value - (nreverse - (cdr - (nreverse vm-mouse-read-string-return-value))))) - ((equal string done-doc) - (vm-mouse-read-string-quit-handler t)) - (t (setq vm-mouse-read-string-return-value - (nconc vm-mouse-read-string-return-value - (list string))) - (if (null vm-mouse-read-string-multi-word) - (vm-mouse-read-string-quit-handler t))))) - (setq buffer-read-only nil) - (erase-buffer) - (setq start (point)) - (insert vm-mouse-read-string-prompt) - (vm-set-region-face start (point) 'bold) - (insert (mapconcat 'identity vm-mouse-read-string-return-value " ")) - (insert ?\n ?\n) - (setq start (point)) - (insert key-doc) - (vm-mouse-set-mouse-track-highlight start (point)) - (vm-set-region-face start (point) 'italic) - (insert ?\n) - (if vm-mouse-read-string-multi-word - (progn - (setq start (point)) - (insert bs-doc) - (vm-mouse-set-mouse-track-highlight start (point)) - (vm-set-region-face start (point) 'italic) - (insert ?\n) - (setq start (point)) - (insert done-doc) - (vm-mouse-set-mouse-track-highlight start (point)) - (vm-set-region-face start (point) 'italic) - (insert ?\n))) - (insert ?\n) - (vm-show-list vm-mouse-read-string-completion-list - 'vm-mouse-read-string-event-handler) - (setq buffer-read-only t))) - -(defun vm-mouse-read-string-quit-handler (&optional normal-exit) - (interactive) - (vm-maybe-delete-windows-or-frames-on (current-buffer)) - (if normal-exit - (throw 'exit nil) - (throw 'exit t)))
--- a/lisp/vm/vm-page.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,729 +0,0 @@ -;;; Commands to move around within a VM message -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-page) - -(defun vm-scroll-forward (&optional arg) - "Scroll forward a screenful of text. -If the current message is being previewed, the message body is revealed. -If at the end of the current message, moves to the next message iff the -value of vm-auto-next-message is non-nil. -Prefix argument N means scroll forward N lines." - (interactive "P") - (let ((mp-changed (vm-follow-summary-cursor)) - needs-decoding - (was-invisible nil)) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-empty) - (setq needs-decoding (and vm-display-using-mime - (not vm-mime-decoded) - (not (vm-mime-plain-message-p - (car vm-message-pointer))) - vm-auto-decode-mime-messages - (eq vm-system-state 'previewing))) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) - (let ((point (point)) - (w (vm-get-visible-buffer-window (current-buffer)))) - (if (or (null w) - (not (vm-frame-totally-visible-p (vm-window-frame w)))) - (progn - (vm-display (current-buffer) t - '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message)) - ;; window start sticks to end of clip region when clip - ;; region moves back past it in the buffer. fix it. - (setq w (vm-get-visible-buffer-window (current-buffer))) - (if (= (window-start w) (point-max)) - (set-window-start w (point-min))) - (setq was-invisible t)))) - (if (or mp-changed was-invisible needs-decoding - (and (eq vm-system-state 'previewing) - (pos-visible-in-window-p - (point-max) - (vm-get-visible-buffer-window (current-buffer))))) - (progn - (if (not was-invisible) - (let ((w (vm-get-visible-buffer-window (current-buffer))) - old-w-start) - (setq old-w-start (window-start w)) - (vm-display nil nil '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message)) - (setq w (vm-get-visible-buffer-window (current-buffer))) - (and w (set-window-start w old-w-start)))) - (if (eq vm-system-state 'previewing) - (vm-show-current-message)) - (vm-howl-if-eom)) - (let ((vmp vm-message-pointer) - (msg-buf (current-buffer)) - (h-diff 0) - w old-w old-w-height old-w-start result) - (if (eq vm-system-state 'previewing) - (vm-show-current-message)) - (setq vm-system-state 'reading) - (setq old-w (vm-get-visible-buffer-window msg-buf) - old-w-height (window-height old-w) - old-w-start (window-start old-w)) - (vm-display nil nil '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message)) - (setq w (vm-get-visible-buffer-window msg-buf)) - (if (null w) - (error "current window configuration hides the message buffer.") - (setq h-diff (- (window-height w) old-w-height))) - ;; must restore this since it gets clobbered by window - ;; teardown and rebuild done by the window config stuff. - (set-window-start w old-w-start) - (setq old-w (selected-window)) - (unwind-protect - (progn - (select-window w) - (let ((next-screen-context-lines - (+ next-screen-context-lines h-diff))) - (while (eq (setq result (vm-scroll-forward-internal arg)) - 'tryagain)) - (cond ((and (not (eq result 'next-message)) - vm-honor-page-delimiters) - (vm-narrow-to-page) - ;; This voodoo is required! For some - ;; reason the 18.52 emacs display - ;; doesn't immediately reflect the - ;; clip region change that occurs - ;; above without this mantra. - (scroll-up 0))))) - (select-window old-w)) - (set-buffer msg-buf) - (cond ((eq result 'next-message) - (vm-next-message)) - ((eq result 'end-of-message) - (let ((vm-message-pointer vmp)) - (vm-emit-eom-blurb))) - (t - (and (> (prefix-numeric-value arg) 0) - (vm-howl-if-eom))))))) - (if (not vm-startup-message-displayed) - (vm-display-startup-message))) - -(defun vm-scroll-forward-internal (arg) - (let ((direction (prefix-numeric-value arg)) - (w (selected-window))) - (condition-case error-data - (progn (scroll-up arg) nil) -;; this looks like it should work, but doesn't because the -;; redisplay code is schizophrenic when it comes to updates. A -;; window position may no longer be visible but -;; pos-visible-in-window-p will still say it is because it was -;; visible before some window size change happened. -;; (progn -;; (if (and (> direction 0) -;; (pos-visible-in-window-p -;; (vm-text-end-of (car vm-message-pointer)))) -;; (signal 'end-of-buffer nil) -;; (scroll-up arg)) -;; nil ) - (error - (if (or (and (< direction 0) - (> (point-min) (vm-text-of (car vm-message-pointer)))) - (and (>= direction 0) - (/= (point-max) - (vm-text-end-of (car vm-message-pointer))))) - (progn - (vm-widen-page) - (if (>= direction 0) - (progn - (forward-page 1) - (set-window-start w (point)) - nil ) - (if (or (bolp) - (not (save-excursion - (beginning-of-line) - (looking-at page-delimiter)))) - (forward-page -1)) - (beginning-of-line) - (set-window-start w (point)) - 'tryagain)) - (if (eq (car error-data) 'end-of-buffer) - (if vm-auto-next-message - 'next-message - (set-window-point w (point)) - 'end-of-message))))))) - -;; exploratory scrolling, what a concept. -;; -;; we do this because pos-visible-in-window-p checks the current -;; window configuration, while this exploratory scrolling forces -;; Emacs to recompute the display, giving us an up to the moment -;; answer about where the end of the message is going to be -;; visible when redisplay finally does occur. -(defun vm-howl-if-eom () - (let ((w (get-buffer-window (current-buffer)))) - (and w - (save-excursion - (save-window-excursion - (condition-case () - (let ((next-screen-context-lines 0)) - (select-window w) - (save-excursion - (save-window-excursion - ;; scroll-fix.el replaces scroll-up and - ;; doesn't behave properly when it hits - ;; end of buffer. It does this! - ;; (ding) - ;; (message (get 'beginning-of-buffer 'error-message)) - (let ((scroll-in-place-replace-original nil)) - (scroll-up nil)))) - nil) - (error t)))) - (= (vm-text-end-of (car vm-message-pointer)) (point-max)) - (vm-emit-eom-blurb)))) - -(defun vm-emit-eom-blurb () - (if (vm-full-name-of (car vm-message-pointer)) - (message "End of message %s from %s" - (vm-number-of (car vm-message-pointer)) - (vm-full-name-of (car vm-message-pointer))) - (message "End of message %s" - (vm-number-of (car vm-message-pointer))))) - -(defun vm-scroll-backward (&optional arg) - "Scroll backward a screenful of text. -Prefix N scrolls backward N lines." - (interactive "P") - (vm-scroll-forward (cond ((null arg) '-) - ((consp arg) (list (- (car arg)))) - ((numberp arg) (- arg)) - ((symbolp arg) nil) - (t arg)))) - -(defun vm-highlight-headers () - (cond - ((and vm-xemacs-p vm-use-lucid-highlighting) - (require 'highlight-headers) - ;; disable the url marking stuff, since VM has its own interface. - (let ((highlight-headers-mark-urls nil) - (highlight-headers-regexp (or vm-highlighted-header-regexp - highlight-headers-regexp))) - (highlight-headers (point-min) (point-max) t))) - (vm-xemacs-p - (let (e) - (map-extents (function - (lambda (e ignore) - (if (extent-property e 'vm-highlight) - (delete-extent e)) - nil)) - (current-buffer) (point-min) (point-max)) - (goto-char (point-min)) - (while (vm-match-header) - (cond ((vm-match-header vm-highlighted-header-regexp) - (setq e (make-extent (vm-matched-header-contents-start) - (vm-matched-header-contents-end))) - (set-extent-property e 'face vm-highlighted-header-face) - (set-extent-property e 'vm-highlight t))) - (goto-char (vm-matched-header-end))))) - ((fboundp 'overlay-put) - (let (o-lists p) - (setq o-lists (overlay-lists) - p (car o-lists)) - (while p - (and (overlay-get (car p) 'vm-highlight) - (delete-overlay (car p))) - (setq p (cdr p))) - (setq p (cdr o-lists)) - (while p - (and (overlay-get (car p) 'vm-highlight) - (delete-overlay (car p))) - (setq p (cdr p))) - (goto-char (point-min)) - (while (vm-match-header) - (cond ((vm-match-header vm-highlighted-header-regexp) - (setq p (make-overlay (vm-matched-header-contents-start) - (vm-matched-header-contents-end))) - (overlay-put p 'face vm-highlighted-header-face) - (overlay-put p 'vm-highlight t))) - (goto-char (vm-matched-header-end))))))) - -(defun vm-energize-urls () - ;; Don't search too long in large regions. If the region is - ;; large, search just the head and the tail of the region since - ;; they tend to contain the interesting text. - (let ((search-limit vm-url-search-limit) - search-pairs n) - (if (and search-limit (> (- (point-max) (point-min)) search-limit)) - (setq search-pairs (list (cons (point-min) - (+ (point-min) (/ search-limit 2))) - (cons (- (point-max) (/ search-limit 2)) - (point-max)))) - (setq search-pairs (list (cons (point-min) (point-max))))) - (cond - (vm-xemacs-p - (let (e) - (map-extents (function - (lambda (e ignore) - (if (extent-property e 'vm-url) - (delete-extent e)) - nil)) - (current-buffer) (point-min) (point-max)) - (while search-pairs - (goto-char (car (car search-pairs))) - (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq n 1) - (while (null (match-beginning n)) - (vm-increment n)) - (setq e (make-extent (match-beginning n) (match-end n))) - (set-extent-property e 'vm-url t) - (if vm-highlight-url-face - (set-extent-property e 'face vm-highlight-url-face)) - (if vm-url-browser - (let ((keymap (make-sparse-keymap)) - (popup-function - (if (save-excursion - (goto-char (match-beginning n)) - (looking-at "mailto:")) - 'vm-menu-popup-mailto-url-browser-menu - 'vm-menu-popup-url-browser-menu))) - (define-key keymap 'button2 'vm-mouse-send-url-at-event) - (if vm-popup-menu-on-mouse-3 - (define-key keymap 'button3 popup-function)) - (define-key keymap "\r" - (function (lambda () (interactive) - (vm-mouse-send-url-at-position (point))))) - (set-extent-property e 'keymap keymap) - (set-extent-property e 'balloon-help 'vm-url-help) - (set-extent-property e 'highlight t)))) - (setq search-pairs (cdr search-pairs))))) - ((and vm-fsfemacs-19-p - (fboundp 'overlay-put)) - (let (o-lists o p) - (setq o-lists (overlay-lists) - p (car o-lists)) - (while p - (and (overlay-get (car p) 'vm-url) - (delete-overlay (car p))) - (setq p (cdr p))) - (setq p (cdr o-lists)) - (while p - (and (overlay-get (car p) 'vm-url) - (delete-overlay (car p))) - (setq p (cdr p))) - (while search-pairs - (goto-char (car (car search-pairs))) - (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) - (setq n 1) - (while (null (match-beginning n)) - (vm-increment n)) - (setq o (make-overlay (match-beginning n) (match-end n))) - (overlay-put o 'vm-url t) - (if vm-highlight-url-face - (overlay-put o 'face vm-highlight-url-face)) - (if vm-url-browser - (let ((keymap (make-sparse-keymap)) - (popup-function - (if (save-excursion - (goto-char (match-beginning n)) - (looking-at "mailto:")) - 'vm-menu-popup-mailto-url-browser-menu - 'vm-menu-popup-url-browser-menu))) - (overlay-put o 'mouse-face 'highlight) - (setq keymap (nconc keymap (current-local-map))) - (if vm-popup-menu-on-mouse-3 - (define-key keymap [mouse-3] popup-function)) - (define-key keymap "\r" - (function (lambda () (interactive) - (vm-mouse-send-url-at-position (point))))) - (overlay-put o 'local-map keymap)))) - (setq search-pairs (cdr search-pairs)))))))) - -(defun vm-energize-headers () - (cond - (vm-xemacs-p - (let ((search-tuples '(("^From:" vm-menu-author-menu) - ("^Subject:" vm-menu-subject-menu))) - regexp menu keymap e) - (map-extents (function - (lambda (e ignore) - (if (extent-property e 'vm-header) - (delete-extent e)) - nil)) - (current-buffer) (point-min) (point-max)) - (while search-tuples - (goto-char (point-min)) - (setq regexp (nth 0 (car search-tuples)) - menu (symbol-value (nth 1 (car search-tuples)))) - (while (re-search-forward regexp nil t) - (save-excursion (goto-char (match-beginning 0)) (vm-match-header)) - (setq e (make-extent (vm-matched-header-contents-start) - (vm-matched-header-contents-end))) - (set-extent-property e 'vm-header t) - (setq keymap (make-sparse-keymap)) - ;; Might as well make button2 do what button3 does in - ;; this case, since there is no default 'select' - ;; action. - (define-key keymap 'button2 - (list 'lambda () '(interactive) - (list 'popup-menu (list 'quote menu)))) - (if vm-popup-menu-on-mouse-3 - (define-key keymap 'button3 - (list 'lambda () '(interactive) - (list 'popup-menu (list 'quote menu))))) - (set-extent-property e 'keymap keymap) - (set-extent-property e 'balloon-help 'vm-mouse-3-help) - (set-extent-property e 'highlight t)) - (setq search-tuples (cdr search-tuples))))) - ((and vm-fsfemacs-19-p - (fboundp 'overlay-put)) - (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu) - ("^Subject:" vm-menu-fsfemacs-subject-menu))) - regexp menu - o-lists o p) - (setq o-lists (overlay-lists) - p (car o-lists)) - (while p - (and (overlay-get (car p) 'vm-header) - (delete-overlay (car p))) - (setq p (cdr p))) - (setq p (cdr o-lists)) - (while p - (and (overlay-get (car p) 'vm-header) - (delete-overlay (car p))) - (setq p (cdr p))) - (while search-tuples - (goto-char (point-min)) - (setq regexp (nth 0 (car search-tuples)) - menu (symbol-value (nth 1 (car search-tuples)))) - (while (re-search-forward regexp nil t) - (goto-char (match-end 0)) - (save-excursion (goto-char (match-beginning 0)) (vm-match-header)) - (setq o (make-overlay (vm-matched-header-contents-start) - (vm-matched-header-contents-end))) - (overlay-put o 'vm-header menu) - (overlay-put o 'mouse-face 'highlight)) - (setq search-tuples (cdr search-tuples))))))) - -(defun vm-display-xface () - (let ((case-fold-search t) e g h) - (if (map-extents (function - (lambda (e ignore) - (if (extent-property e 'vm-xface) - t - nil))) - (current-buffer) (point-min) (point-max)) - nil - (goto-char (point-min)) - (if (find-face 'vm-xface) - nil - (make-face 'vm-xface) - (set-face-background 'vm-xface "white") - (set-face-foreground 'vm-xface "black")) - (if (re-search-forward "^X-Face:" nil t) - (progn - (goto-char (match-beginning 0)) - (vm-match-header) - (setq h (concat "X-Face: " (vm-matched-header-contents))) - (setq g (intern h vm-xface-cache)) - (if (boundp g) - (setq g (symbol-value g)) - (set g (make-glyph - (list - (list 'global (cons '(tty) [nothing])) - (list 'global (cons '(win) (vector 'xface ':data h)))))) - (setq g (symbol-value g)) - ;; XXX broken. Gives extra pixel lines at the - ;; bottom of the glyph in 19.12 - ;;(set-glyph-baseline g 100) - (set-glyph-face g 'vm-xface)) - (setq e (make-extent (vm-vheaders-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer)))) - (set-extent-property e 'vm-xface t) - (set-extent-begin-glyph e g)))))) - -(defun vm-url-help (object) - (format - "Use mouse button 2 to send the URL to %s. -Use mouse button 3 to choose a Web browser for the URL." - (cond ((stringp vm-url-browser) vm-url-browser) - ((eq vm-url-browser 'w3-fetch) - "Emacs W3") - ((eq vm-url-browser 'w3-fetch-other-frame) - "Emacs W3") - ((eq vm-url-browser 'vm-mouse-send-url-to-mosaic) - "Mosaic") - ((eq vm-url-browser 'vm-mouse-send-url-to-netscape) - "Netscape") - (t (symbol-name vm-url-browser))))) - -(defun vm-energize-urls-in-message-region (&optional start end) - (save-excursion - (or start (setq start (vm-headers-of (car vm-message-pointer)))) - (or end (setq end (vm-text-end-of (car vm-message-pointer)))) - ;; energize the URLs - (if (or vm-highlight-url-face vm-url-browser) - (save-restriction - (widen) - (narrow-to-region start end) - (vm-energize-urls))))) - -(defun vm-highlight-headers-maybe () - ;; highlight the headers - (if (or vm-highlighted-header-regexp - (and vm-xemacs-p vm-use-lucid-highlighting)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-end-of (car vm-message-pointer))) - (vm-highlight-headers)))) - -(defun vm-energize-headers-and-xfaces () - ;; energize certain headers - (if (and vm-use-menus (vm-menu-support-possible-p)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-of (car vm-message-pointer))) - (vm-energize-headers))) - ;; display xfaces, if we can - (if (and vm-display-xfaces - vm-xemacs-p - (featurep 'xface)) - (save-restriction - (widen) - (narrow-to-region (vm-headers-of (car vm-message-pointer)) - (vm-text-of (car vm-message-pointer))) - (vm-display-xface)))) - -(defun vm-narrow-for-preview () - (widen) - ;; hide as much of the message body as vm-preview-lines specifies - (narrow-to-region - (vm-vheaders-of (car vm-message-pointer)) - (cond ((not (eq vm-preview-lines t)) - (min - (vm-text-end-of (car vm-message-pointer)) - (save-excursion - (goto-char (vm-text-of (car vm-message-pointer))) - (forward-line (if (natnump vm-preview-lines) vm-preview-lines 0)) - (point)))) - (t (vm-text-end-of (car vm-message-pointer)))))) - -(defun vm-preview-current-message () - (vm-save-buffer-excursion - (setq vm-system-state 'previewing - vm-mime-decoded nil) - (if vm-real-buffers - (vm-make-virtual-copy (car vm-message-pointer))) - - ;; run the message select hooks. - (save-excursion - (vm-select-folder-buffer) - (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook) - (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer)) - (vm-run-message-hook (car vm-message-pointer) - 'vm-select-new-message-hook)) - (and vm-select-unread-message-hook - (vm-unread-flag (car vm-message-pointer)) - (vm-run-message-hook (car vm-message-pointer) - 'vm-select-unread-message-hook))) - - (vm-narrow-for-preview) - (if (or vm-mime-display-function - (and vm-display-using-mime - (not (vm-mime-plain-message-p (car vm-message-pointer))))) - (let ((layout (vm-mm-layout (car vm-message-pointer)))) - (vm-make-presentation-copy (car vm-message-pointer)) - (vm-save-buffer-excursion - (vm-replace-buffer-in-windows (current-buffer) - vm-presentation-buffer)) - (set-buffer vm-presentation-buffer) - (setq vm-system-state 'previewing) - (vm-narrow-for-preview)) - (setq vm-presentation-buffer nil) - (and vm-presentation-buffer-handle - (vm-replace-buffer-in-windows vm-presentation-buffer-handle - (current-buffer)))) - - ;; at this point the current buffer is the presentation buffer - ;; if we're using one for this message. - - (vm-unbury-buffer (current-buffer)) - (vm-energize-urls-in-message-region) - (vm-highlight-headers-maybe) - (vm-energize-headers-and-xfaces) - - (if vm-honor-page-delimiters - (vm-narrow-to-page)) - (goto-char (vm-text-of (car vm-message-pointer))) - ;; If we have a window, set window start appropriately. - (let ((w (vm-get-visible-buffer-window (current-buffer)))) - (if w - (progn (set-window-start w (point-min)) - (set-window-point w (vm-text-of (car vm-message-pointer)))))) - (if (or (null vm-preview-lines) - (and (not vm-preview-read-messages) - (not (vm-new-flag (car vm-message-pointer))) - (not (vm-unread-flag (car vm-message-pointer))))) - (vm-show-current-message) - (vm-update-summary-and-mode-line)))) - -(defun vm-show-current-message () - (and vm-display-using-mime - vm-auto-decode-mime-messages - (if vm-mail-buffer - (not (vm-buffer-variable-value vm-mail-buffer 'vm-mime-decoded)) - (not vm-mime-decoded)) - (not (vm-mime-plain-message-p (car vm-message-pointer))) - (condition-case data - (vm-decode-mime-message) - (vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer) - (car (cdr data))) - (message "%s" (car (cdr data)))))) - (vm-save-buffer-excursion - (save-excursion - (save-excursion - (goto-char (point-min)) - (widen) - (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer)))) - (if vm-honor-page-delimiters - (progn - (if (looking-at page-delimiter) - (forward-page 1)) - (vm-narrow-to-page)))) - ;; don't mark the message as read if the user can't see it! - (if (vm-get-visible-buffer-window (current-buffer)) - (progn - (save-excursion - (setq vm-system-state 'showing) - (if vm-mail-buffer - (vm-set-buffer-variable vm-mail-buffer 'vm-system-state - 'showing)) - ;; We could be in the presentation buffer here. Since - ;; the presentation buffer's message pointer and sole - ;; message are a mockup, they will cause trouble if - ;; passed into the undo/update system. So we switch - ;; into the real message buffer to do attribute - ;; updates. - (vm-select-folder-buffer) - (cond ((vm-new-flag (car vm-message-pointer)) - (vm-set-new-flag (car vm-message-pointer) nil))) - (cond ((vm-unread-flag (car vm-message-pointer)) - (vm-set-unread-flag (car vm-message-pointer) nil)))) - (vm-update-summary-and-mode-line) - (vm-howl-if-eom)) - (vm-update-summary-and-mode-line)))) - -(defun vm-expose-hidden-headers () - "Toggle exposing and hiding message headers that are normally not visible." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-empty) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) - (vm-display (current-buffer) t '(vm-expose-hidden-headers) - '(vm-expose-hidden-headers reading-message)) - (let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer))))) - (vm-widen-page) - (goto-char (point-max)) - (widen) - (if exposed - (narrow-to-region (point) (vm-vheaders-of (car vm-message-pointer))) - (narrow-to-region (point) (vm-start-of (car vm-message-pointer)))) - (goto-char (point-min)) - (let (w) - (setq w (vm-get-visible-buffer-window (current-buffer))) - (and w (set-window-point w (point-min))) - (and w - (= (window-start w) (vm-vheaders-of (car vm-message-pointer))) - (not exposed) - (set-window-start w (vm-start-of (car vm-message-pointer))))) - (if vm-honor-page-delimiters - (vm-narrow-to-page)))) - -(defun vm-widen-page () - (if (or (> (point-min) (vm-text-of (car vm-message-pointer))) - (/= (point-max) (vm-text-end-of (car vm-message-pointer)))) - (narrow-to-region (vm-vheaders-of (car vm-message-pointer)) - (if (or (vm-new-flag (car vm-message-pointer)) - (vm-unread-flag (car vm-message-pointer))) - (vm-text-of (car vm-message-pointer)) - (vm-text-end-of (car vm-message-pointer)))))) - -(defun vm-narrow-to-page () - (save-excursion - (let (min max (omin (point-min)) (omax (point-max))) - (if (or (bolp) (not (save-excursion - (beginning-of-line) - (looking-at page-delimiter)))) - (forward-page -1)) - (setq min (point)) - (forward-page 1) - (beginning-of-line) - (setq max (point)) - (narrow-to-region min max)))) - -(defun vm-beginning-of-message () - "Moves to the beginning of the current message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-empty) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) - (vm-widen-page) - (push-mark) - (vm-display (current-buffer) t '(vm-beginning-of-message) - '(vm-beginning-of-message reading-message)) - (let ((osw (selected-window))) - (unwind-protect - (progn - (select-window (vm-get-visible-buffer-window (current-buffer))) - (goto-char (point-min))) - (if (not (eq osw (selected-window))) - (select-window osw)))) - (if vm-honor-page-delimiters - (vm-narrow-to-page))) - -(defun vm-end-of-message () - "Moves to the end of the current message, exposing and flagging it read -as necessary." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - (vm-error-if-folder-empty) - (and vm-presentation-buffer - (set-buffer vm-presentation-buffer)) - (if (eq vm-system-state 'previewing) - (vm-show-current-message)) - (setq vm-system-state 'reading) - (vm-widen-page) - (push-mark) - (vm-display (current-buffer) t '(vm-end-of-message) - '(vm-end-of-message reading-message)) - (let ((osw (selected-window))) - (unwind-protect - (progn - (select-window (vm-get-visible-buffer-window (current-buffer))) - (goto-char (point-max))) - (if (not (eq osw (selected-window))) - (select-window osw)))) - (if vm-honor-page-delimiters - (vm-narrow-to-page)))
--- a/lisp/vm/vm-pop.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,501 +0,0 @@ -;;; Simple POP (RFC 1939) client for VM -;;; Copyright (C) 1993, 1994, 1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-pop) - -;; Nothing fancy here. -;; Our goal is to drag the mail from the POP maildrop to the crash box. -;; just as if we were using movemail on a spool file. -(defun vm-pop-move-mail (source destination) - (let ((process nil) - (folder-type vm-folder-type) - (saved-password t) - (m-per-session vm-pop-messages-per-session) - (b-per-session vm-pop-bytes-per-session) - (handler (and (fboundp 'find-file-name-handler) - (condition-case () - (find-file-name-handler source 'vm-pop-move-mail) - (wrong-number-of-arguments - (find-file-name-handler source))))) - (popdrop (vm-safe-popdrop-string source)) - (statblob nil) - mailbox-count mailbox-size message-size response - n retrieved retrieved-bytes process-buffer) - (unwind-protect - (catch 'done - (if handler - (throw 'done - (funcall handler 'vm-pop-move-mail source destination))) - (setq process (vm-pop-make-session source)) - (or process (throw 'done nil)) - (setq process-buffer (process-buffer process)) - (save-excursion - (set-buffer process-buffer) - (setq vm-folder-type (or folder-type vm-default-folder-type)) - ;; find out how many messages are in the box. - (vm-pop-send-command process "STAT") - (setq response (vm-pop-read-stat-response process) - mailbox-count (nth 0 response) - mailbox-size (nth 1 response)) - ;; forget it if the command fails - ;; or if there are no messages present. - (if (or (null mailbox-count) - (< mailbox-count 1)) - (throw 'done nil)) - ;; loop through the maildrop retrieving and deleting - ;; messages as we go. - (setq n 1 retrieved 0 retrieved-bytes 0) - (setq statblob (vm-pop-start-status-timer)) - (vm-set-pop-stat-x-box statblob popdrop) - (vm-set-pop-stat-x-maxmsg statblob mailbox-count) - (while (and (<= n mailbox-count) - (or (not (natnump m-per-session)) - (< retrieved m-per-session)) - (or (not (natnump b-per-session)) - (< retrieved-bytes b-per-session))) - (vm-set-pop-stat-x-currmsg statblob n) - (vm-pop-send-command process (format "LIST %d" n)) - (setq message-size (vm-pop-read-list-response process)) - (vm-set-pop-stat-x-need statblob message-size) - (if (and (integerp vm-pop-max-message-size) - (> message-size vm-pop-max-message-size) - (progn - (setq response - (if vm-pop-ok-to-ask - (vm-pop-ask-about-large-message process - message-size - n) - 'skip)) - (not (eq response 'retrieve)))) - (if (eq response 'delete) - (progn - (message "Deleting message %d..." n) - (vm-pop-send-command process (format "DELE %d" n)) - (and (null (vm-pop-read-response process)) - (throw 'done (not (equal retrieved 0))))) - (if vm-pop-ok-to-ask - (message "Skipping message %d..." n) - (message "Skipping message %d in %s, too large (%d > %d)..." - n popdrop message-size vm-pop-max-message-size))) - (message "Retrieving message %d (of %d) from %s..." - n mailbox-count popdrop) - (vm-pop-send-command process (format "RETR %d" n)) - (and (null (vm-pop-read-response process)) - (throw 'done (not (equal retrieved 0)))) - (and (null (vm-pop-retrieve-to-crashbox process destination - statblob)) - (throw 'done (not (equal retrieved 0)))) - (vm-increment retrieved) - (and b-per-session - (setq retrieved-bytes (+ retrieved-bytes message-size))) - (vm-pop-send-command process (format "DELE %d" n)) - ;; DELE can't fail but Emacs or this code might - ;; blow a gasket and spew filth down the - ;; connection, so... - (and (null (vm-pop-read-response process)) - (throw 'done (not (equal retrieved 0))))) - (vm-increment n)) - (not (equal retrieved 0)) )) - (and statblob (vm-pop-stop-status-timer statblob)) - (if process - (vm-pop-end-session process))))) - -(defun vm-pop-check-mail (source) - (let ((process nil) - (handler (and (fboundp 'find-file-name-handler) - (condition-case () - (find-file-name-handler source 'vm-pop-check-mail) - (wrong-number-of-arguments - (find-file-name-handler source))))) - response) - (unwind-protect - (save-excursion - (catch 'done - (if handler - (throw 'done - (funcall handler 'vm-pop-check-mail source))) - (setq process (vm-pop-make-session source)) - (or process (throw 'done nil)) - (set-buffer (process-buffer process)) - (vm-pop-send-command process "STAT") - (setq response (vm-pop-read-stat-response process)) - (if (null response) - nil - (not (equal 0 (car response)))))) - (and process (vm-pop-end-session process))))) - -(defun vm-pop-make-session (source) - (let ((process-to-shutdown nil) - process - (saved-password t) - (popdrop (vm-safe-popdrop-string source)) - greeting timestamp - host port auth user pass source-list process-buffer) - (unwind-protect - (catch 'done - ;; parse the maildrop - (setq source-list (vm-parse source "\\([^:]+\\):?") - host (nth 0 source-list) - port (nth 1 source-list) - auth (nth 2 source-list) - user (nth 3 source-list) - pass (nth 4 source-list)) - ;; carp if parts are missing - (if (null host) - (error "No host in POP maildrop specification, \"%s\"" - source)) - (if (null port) - (error "No port in POP maildrop specification, \"%s\"" - source)) - (if (string-match "^[0-9]+$" port) - (setq port (string-to-int port))) - (if (null auth) - (error - "No authentication method in POP maildrop specification, \"%s\"" - source)) - (if (null user) - (error "No user in POP maildrop specification, \"%s\"" - source)) - (if (null pass) - (error "No password in POP maildrop specification, \"%s\"" - source)) - (if (equal pass "*") - (progn - (setq pass (car (cdr (assoc source vm-pop-passwords)))) - (if (null pass) - (if (null vm-pop-ok-to-ask) - (progn (message "Need password for %s" popdrop) - (throw 'done nil)) - (setq pass - (vm-read-password - (format "POP password for %s: " - popdrop)) - vm-pop-passwords (cons (list source pass) - vm-pop-passwords) - saved-password t))))) - ;; get the trace buffer - (setq process-buffer - (get-buffer-create (format "trace of POP session to %s" host))) - ;; Tell XEmacs/MULE not to mess with the text. - (and vm-xemacs-mule-p - (set-buffer-file-coding-system 'binary t)) - ;; clear the trace buffer of old output - (save-excursion - (set-buffer process-buffer) - (buffer-disable-undo) - (erase-buffer)) - ;; open the connection to the server - (setq process (open-network-stream "POP" process-buffer host port)) - (and (null process) (throw 'done nil)) - (process-kill-without-query process) - (save-excursion - (set-buffer process-buffer) - (make-local-variable 'vm-pop-read-point) - (setq vm-pop-read-point (point-min)) - (if (null (setq greeting (vm-pop-read-response process t))) - (progn (delete-process process) - (throw 'done nil))) - (setq process-to-shutdown process) - ;; authentication - (cond ((equal auth "pass") - (vm-pop-send-command process (format "USER %s" user)) - (and (null (vm-pop-read-response process)) - (throw 'done nil)) - (vm-pop-send-command process (format "PASS %s" pass)) - (if (null (vm-pop-read-response process)) - (progn - (if saved-password - (setq vm-pop-passwords - (delete (list source pass) - vm-pop-passwords))) - (throw 'done nil)))) - ((equal auth "rpop") - (vm-pop-send-command process (format "USER %s" user)) - (and (null (vm-pop-read-response process)) - (throw 'done nil)) - (vm-pop-send-command process (format "RPOP %s" pass)) - (and (null (vm-pop-read-response process)) - (throw 'done nil))) - ((equal auth "apop") - (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)") - timestamp (car timestamp)) - (if (null timestamp) - (progn - (goto-char (point-max)) - (insert-before-markers "<<< ooops, no timestamp found in greeting! >>>\n") - (throw 'done nil))) - (vm-pop-send-command - process - (format "APOP %s %s" - user - (vm-pop-md5 (concat timestamp pass)))) - (and (null (vm-pop-read-response process)) - (throw 'done nil))) - (t (error "Don't know how to authenticate using %s" auth))) - (setq process-to-shutdown nil) - process )) - (if process-to-shutdown - (vm-pop-end-session process-to-shutdown))))) - -(defun vm-pop-end-session (process) - (save-excursion - (set-buffer (process-buffer process)) - (vm-pop-send-command process "QUIT") - (vm-pop-read-response process) - (if (fboundp 'add-async-timeout) - (add-async-timeout 2 'delete-process process) - (run-at-time 2 nil 'delete-process process)))) - -(defun vm-pop-stat-timer (o) (aref o 0)) -(defun vm-pop-stat-x-box (o) (aref o 1)) -(defun vm-pop-stat-x-currmsg (o) (aref o 2)) -(defun vm-pop-stat-x-maxmsg (o) (aref o 3)) -(defun vm-pop-stat-x-got (o) (aref o 4)) -(defun vm-pop-stat-x-need (o) (aref o 5)) -(defun vm-pop-stat-y-box (o) (aref o 6)) -(defun vm-pop-stat-y-currmsg (o) (aref o 7)) -(defun vm-pop-stat-y-maxmsg (o) (aref o 8)) -(defun vm-pop-stat-y-got (o) (aref o 9)) -(defun vm-pop-stat-y-need (o) (aref o 10)) - -(defun vm-set-pop-stat-timer (o val) (aset o 0 val)) -(defun vm-set-pop-stat-x-box (o val) (aset o 1 val)) -(defun vm-set-pop-stat-x-currmsg (o val) (aset o 2 val)) -(defun vm-set-pop-stat-x-maxmsg (o val) (aset o 3 val)) -(defun vm-set-pop-stat-x-got (o val) (aset o 4 val)) -(defun vm-set-pop-stat-x-need (o val) (aset o 5 val)) -(defun vm-set-pop-stat-y-box (o val) (aset o 6 val)) -(defun vm-set-pop-stat-y-currmsg (o val) (aset o 7 val)) -(defun vm-set-pop-stat-y-maxmsg (o val) (aset o 8 val)) -(defun vm-set-pop-stat-y-got (o val) (aset o 9 val)) -(defun vm-set-pop-stat-y-need (o val) (aset o 10 val)) - -(defun vm-pop-start-status-timer () - (let ((blob (make-vector 11 nil)) - timer) - (setq timer (add-timeout 5 'vm-pop-report-retrieval-status blob 5)) - (vm-set-pop-stat-timer blob timer) - blob )) - -(defun vm-pop-stop-status-timer (status-blob) - (if (fboundp 'disable-timeout) - (disable-timeout (vm-pop-stat-timer status-blob)) - (cancel-timer (vm-pop-stat-timer status-blob)))) - -(defun vm-pop-report-retrieval-status (o) - (cond ((null (vm-pop-stat-x-got o)) t) - ;; should not be possible, but better safe... - ((not (eq (vm-pop-stat-x-box o) (vm-pop-stat-y-box o))) t) - ((not (eq (vm-pop-stat-x-currmsg o) (vm-pop-stat-y-currmsg o))) t) - (t (message "Retrieving message %d (of %d) from %s, %s..." - (vm-pop-stat-x-currmsg o) - (vm-pop-stat-x-maxmsg o) - (vm-pop-stat-x-box o) - (format "%d%s of %d%s" - (vm-pop-stat-x-got o) - (if (> (vm-pop-stat-x-got o) - (vm-pop-stat-x-need o)) - "!" - "") - (vm-pop-stat-x-need o) - (if (eq (vm-pop-stat-x-got o) - (vm-pop-stat-y-got o)) - " (stalled)" - ""))))) - (vm-set-pop-stat-y-box o (vm-pop-stat-x-box o)) - (vm-set-pop-stat-y-currmsg o (vm-pop-stat-x-currmsg o)) - (vm-set-pop-stat-y-maxmsg o (vm-pop-stat-x-maxmsg o)) - (vm-set-pop-stat-y-got o (vm-pop-stat-x-got o)) - (vm-set-pop-stat-y-need o (vm-pop-stat-x-need o))) - -(defun vm-pop-send-command (process command) - (goto-char (point-max)) - (if (= (aref command 0) ?P) - (insert-before-markers "PASS <omitted>\r\n") - (insert-before-markers command "\r\n")) - (setq vm-pop-read-point (point)) - (process-send-string process command) - (process-send-string process "\r\n")) - -(defun vm-pop-read-response (process &optional return-response-string) - (let ((case-fold-search nil) - match-end) - (goto-char vm-pop-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char vm-pop-read-point)) - (setq match-end (point)) - (goto-char vm-pop-read-point) - (if (not (looking-at "+OK")) - (progn (setq vm-pop-read-point match-end) nil) - (setq vm-pop-read-point match-end) - (if return-response-string - (buffer-substring (point) match-end) - t )))) - -(defun vm-pop-read-past-dot-sentinel-line (process) - (let ((case-fold-search nil)) - (goto-char vm-pop-read-point) - (while (not (re-search-forward "^\\.\r\n" nil 0)) - (beginning-of-line) - ;; save-excursion doesn't work right - (let ((opoint (point))) - (accept-process-output process) - (goto-char opoint))) - (setq vm-pop-read-point (point)))) - -(defun vm-pop-read-stat-response (process) - (let ((response (vm-pop-read-response process t)) - list) - (setq list (vm-parse response "\\([^ ]+\\) *")) - (list (string-to-int (nth 1 list)) (string-to-int (nth 2 list))))) - -(defun vm-pop-read-list-response (process) - (let ((response (vm-pop-read-response process t))) - (string-to-int (nth 2 (vm-parse response "\\([^ ]+\\) *"))))) - -(defun vm-pop-ask-about-large-message (process size n) - (let ((work-buffer nil) - (pop-buffer (current-buffer)) - start end) - (unwind-protect - (save-excursion - (save-window-excursion - (vm-pop-send-command process (format "TOP %d %d" n 0)) - (if (vm-pop-read-response process) - (progn - (setq start vm-pop-read-point) - (vm-pop-read-past-dot-sentinel-line process) - (setq end vm-pop-read-point) - (setq work-buffer (generate-new-buffer "*pop-glop*")) - (set-buffer work-buffer) - (insert-buffer-substring pop-buffer start end) - (forward-line -1) - (delete-region (point) (point-max)) - (vm-pop-cleanup-region (point-min) (point-max)) - (vm-display-buffer work-buffer) - (setq minibuffer-scroll-window (selected-window)) - (goto-char (point-min)) - (if (re-search-forward "^Received:" nil t) - (progn - (goto-char (match-beginning 0)) - (vm-reorder-message-headers - nil vm-visible-headers - vm-invisible-header-regexp))) - (set-window-point (selected-window) (point)))) - (if (y-or-n-p (format "Message %d, size = %d, retrieve? " n size)) - 'retrieve - (if (y-or-n-p (format "Delete message %d from popdrop? " n size)) - 'delete - 'skip)))) - (and work-buffer (kill-buffer work-buffer))))) - -(defun vm-pop-retrieve-to-crashbox (process crash statblob) - (let ((start vm-pop-read-point) end) - (goto-char start) - (vm-set-pop-stat-x-got statblob 0) - (while (not (re-search-forward "^\\.\r\n" nil 0)) - (beginning-of-line) - ;; save-excursion doesn't work right - (let* ((opoint (point)) - (func - (function - (lambda (beg end len) - (if vm-pop-read-point - (progn - (vm-set-pop-stat-x-got statblob (- end start)) - (if (zerop (% (random) 10)) - (vm-pop-report-retrieval-status statblob))))))) - (after-change-functions (cons func after-change-functions))) - (accept-process-output process) - (goto-char opoint))) - (vm-set-pop-stat-x-got statblob nil) - (setq vm-pop-read-point (point-marker)) - (goto-char (match-beginning 0)) - (setq end (point-marker)) - (vm-pop-cleanup-region start end) - ;; Some POP servers strip leading and trailing message - ;; separators, some don't. Figure out what kind we're - ;; talking to and do the right thing. - (if (eq (vm-get-folder-type nil start end) 'unknown) - (progn - (vm-munge-message-separators vm-folder-type start end) - (goto-char start) - ;; avoid the consing and stat() call for all but babyl - ;; files, since this will probably slow things down. - ;; only babyl files have the folder header, and we - ;; should only insert it if the crash box is empty. - (if (and (eq vm-folder-type 'babyl) - (let ((attrs (file-attributes crash))) - (or (null attrs) (equal 0 (nth 7 attrs))))) - (let ((opoint (point))) - (vm-convert-folder-header nil vm-folder-type) - ;; if start is a marker, then it was moved - ;; forward by the insertion. restore it. - (setq start opoint) - (goto-char start) - (vm-skip-past-folder-header))) - (insert (vm-leading-message-separator)) - ;; this will not find the trailing message separator but - ;; for the Content-Length stuff counting from eob is - ;; the same thing in this case. - (vm-convert-folder-type-headers nil vm-folder-type) - (goto-char end) - (insert-before-markers (vm-trailing-message-separator)))) - ;; Set file type to binary for DOS/Windows. I don't know if - ;; this is correct to do or not; it depends on whether the - ;; the CRLF or the LF newline convention is used on the inbox - ;; associated with this crashbox. This setting assumes the LF - ;; newline convention is used. - (let ((buffer-file-type t)) - (write-region start end crash t 0)) - (delete-region start end) - t )) - -(defun vm-pop-cleanup-region (start end) - (if (> (- end start) 30000) - (message "CRLF conversion and char unstuffing...")) - (setq end (vm-marker end)) - (save-excursion - (goto-char start) - ;; CRLF -> LF - (while (and (< (point) end) (search-forward "\r\n" end t)) - (replace-match "\n" t t)) - (goto-char start) - ;; chop leading dots - (while (and (< (point) end) (re-search-forward "^\\." end t)) - (replace-match "" t t) - (forward-char))) - (if (> (- end start) 30000) - (message "CRLF conversion and dot unstuffing... done")) - (set-marker end nil)) - -(defun vm-pop-md5 (string) - (let ((buffer nil)) - (unwind-protect - (save-excursion - (setq buffer (generate-new-buffer "*vm-work*")) - (set-buffer buffer) - (insert string) - (call-process-region (point-min) (point-max) - "/bin/sh" t buffer nil - shell-command-switch vm-pop-md5-program) - ;; MD5 digest is 32 chars long - ;; mddriver adds a newline to make neaten output for tty - ;; viewing, make sure we leave it behind. - (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32))) - (and buffer (kill-buffer buffer)))))
--- a/lisp/vm/vm-reply.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1226 +0,0 @@ -;;; Mailing, forwarding, and replying commands for VM -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-reply) - -(defun vm-do-reply (to-all include-text count) - (let ((mlist (vm-select-marked-or-prefixed-messages count)) - (dir default-directory) - (message-pointer vm-message-pointer) - (case-fold-search t) - to cc subject mp in-reply-to references tmp tmp2 newsgroups) - (setq mp mlist) - (while mp - (cond - ((eq mlist mp) - (cond ((setq to - (let ((reply-to - (vm-get-header-contents (car mp) "Reply-To:" - ", "))) - (if (vm-ignored-reply-to reply-to) - nil - reply-to )))) - ((setq to (vm-get-header-contents (car mp) "From:" ", "))) - ;; bad, but better than nothing for some - ((setq to (vm-grok-From_-author (car mp)))) - (t (error "No From: or Reply-To: header in message"))) - (setq subject (vm-get-header-contents (car mp) "Subject:") - in-reply-to - (and vm-in-reply-to-format - (let ((vm-summary-uninteresting-senders nil)) - (vm-sprintf 'vm-in-reply-to-format (car mp)))) - in-reply-to (and (not (equal "" in-reply-to)) in-reply-to)) - (and subject vm-reply-subject-prefix - (let ((case-fold-search t)) - (not - (equal - (string-match (regexp-quote vm-reply-subject-prefix) - subject) - 0))) - (setq subject (concat vm-reply-subject-prefix subject)))) - (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:" - ", ")) - (setq to (concat to "," tmp))) - ((setq tmp (vm-get-header-contents (car mp) "From:" - ", ")) - (setq to (concat to "," tmp))) - ;; bad, but better than nothing for some - ((setq tmp (vm-grok-From_-author (car mp))) - (setq to (concat to "," tmp))) - (t (error "No From: or Reply-To: header in message"))))) - (if to-all - (progn - (setq tmp (vm-get-header-contents (car mp) "To:" - ", ")) - (setq tmp2 (vm-get-header-contents (car mp) "Cc:" - ", ")) - (if tmp - (if cc - (setq cc (concat cc "," tmp)) - (setq cc tmp))) - (if tmp2 - (if cc - (setq cc (concat cc "," tmp2)) - (setq cc tmp2))))) - (setq references - (cons (vm-get-header-contents (car mp) "References:" " ") - (cons (vm-get-header-contents (car mp) "In-reply-to:" " ") - (cons (vm-get-header-contents (car mp) "Message-ID:" - " ") - references)))) - (setq newsgroups - (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To:" ",")) - (vm-get-header-contents (car mp) "Newsgroups:" ",")) - newsgroups)) - (setq mp (cdr mp))) - (if vm-strip-reply-headers - (let ((mail-use-rfc822 t)) - (and to (setq to (mail-strip-quoted-names to))) - (and cc (setq cc (mail-strip-quoted-names cc))))) - (setq to (vm-parse-addresses to) - cc (vm-parse-addresses cc)) - (if vm-reply-ignored-addresses - (setq to (vm-strip-ignored-addresses to) - cc (vm-strip-ignored-addresses cc))) - (setq to (vm-delete-duplicates to nil t)) - (setq cc (vm-delete-duplicates - (append (vm-delete-duplicates cc nil t) - to (copy-sequence to)) - t t)) - (and to (setq to (mapconcat 'identity to ",\n "))) - (and cc (setq cc (mapconcat 'identity cc ",\n "))) - (and (null to) (setq to cc cc nil)) - (setq references (delq nil references) - references (mapconcat 'identity references " ") - references (vm-parse references "[^<]*\\(<[^>]+>\\)") - references (vm-delete-duplicates references) - references (if references (mapconcat 'identity references "\n\t"))) - (setq newsgroups (delq nil newsgroups) - newsgroups (mapconcat 'identity newsgroups ",") - newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") - newsgroups (vm-delete-duplicates newsgroups) - newsgroups (if newsgroups (mapconcat 'identity newsgroups ","))) - (vm-mail-internal - (format "reply to %s%s" (vm-su-full-name (car mlist)) - (if (cdr mlist) ", ..." "")) - to subject in-reply-to cc references newsgroups) - (make-local-variable 'vm-reply-list) - (setq vm-system-state 'replying - vm-reply-list mlist - default-directory dir) - (if include-text - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") nil 0)) - (forward-char 1) - (while mlist - (save-restriction - (narrow-to-region (point) (point)) - (vm-yank-message (car mlist)) - (goto-char (point-max))) - (setq mlist (cdr mlist))))) - (run-hooks 'vm-reply-hook) - (run-hooks 'vm-mail-mode-hook))) - -(defun vm-strip-ignored-addresses (addresses) - (setq addresses (copy-sequence addresses)) - (let (re-list list addr-list) - (setq re-list vm-reply-ignored-addresses) - (while re-list - (setq addr-list addresses) - (while addr-list - (if (string-match (car re-list) (car addr-list)) - (setq addresses (delq (car addr-list) addresses))) - (setq addr-list (cdr addr-list))) - (setq re-list (cdr re-list)))) - addresses ) - -(defun vm-ignored-reply-to (reply-to) - (if reply-to - (let (re-list result) - (setq re-list vm-reply-ignored-reply-tos) - (while re-list - (if (string-match (car re-list) reply-to) - (setq result t re-list nil) - (setq re-list (cdr re-list)))) - result ))) - -(defun vm-mail-yank-default (message) - (save-excursion - (vm-reorder-message-headers nil vm-included-text-headers - vm-included-text-discard-header-regexp) - ;; if all the headers are gone, delete the trailing blank line, too. - (if (eq (following-char) ?\n) - (delete-char 1)) - (if vm-included-text-attribution-format - (let ((vm-summary-uninteresting-senders nil)) - (insert (vm-sprintf 'vm-included-text-attribution-format message)))) - ; turn off zmacs-regions for Lucid Emacs 19 - ; and get around transient-mark-mode in FSF Emacs 19 - ; all this so that (mark) does what it did in v18, sheesh. - (let* ((zmacs-regions nil) - (mark-even-if-inactive t) - (end (mark-marker))) - (while (< (point) end) - (insert vm-included-text-prefix) - (forward-line 1))))) - -(defun vm-yank-message-other-folder (folder) - "Like vm-yank-message except the message is yanked from a folder other -than the one that spawned the current Mail mode buffer. The name of the -folder is read from the minibuffer. - -Don't call this function from a program." - (interactive - (list - (let ((dir (if vm-folder-directory - (expand-file-name vm-folder-directory) - default-directory)) - (last-command last-command) - (this-command this-command)) - (read-file-name "Yank from folder: " dir nil t)))) - (let ((b (current-buffer)) newbuf sumbuf default result prompt mp) - (set-buffer (or (vm-get-file-buffer folder) (find-file-noselect folder))) - (setq newbuf (current-buffer)) - (if (not (eq major-mode 'vm-mode)) - (vm-mode)) - (if vm-presentation-buffer-handle - (vm-bury-buffer vm-presentation-buffer-handle)) - (if (null vm-message-pointer) - (error "No messages in folder %s" folder)) - (setq default (vm-number-of (car vm-message-pointer))) - (save-excursion - (save-window-excursion - (save-window-excursion - (vm-summarize)) - (vm-display vm-summary-buffer t '(vm-yank-message-other-folder) - '(vm-yank-message-other-folder composing-message)) - (setq sumbuf (current-buffer)) - (setq prompt (format "Yank message number: (default %s) " default) - result 0) - (while (zerop result) - (setq result (read-string prompt)) - (and (string= result "") default (setq result default)) - (setq result (string-to-int result))) - (if (null (setq mp (nthcdr (1- result) vm-message-list))) - (error "No such message.")))) - (set-buffer b) - (unwind-protect - (let ((vm-mail-buffer newbuf)) - (vm-yank-message (car mp))) - (vm-bury-buffer newbuf) - (vm-bury-buffer sumbuf)))) - -(defun vm-yank-message (message) - "Yank message number N into the current buffer at point. -When called interactively N is always read from the minibuffer. When -called non-interactively the first argument is expected to be a -message struct. - -This command is meant to be used in VM created Mail mode buffers; the -yanked message comes from the mail buffer containing the message you -are replying to, forwarding, or invoked VM's mail command from. - -All message headers are yanked along with the text. Point is -left before the inserted text, the mark after. Any hook -functions bound to mail-citation-hook are run, after inserting -the text and setting point and mark. For backward compatibility, -if mail-citation-hook is set to nil, `mail-yank-hooks' is run -instead. - -If mail-citation-hook and mail-yank-hooks are both nil, this -default action is taken: the yanked headers are trimmed as -specified by vm-included-text-headers and -vm-included-text-discard-header-regexp, and the value of -vm-included-text-prefix is prepended to every yanked line." - (interactive - (list - ;; What we really want for the first argument is a message struct, - ;; but if called interactively, we let the user type in a message - ;; number instead. - (let (mp default - (result 0) - prompt - (last-command last-command) - (this-command this-command)) - (save-excursion - (vm-select-folder-buffer) - (setq default (and vm-message-pointer - (vm-number-of (car vm-message-pointer))) - prompt (if default - (format "Yank message number: (default %s) " - default) - "Yank message number: ")) - (while (zerop result) - (setq result (read-string prompt)) - (and (string= result "") default (setq result default)) - (setq result (string-to-int result))) - (if (null (setq mp (nthcdr (1- result) vm-message-list))) - (error "No such message."))) - (car mp)))) - (if (not (bufferp vm-mail-buffer)) - (error "This is not a VM Mail mode buffer.")) - (if (null (buffer-name vm-mail-buffer)) - (error "The folder buffer containing message %d has been killed." - (vm-number-of message))) - (vm-display nil nil '(vm-yank-message) '(vm-yank-message composing-message)) - (setq message (vm-real-message-of message)) - (let ((b (current-buffer)) (start (point)) end) - (save-restriction - (widen) - (save-excursion - (if (vectorp (vm-mm-layout message)) - (let* ((o (vm-mm-layout message)) - (type (car (vm-mm-layout-type o))) - parts) - (vm-insert-region-from-buffer (vm-buffer-of message) - (vm-headers-of message) - (vm-text-of message)) - (cond ((vm-mime-types-match "multipart" type) - (setq parts (copy-sequence (vm-mm-layout-parts o)))) - (t (setq parts (list o)))) - (while parts - (cond ((vm-mime-text-type-p (car parts)) - (if (cond ((vm-mime-types-match - "text/html" - (car (vm-mm-layout-type (car parts)))) - (vm-mime-display-internal-text/html - (car parts))) - ((vm-mime-types-match - "text/enriched" - (car (vm-mm-layout-type (car parts)))) - (vm-mime-display-internal-text/enriched - (car parts))) - ((vm-mime-display-internal-text/plain - (car parts) t))) - nil - ;; charset problems probably - ;; just dump the raw bits - (vm-mime-insert-mime-body (car parts)) - (vm-mime-transfer-decode-region (car parts) - start (point))) - (setq parts (cdr parts))) - ((vm-mime-composite-type-p - (car (vm-mm-layout-type (car parts)))) - (setq parts (nconc (copy-sequence - (vm-mm-layout-parts - (car parts))) - (cdr parts)))) - (t (setq parts (cdr parts))))) - (setq end (point-marker))) - (set-buffer (vm-buffer-of message)) - (save-restriction - (widen) - (append-to-buffer b (vm-headers-of message) - (vm-text-end-of message)) - (setq end (vm-marker (+ start (- (vm-text-end-of message) - (vm-headers-of message))) b))))) - (push-mark end) - (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mail-yank-hooks (run-hooks 'mail-yank-hooks)) - (t (vm-mail-yank-default message)))))) - -(defun vm-mail-send-and-exit (arg) - "Just like mail-send-and-exit except that VM flags the appropriate message(s) -as having been replied to, if appropriate." - (interactive "P") - (vm-check-for-killed-folder) - (let ((b (current-buffer))) - (vm-mail-send) - (cond ((null (buffer-name b)) ;; dead buffer - ;; This improves window configuration behavior in - ;; XEmacs. It avoids taking the folder buffer from - ;; one frame and attaching it to the selected frame. - (set-buffer (window-buffer (selected-window))) - (vm-display nil nil '(vm-mail-send-and-exit) - '(vm-mail-send-and-exit - reading-message - startup))) - (t - (vm-display b nil '(vm-mail-send-and-exit) - '(vm-mail-send-and-exit reading-message startup)) - (vm-bury-buffer b))))) - -(defun vm-keep-mail-buffer (buffer) - ;; keep this buffer if the user demands it - (if (memq buffer vm-kept-mail-buffers) - (setq vm-kept-mail-buffers - (delq buffer vm-kept-mail-buffers))) - (setq vm-kept-mail-buffers (cons buffer vm-kept-mail-buffers) - vm-kept-mail-buffers (vm-delete 'buffer-name - vm-kept-mail-buffers t)) - (if (not (eq vm-keep-sent-messages t)) - (let ((extras (nthcdr (or vm-keep-sent-messages 0) - vm-kept-mail-buffers))) - (mapcar (function - (lambda (b) - (and (buffer-name b) - (not (buffer-modified-p b)) - (kill-buffer b)))) - extras) - (and vm-kept-mail-buffers extras - (setcdr (memq (car extras) vm-kept-mail-buffers) nil))))) - -(defun vm-help-tale () - (save-excursion - (goto-char (point-min)) - (while (vm-match-header) - (if (not (vm-match-header "To:\\|Resent-To:\\|Cc:\\|Resent-Cc:")) - (goto-char (vm-matched-header-end)) - (goto-char (vm-matched-header-contents-start)) - (if (re-search-forward "[^, \t][ \t]*\n[ \t\n]+[^ \t\n]" - (vm-matched-header-contents-end) - t) - (error "tale is an idiot, and so are you. :-)")) - (goto-char (vm-matched-header-end)))))) - -(defun vm-mail-send () - "Just like mail-send except that VM flags the appropriate message(s) -as replied to, forwarded, etc, if appropriate." - (interactive) - (if vm-tale-is-an-idiot - (vm-help-tale)) - ;; protect value of this-command from minibuffer read - (let ((this-command this-command)) - (if (and vm-confirm-mail-send - (not (y-or-n-p "Send the message? "))) - (error "Message not sent."))) - ;; send mail using MIME if user requests it and if the buffer - ;; has not already been MIME encoded. - (if (and vm-send-using-mime - (null (vm-mail-mode-get-header-contents "MIME-Version:"))) - (vm-mime-encode-composition)) - ;; this to prevent Emacs 19 from asking whether a message that - ;; has already been sent should be sent again. VM renames mail - ;; buffers after the message has been sent, so the user should - ;; already know that the message has been sent. - (set-buffer-modified-p t) - (let ((composition-buffer (current-buffer)) - ;; preserve these in case the composition buffer gets - ;; killed. - (vm-reply-list vm-reply-list) - (vm-forward-list vm-forward-list) - (vm-redistribute-list vm-redistribute-list)) - ;; fragment message using message/partial if it is too big. - (if (and vm-send-using-mime - (integerp vm-mime-max-message-size) - (> (buffer-size) vm-mime-max-message-size)) - (let (list) - (setq list (vm-mime-fragment-composition vm-mime-max-message-size)) - (while list - (save-excursion - (set-buffer (car list)) - (vm-mail-send) - (kill-buffer (car list))) - (setq list (cdr list))) - ;; what mail-send would have done - (set-buffer-modified-p nil)) - ;; don't want a buffer change to occur here - ;; save-excursion to be sure. - ;; - ;; also protect value of this-command from minibuffer reads - (let ((this-command this-command)) - (save-excursion - (mail-send)))) - ;; be careful, something could have killed the composition - ;; buffer inside mail-send. - (if (eq (current-buffer) composition-buffer) - (progn - (cond ((eq vm-system-state 'replying) - (vm-mail-mark-replied)) - ((eq vm-system-state 'forwarding) - (vm-mail-mark-forwarded)) - ((eq vm-system-state 'redistributing) - (vm-mail-mark-redistributed))) - (vm-rename-current-mail-buffer) - (vm-keep-mail-buffer (current-buffer)))) - (vm-display nil nil '(vm-mail-send) '(vm-mail-send)))) - -(defun vm-mail-mode-get-header-contents (header-name-regexp) - (let ((contents nil) - regexp) - (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^" - (regexp-quote mail-header-separator) "$\\)")) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (and (re-search-forward regexp nil t) - (match-beginning 1) - (progn (goto-char (match-beginning 0)) - (vm-match-header))) - (vm-matched-header-contents) - nil )))))) - -(defun vm-rename-current-mail-buffer () - (if vm-rename-current-buffer-function - (funcall vm-rename-current-buffer-function) - (let ((case-fold-search nil)) - (if (not (string-match "^sent " (buffer-name))) - (let (prefix name n) - (if (not (= ?* (aref (buffer-name) 0))) - (setq prefix (format "sent %s" (buffer-name))) - (let (recipients) - (cond ((not (zerop (length (setq recipients - (mail-fetch-field "To")))))) - ((not (zerop (length (setq recipients - (mail-fetch-field "Cc")))))) - ((not (zerop (length (setq recipients - (mail-fetch-field "Bcc")))))) - ; can't happen?!? - (t (setq recipients "the horse with no name"))) - (setq prefix (format "sent mail to %s" recipients)))) - (if (> (length prefix) 44) - (setq prefix (concat (substring prefix 0 40) " ..."))) - (setq name prefix n 2) - (while (get-buffer name) - (setq name (format "%s<%d>" prefix n)) - (vm-increment n)) - (rename-buffer name)))))) - -(defun vm-mail-mark-replied () - (save-excursion - (let ((mp vm-reply-list)) - (while mp - (if (null (buffer-name (vm-buffer-of (car mp)))) - () - (set-buffer (vm-buffer-of (car mp))) - (cond ((and (memq (car mp) vm-message-list) - (null (vm-replied-flag (car mp)))) - (vm-set-replied-flag (car mp) t)))) - (setq mp (cdr mp))) - (vm-update-summary-and-mode-line)))) - -(defun vm-mail-mark-forwarded () - (save-excursion - (let ((mp vm-forward-list)) - (while mp - (if (null (buffer-name (vm-buffer-of (car mp)))) - () - (set-buffer (vm-buffer-of (car mp))) - (cond ((and (memq (car mp) vm-message-list) - (null (vm-forwarded-flag (car mp)))) - (vm-set-forwarded-flag (car mp) t)))) - (setq mp (cdr mp))) - (vm-update-summary-and-mode-line)))) - -(defun vm-mail-mark-redistributed () - (save-excursion - (let ((mp vm-redistribute-list)) - (while mp - (if (null (buffer-name (vm-buffer-of (car mp)))) - () - (set-buffer (vm-buffer-of (car mp))) - (cond ((and (memq (car mp) vm-message-list) - (null (vm-redistributed-flag (car mp)))) - (vm-set-redistributed-flag (car mp) t)))) - (setq mp (cdr mp))) - (vm-update-summary-and-mode-line)))) - -(defun vm-reply (count) - "Reply to the sender of the current message. -Numeric prefix argument N means to reply to the current message plus the -next N-1 messages. A negative N means reply to the current message and -the previous N-1 messages. - -If invoked on marked messages (via vm-next-command-uses-marks), -all marked messages will be replied to. - -You will be placed into a standard Emacs Mail mode buffer to compose and -send your message. See the documentation for the function `mail' for -more info. - -Note that the normal binding of C-c C-y in the reply buffer is -automatically changed to vm-yank-message during a reply. This -allows you to yank any message from the current folder into a -reply. - -Normal VM commands may be accessed in the reply buffer by prefixing them -with C-c C-v." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-do-reply nil nil count)) - -(defun vm-reply-include-text (count) - "Reply to the sender (only) of the current message and include text -from the message. See the documentation for function vm-reply for details." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-do-reply nil t count)) - -(defun vm-followup (count) - "Reply to all recipients of the current message. -See the documentation for the function vm-reply for details." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-do-reply t nil count)) - -(defun vm-followup-include-text (count) - "Reply to all recipients of the current message and include text from -the message. See the documentation for the function vm-reply for details." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-do-reply t t count)) - -(defun vm-forward-message-all-headers () - "Like vm-forward-message but always forwards all the headers." - (interactive) - (let ((vm-forwarded-headers nil) - (vm-unforwarded-header-regexp "only-drop-this-header") - ;; set these because vm-forward-message calls vm-send-digest - ;; if there is more than one message to be forwarded. - (vm-rfc934-digest-headers nil) - (vm-rfc934-digest-discard-header-regexp "only-drop-this-header") - (vm-rfc1153-digest-headers nil) - (vm-rfc1153-digest-discard-header-regexp "only-drop-this-header") - (vm-mime-digest-headers nil) - (vm-mime-digest-discard-header-regexp "only-drop-this-header")) - (vm-forward-message))) - -(defun vm-forward-message () - "Forward the current message to one or more recipients. -You will be placed in a Mail mode buffer as you would with a -reply, but you must fill in the To: header and perhaps the -Subject: header manually." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (if (and (eq last-command 'vm-next-command-uses-marks) - (cdr (vm-select-marked-or-prefixed-messages 0))) - (let ((vm-digest-send-type vm-forwarding-digest-type)) - (setq this-command 'vm-next-command-uses-marks) - (command-execute 'vm-send-digest)) - (let ((dir default-directory) - (miming (and vm-send-using-mime - (equal vm-forwarding-digest-type "mime"))) - mail-buffer - header-end - (mp (vm-select-marked-or-prefixed-messages 1))) - (save-restriction - (widen) - (vm-mail-internal - (format "forward of %s's note re: %s" - (vm-su-full-name (car vm-message-pointer)) - (vm-su-subject (car vm-message-pointer))) - nil - (and vm-forwarding-subject-format - (let ((vm-summary-uninteresting-senders nil)) - (vm-sprintf 'vm-forwarding-subject-format (car mp))))) - (make-local-variable 'vm-forward-list) - (setq vm-system-state 'forwarding - vm-forward-list (list (car mp)) - default-directory dir) - (if miming - (progn - (setq mail-buffer (current-buffer)) - (set-buffer (generate-new-buffer "*vm-forward-buffer*")) - (setq header-end (point)) - (insert "\n")) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) - "\n")) - (goto-char (match-end 0)) - (setq header-end (match-beginning 0))) - (cond ((equal vm-forwarding-digest-type "mime") - (vm-mime-encapsulate-messages (list (car mp)) - vm-forwarded-headers - vm-unforwarded-header-regexp - nil) - (goto-char header-end) - (insert "MIME-Version: 1.0\n") - (insert "Content-Type: message/rfc822\n") - (insert "Content-Transfer-Encoding: " - (vm-determine-proper-content-transfer-encoding - (point) - (point-max)) - "\n")) - ((equal vm-forwarding-digest-type "rfc934") - (vm-rfc934-encapsulate-messages - vm-forward-list vm-forwarded-headers - vm-unforwarded-header-regexp)) - ((equal vm-forwarding-digest-type "rfc1153") - (vm-rfc1153-encapsulate-messages - vm-forward-list vm-forwarded-headers - vm-unforwarded-header-regexp)) - ((equal vm-forwarding-digest-type nil) - (vm-no-frills-encapsulate-message - (car vm-forward-list) vm-forwarded-headers - vm-unforwarded-header-regexp))) - (if miming - (let ((b (current-buffer))) - (set-buffer mail-buffer) - (mail-text) - (vm-mime-attach-object b "message/rfc822" nil nil t) - (add-hook 'kill-buffer-hook - (list 'lambda () - (list 'if (list 'eq mail-buffer '(current-buffer)) - (list 'kill-buffer b)))))) - (mail-position-on-field "To")) - (run-hooks 'vm-forward-message-hook) - (run-hooks 'vm-mail-mode-hook)))) - -(defun vm-resend-bounced-message () - "Extract the original text from a bounced message and resend it. -You will be placed in a Mail mode buffer with the extracted message and -you can change the recipient address before resending the message." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((b (current-buffer)) start - (dir default-directory) - (layout (vm-mm-layout (car vm-message-pointer))) - (lim (vm-text-end-of (car vm-message-pointer)))) - (save-restriction - (widen) - (if (or (not (vectorp layout)) - (not (setq layout (vm-mime-layout-contains-type - layout "message/rfc822")))) - (save-excursion - (goto-char (vm-text-of (car vm-message-pointer))) - (let ((case-fold-search t)) - ;; What a wonderful world it would be if mailers - ;; used a single message encapsulation standard - ;; instead of all the weird variants. It is - ;; useless to try to cover them all. This simple - ;; rule should cover the sanest of the formats - (if (not (re-search-forward "^Received:" lim t)) - (error "This doesn't look like a bounced message.")) - (beginning-of-line) - (setq start (point))))) - ;; briefly nullify vm-mail-header-from to keep vm-mail-internal - ;; from inserting another From header. - (let ((vm-mail-header-from nil)) - (vm-mail-internal - (format "retry of bounce from %s" - (vm-su-from (car vm-message-pointer))))) - (goto-char (point-min)) - (if (vectorp layout) - (progn - (setq start (point)) - (vm-mime-insert-mime-body layout) - (vm-mime-transfer-decode-region layout start (point))) - (insert-buffer-substring b start lim)) - (delete-region (point) (point-max)) - (goto-char (point-min)) - ;; delete all but pertinent headers - (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)") - (vm-reorder-message-headers nil vm-resend-bounced-headers - vm-resend-bounced-discard-header-regexp) - (if (search-forward "\n\n" nil t) - (replace-match "") - (goto-char (point-max))) - (insert ?\n mail-header-separator ?\n) - (goto-char (point-min)) - (if vm-mail-header-from - (insert "Resent-From: " vm-mail-header-from ?\n)) - (mail-position-on-field "Resent-To") - (setq default-directory dir))) - (run-hooks 'vm-resend-bounced-message-hook) - (run-hooks 'vm-mail-mode-hook)) - -(defun vm-resend-message () - "Resend the current message to someone else. -The current message will be copied to a Mail mode buffer and you -can edit the message and send it as usual. - -NOTE: since you are doing a resend, a Resent-To header is provided -for you to fill in the new recipient list. If you don't fill in -this header, what happens when you send the message is undefined. -You may also create a Resent-Cc header." - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (save-restriction - (widen) - (let ((b (current-buffer)) - (dir default-directory) - (vmp vm-message-pointer) - (start (vm-headers-of (car vm-message-pointer))) - (lim (vm-text-end-of (car vm-message-pointer)))) - ;; briefly nullify vm-mail-header-from to keep vm-mail-internal - ;; from inserting another From header. - (let ((vm-mail-header-from nil)) - (vm-mail-internal - (format "resend of %s's note re: %s" - (vm-su-full-name (car vm-message-pointer)) - (vm-su-subject (car vm-message-pointer))))) - (goto-char (point-min)) - (insert-buffer-substring b start lim) - (delete-region (point) (point-max)) - (goto-char (point-min)) - (if vm-mail-header-from - (insert "Resent-From: " vm-mail-header-from ?\n)) - (insert "Resent-To: \n") - (if mail-self-blind - (insert "Bcc: " (user-login-name) ?\n)) - (if mail-archive-file-name - (insert "FCC: " mail-archive-file-name ?\n)) - ;; delete all but pertinent headers - (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)") - (vm-reorder-message-headers nil vm-resend-headers - vm-resend-discard-header-regexp) - (if (search-forward "\n\n" nil t) - (replace-match "")) - (insert ?\n mail-header-separator ?\n) - (goto-char (point-min)) - (mail-position-on-field "Resent-To") - (make-local-variable 'vm-redistribute-list) - (setq vm-system-state 'redistributing - vm-redistribute-list (list (car vmp)) - default-directory dir) - (run-hooks 'vm-resend-message-hook) - (run-hooks 'vm-mail-mode-hook)))) - -(defun vm-send-digest (&optional prefix) - "Send a digest of all messages in the current folder to recipients. -The type of the digest is specified by the variable vm-digest-send-type. -You will be placed in a Mail mode buffer as is usual with replies, but you -must fill in the To: and Subject: headers manually. - -Prefix arg means to insert a list of preamble lines at the beginning of -the digest. One line is generated for each message being digestified. -The variable vm-digest-preamble-format determines the format of the -preamble lines. - -If invoked on marked messages (via vm-next-command-uses-marks), -only marked messages will be put into the digest." - (interactive "P") - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((dir default-directory) - (miming (and vm-send-using-mime (equal vm-digest-send-type "mime"))) - mp mail-buffer b - ;; prefix arg doesn't have "normal" meaning here, so only call - ;; vm-select-marked-or-prefixed-messages if we're using marks. - (mlist (if (eq last-command 'vm-next-command-uses-marks) - (vm-select-marked-or-prefixed-messages 0) - vm-message-list)) - start header-end boundary) - (save-restriction - (widen) - (vm-mail-internal (format "digest from %s" (buffer-name))) - (make-local-variable 'vm-forward-list) - (setq vm-system-state 'forwarding - vm-forward-list mlist - default-directory dir) - (if miming - (progn - (setq mail-buffer (current-buffer)) - (set-buffer (generate-new-buffer "*vm-digest-buffer*")) - (setq header-end (point)) - (insert "\n") - (setq start (point-marker))) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) - "\n")) - (goto-char (match-end 0)) - (setq start (point-marker) - header-end (match-beginning 0))) - (message "Building %s digest..." vm-digest-send-type) - (cond ((equal vm-digest-send-type "mime") - (setq boundary (vm-mime-encapsulate-messages - mlist vm-mime-digest-headers - vm-mime-digest-discard-header-regexp - t)) - (goto-char header-end) - (insert "MIME-Version: 1.0\n") - (insert (if vm-mime-avoid-folding-content-type - "Content-Type: multipart/digest; boundary=\"" - "Content-Type: multipart/digest;\n\tboundary=\"") - boundary "\"\n") - (insert "Content-Transfer-Encoding: " - (vm-determine-proper-content-transfer-encoding - (point) - (point-max)) - "\n")) - ((equal vm-digest-send-type "rfc934") - (vm-rfc934-encapsulate-messages - mlist vm-rfc934-digest-headers - vm-rfc934-digest-discard-header-regexp)) - ((equal vm-digest-send-type "rfc1153") - (vm-rfc1153-encapsulate-messages - mlist vm-rfc1153-digest-headers - vm-rfc1153-digest-discard-header-regexp))) - (goto-char start) - (setq mp mlist) - (if miming - (let ((b (current-buffer))) - (set-buffer mail-buffer) - (mail-text) - (vm-mime-attach-object b "multipart/digest" - (list (concat "boundary=\"" - boundary "\"")) nil t) - (add-hook 'kill-buffer-hook - (list 'lambda () - (list 'if (list 'eq mail-buffer '(current-buffer)) - (list 'kill-buffer b)))))) - (if prefix - (save-excursion - (message "Building digest preamble...") - (if miming - (progn - (set-buffer mail-buffer) - (mail-text))) - (while mp - (let ((vm-summary-uninteresting-senders nil)) - (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")) - (if vm-digest-center-preamble - (progn - (forward-char -1) - (center-line) - (forward-char 1))) - (setq mp (cdr mp))))) - (mail-position-on-field "To") - (message "Building %s digest... done" vm-digest-send-type))) - (run-hooks 'vm-send-digest-hook) - (run-hooks 'vm-mail-mode-hook)) - -(defun vm-send-rfc934-digest (&optional preamble) - "Like vm-send-digest but always sends an RFC 934 digest." - (interactive "P") - (let ((vm-digest-send-type "rfc934")) - (vm-send-digest preamble))) - -(defun vm-send-rfc1153-digest (&optional preamble) - "Like vm-send-digest but always sends an RFC 1153 digest." - (interactive "P") - (let ((vm-digest-send-type "rfc1153")) - (vm-send-digest preamble))) - -(defun vm-send-mime-digest (&optional preamble) - "Like vm-send-digest but always sends an MIME (multipart/digest) digest." - (interactive "P") - (let ((vm-digest-send-type "mime")) - (vm-send-digest preamble))) - -(defun vm-continue-composing-message (&optional not-picky) - "Find and select the most recently used mail composition buffer. -If the selected buffer is already a Mail mode buffer then it is -buried before beginning the search. Non Mail mode buffers and -unmodified Mail buffers are skipped. Prefix arg means unmodified -Mail mode buffers are not skipped. If no suitable buffer is -found, the current buffer remains selected." - (interactive "P") - (if (eq major-mode 'mail-mode) - (vm-bury-buffer (current-buffer))) - (let ((b (vm-find-composition-buffer not-picky))) - (if (not (or (null b) (eq b (current-buffer)))) - (progn - ;; avoid having the window configuration code choose a - ;; different composition buffer. - (vm-unbury-buffer b) - (set-buffer b) - (if (and vm-mutable-frames vm-frame-per-composition - (vm-multiple-frames-possible-p) - ;; only pop up a frame if there's an undisplay - ;; hook in place to make the frame go away. - vm-undisplay-buffer-hook) - (let ((w (vm-get-buffer-window b))) - (if (null w) - (vm-goto-new-frame 'composition) - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))) - ;; need to do this here too, since XEmacs has per - ;; frame buffer lists. - (vm-unbury-buffer b) - (vm-set-hooks-for-frame-deletion))) - (vm-display b t '(vm-continue-composing-message) - '(vm-continue-composing-message composing-message))) - (message "No composition buffers found")))) - -(defun vm-mail-to-mailto-url (url) - (let ((address (car (vm-parse url "^mailto:\\(.+\\)")))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-mail-internal nil address) - (run-hooks 'vm-mail-hook) - (run-hooks 'vm-mail-mode-hook))) - -;; to quiet the v19 byte compiler -(defvar mail-mode-map) -(defvar mail-aliases) -(defvar mail-default-reply-to) -(defvar mail-signature-file) - -(defun vm-mail-internal - (&optional buffer-name to subject in-reply-to cc references newsgroups) - (let ((folder-buffer nil)) - (if (memq major-mode '(vm-mode vm-virtual-mode)) - (setq folder-buffer (current-buffer))) - (set-buffer (generate-new-buffer (or buffer-name "*VM-mail*"))) - ;; avoid trying to write auto-save files in potentially - ;; unwritable directories. - (setq default-directory (or vm-folder-directory (expand-file-name "~/"))) - (auto-save-mode (if auto-save-default 1 -1)) - (mail-mode) - (use-local-map vm-mail-mode-map) - ;; make mail-mode-map the parent of this vm-mail-mode-map, if we can. - ;; do it only once. - (if (not vm-mail-mode-map-parented) - (cond ((fboundp 'set-keymap-parents) - (set-keymap-parents vm-mail-mode-map (list mail-mode-map)) - (setq vm-mail-mode-map-parented t)) - ((consp mail-mode-map) - (nconc vm-mail-mode-map mail-mode-map) - (setq vm-mail-mode-map-parented t)))) - (setq vm-mail-buffer folder-buffer - mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 - (vm-menu-support-possible-p) - (vm-menu-mode-menu))) - (and vm-use-menus (vm-menu-support-possible-p) - (vm-menu-install-mail-mode-menu)) - (if (fboundp 'mail-aliases-setup) ; use mail-abbrevs.el if present - (mail-aliases-setup) - (if (eq mail-aliases t) - (progn - (setq mail-aliases nil) - (if (file-exists-p (or mail-personal-alias-file "~/.mailrc")) - (build-mail-aliases))))) - (if (stringp vm-mail-header-from) - (insert "From: " vm-mail-header-from "\n")) - (insert "To: " (or to "") "\n") - (and cc (insert "Cc: " cc "\n")) - (insert "Subject: " (or subject "") "\n") - (and newsgroups (insert "Newsgroups: " newsgroups "\n")) - (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n")) - (and references (insert "References: " references "\n")) - (insert "X-Mailer: VM " vm-version " under " - (if vm-fsfemacs-19-p "Emacs " "") - emacs-version "\n") - ;; REPLYTO environmental variable support - ;; note that in FSF Emacs v19.29 we would initialize if the - ;; value was t. nil is the treigger value used now. - (and (eq mail-default-reply-to nil) - (setq mail-default-reply-to (getenv "REPLYTO"))) - (if mail-default-reply-to - (insert "Reply-To: " mail-default-reply-to "\n")) - (if mail-self-blind - (insert "Bcc: " (user-login-name) "\n")) - (if mail-archive-file-name - (insert "FCC: " mail-archive-file-name "\n")) - (if mail-default-headers - (insert mail-default-headers)) - (if (not (= (preceding-char) ?\n)) - (insert ?\n)) - (insert mail-header-separator "\n") - (cond ((stringp mail-signature) - (save-excursion - (insert mail-signature))) - ((eq mail-signature t) - (save-excursion - (insert "-- \n") - (insert-file-contents (or (and (boundp 'mail-signature-file) - (stringp mail-signature-file) - mail-signature-file) - "~/.signature"))))) - ;; move this buffer to the head of the buffer list so window - ;; config stuff will select it as the composition buffer. - (vm-unbury-buffer (current-buffer)) - ;; make a new frame if the user wants it. - (if (and vm-mutable-frames vm-frame-per-composition - (vm-multiple-frames-possible-p)) - (progn - (vm-goto-new-frame 'composition) - (vm-set-hooks-for-frame-deletion))) - ;; now do window configuration - (vm-display (current-buffer) t - '(vm-mail - vm-mail-other-frame - vm-mail-other-window - vm-reply - vm-reply-other-frame - vm-reply-include-text - vm-reply-include-text-other-frame - vm-followup - vm-followup-other-frame - vm-followup-include-text - vm-followup-include-text-other-frame - vm-send-digest - vm-send-digest-other-frame - vm-send-rfc934-digest - vm-send-rfc934-digest-other-frame - vm-send-rfc1153-digest - vm-send-rfc1153-digest-other-frame - vm-send-mime-digest - vm-send-mime-digest-other-frame - vm-forward-message - vm-forward-message-other-frame - vm-forward-message-all-headers - vm-forward-message-all-headers-other-frame - vm-resend-message - vm-resend-message-other-frame - vm-resend-bounced-message - vm-resend-bounced-message-other-frame) - (list this-command 'composing-message)) - (if (null to) - (mail-position-on-field "To")) - (run-hooks 'mail-setup-hook))) - -(defun vm-reply-other-frame (count) - "Like vm-reply, but run in a newly created frame." - (interactive "p") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-reply count)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-reply-include-text-other-frame (count) - "Like vm-reply-include-text, but run in a newly created frame." - (interactive "p") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-reply-include-text count)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-followup-other-frame (count) - "Like vm-followup, but run in a newly created frame." - (interactive "p") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-followup count)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-followup-include-text-other-frame (count) - "Like vm-followup-include-text, but run in a newly created frame." - (interactive "p") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-followup-include-text count)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-forward-message-all-headers-other-frame () - "Like vm-forward-message-all-headers, but run in a newly created frame." - (interactive) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-forward-message-all-headers)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-forward-message-other-frame () - "Like vm-forward-message, but run in a newly created frame." - (interactive) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-forward-message)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-resend-message-other-frame () - "Like vm-resend-message, but run in a newly created frame." - (interactive) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-resend-message)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-resend-bounced-message-other-frame () - "Like vm-resend-bounced-message, but run in a newly created frame." - (interactive) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-resend-bounced-message)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-send-digest-other-frame (&optional prefix) - "Like vm-send-digest, but run in a newly created frame." - (interactive "P") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-send-digest prefix)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-send-rfc934-digest-other-frame (&optional prefix) - "Like vm-send-rfc934-digest, but run in a newly created frame." - (interactive "P") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-send-rfc934-digest prefix)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-send-rfc1153-digest-other-frame (&optional prefix) - "Like vm-send-rfc1153-digest, but run in a newly created frame." - (interactive "P") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-send-rfc1153-digest prefix)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-send-mime-digest-other-frame (&optional prefix) - "Like vm-send-mime-digest, but run in a newly created frame." - (interactive "P") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-send-mime-digest prefix)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion)))
--- a/lisp/vm/vm-save.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,568 +0,0 @@ -;;; Saving and piping messages under VM -;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-save) - -;; (match-data) returns the match data as MARKERS, often corrupting -;; it in the process due to buffer narrowing, and the fact that buffers are -;; indexed from 1 while strings are indexed from 0. :-( -(defun vm-match-data () - (let ((index '(9 8 7 6 5 4 3 2 1 0)) - (list)) - (while index - (setq list (cons (match-beginning (car index)) - (cons (match-end (car index)) list)) - index (cdr index))) - list )) - -(defun vm-auto-select-folder (mp auto-folder-alist) - (condition-case error-data - (catch 'match - (let (header alist tuple-list) - (setq alist auto-folder-alist) - (while alist - (setq header (vm-get-header-contents (car mp) (car (car alist)) - ", ")) - (if (null header) - () - (setq tuple-list (cdr (car alist))) - (while tuple-list - (if (let ((case-fold-search vm-auto-folder-case-fold-search)) - (string-match (car (car tuple-list)) header)) - ;; Don't waste time eval'ing an atom. - (if (atom (cdr (car tuple-list))) - (throw 'match (cdr (car tuple-list))) - (let* ((match-data (vm-match-data)) - ;; allow this buffer to live forever - (buf (get-buffer-create " *vm-auto-folder*")) - (result)) - ;; Set up a buffer that matches our cached - ;; match data. - (save-excursion - (set-buffer buf) - (widen) - (erase-buffer) - (insert header) - ;; It appears that get-buffer-create clobbers the - ;; match-data. - ;; - ;; The match data is off by one because we matched - ;; a string and Emacs indexes strings from 0 and - ;; buffers from 1. - ;; - ;; Also store-match-data only accepts MARKERS!! - ;; AUGHGHGH!! - (store-match-data - (mapcar - (function (lambda (n) (and n (vm-marker n)))) - (mapcar - (function (lambda (n) (and n (1+ n)))) - match-data))) - (setq result (eval (cdr (car tuple-list)))) - (while (consp result) - (setq result (vm-auto-select-folder mp result))) - (if result - (throw 'match result)))))) - (setq tuple-list (cdr tuple-list)))) - (setq alist (cdr alist))) - nil )) - (error (error "error processing vm-auto-folder-alist: %s" - (prin1-to-string error-data))))) - -(defun vm-auto-archive-messages (&optional arg) - "Save all unfiled messages that auto-match a folder via -vm-auto-folder-alist to their appropriate folders. Messages that -are flagged for deletion are not saved. - -Prefix arg means to ask user for confirmation before saving each message. - -When invoked on marked messages (via vm-next-command-uses-marks), -only marked messages are checked against vm-auto-folder-alist. - -The saved messages are flagged as `filed'." - (interactive "P") - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (message "Archiving...") - (let ((auto-folder) - (archived 0)) - (unwind-protect - ;; Need separate (let ...) so vm-message-pointer can - ;; revert back in time for - ;; (vm-update-summary-and-mode-line). - ;; vm-last-save-folder is tucked away here since archives - ;; shouldn't affect its value. - (let ((vm-message-pointer - (if (eq last-command 'vm-next-command-uses-marks) - (vm-select-marked-or-prefixed-messages 0) - vm-message-list)) - (done nil) - stop-point - (vm-last-save-folder vm-last-save-folder) - (vm-move-after-deleting nil)) - ;; mark the place where we should stop. otherwise if any - ;; messages in this folder are archived to this folder - ;; we would file messages into this folder forever. - (setq stop-point (vm-last vm-message-pointer)) - (while (not done) - (and (not (vm-filed-flag (car vm-message-pointer))) - ;; don't archive deleted messages - (not (vm-deleted-flag (car vm-message-pointer))) - (setq auto-folder (vm-auto-select-folder - vm-message-pointer - vm-auto-folder-alist)) - (or (null arg) - (y-or-n-p - (format "Save message %s in folder %s? " - (vm-number-of (car vm-message-pointer)) - auto-folder))) - (let ((vm-delete-after-saving vm-delete-after-archiving)) - (vm-save-message auto-folder) - (vm-increment archived) - (message "%d archived, still working..." archived))) - (setq done (eq vm-message-pointer stop-point) - vm-message-pointer (cdr vm-message-pointer)))) - ;; fix mode line - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line)) - (if (zerop archived) - (message "No messages were archived") - (message "%d message%s archived" - archived (if (= 1 archived) "" "s"))))) - -(defun vm-save-message (folder &optional count) - "Save the current message to a mail folder. -If the folder already exists, the message will be appended to it. - -Prefix arg COUNT means save this message and the next COUNT-1 -messages. A negative COUNT means save this message and the -previous COUNT-1 messages. - -When invoked on marked messages (via vm-next-command-uses-marks), -all marked messages in the current folder are saved; other messages are -ignored. - -The saved messages are flagged as `filed'." - (interactive - (list - ;; protect value of last-command - (let ((last-command last-command) - (this-command this-command)) - (vm-follow-summary-cursor) - (let ((default (save-excursion - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (or (vm-auto-select-folder vm-message-pointer - vm-auto-folder-alist) - vm-last-save-folder))) - (dir (or vm-folder-directory default-directory))) - (cond ((and default - (let ((default-directory dir)) - (file-directory-p default))) - (vm-read-file-name "Save in folder: " dir nil nil default)) - (default - (vm-read-file-name - (format "Save in folder: (default %s) " default) - dir default)) - (t - (vm-read-file-name "Save in folder: " dir nil))))) - (prefix-numeric-value current-prefix-arg))) - (let (unexpanded-folder) - (setq unexpanded-folder folder) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-display nil nil '(vm-save-message) '(vm-save-message)) - (or count (setq count 1)) - ;; Expand the filename, forcing relative paths to resolve - ;; into the folder directory. - (let ((default-directory - (expand-file-name (or vm-folder-directory default-directory)))) - (setq folder (expand-file-name folder))) - ;; Confirm new folders, if the user requested this. - (if (and vm-confirm-new-folders (interactive-p) - (not (file-exists-p folder)) - (or (not vm-visit-when-saving) (not (vm-get-file-buffer folder))) - (not (y-or-n-p (format "%s does not exist, save there anyway? " - folder)))) - (error "Save aborted")) - ;; Check and see if we are currently visiting the folder - ;; that the user wants to save to. - (if (and (not vm-visit-when-saving) (vm-get-file-buffer folder)) - (error "Folder %s is being visited, cannot save." folder)) - (let ((mlist (vm-select-marked-or-prefixed-messages count)) - (m nil) (count 0) folder-buffer target-type) - (cond ((and mlist (eq vm-visit-when-saving t)) - (setq folder-buffer (or (vm-get-file-buffer folder) - ;; avoid letter bombs - (let ((inhibit-local-variables t) - (enable-local-variables nil)) - (find-file-noselect folder))))) - ((and mlist vm-visit-when-saving) - (setq folder-buffer (vm-get-file-buffer folder)))) - (if (and mlist vm-check-folder-types) - (progn - (setq target-type (or (vm-get-folder-type folder) - vm-default-folder-type - (and mlist - (vm-message-type-of (car mlist))))) - (if (eq target-type 'unknown) - (error "Folder %s's type is unrecognized" folder)))) - ;; if target folder is empty or nonexistent we need to - ;; write out the folder header first. - (if mlist - (let ((attrs (file-attributes folder))) - (if (or (null attrs) (= 0 (nth 7 attrs))) - (if (null folder-buffer) - (vm-write-string folder (vm-folder-header target-type)) - (vm-write-string folder-buffer - (vm-folder-header target-type)))))) - (save-excursion - (while mlist - (setq m (vm-real-message-of (car mlist))) - (set-buffer (vm-buffer-of m)) - (vm-save-restriction - (widen) - ;; have to stuff the attributes in all cases because - ;; the deleted attribute may have been stuffed - ;; previously and we don't want to save that attribute. - ;; also we don't want to save out the cached summary entry. - (vm-stuff-attributes m t) - (if (null folder-buffer) - (if (or (null vm-check-folder-types) - (eq target-type (vm-message-type-of m))) - (write-region (vm-start-of m) - (vm-end-of m) - folder t 'quiet) - (if (null vm-convert-folder-types) - (if (not (vm-virtual-message-p (car mlist))) - (error "Folder type mismatch: %s, %s" - (vm-message-type-of m) target-type) - (error "Message %s type mismatches folder %s" - (vm-number-of (car mlist)) - folder - (vm-message-type-of m) - target-type)) - (vm-write-string - folder - (vm-leading-message-separator target-type m t)) - (if (eq target-type 'From_-with-Content-Length) - (vm-write-string - folder - (concat vm-content-length-header " " - (vm-su-byte-count m) "\n"))) - (write-region (vm-headers-of m) - (vm-text-end-of m) - folder t 'quiet) - (vm-write-string - folder - (vm-trailing-message-separator target-type)))) - (save-excursion - (set-buffer folder-buffer) - ;; if the buffer is a live VM folder - ;; honor vm-folder-read-only. - (if vm-folder-read-only - (signal 'folder-read-only (list (current-buffer)))) - (let ((buffer-read-only nil)) - (vm-save-restriction - (widen) - (save-excursion - (goto-char (point-max)) - (if (or (null vm-check-folder-types) - (eq target-type (vm-message-type-of m))) - (insert-buffer-substring - (vm-buffer-of m) - (vm-start-of m) (vm-end-of m)) - (if (null vm-convert-folder-types) - (if (not (vm-virtual-message-p (car mlist))) - (error "Folder type mismatch: %s, %s" - (vm-message-type-of m) target-type) - (error "Message %s type mismatches folder %s" - (vm-number-of (car mlist)) - folder - (vm-message-type-of m) - target-type)) - (vm-write-string - (current-buffer) - (vm-leading-message-separator target-type m t)) - (if (eq target-type 'From_-with-Content-Length) - (vm-write-string - (current-buffer) - (concat vm-content-length-header " " - (vm-su-byte-count m) "\n"))) - (insert-buffer-substring (vm-buffer-of m) - (vm-headers-of m) - (vm-text-end-of m)) - (vm-write-string - (current-buffer) - (vm-trailing-message-separator target-type))))) - ;; vars should exist and be local - ;; but they may have strange values, - ;; so check the major-mode. - (cond ((eq major-mode 'vm-mode) - (vm-increment vm-messages-not-on-disk) - (vm-clear-modification-flag-undos))))))) - (if (null (vm-filed-flag m)) - (vm-set-filed-flag m t)) - (vm-increment count) - (vm-update-summary-and-mode-line) - (setq mlist (cdr mlist))))) - (if m - (if folder-buffer - (progn - (save-excursion - (set-buffer folder-buffer) - (if (eq major-mode 'vm-mode) - (progn - (vm-check-for-killed-summary) - (vm-assimilate-new-messages) - (if (null vm-message-pointer) - (progn (setq vm-message-pointer vm-message-list - vm-need-summary-pointer-update t) - (intern (buffer-name) - vm-buffers-needing-display-update) - (vm-preview-current-message)) - (vm-update-summary-and-mode-line))))) - (if (interactive-p) - (message "%d message%s saved to buffer %s" - count - (if (/= 1 count) "s" "") - (buffer-name folder-buffer)))) - (if (interactive-p) - (message "%d message%s saved to %s" - count (if (/= 1 count) "s" "") folder))))) - (setq vm-last-save-folder unexpanded-folder) - (if vm-delete-after-saving - (vm-delete-message count)))) - -(defun vm-save-message-sans-headers (file &optional count) - "Save the current message to a file, without its header section. -If the file already exists, the message will be appended to it. -Prefix arg COUNT means save the next COUNT messages. A negative COUNT means -save the previous COUNT. - -When invoked on marked messages (via vm-next-command-uses-marks), -all marked messages in the current folder are saved; other messages are -ignored. - -The saved messages are flagged as `written'. - -This command should NOT be used to save message to mail folders; use -vm-save-message instead (normally bound to `s')." - (interactive - ;; protect value of last-command - (let ((last-command last-command) - (this-command this-command)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (list - (vm-read-file-name - (if vm-last-written-file - (format "Write text to file: (default %s) " - vm-last-written-file) - "Write text to file: ") - nil vm-last-written-file nil) - (prefix-numeric-value current-prefix-arg)))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-display nil nil '(vm-save-message-sans-headers) - '(vm-save-message-sans-headers)) - (or count (setq count 1)) - (setq file (expand-file-name file)) - ;; Check and see if we are currently visiting the file - ;; that the user wants to save to. - (if (and (not vm-visit-when-saving) (vm-get-file-buffer file)) - (error "File %s is being visited, cannot save." file)) - (let ((mlist (vm-select-marked-or-prefixed-messages count)) - (m nil) file-buffer) - (cond ((and mlist (eq vm-visit-when-saving t)) - (setq file-buffer (or (vm-get-file-buffer file) - (find-file-noselect file)))) - ((and mlist vm-visit-when-saving) - (setq file-buffer (vm-get-file-buffer file)))) - (save-excursion - (while mlist - (setq m (vm-real-message-of (car mlist))) - (set-buffer (vm-buffer-of m)) - (vm-save-restriction - (widen) - (if (null file-buffer) - (write-region (vm-text-of m) - (vm-text-end-of m) - file t 'quiet) - (let ((start (vm-text-of m)) - (end (vm-text-end-of m))) - (save-excursion - (set-buffer file-buffer) - (save-excursion - (let (buffer-read-only) - (vm-save-restriction - (widen) - (save-excursion - (goto-char (point-max)) - (insert-buffer-substring - (vm-buffer-of m) - start end)))))))) - (if (null (vm-written-flag m)) - (vm-set-written-flag m t)) - (vm-update-summary-and-mode-line) - (setq mlist (cdr mlist))))) - (if m - (if file-buffer - (message "Message%s written to buffer %s" (if (/= 1 count) "s" "") - (buffer-name file-buffer)) - (message "Message%s written to %s" (if (/= 1 count) "s" "") file))) - (setq vm-last-written-file file))) - -(defun vm-pipe-message-to-command (command prefix-arg) - "Runs a shell command with some or all of the contents of the -current message as input. -By default, the entire message is used. -With one \\[universal-argument] the text portion of the message is used. -With two \\[universal-argument]'s the header portion of the message is used. -With three \\[universal-argument]'s the visible header portion of the message - plus the text portion is used. - -When invoked on marked messages (via vm-next-command-uses-marks), -each marked message is successively piped to the shell command, -one message per command invocation. - -Output, if any, is displayed. The message is not altered." - (interactive - ;; protect value of last-command - (let ((last-command last-command) - (this-command this-command)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (list (read-string "Pipe to command: " vm-last-pipe-command) - current-prefix-arg))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (setq vm-last-pipe-command command) - (let ((buffer (get-buffer-create "*Shell Command Output*")) - m - (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))) - ;; prefix arg doesn't have "normal" meaning here, so only call - ;; vm-select-marked-or-prefixed-messages if we're using marks. - (mlist (if (eq last-command 'vm-next-command-uses-marks) - (vm-select-marked-or-prefixed-messages 0) - (list (car vm-message-pointer))))) - (set-buffer buffer) - (erase-buffer) - (while mlist - (setq m (vm-real-message-of (car mlist))) - (set-buffer (vm-buffer-of m)) - (save-restriction - (widen) - (goto-char (vm-headers-of m)) - (cond ((equal prefix-arg nil) - (narrow-to-region (point) (vm-text-end-of m))) - ((equal prefix-arg '(4)) - (narrow-to-region (vm-text-of m) - (vm-text-end-of m))) - ((equal prefix-arg '(16)) - (narrow-to-region (point) (vm-text-of m))) - ((equal prefix-arg '(64)) - (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m))) - (t (narrow-to-region (point) (vm-text-end-of m)))) - (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))) - (call-process-region (point-min) (point-max) - (or shell-file-name "sh") - nil buffer nil shell-command-switch command))) - (setq mlist (cdr mlist))) - (set-buffer buffer) - (if (not (zerop (buffer-size))) - (vm-display buffer t '(vm-pipe-message-to-command) - '(vm-pipe-message-to-command)) - (vm-display nil nil '(vm-pipe-message-to-command) - '(vm-pipe-message-to-command))))) - -(defun vm-print-message (&optional count) - "Print the current message -Prefix arg N means print the current message and the next N - 1 messages. -Prefix arg -N means print the current message and the previous N - 1 messages. - -The variable `vm-print-command' controls what command is run to -print the message, and `vm-print-command-switches' is a list of switches -to pass to the command. - -When invoked on marked messages (via vm-next-command-uses-marks), -each marked message is printed, one message per vm-print-command invocation. - -Output, if any, is displayed. The message is not altered." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (or count (setq count 1)) - (let ((buffer (get-buffer-create "*Shell Command Output*")) - (command (mapconcat (function identity) - (nconc (list vm-print-command) - vm-print-command-switches) - " ")) - (m nil) - (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))) - (mlist (vm-select-marked-or-prefixed-messages count))) - (set-buffer buffer) - (erase-buffer) - (while mlist - (setq m (vm-real-message-of (car mlist))) - (set-buffer (vm-buffer-of m)) - (if (and vm-display-using-mime (vectorp (vm-mm-layout m))) - (let ((work-buffer nil)) - (unwind-protect - (progn - (setq work-buffer (generate-new-buffer "*vm-work*")) - (set-buffer work-buffer) - (vm-insert-region-from-buffer - (vm-buffer-of m) (vm-vheaders-of m) (vm-text-of m)) - (vm-decode-mime-encoded-words) - (goto-char (point-max)) - (let ((vm-auto-displayed-mime-content-types - '("text" "multipart")) - (vm-mime-internal-content-types - '("text" "multipart")) - (vm-mime-external-content-types-alist nil)) - (vm-decode-mime-layout (vm-mm-layout m))) - (let ((pop-up-windows (and pop-up-windows - (eq vm-mutable-windows t)))) - (call-process-region (point-min) (point-max) - (or shell-file-name "sh") - nil buffer nil - shell-command-switch command))) - (and work-buffer (kill-buffer work-buffer)))) - (save-restriction - (widen) - (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m)) - (let ((pop-up-windows (and pop-up-windows - (eq vm-mutable-windows t)))) - (call-process-region (point-min) (point-max) - (or shell-file-name "sh") - nil buffer nil - shell-command-switch command)))) - (setq mlist (cdr mlist))) - (set-buffer buffer) - (if (not (zerop (buffer-size))) - (vm-display buffer t '(vm-pipe-message-to-command) - '(vm-pipe-message-to-command)) - (vm-display nil nil '(vm-pipe-message-to-command) - '(vm-pipe-message-to-command)))))
--- a/lisp/vm/vm-search18.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,476 +0,0 @@ -;; Incremental search through a mail folder -;; For version 18 of FSF Emacs only. -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. - - -(provide 'vm-search) - -;; Adapted for the VM mail reader, Kyle Jones, May 1989 - - -;; This function does all the work of incremental search. -;; The functions attached to ^R and ^S are trivial, -;; merely calling this one, but they are always loaded by default -;; whereas this file can optionally be autoloadable. -;; This is the only entry point in this file. - -(defun vm-isearch (forward &optional regexp) - (let ((search-string "") - (search-message "") - (cmds nil) - (success t) - (wrapped nil) - (barrier (point)) - adjusted - (invalid-regexp nil) - (slow-terminal-mode (and (<= (baud-rate) search-slow-speed) - (> (window-height) - (* 4 search-slow-window-lines)))) - (other-end nil) ;Start of last match if fwd, end if backwd. - (small-window nil) ;if t, using a small window - (found-point nil) ;to restore point from a small window - ;; This is the window-start value found by the search. - (found-start nil) - (opoint (point)) - (vm-ml-message-new vm-ml-message-new) - (vm-ml-message-unread vm-ml-message-unread) - (vm-ml-message-read vm-ml-message-read) - (vm-ml-message-edited vm-ml-message-edited) - (vm-ml-message-replied vm-ml-message-replied) - (vm-ml-message-forwarded vm-ml-message-forwarded) - (vm-ml-message-filed vm-ml-message-filed) - (vm-ml-message-written vm-ml-message-written) - (vm-ml-message-marked vm-ml-message-marked) - (vm-ml-message-deleted vm-ml-message-deleted) - (vm-ml-message-number vm-ml-message-number) - (vm-message-pointer vm-message-pointer) - (inhibit-quit t)) ;Prevent ^G from quitting immediately. - (vm-isearch-push-state) - (save-window-excursion - (catch 'search-done - (while t - (or (>= unread-command-char 0) - (progn - (or (input-pending-p) - (vm-isearch-message)) - (if (and slow-terminal-mode - (not (or small-window (pos-visible-in-window-p)))) - (progn - (setq small-window t) - (setq found-point (point)) - (move-to-window-line 0) - (let ((window-min-height 1)) - (split-window nil (if (< search-slow-window-lines 0) - (1+ (- search-slow-window-lines)) - (- (window-height) - (1+ search-slow-window-lines))))) - (if (< search-slow-window-lines 0) - (progn (vertical-motion (- 1 search-slow-window-lines)) - (set-window-start (next-window) (point)) - (set-window-hscroll (next-window) - (window-hscroll)) - (set-window-hscroll (selected-window) 0)) - (other-window 1)) - (goto-char found-point))))) - (let ((char (if quit-flag - ?\C-g - (read-char)))) - (setq quit-flag nil adjusted nil) - ;; Meta character means exit search. - (cond ((and (>= char 128) - search-exit-option) - (setq unread-command-char char) - (throw 'search-done t)) - ((eq char search-exit-char) - ;; Esc means exit search normally. - ;; Except, if first thing typed, it means do nonincremental - (if (= 0 (length search-string)) - (vm-nonincremental-search forward regexp)) - (throw 'search-done t)) - ((= char ?\C-g) - ;; ^G means the user tried to quit. - (ding) - (discard-input) - (if success - ;; If search is successful, move back to starting point - ;; and really do quit. - (progn (goto-char opoint) - (vm-update-search-position) - (signal 'quit nil)) - ;; If search is failing, rub out until it is once more - ;; successful. - (while (not success) (vm-isearch-pop)))) - ((or (eq char search-repeat-char) - (eq char search-reverse-char)) - (if (eq forward (eq char search-repeat-char)) - ;; C-s in forward or C-r in reverse. - (if (equal search-string "") - ;; If search string is empty, use last one. - (setq search-string - (if regexp - search-last-regexp search-last-string) - search-message - (mapconcat 'text-char-description - search-string "")) - ;; If already have what to search for, repeat it. - (or success - (progn (goto-char (if forward (point-min) (point-max))) - (setq wrapped t)))) - ;; C-s in reverse or C-r in forward, change direction. - (setq forward (not forward))) - (setq barrier (point)) ; For subsequent \| if regexp. - (setq success t) - (or (equal search-string "") - (vm-isearch-search)) - (vm-isearch-push-state)) - ((= char search-delete-char) - ;; Rubout means discard last input item and move point - ;; back. If buffer is empty, just beep. - (if (null (cdr cmds)) - (ding) - (vm-isearch-pop))) - (t - (cond ((or (eq char search-yank-word-char) - (eq char search-yank-line-char)) - ;; ^W means gobble next word from buffer. - ;; ^Y means gobble rest of line from buffer. - (let ((word (save-excursion - (and (not forward) other-end - (goto-char other-end)) - (buffer-substring - (point) - (save-excursion - (if (eq char search-yank-line-char) - (end-of-line) - (forward-word 1)) - (point)))))) - (setq search-string (concat search-string word) - search-message - (concat search-message - (mapconcat 'text-char-description - word ""))))) - ;; Any other control char => - ;; unread it and exit the search normally. - ((and search-exit-option - (/= char search-quote-char) - (or (= char ?\177) - (and (< char ? ) (/= char ?\t) (/= char ?\r)))) - (setq unread-command-char char) - (throw 'search-done t)) - (t - ;; Any other character => add it to the - ;; search string and search. - (cond ((= char search-quote-char) - (setq char (read-quoted-char - (vm-isearch-message t)))) - ((= char ?\r) - ;; unix braindeath - (setq char ?\n))) - (setq search-string (concat search-string - (char-to-string char)) - search-message (concat search-message - (text-char-description char))))) - (if (and (not success) - ;; unsuccessful regexp search may become - ;; successful by addition of characters which - ;; make search-string valid - (not regexp)) - nil - ;; If a regexp search may have been made more - ;; liberal, retreat the search start. - ;; Go back to place last successful search started - ;; or to the last ^S/^R (barrier), whichever is nearer. - (and regexp success cmds - (cond ((memq char '(?* ??)) - (setq adjusted t) - (let ((cs (nth (if forward - 5 ; other-end - 2) ; saved (point) - (car (cdr cmds))))) - ;; (car cmds) is after last search; - ;; (car (cdr cmds)) is from before it. - (setq cs (or cs barrier)) - (goto-char - (if forward - (max cs barrier) - (min cs barrier))))) - ((eq char ?\|) - (setq adjusted t) - (goto-char barrier)))) - ;; In reverse regexp search, adding a character at - ;; the end may cause zero or many more chars to be - ;; matched, in the string following point. - ;; Allow all those possibilities without moving point as - ;; long as the match does not extend past search origin. - (if (and regexp (not forward) (not adjusted) - (condition-case () - (looking-at search-string) - (error nil)) - (<= (match-end 0) (min opoint barrier))) - (setq success t invalid-regexp nil - other-end (match-end 0)) - ;; Not regexp, not reverse, or no match at point. - (if (and other-end (not adjusted)) - (goto-char (if forward other-end - (min opoint barrier (1+ other-end))))) - (vm-isearch-search))) - (vm-isearch-push-state)))))) - (setq found-start (window-start (selected-window))) - (setq found-point (point))) - (if (> (length search-string) 0) - (if regexp - (setq search-last-regexp search-string) - (setq search-last-string search-string))) - (message "") - (if small-window - (goto-char found-point) - ;; Exiting the save-window-excursion clobbers this; restore it. - (set-window-start (selected-window) found-start t)))) - -(defun vm-isearch-message (&optional c-q-hack ellipsis) - ;; If about to search, and previous search regexp was invalid, - ;; check that it still is. If it is valid now, - ;; let the message we display while searching say that it is valid. - (and invalid-regexp ellipsis - (condition-case () - (progn (re-search-forward search-string (point) t) - (setq invalid-regexp nil)) - (error nil))) - ;; If currently failing, display no ellipsis. - (or success (setq ellipsis nil)) - (let ((m (concat (if success "" "failing ") - (if wrapped "wrapped ") - (if regexp "regexp " "") - "VM I-search" - (if forward ": " " backward: ") - search-message - (if c-q-hack "^Q" "") - (if invalid-regexp - (concat " [" invalid-regexp "]") - "")))) - (aset m 0 (upcase (aref m 0))) - (let ((cursor-in-echo-area ellipsis)) - (if c-q-hack m (message "%s" m))))) - -(defun vm-isearch-pop () - (setq cmds (cdr cmds)) - (let ((cmd (car cmds))) - (setq search-string (car cmd) - search-message (car (cdr cmd)) - success (nth 3 cmd) - forward (nth 4 cmd) - other-end (nth 5 cmd) - invalid-regexp (nth 6 cmd) - wrapped (nth 7 cmd) - barrier (nth 8 cmd) -; unused now -; vm-ml-attributes-string (nth 9 cmd) - vm-ml-message-number (nth 10 cmd) - vm-message-pointer (nth 11 cmd)) - (if vm-summary-buffer - (save-excursion - (set-buffer vm-summary-buffer) - (setq - ; unused now - ;vm-ml-attributes-string (nth 9 cmd) - vm-ml-message-number (nth 10 cmd)))) - (goto-char (car (cdr (cdr cmd)))) - (vm-set-summary-pointer (car vm-message-pointer)))) - -(defun vm-isearch-push-state () - (setq cmds (cons (list search-string search-message (point) - success forward other-end invalid-regexp - wrapped barrier -; unused now -; vm-ml-attributes-string - nil - vm-ml-message-number - vm-message-pointer) - cmds))) - -(defun vm-isearch-search () - (vm-isearch-message nil t) - (condition-case lossage - (let ((inhibit-quit nil)) - (if regexp (setq invalid-regexp nil)) - (setq success - (funcall - (if regexp - (if forward 're-search-forward 're-search-backward) - (if forward 'search-forward 'search-backward)) - search-string nil t)) - (if success - (setq other-end - (if forward (match-beginning 0) (match-end 0))))) - (quit (setq unread-command-char ?\C-g) - (setq success nil)) - (invalid-regexp (setq invalid-regexp (car (cdr lossage))) - (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid " - invalid-regexp) - (setq invalid-regexp "incomplete input")))) - (if success - (vm-update-search-position) - ;; Ding if failed this time after succeeding last time. - (and (nth 3 (car cmds)) - (ding)) - (goto-char (nth 2 (car cmds))))) - -;; This is called from incremental-search -;; if the first input character is the exit character. -;; The interactive-arg-reader uses free variables `forward' and `regexp' -;; which are bound by `incremental-search'. - -;; We store the search string in `search-string' -;; which has been bound already by `incremental-search' -;; so that, when we exit, it is copied into `search-last-string'. - -(defun vm-nonincremental-search (forward regexp) - (let (message char function string inhibit-quit - (cursor-in-echo-area t)) - ;; Prompt assuming not word search, - (setq message (if regexp - (if forward "VM Regexp search: " - "VM Regexp search backward: ") - (if forward "VM Search: " "VM Search backward: "))) - (message "%s" message) - ;; Read 1 char and switch to word search if it is ^W. - (setq char (read-char)) - (if (eq char search-yank-word-char) - (setq message (if forward "VM Word search: " "VM Word search backward: ")) - ;; Otherwise let that 1 char be part of the search string. - (setq unread-command-char char)) - (setq function - (if (eq char search-yank-word-char) - (if forward 'word-search-forward 'word-search-backward) - (if regexp - (if forward 're-search-forward 're-search-backward) - (if forward 'search-forward 'search-backward)))) - ;; Read the search string with corrected prompt. - (setq string (read-string message)) - ;; Empty means use default. - (if (= 0 (length string)) - (setq string search-last-string) - ;; Set last search string now so it is set even if we fail. - (setq search-last-string string)) - ;; Since we used the minibuffer, we should be available for redo. - (setq command-history (cons (list function string) command-history)) - ;; Go ahead and search. - (funcall function string))) - -(defun vm-update-search-position (&optional record-change) - (if (and (>= (point) (vm-start-of (car vm-message-pointer))) - (<= (point) (vm-end-of (car vm-message-pointer)))) - nil - (let ((mp vm-message-list) - (point (point))) - (while mp - (if (and (>= point (vm-start-of (car mp))) - (<= point (vm-end-of (car mp)))) - (if record-change - (progn - (vm-record-and-change-message-pointer vm-message-pointer mp) - (setq mp nil)) - (setq vm-message-pointer mp mp nil)) - (setq mp (cdr mp)))) - (setq vm-need-summary-pointer-update t) - (vm-update-summary-and-mode-line)))) - -(defun vm-isearch-forward (&optional arg) - "Incrementally search forward through the current folder's messages. -Usage is identical to the standard Emacs incremental search. -When the search terminates the message containing point will be selected. - -If the variable vm-search-using-regexps is non-nil, regular expressions -are understood; nil means the search will be for the input string taken -literally. Specifying a prefix ARG interactively toggles the value of -vm-search-using-regexps for this search." - (interactive "P") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-error-if-virtual-folder) - (vm-display (current-buffer) t '(vm-isearch-forward) '(vm-isearch-forward)) - (let ((clip-head (point-min)) - (clip-tail (point-max)) - (old-w (selected-window))) - (unwind-protect - (progn (select-window (get-buffer-window (current-buffer))) - (widen) - (vm-isearch t (if arg - (not vm-search-using-regexps) - vm-search-using-regexps)) - (vm-update-search-position t) - ;; vm-show-current-message only adjusts (point-max), - ;; it doesn't change (point-min). - (narrow-to-region - (if (< (point) (vm-vheaders-of (car vm-message-pointer))) - (vm-start-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer))) - (point-max)) - (vm-show-current-message) - (setq vm-system-state 'reading) - ;; turn the clipping unwind into a noop - (setq clip-head (point-min)) - (setq clip-tail (point-max))) - (narrow-to-region clip-head clip-tail) - (select-window old-w)))) - -(defun vm-isearch-backward (&optional arg) - "Incrementally search backward through the current folder's messages. -Usage is identical to the standard Emacs incremental search. -When the search terminates the message containing point will be selected. - -If the variable vm-search-using-regexps is non-nil, regular expressions -are understood; nil means the search will be for the input string taken -literally. Specifying a prefix ARG interactively toggles the value of -vm-search-using-regexps for this search." - (interactive "P") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-error-if-virtual-folder) - (vm-display (current-buffer) t '(vm-isearch-backward) - (list 'vm-isearch-backward 'searching-message)) - (let ((clip-head (point-min)) - (clip-tail (point-max)) - (old-w (selected-window))) - (unwind-protect - (progn (select-window (get-buffer-window (current-buffer))) - (widen) - (vm-isearch nil (if arg - (not vm-search-using-regexps) - vm-search-using-regexps)) - (vm-update-search-position t) - ;; vm-show-current-message only adjusts (point-max), - ;; it doesn't change (point-min). - (narrow-to-region - (if (< (point) (vm-vheaders-of (car vm-message-pointer))) - (vm-start-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer))) - (point-max)) - (vm-show-current-message) - (setq vm-system-state 'reading) - ;; turn the clipping unwind into a noop - (setq clip-head (point-min)) - (setq clip-tail (point-max))) - (narrow-to-region clip-head clip-tail) - (select-window old-w))))
--- a/lisp/vm/vm-search19.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -;;; Incremental search through a mail folder (for Lucid and FSF Emacs 19) -;;; Copyright (C) 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-search) - -(defun vm-isearch-forward (&optional arg) - "Incrementally search forward through the current folder's messages. -Usage is identical to the standard Emacs incremental search. -When the search terminates the message containing point will be selected. - -If the variable vm-search-using-regexps is non-nil, regular expressions -are understood; nil means the search will be for the input string taken -literally. Specifying a prefix ARG interactively toggles the value of -vm-search-using-regexps for this search." - (interactive "P") - (let ((vm-search-using-regexps - (if arg (not vm-search-using-regexps) vm-search-using-regexps))) - (vm-isearch t))) - -(defun vm-isearch-backward (&optional arg) - "Incrementally search backward through the current folder's messages. -Usage is identical to the standard Emacs incremental search. -When the search terminates the message containing point will be selected. - -If the variable vm-search-using-regexps is non-nil, regular expressions -are understood; nil means the search will be for the input string taken -literally. Specifying a prefix ARG interactively toggles the value of -vm-search-using-regexps for this search." - (interactive "P") - (let ((vm-search-using-regexps - (if arg (not vm-search-using-regexps) vm-search-using-regexps))) - (vm-isearch nil))) - -(defun vm-isearch (forward) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-error-if-virtual-folder) - (vm-display (current-buffer) t '(vm-isearch-forward vm-isearch-backward) - (list this-command 'searching-message)) - (let ((clip-head (point-min)) - (clip-tail (point-max)) - (old-vm-message-pointer vm-message-pointer)) - (unwind-protect - (progn (select-window (vm-get-visible-buffer-window (current-buffer))) - (widen) - (add-hook 'pre-command-hook 'vm-isearch-widen) - ;; order is significant, we want to narrow after - ;; the update - (add-hook 'post-command-hook 'vm-isearch-narrow) - (add-hook 'post-command-hook 'vm-isearch-update) - (isearch-mode forward vm-search-using-regexps nil t) - (vm-isearch-update) - (if (not (eq vm-message-pointer old-vm-message-pointer)) - (progn - (vm-record-and-change-message-pointer - old-vm-message-pointer vm-message-pointer) - (vm-update-summary-and-mode-line) - ;; vm-show-current-message only adjusts (point-max), - ;; it doesn't change (point-min). - (widen) - (narrow-to-region - (if (< (point) (vm-vheaders-of (car vm-message-pointer))) - (vm-start-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer))) - (vm-text-end-of (car vm-message-pointer))) - (save-excursion (vm-energize-urls)) - (vm-display nil nil - '(vm-isearch-forward vm-isearch-backward) - '(reading-message)) - ;; turn the unwinds into a noop - (setq old-vm-message-pointer vm-message-pointer) - (setq clip-head (point-min)) - (setq clip-tail (point-max))))) - (remove-hook 'pre-command-hook 'vm-isearch-widen) - (remove-hook 'post-command-hook 'vm-isearch-update) - (remove-hook 'post-command-hook 'vm-isearch-narrow) - (narrow-to-region clip-head clip-tail) - (setq vm-message-pointer old-vm-message-pointer)))) - -(defun vm-isearch-widen () - (if (eq major-mode 'vm-mode) - (widen))) - -(defun vm-isearch-narrow () - (if (eq major-mode 'vm-mode) - (narrow-to-region - (if (< (point) (vm-vheaders-of (car vm-message-pointer))) - (vm-start-of (car vm-message-pointer)) - (vm-vheaders-of (car vm-message-pointer))) - (vm-text-end-of (car vm-message-pointer))))) - -(defun vm-isearch-update () - (if (eq major-mode 'vm-mode) - (if (and (>= (point) (vm-start-of (car vm-message-pointer))) - (<= (point) (vm-end-of (car vm-message-pointer)))) - nil - (let ((mp vm-message-list) - (point (point))) - (while mp - (if (and (>= point (vm-start-of (car mp))) - (<= point (vm-end-of (car mp)))) - (setq vm-message-pointer mp mp nil) - (setq mp (cdr mp)))) - (setq vm-need-summary-pointer-update t) - (intern (buffer-name) vm-buffers-needing-display-update) - (vm-update-summary-and-mode-line)))))
--- a/lisp/vm/vm-sort.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,557 +0,0 @@ -;;; Sorting and moving messages inside VM -;;; Copyright (C) 1993, 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-sort) - -(defun vm-move-message-forward (count) - "Move a message forward in a VM folder. -Prefix arg COUNT causes the current message to be moved COUNT messages forward. -A negative COUNT causes movement to be backward instead of forward. -COUNT defaults to 1. The current message remains selected after being -moved. - -If vm-move-messages-physically is non-nil, the physical copy of -the message in the folder is moved. A nil value means just -change the presentation order and leave the physical order of -the folder undisturbed." - (interactive "p") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (if vm-move-messages-physically - (vm-error-if-folder-read-only)) - (vm-display nil nil '(vm-move-message-forward - vm-move-message-backward - vm-move-message-forward-physically - vm-move-message-backward-physically) - (list this-command)) - (let* ((ovmp vm-message-pointer) vmp-prev ovmp-prev - (vm-message-pointer vm-message-pointer) - (direction (if (> count 0) 'forward 'backward)) - (count (vm-abs count))) - (while (not (zerop count)) - (vm-move-message-pointer direction) - (vm-decrement count)) - (if (> (string-to-int (vm-number-of (car vm-message-pointer))) - (string-to-int (vm-number-of (car ovmp)))) - (setq vm-message-pointer (cdr vm-message-pointer))) - (if (eq vm-message-pointer ovmp) - () - (if (null vm-message-pointer) - (setq vmp-prev (vm-last vm-message-list)) - (setq vmp-prev (vm-reverse-link-of (car vm-message-pointer)))) - (setq ovmp-prev (vm-reverse-link-of (car ovmp))) - ;; lock out interrupts to preserve message list integrity. - (let ((inhibit-quit t)) - (if ovmp-prev - (progn - (setcdr ovmp-prev (cdr ovmp)) - (and (cdr ovmp) - (vm-set-reverse-link-of (car (cdr ovmp)) ovmp-prev))) - (setq vm-message-list (cdr ovmp)) - (vm-set-reverse-link-of (car vm-message-list) nil)) - (if vmp-prev - (progn - (setcdr vmp-prev ovmp) - (vm-set-reverse-link-of (car ovmp) vmp-prev)) - (setq vm-message-list ovmp) - (vm-set-reverse-link-of (car vm-message-list) nil)) - (setcdr ovmp vm-message-pointer) - (and vm-message-pointer - (vm-set-reverse-link-of (car vm-message-pointer) ovmp)) - (if (and vm-move-messages-physically - (not (eq major-mode 'vm-virtual-mode))) - (vm-physically-move-message (car ovmp) (car vm-message-pointer))) - (setq vm-ml-sort-keys nil) - (if (not vm-folder-read-only) - (progn - (setq vm-message-order-changed t) - (vm-set-buffer-modified-p t) - (vm-clear-modification-flag-undos)))) - (cond ((null ovmp-prev) - (setq vm-numbering-redo-start-point vm-message-list - vm-numbering-redo-end-point vm-message-pointer - vm-summary-pointer (car vm-message-list))) - ((null vmp-prev) - (setq vm-numbering-redo-start-point vm-message-list - vm-numbering-redo-end-point (cdr ovmp-prev) - vm-summary-pointer (car ovmp-prev))) - ((or (not vm-message-pointer) - (< (string-to-int (vm-number-of (car ovmp-prev))) - (string-to-int (vm-number-of (car vm-message-pointer))))) - (setq vm-numbering-redo-start-point (cdr ovmp-prev) - vm-numbering-redo-end-point (cdr ovmp) - vm-summary-pointer (car (cdr ovmp-prev)))) - (t - (setq vm-numbering-redo-start-point ovmp - vm-numbering-redo-end-point (cdr ovmp-prev) - vm-summary-pointer (car ovmp-prev)))) - (if vm-summary-buffer - (let (list mp) - (vm-copy-local-variables vm-summary-buffer 'vm-summary-pointer) - (setq vm-need-summary-pointer-update t) - (setq mp vm-numbering-redo-start-point) - (while (not (eq mp vm-numbering-redo-end-point)) - (vm-mark-for-summary-update (car mp)) - (setq list (cons (car mp) list) - mp (cdr mp))) - (vm-mapc - (function - (lambda (m p) - (vm-set-su-start-of m (car p)) - (vm-set-su-end-of m (car (cdr p))))) - (setq list (nreverse list)) - (sort - (mapcar - (function - (lambda (p) - (list (vm-su-start-of p) (vm-su-end-of p)))) - list) - (function - (lambda (p q) - (< (car p) (car q)))))))))) - (if vm-move-messages-physically - ;; clip region is messed up - (vm-preview-current-message) - (vm-update-summary-and-mode-line))) - -(defun vm-move-message-backward (count) - "Move a message backward in a VM folder. -Prefix arg COUNT causes the current message to be moved COUNT -messages backward. A negative COUNT causes movement to be -forward instead of backward. COUNT defaults to 1. The current -message remains selected after being moved. - -If vm-move-messages-physically is non-nil, the physical copy of -the message in the folder is moved. A nil value means just -change the presentation order and leave the physical order of -the folder undisturbed." - (interactive "p") - (vm-move-message-forward (- count))) - -(defun vm-move-message-forward-physically (count) - "Like vm-move-message-forward but always move the message physically." - (interactive "p") - (let ((vm-move-messages-physically t)) - (vm-move-message-forward count))) - -(defun vm-move-message-backward-physically (count) - "Like vm-move-message-backward but always move the message physically." - (interactive "p") - (let ((vm-move-messages-physically t)) - (vm-move-message-backward count))) - -;; move message m to be before m-dest -;; and fix up the location markers afterwards. -;; m better not equal m-dest. -;; of m-dest is nil, move m to the end of buffer. -;; -;; consider carefully the effects of insertion on markers -;; and variables containg markers before you modify this code. -(defun vm-physically-move-message (m m-dest) - (save-excursion - (vm-save-restriction - (widen) - - ;; Make sure vm-headers-of and vm-text-of are non-nil in - ;; their slots before we try to move them. (Simply - ;; referencing the slot with their slot function is - ;; sufficient to guarantee this.) Otherwise, they be - ;; initialized in the middle of the message move and get the - ;; offset applied to them twice by way of a relative offset - ;; from one of the other location markers that has already - ;; been moved. - ;; - ;; Also, and more importantly, vm-vheaders-of might run - ;; vm-reorder-message-headers, which can add text to - ;; message. This MUST NOT happen after offsets have been - ;; computed for the message move or varying levels of chaos - ;; will ensue. In the case of BABYL files, where - ;; vm-reorder-message-headers can add a lot of new text, - ;; folder curroption can be massive. - (vm-text-of m) - (vm-vheaders-of m) - - (let ((dest-start (if m-dest (vm-start-of m-dest) (point-max))) - (buffer-read-only nil) - offset doomed-start doomed-end) - (goto-char dest-start) - (insert-buffer-substring (current-buffer) (vm-start-of m) (vm-end-of m)) - (setq doomed-start (marker-position (vm-start-of m)) - doomed-end (marker-position (vm-end-of m)) - offset (- (vm-start-of m) dest-start)) - (set-marker (vm-start-of m) (- (vm-start-of m) offset)) - (set-marker (vm-headers-of m) (- (vm-headers-of m) offset)) - (set-marker (vm-text-end-of m) (- (vm-text-end-of m) offset)) - (set-marker (vm-end-of m) (- (vm-end-of m) offset)) - (set-marker (vm-text-of m) (- (vm-text-of m) offset)) - (set-marker (vm-vheaders-of m) (- (vm-vheaders-of m) offset)) - ;; now fix the start of m-dest since it didn't - ;; move forward with its message. - (and m-dest (set-marker (vm-start-of m-dest) (vm-end-of m))) - ;; delete the old copy of the message - (delete-region doomed-start doomed-end))))) - -(defun vm-so-sortable-datestring (m) - (or (vm-sortable-datestring-of m) - (progn - (vm-set-sortable-datestring-of - m - (condition-case nil - (timezone-make-date-sortable - (or (vm-get-header-contents m "Date:") - (vm-grok-From_-date m) - "Thu, 1 Jan 1970 00:00:00 GMT") - "GMT" "GMT") - (error "1970010100:00:00"))) - (vm-sortable-datestring-of m)))) - -(defun vm-so-sortable-subject (m) - (or (vm-sortable-subject-of m) - (progn - (vm-set-sortable-subject-of - m - (let ((case-fold-search t) - (subject (vm-su-subject m))) - (if (and vm-subject-ignored-prefix - (string-match vm-subject-ignored-prefix subject) - (zerop (match-beginning 0))) - (setq subject (substring subject (match-end 0)))) - (if (and vm-subject-ignored-suffix - (string-match vm-subject-ignored-suffix subject) - (= (match-end 0) (length subject))) - (setq subject (substring subject 0 (match-beginning 0)))) - subject )) - (vm-sortable-subject-of m)))) - -(defun vm-sort-messages (keys &optional lets-get-physical) - "Sort message in a folder by the specified KEYS. -You may sort by more than one particular message key. If -messages compare equal by the first key, the second key will be -compared and so on. When called interactively the keys will be -read from the minibuffer. Valid keys are - -\"date\" \"reversed-date\" -\"author\" \"reversed-author\" -\"subject\" \"reversed-subject\" -\"recipients\" \"reversed-recipients\" -\"line-count\" \"reversed-line-count\" -\"byte-count\" \"reversed-byte-count\" -\"physical-order\" \"reversed-physical-order\" - -Optional second arg (prefix arg interactively) means the sort -should change the physical order of the messages in the folder. -Normally VM changes presentation order only, leaving the -folder in the order in which the messages arrived." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (list (vm-read-string (if (or current-prefix-arg - vm-move-messages-physically) - "Physically sort messages by: " - "Sort messages by: ") - vm-supported-sort-keys t) - current-prefix-arg))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - ;; only squawk if interactive. The thread display uses this - ;; function and doesn't expect errors. - (if (interactive-p) - (vm-error-if-folder-empty)) - ;; ditto - (if (and (interactive-p) (or vm-move-messages-physically lets-get-physical)) - (vm-error-if-folder-read-only)) - (vm-display nil nil '(vm-sort-messages) '(vm-sort-messages)) - (let (key-list key-funcs key ml-keys - physical-order-list old-message-list new-message-list mp-old mp-new - old-start - doomed-start doomed-end offset - (order-did-change nil) - virtual - physical) - (setq key-list (vm-parse keys "[ \t]*\\([^ \t]+\\)") - ml-keys (and key-list (mapconcat (function identity) key-list "/")) - key-funcs nil - old-message-list vm-message-list - virtual (eq major-mode 'vm-virtual-mode) - physical (and (or lets-get-physical - vm-move-messages-physically) - (not vm-folder-read-only) - (not virtual))) - (or key-list (error "No sort keys specified.")) - (while key-list - (setq key (car key-list)) - (cond ((equal key "thread") - (vm-build-threads-if-unbuilt) - (setq key-funcs (cons 'vm-sort-compare-thread key-funcs))) - ((equal key "author") - (setq key-funcs (cons 'vm-sort-compare-author key-funcs))) - ((equal key "reversed-author") - (setq key-funcs (cons 'vm-sort-compare-author-r key-funcs))) - ((equal key "date") - (setq key-funcs (cons 'vm-sort-compare-date key-funcs))) - ((equal key "reversed-date") - (setq key-funcs (cons 'vm-sort-compare-date-r key-funcs))) - ((equal key "subject") - (setq key-funcs (cons 'vm-sort-compare-subject key-funcs))) - ((equal key "reversed-subject") - (setq key-funcs (cons 'vm-sort-compare-subject-r key-funcs))) - ((equal key "recipients") - (setq key-funcs (cons 'vm-sort-compare-recipients key-funcs))) - ((equal key "reversed-recipients") - (setq key-funcs (cons 'vm-sort-compare-recipients-r key-funcs))) - ((equal key "byte-count") - (setq key-funcs (cons 'vm-sort-compare-byte-count key-funcs))) - ((equal key "reversed-byte-count") - (setq key-funcs (cons 'vm-sort-compare-byte-count-r key-funcs))) - ((equal key "line-count") - (setq key-funcs (cons 'vm-sort-compare-line-count key-funcs))) - ((equal key "reversed-line-count") - (setq key-funcs (cons 'vm-sort-compare-line-count-r key-funcs))) - ((equal key "physical-order") - (setq key-funcs (cons 'vm-sort-compare-physical-order key-funcs))) - ((equal key "reversed-physical-order") - (setq key-funcs (cons 'vm-sort-compare-physical-order-r key-funcs))) - (t (error "Unknown key: %s" key))) - (setq key-list (cdr key-list))) - (message "Sorting...") - (let ((vm-key-functions (nreverse key-funcs))) - (setq new-message-list (sort (copy-sequence old-message-list) - 'vm-sort-compare-xxxxxx)) - ;; only need to do this sort if we're going to physically - ;; move messages later. - (if physical - (setq vm-key-functions '(vm-sort-compare-physical-order) - physical-order-list (sort (copy-sequence old-message-list) - 'vm-sort-compare-xxxxxx)))) - (message "Sorting... done") - (let ((inhibit-quit t)) - (setq mp-old old-message-list - mp-new new-message-list) - (while mp-new - (if (eq (car mp-old) (car mp-new)) - (setq mp-old (cdr mp-old) - mp-new (cdr mp-new)) - (setq order-did-change t) - ;; unless a full redo has been requested, the numbering - ;; start point now points to a cons in the old message - ;; list. therefore we just change the variable - ;; directly to avoid the list scan that - ;; vm-set-numbering-redo-start-point does. - (cond ((not (eq vm-numbering-redo-start-point t)) - (setq vm-numbering-redo-start-point mp-new - vm-numbering-redo-end-point nil))) - (if vm-summary-buffer - (progn - (setq vm-need-summary-pointer-update t) - ;; same logic as numbering reset above... - (cond ((not (eq vm-summary-redo-start-point t)) - (setq vm-summary-redo-start-point mp-new))) - ;; start point of this message's summary is now - ;; wrong relative to where it is in the - ;; message list. fix it and the summary rebuild - ;; will take care of the rest. - (vm-set-su-start-of (car mp-new) - (vm-su-start-of (car mp-old))))) - (setq mp-new nil))) - (if (and order-did-change physical) - (let ((buffer-read-only nil)) - ;; the folder is being physically ordered so we don't - ;; need a message order header to be stuffed, nor do - ;; we need to retain one in the folder buffer. so we - ;; strip out any existing message order header and - ;; say there are no changes to prevent a message - ;; order header from being stuffed later. - (vm-remove-message-order) - (setq vm-message-order-changed nil) - (message "Moving messages... ") - (widen) - (setq mp-old physical-order-list - mp-new new-message-list) - (setq old-start (vm-start-of (car mp-old))) - (while mp-new - (if (< (vm-start-of (car mp-old)) old-start) - ;; already moved this message - (setq mp-old (cdr mp-old)) - (if (eq (car mp-old) (car mp-new)) - (setq mp-old (cdr mp-old) - mp-new (cdr mp-new)) - ;; move message - (vm-physically-move-message (car mp-new) (car mp-old)) - ;; record start position. if vm-start-of - ;; mp-old ever becomes less than old-start - ;; we're running into messages that have - ;; already been moved. - (setq old-start (vm-start-of (car mp-old))) - ;; move mp-new but not mp-old because we moved - ;; mp-old down one message by inserting a - ;; message in front of it. - (setq mp-new (cdr mp-new))))) - (message "Moving messages... done") - (vm-set-buffer-modified-p t) - (vm-clear-modification-flag-undos)) - (if (and order-did-change (not vm-folder-read-only)) - (progn - (setq vm-message-order-changed t) - (vm-set-buffer-modified-p t) - (vm-clear-modification-flag-undos)))) - (setq vm-ml-sort-keys ml-keys) - (intern (buffer-name) vm-buffers-needing-display-update) - (cond (order-did-change - (setq vm-message-list new-message-list) - (vm-reverse-link-messages) - (if vm-message-pointer - (setq vm-message-pointer - (or (cdr (vm-reverse-link-of (car vm-message-pointer))) - vm-message-list))) - (if vm-last-message-pointer - (setq vm-last-message-pointer - (or (cdr (vm-reverse-link-of - (car vm-last-message-pointer))) - vm-message-list)))))) - (if (and vm-message-pointer - order-did-change - (or lets-get-physical vm-move-messages-physically)) - ;; clip region is most likely messed up - (vm-preview-current-message) - (vm-update-summary-and-mode-line)))) - -(defun vm-sort-compare-xxxxxx (m1 m2) - (let ((key-funcs vm-key-functions) result) - (while (and key-funcs - (eq '= (setq result (funcall (car key-funcs) m1 m2)))) - (setq key-funcs (cdr key-funcs))) - (and key-funcs result) )) - -(defun vm-sort-compare-thread (m1 m2) - (let ((list1 (vm-th-thread-list m1)) - (list2 (vm-th-thread-list m2))) - (catch 'done - (if (not (eq (car list1) (car list2))) - (let ((date1 (get (car list1) 'oldest-date)) - (date2 (get (car list2) 'oldest-date))) - (cond ((string-lessp date1 date2) t) - ((string-equal date1 date2) '=) - (t nil))) - (while (and list1 list2) - (cond ((string-lessp (car list1) (car list2)) (throw 'done t)) - ((not (string-equal (car list1) (car list2))) - (throw 'done nil))) - (setq list1 (cdr list1) - list2 (cdr list2))) - (cond ((and list1 (not list2)) nil) - ((and list2 (not list1)) t) - (t '=)))))) - -(defun vm-sort-compare-author (m1 m2) - (let ((s1 (vm-su-from m1)) - (s2 (vm-su-from m2))) - (cond ((string-lessp s1 s2) t) - ((string-equal s1 s2) '=) - (t nil)))) - -(defun vm-sort-compare-author-r (m1 m2) - (let ((s1 (vm-su-from m1)) - (s2 (vm-su-from m2))) - (cond ((string-lessp s1 s2) nil) - ((string-equal s1 s2) '=) - (t t)))) - -(defun vm-sort-compare-date (m1 m2) - (let ((s1 (vm-so-sortable-datestring m1)) - (s2 (vm-so-sortable-datestring m2))) - (cond ((string-lessp s1 s2) t) - ((string-equal s1 s2) '=) - (t nil)))) - -(defun vm-sort-compare-date-r (m1 m2) - (let ((s1 (vm-so-sortable-datestring m1)) - (s2 (vm-so-sortable-datestring m2))) - (cond ((string-lessp s1 s2) nil) - ((string-equal s1 s2) '=) - (t t)))) - -(defun vm-sort-compare-recipients (m1 m2) - (let ((s1 (vm-su-to m1)) - (s2 (vm-su-to m2))) - (cond ((string-lessp s1 s2) t) - ((string-equal s1 s2) '=) - (t nil)))) - -(defun vm-sort-compare-recipients-r (m1 m2) - (let ((s1 (vm-su-to m1)) - (s2 (vm-su-to m2))) - (cond ((string-lessp s1 s2) nil) - ((string-equal s1 s2) '=) - (t t)))) - -(defun vm-sort-compare-subject (m1 m2) - (let ((s1 (vm-so-sortable-subject m1)) - (s2 (vm-so-sortable-subject m2))) - (cond ((string-lessp s1 s2) t) - ((string-equal s1 s2) '=) - (t nil)))) - -(defun vm-sort-compare-subject-r (m1 m2) - (let ((s1 (vm-so-sortable-subject m1)) - (s2 (vm-so-sortable-subject m2))) - (cond ((string-lessp s1 s2) nil) - ((string-equal s1 s2) '=) - (t t)))) - -(defun vm-sort-compare-line-count (m1 m2) - (let ((n1 (string-to-int (vm-su-line-count m1))) - (n2 (string-to-int (vm-su-line-count m2)))) - (cond ((< n1 n2) t) - ((= n1 n2) '=) - (t nil)))) - -(defun vm-sort-compare-line-count-r (m1 m2) - (let ((n1 (string-to-int (vm-su-line-count m1))) - (n2 (string-to-int (vm-su-line-count m2)))) - (cond ((> n1 n2) t) - ((= n1 n2) '=) - (t nil)))) - -(defun vm-sort-compare-byte-count (m1 m2) - (let ((n1 (string-to-int (vm-su-byte-count m1))) - (n2 (string-to-int (vm-su-byte-count m2)))) - (cond ((< n1 n2) t) - ((= n1 n2) '=) - (t nil)))) - -(defun vm-sort-compare-byte-count-r (m1 m2) - (let ((n1 (string-to-int (vm-su-byte-count m1))) - (n2 (string-to-int (vm-su-byte-count m2)))) - (cond ((> n1 n2) t) - ((= n1 n2) '=) - (t nil)))) - -(defun vm-sort-compare-physical-order (m1 m2) - (let ((n1 (vm-start-of m1)) - (n2 (vm-start-of m2))) - (cond ((< n1 n2) t) - ((= n1 n2) '=) - (t nil)))) - -(defun vm-sort-compare-physical-order-r (m1 m2) - (let ((n1 (vm-start-of m1)) - (n2 (vm-start-of m2))) - (cond ((> n1 n2) t) - ((= n1 n2) '=) - (t nil))))
--- a/lisp/vm/vm-startup.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1113 +0,0 @@ -;;; Entry points for VM -;;; Copyright (C) 1994-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-startup) - -(defun vm (&optional folder read-only) - "Read mail under Emacs. -Optional first arg FOLDER specifies the folder to visit. It defaults -to the value of vm-primary-inbox. The folder buffer is put into VM -mode, a major mode for reading mail. - -Prefix arg or optional second arg READ-ONLY non-nil indicates -that the folder should be considered read only. No attribute -changes, message additions or deletions will be allowed in the -visited folder. - -Visiting the primary inbox causes any contents of the system mailbox to -be moved and appended to the resulting buffer. - -All the messages can be read by repeatedly pressing SPC. Use `n'ext and -`p'revious to move about in the folder. Messages are marked for -deletion with `d', and saved to another folder with `s'. Quitting VM -with `q' expunges deleted messages and saves the buffered folder to -disk. - -See the documentation for vm-mode for more information." - (interactive (list nil current-prefix-arg)) - (vm-session-initialization) - ;; set inhibit-local-variables non-nil to protect - ;; against letter bombs. - ;; set enable-local-variables to nil for newer Emacses - (catch 'done - (let ((full-startup (not (bufferp folder))) - folder-buffer first-time totals-blurb - preserve-auto-save-file) - (setq folder-buffer - (if (bufferp folder) - folder - (let ((file (or folder (expand-file-name vm-primary-inbox - vm-folder-directory)))) - (if (file-directory-p file) - ;; MH code perhaps... ? - (error "%s is a directory" file) - (or (vm-get-file-buffer file) - (let ((default-directory - (or (and vm-folder-directory - (expand-file-name vm-folder-directory)) - default-directory)) - (inhibit-local-variables t) - (enable-local-variables nil) - ;; for XEmacs/Mule - (coding-system-for-read 'no-conversion)) - (message "Reading %s..." file) - (prog1 (find-file-noselect file) - ;; update folder history - (let ((item (or folder vm-primary-inbox))) - (if (not (equal item (car vm-folder-history))) - (setq vm-folder-history - (cons item vm-folder-history)))) - (message "Reading %s... done" file)))))))) - (set-buffer folder-buffer) - ;; for XEmacs/MULE - ;; - ;; If the file coding system is not a no-conversion variant, - ;; make it so by encoding all the text, then setting - ;; the file coding system and decoding it. - ;; This is only possible if a file is visited and then vm-mode - ;; is run on it afterwards. - (defvar buffer-file-coding-system) - (if (and vm-xemacs-mule-p - (not (eq (get-coding-system buffer-file-coding-system) - (get-coding-system 'no-conversion-unix))) - (not (eq (get-coding-system buffer-file-coding-system) - (get-coding-system 'no-conversion-dos))) - (not (eq (get-coding-system buffer-file-coding-system) - (get-coding-system 'no-conversion-mac))) - (not (eq (get-coding-system buffer-file-coding-system) - (get-coding-system 'binary)))) - (let ((buffer-read-only nil) - (omodified (buffer-modified-p))) - (unwind-protect - (progn - (encode-coding-region (point-min) (point-max) - buffer-file-coding-system) - (set-buffer-file-coding-system 'no-conversion nil) - (decode-coding-region (point-min) (point-max) - buffer-file-coding-system)) - (set-buffer-modified-p omodified)))) - (vm-check-for-killed-summary) - (vm-check-for-killed-presentation) - ;; If the buffer's not modified then we know that there can be no - ;; messages in the folder that are not on disk. - (or (buffer-modified-p) (setq vm-messages-not-on-disk 0)) - (setq first-time (not (eq major-mode 'vm-mode)) - preserve-auto-save-file (and buffer-file-name - (not (buffer-modified-p)) - (file-newer-than-file-p - (make-auto-save-file-name) - buffer-file-name))) - ;; Force the folder to be read only if the auto - ;; save file contains information the user might not - ;; want overwritten, i.e. recover-file might be - ;; desired. What we want to avoid is an auto-save. - ;; Making the folder read only will keep - ;; subsequent actions from modifying the buffer in a - ;; way that triggers an auto save. - ;; - ;; Also force the folder read-only if it was read only and - ;; not already in vm-mode, since there's probably a good - ;; reason for this. - (setq vm-folder-read-only (or preserve-auto-save-file read-only - (default-value 'vm-folder-read-only) - (and first-time buffer-read-only))) - ;; If this is not a VM mode buffer then some initialization - ;; needs to be done - (if first-time - (progn - (if (fboundp 'buffer-disable-undo) - (buffer-disable-undo (current-buffer)) - ;; obfuscation to make the v19 compiler not whine - ;; about obsolete functions. - (let ((x 'buffer-flush-undo)) - (funcall x (current-buffer)))) - (abbrev-mode 0) - (auto-fill-mode 0) - (vm-mode-internal))) - (vm-assimilate-new-messages nil t) - (if first-time - (progn - (vm-gobble-visible-header-variables) - (vm-gobble-bookmark) - (vm-gobble-summary) - (vm-gobble-labels) - (vm-start-itimers-if-needed))) - - ;; make a new frame if the user wants one. reuse an - ;; existing frame that is showing this folder. - (if (and full-startup - ;; this so that "emacs -f vm" doesn't create a frame. - this-command) - (apply 'vm-goto-new-folder-frame-maybe - (if folder '(folder) '(primary-folder folder)))) - - ;; raise frame if requested and apply startup window - ;; configuration. - (if full-startup - (let ((buffer-to-display (or vm-summary-buffer - vm-presentation-buffer - (current-buffer)))) - (vm-display buffer-to-display buffer-to-display - (list this-command) - (list (or this-command 'vm) 'startup)) - (if vm-raise-frame-at-startup - (vm-raise-frame)))) - - ;; say this NOW, before the non-previewers read a message, - ;; alter the new message count and confuse themselves. - (if full-startup - ;; save blurb so we can repeat it later as necessary. - (setq totals-blurb (vm-emit-totals-blurb))) - - (vm-thoughtfully-select-message) - (vm-update-summary-and-mode-line) - ;; need to do this after any frame creation because the - ;; toolbar sets frame-specific height and width specifiers. - (and (vm-toolbar-support-possible-p) vm-use-toolbar - (progn - (vm-toolbar-install-toolbar) - (vm-toolbar-update-toolbar))) - - (and vm-use-menus (vm-menu-support-possible-p) - (vm-menu-install-visited-folders-menu)) - - (if full-startup - (progn - (if (and (vm-should-generate-summary) - ;; don't generate a summary if recover-file is - ;; likely to happen, since recover-file does - ;; nothing useful in a summary buffer. - (not preserve-auto-save-file)) - (vm-summarize t nil)) - ;; raise the summary frame if the user wants frames - ;; raised and if there is a summary frame. - (if (and vm-summary-buffer - vm-mutable-frames - vm-frame-per-summary - vm-raise-frame-at-startup) - (vm-raise-frame)) - ;; if vm-mutable-windows is nil, the startup - ;; configuration can't be applied, so do - ;; something to get a VM buffer on the screen - (if vm-mutable-windows - (vm-display nil nil (list this-command) - (list (or this-command 'vm) 'startup)) - (save-excursion - (switch-to-buffer (or vm-summary-buffer - vm-presentation-buffer - (current-buffer))))))) - - (if vm-message-list - (vm-preview-current-message)) - - (run-hooks 'vm-visit-folder-hook) - - (if full-startup - (message totals-blurb)) - ;; Warn user about auto save file, if appropriate. - (if (and full-startup preserve-auto-save-file) - (message - (substitute-command-keys - "Auto save file is newer; consider \\[recover-file]. FOLDER IS READ ONLY."))) - ;; if we're not doing a full startup or if doing more would - ;; trash the auto save file that we need to preserve, - ;; stop here. - (if (or (not full-startup) preserve-auto-save-file) - (throw 'done t)) - (if (and vm-auto-get-new-mail - (not vm-block-new-mail) - (not vm-folder-read-only)) - (progn - (message "Checking for new mail for %s..." - (or buffer-file-name (buffer-name))) - (if (and (vm-get-spooled-mail t) (vm-assimilate-new-messages t)) - (progn - (setq totals-blurb (vm-emit-totals-blurb)) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)))) - (message totals-blurb))) - - ;; Display copyright and copying info unless - ;; user says no. - (if (and (interactive-p) (not vm-startup-message-displayed)) - (progn - (vm-display-startup-message) - (if (not (input-pending-p)) - (message totals-blurb))))))) - -(defun vm-other-frame (&optional folder read-only) - "Like vm, but run in a newly created frame." - (interactive (list nil current-prefix-arg)) - (vm-session-initialization) - (if (vm-multiple-frames-possible-p) - (if folder - (vm-goto-new-frame 'folder) - (vm-goto-new-frame 'primary-folder 'folder))) - (let ((vm-frame-per-folder nil) - (vm-search-other-frames nil)) - (vm folder read-only)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-other-window (&optional folder read-only) - "Like vm, but run in a different window." - (interactive (list nil current-prefix-arg)) - (vm-session-initialization) - (if (one-window-p t) - (split-window)) - (other-window 1) - (let ((vm-frame-per-folder nil) - (vm-search-other-frames nil)) - (vm folder read-only))) - -(put 'vm-mode 'mode-class 'special) - -(defun vm-mode (&optional read-only) - "Major mode for reading mail. - -This is VM 6.34. - -Commands: - h - summarize folder contents - C-t - toggle threads display - - n - go to next message - p - go to previous message - N - like `n' but ignores skip-variable settings - P - like `p' but ignores skip-variable settings - M-n - go to next unread message - M-p - go to previous unread message - RET - go to numbered message (uses prefix arg or prompts in minibuffer) - TAB - go to last message seen - ^ - go to parent of this message - M-s - incremental search through the folder - - t - display hidden headers - SPC - expose message body or scroll forward a page - b - scroll backward a page - < - go to beginning of current message - > - go to end of current message - - d - delete message, prefix arg deletes messages forward - C-d - delete message, prefix arg deletes messages backward - u - undelete - k - flag for deletion all messages with same subject as the current message - - r - reply (only to the sender of the message) - R - reply with included text from the current message - M-r - extract and resend bounced message - f - followup (reply to all recipients of message) - F - followup with included text from the current message - z - forward the current message - m - send a message - B - resend the current message to another user. - c - continue composing the most recent message you were composing - - @ - digestify and mail entire folder contents (the folder is not modified) - * - burst a digest into individual messages, and append and assimilate these - messages into the current folder. - - G - sort messages by various keys - - g - get any new mail that has arrived in the system mailbox - (new mail is appended to the disk and buffer copies of the - primary inbox.) - v - visit another mail folder - - e - edit the current message - j - discard cached information about the current message - - s - save current message in a folder (appends if folder already exists) - w - write current message to a file without its headers (appends if exists) - S - save entire folder to disk, does not expunge - A - save unfiled messages to their vm-auto-folder-alist specified folders - # - expunge deleted messages (without saving folder) - q - quit VM, deleted messages are not expunged, folder is - saved to disk if it is modified. new messages are changed - to be flagged as just unread. - x - exit VM with no change to the folder - - M N - use marks; the next vm command will affect only marked messages - if it makes sense for the command to do so. These commands - apply and remove marks to messages. - - M M - mark the current message - M U - unmark the current message - M m - mark all messages - M u - unmark all messages - M C - mark messages matched by a virtual folder selector - M c - unmark messages matched by a virtual folder selector - M T - mark thread tree rooted at the current message - M t - unmark thread tree rooted at the current message - M S - mark messages with the same subject as the current message - M s - unmark messages with the same subject as the current message - M A - mark messages with the same author as the current message - M a - unmark messages with the same author as the current message - M R - mark messages within the point/mark region in the summary - M r - unmark messages within the point/mark region in the summary - - M ? - partial help for mark commands - - W S - save the current window configuration to a name - W D - delete a window configuration - W W - apply a configuration - W ? - help for the window configuration commands - - V V - visit a virtual folder (must be defined in vm-virtual-folder-alist) - V C - create a virtual folder composed of a subset of the - current folder's messages. - V A - apply the selectors of a named virtual folder to the - messages in the current folder and create a virtual folder - containing the selected messages. - V M - toggle whether this virtual folder's messages mirror the - underlying real messages' attributes. - V ? - help for virtual folder commands - - C-_ - undo, special undo that retracts the most recent - changes in message attributes and labels. Expunges, - message edits, and saves cannot be undone. C-x u is - also bound to this command. - - a - set message attributes - - l a - add labels to message - l d - delete labels from message - - L - reload your VM init file, ~/.vm - - % - change a folder to another type - - ? - help - - ! - run a shell command - | - run a shell command with the current message as input - - M-C - view conditions under which you may redistribute VM - M-W - view the details of VM's lack of a warranty - -Use M-x vm-submit-bug-report to submit a bug report. - -Variables: - vm-arrived-message-hook - vm-arrived-messages-hook - vm-auto-center-summary - vm-auto-decode-mime-messages - vm-auto-displayed-mime-content-types - vm-auto-folder-alist - vm-auto-folder-case-fold-search - vm-auto-get-new-mail - vm-auto-next-message - vm-berkeley-mail-compatibility - vm-burst-digest-messages-inherit-labels - vm-check-folder-types - vm-circular-folders - vm-confirm-new-folders - vm-confirm-quit - vm-convert-folder-types - vm-crash-box - vm-crash-box-suffix - vm-default-folder-type - vm-delete-after-archiving - vm-delete-after-bursting - vm-delete-after-saving - vm-delete-empty-folders - vm-digest-burst-type - vm-digest-center-preamble - vm-digest-preamble-format - vm-digest-send-type - vm-display-buffer-hook - vm-display-using-mime - vm-edit-message-hook - vm-folder-directory - vm-folder-read-only - vm-follow-summary-cursor - vm-forward-message-hook - vm-forwarded-headers - vm-forwarding-digest-type - vm-forwarding-subject-format - vm-frame-parameter-alist - vm-frame-per-completion - vm-frame-per-composition - vm-frame-per-edit - vm-frame-per-folder - vm-frame-per-help - vm-frame-per-summary - vm-highlighted-header-face - vm-highlighted-header-regexp - vm-honor-page-delimiters - vm-image-directory - vm-in-reply-to-format - vm-included-text-attribution-format - vm-included-text-discard-header-regexp - vm-included-text-headers - vm-included-text-prefix - vm-invisible-header-regexp - vm-jump-to-new-messages - vm-jump-to-unread-messages - vm-keep-crash-boxes - vm-keep-sent-messages - vm-mail-check-interval - vm-mail-header-from - vm-mail-mode-hook - vm-make-crash-box-name - vm-make-spool-file-name - vm-mime-8bit-composition-charset - vm-mime-8bit-text-transfer-encoding - vm-mime-alternative-select-method - vm-mime-attachment-auto-type-alist - vm-mime-attachment-save-directory - vm-mime-avoid-folding-content-type - vm-mime-base64-decoder-program - vm-mime-base64-decoder-switches - vm-mime-base64-encoder-program - vm-mime-base64-encoder-switches - vm-mime-button-face - vm-mime-charset-font-alist - vm-mime-default-face-charsets - vm-mime-digest-discard-header-regexp - vm-mime-digest-headers - vm-mime-display-function - vm-mime-external-content-types-alist - vm-mime-ignore-mime-version - vm-mime-internal-content-types - vm-mime-max-message-size - vm-mode-hook - vm-mosaic-program - vm-mosaic-program-switches - vm-move-after-deleting - vm-move-after-killing - vm-move-after-undeleting - vm-move-messages-physically - vm-mutable-frames - vm-mutable-windows - vm-netscape-program - vm-netscape-program-switches - vm-pop-bytes-per-session - vm-pop-max-message-size - vm-pop-md5-program - vm-pop-messages-per-session - vm-popup-menu-on-mouse-3 - vm-preferences-file - vm-preview-lines - vm-preview-read-messages - vm-primary-inbox - vm-quit-hook - vm-recognize-pop-maildrops - vm-reply-hook - vm-reply-ignored-addresses - vm-reply-ignored-reply-tos - vm-reply-subject-prefix - vm-resend-bounced-discard-header-regexp - vm-resend-bounced-headers - vm-resend-bounced-message-hook - vm-resend-discard-header-regexp - vm-resend-headers - vm-resend-message-hook - vm-retrieved-spooled-mail-hook - vm-rfc1153-digest-discard-header-regexp - vm-rfc1153-digest-headers - vm-rfc934-digest-discard-header-regexp - vm-rfc934-digest-headers - vm-search-using-regexps - vm-select-message-hook - vm-select-new-message-hook - vm-select-unread-message-hook - vm-send-digest-hook - vm-send-using-mime - vm-skip-deleted-messages - vm-skip-read-messages - vm-spool-file-suffixes - vm-spool-files - vm-startup-with-summary - vm-strip-reply-headers - vm-summary-arrow - vm-summary-format - vm-summary-highlight-face - vm-summary-mode-hook - vm-summary-redo-hook - vm-summary-show-threads - vm-summary-thread-indent-level - vm-tale-is-an-idiot - vm-temp-file-directory - vm-toolbar-pixmap-directory - vm-trust-From_-with-Content-Length - vm-undisplay-buffer-hook - vm-unforwarded-header-regexp - vm-url-browser - vm-url-search-limit - vm-use-menus - vm-use-toolbar - vm-virtual-folder-alist - vm-virtual-mirror - vm-visible-headers - vm-visit-folder-hook - vm-visit-when-saving - vm-warp-mouse-to-new-frame - vm-window-configuration-file -" - (interactive "P") - (vm (current-buffer) read-only) - (vm-display nil nil '(vm-mode) '(vm-mode))) - -(defun vm-visit-folder (folder &optional read-only) - "Visit a mail file. -VM will parse and present its messages to you in the usual way. - -First arg FOLDER specifies the mail file to visit. When this -command is called interactively the file name is read from the -minibuffer. - -Prefix arg or optional second arg READ-ONLY non-nil indicates -that the folder should be considered read only. No attribute -changes, messages additions or deletions will be allowed in the -visited folder." - (interactive - (save-excursion - (vm-session-initialization) - (vm-select-folder-buffer) - (let ((default-directory (if vm-folder-directory - (expand-file-name vm-folder-directory) - default-directory)) - (default (or vm-last-visit-folder vm-last-save-folder)) - (this-command this-command) - (last-command last-command)) - (list (vm-read-file-name - (format "Visit%s folder:%s " - (if current-prefix-arg " read only" "") - (if default - (format " (default %s)" default) - "")) - default-directory default nil nil 'vm-folder-history) - current-prefix-arg)))) - (vm-session-initialization) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (setq vm-last-visit-folder folder) - (let ((default-directory (or vm-folder-directory default-directory))) - (setq folder (expand-file-name folder))) - (vm folder read-only)) - -(defun vm-visit-folder-other-frame (folder &optional read-only) - "Like vm-visit-folder, but run in a newly created frame." - (interactive - (save-excursion - (vm-session-initialization) - (vm-select-folder-buffer) - (let ((default-directory (if vm-folder-directory - (expand-file-name vm-folder-directory) - default-directory)) - (default (or vm-last-visit-folder vm-last-save-folder)) - (this-command this-command) - (last-command last-command)) - (list (vm-read-file-name - (format "Visit%s folder in other frame:%s " - (if current-prefix-arg " read only" "") - (if default - (format " (default %s)" default) - "")) - default-directory default nil nil 'vm-folder-history) - current-prefix-arg)))) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'folder)) - (let ((vm-frame-per-folder nil) - (vm-search-other-frames nil)) - (vm-visit-folder folder read-only)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-visit-folder-other-window (folder &optional read-only) - "Like vm-visit-folder, but run in a different window." - (interactive - (save-excursion - (vm-session-initialization) - (vm-select-folder-buffer) - (let ((default-directory (if vm-folder-directory - (expand-file-name vm-folder-directory) - default-directory)) - (default (or vm-last-visit-folder vm-last-save-folder)) - (this-command this-command) - (last-command last-command)) - (list (vm-read-file-name - (format "Visit%s folder in other window:%s " - (if current-prefix-arg " read only" "") - (if default - (format " (default %s)" default) - "")) - default-directory default nil nil 'vm-folder-history) - current-prefix-arg)))) - (vm-session-initialization) - (if (one-window-p t) - (split-window)) - (other-window 1) - (let ((vm-frame-per-folder nil) - (vm-search-other-frames nil)) - (vm-visit-folder folder read-only))) - -(put 'vm-virtual-mode 'mode-class 'special) - -(defun vm-virtual-mode (&rest ignored) - "Mode for reading multiple mail folders as one folder. - -The commands available are the same commands that are found in -vm-mode, except that a few of them are not applicable to virtual -folders. - -vm-virtual-mode is not a normal major mode. If you run it, it -will not do anything. The entry point to vm-virtual-mode is -vm-visit-virtual-folder.") - -(defvar scroll-in-place) - -(defun vm-visit-virtual-folder (folder-name &optional read-only) - (interactive - (let ((last-command last-command) - (this-command this-command)) - (vm-session-initialization) - (list - (vm-read-string "Visit virtual folder: " vm-virtual-folder-alist) - current-prefix-arg))) - (vm-session-initialization) - (if (not (assoc folder-name vm-virtual-folder-alist)) - (error "No such virtual folder, %s" folder-name)) - (let ((buffer-name (concat "(" folder-name ")")) - first-time blurb) - (set-buffer (get-buffer-create buffer-name)) - (setq first-time (not (eq major-mode 'vm-virtual-mode))) - (if first-time - (progn - (if (fboundp 'buffer-disable-undo) - (buffer-disable-undo (current-buffer)) - ;; obfuscation to make the v19 compiler not whine - ;; about obsolete functions. - (let ((x 'buffer-flush-undo)) - (funcall x (current-buffer)))) - (abbrev-mode 0) - (auto-fill-mode 0) - (setq mode-name "VM Virtual" - mode-line-format vm-mode-line-format - buffer-read-only t - vm-folder-read-only read-only - vm-label-obarray (make-vector 29 0) - vm-virtual-folder-definition - (assoc folder-name vm-virtual-folder-alist)) - ;; scroll in place messes with scroll-up and this loses - (make-local-variable 'scroll-in-place) - (setq scroll-in-place nil) - (vm-build-virtual-message-list nil) - (use-local-map vm-mode-map) - (and (vm-menu-support-possible-p) - (vm-menu-install-menus)) - (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder) - (add-hook 'kill-buffer-hook 'vm-garbage-collect-message) - ;; save this for last in case the user interrupts. - ;; an interrupt anywhere before this point will cause - ;; everything to be redone next revisit. - (setq major-mode 'vm-virtual-mode) - (run-hooks 'vm-virtual-mode-hook) - ;; must come after the setting of major-mode - (setq mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 - (vm-menu-support-possible-p) - (vm-menu-mode-menu))) - (setq blurb (vm-emit-totals-blurb)) - (if vm-summary-show-threads - (vm-sort-messages "thread")) - (if (vm-thoughtfully-select-message) - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (message blurb))) - ;; make a new frame if the user wants one. reuse an - ;; existing frame that is showing this folder. - (vm-goto-new-folder-frame-maybe 'folder) - (if vm-raise-frame-at-startup - (vm-raise-frame)) - (vm-display nil nil (list this-command) (list this-command 'startup)) - (and (vm-toolbar-support-possible-p) vm-use-toolbar - (vm-toolbar-install-toolbar)) - (if first-time - (progn - (if (vm-should-generate-summary) - (progn (vm-summarize t nil) - (message blurb))) - ;; raise the summary frame if the user wants frames - ;; raised and if there is a summary frame. - (if (and vm-summary-buffer - vm-mutable-frames - vm-frame-per-summary - vm-raise-frame-at-startup) - (vm-raise-frame)) - ;; if vm-mutable-windows is nil, the startup - ;; configuration can't be applied, so do - ;; something to get a VM buffer on the screen - (if vm-mutable-windows - (vm-display nil nil (list this-command) - (list (or this-command 'vm) 'startup)) - (save-excursion - (switch-to-buffer (or vm-summary-buffer - vm-presentation-buffer - (current-buffer))))))) - - ;; check interactive-p so as not to bog the user down if they - ;; run this function from within another function. - (and (interactive-p) - (not vm-startup-message-displayed) - (vm-display-startup-message) - (message blurb)))) - -(defun vm-visit-virtual-folder-other-frame (folder-name &optional read-only) - "Like vm-visit-virtual-folder, but run in a newly created frame." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (vm-session-initialization) - (list - (vm-read-string "Visit virtual folder in other frame: " - vm-virtual-folder-alist) - current-prefix-arg))) - (vm-session-initialization) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'folder)) - (let ((vm-frame-per-folder nil) - (vm-search-other-frames nil)) - (vm-visit-virtual-folder folder-name read-only)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-visit-virtual-folder-other-window (folder-name &optional read-only) - "Like vm-visit-virtual-folder, but run in a different window." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (vm-session-initialization) - (list - (vm-read-string "Visit virtual folder in other window: " - vm-virtual-folder-alist) - current-prefix-arg))) - (vm-session-initialization) - (if (one-window-p t) - (split-window)) - (other-window 1) - (let ((vm-frame-per-folder nil) - (vm-search-other-frames nil)) - (vm-visit-virtual-folder folder-name read-only))) - -(defun vm-mail (&optional to) - "Send a mail message from within VM, or from without. -Optional argument TO is a string that should contain a comma separated -recipient list." - (interactive) - (vm-session-initialization) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-mail-internal nil to) - (run-hooks 'vm-mail-hook) - (run-hooks 'vm-mail-mode-hook)) - -(defun vm-mail-other-frame (&optional to) - "Like vm-mail, but run in a newly created frame. -Optional argument TO is a string that should contain a comma separated -recipient list." - (interactive) - (vm-session-initialization) - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'composition)) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-mail to)) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-mail-other-window (&optional to) - "Like vm-mail, but run in a different window. -Optional argument TO is a string that should contain a comma separated -recipient list." - (interactive) - (vm-session-initialization) - (if (one-window-p t) - (split-window)) - (other-window 1) - (let ((vm-frame-per-composition nil) - (vm-search-other-frames nil)) - (vm-mail to))) - -(defun vm-submit-bug-report () - "Submit a bug report, with pertinent information to the VM bug list." - (interactive) - (require 'reporter) - ;; make sure the user doesn't try to use vm-mail here. - (let ((reporter-mailer '(mail))) - (delete-other-windows) - (reporter-submit-bug-report - vm-maintainer-address - (concat "VM " vm-version) - (list - 'vm-arrived-message-hook - 'vm-arrived-messages-hook - 'vm-auto-center-summary - 'vm-auto-decode-mime-messages - 'vm-auto-displayed-mime-content-types -;; don't send this by default, might be personal stuff in here. -;; 'vm-auto-folder-alist - 'vm-auto-folder-case-fold-search - 'vm-auto-get-new-mail - 'vm-auto-next-message - 'vm-berkeley-mail-compatibility - 'vm-check-folder-types - 'vm-circular-folders - 'vm-confirm-new-folders - 'vm-confirm-quit - 'vm-convert-folder-types - 'vm-crash-box - 'vm-crash-box-suffix - 'vm-default-folder-type - 'vm-delete-after-archiving - 'vm-delete-after-bursting - 'vm-delete-after-saving - 'vm-delete-empty-folders - 'vm-digest-burst-type - 'vm-digest-identifier-header-format - 'vm-digest-center-preamble - 'vm-digest-preamble-format - 'vm-digest-send-type - 'vm-display-buffer-hook - 'vm-display-using-mime - 'vm-edit-message-hook - 'vm-edit-message-mode - 'vm-flush-interval - 'vm-folder-directory - 'vm-folder-read-only - 'vm-follow-summary-cursor - 'vm-forward-message-hook - 'vm-forwarded-headers - 'vm-forwarding-digest-type - 'vm-forwarding-subject-format - 'vm-frame-parameter-alist - 'vm-frame-per-completion - 'vm-frame-per-composition - 'vm-frame-per-edit - 'vm-frame-per-folder - 'vm-frame-per-help - 'vm-frame-per-summary - 'vm-highlight-url-face - 'vm-highlighted-header-regexp - 'vm-honor-page-delimiters - 'vm-image-directory - 'vm-in-reply-to-format - 'vm-included-text-attribution-format - 'vm-included-text-discard-header-regexp - 'vm-included-text-headers - 'vm-included-text-prefix - 'vm-init-file - 'vm-invisible-header-regexp - 'vm-jump-to-new-messages - 'vm-jump-to-unread-messages - 'vm-keep-crash-boxes - 'vm-keep-sent-messages - 'vm-mail-header-from - 'vm-mail-hook - 'vm-make-crash-box-name - 'vm-make-spool-file-name - 'vm-mail-check-interval - 'vm-mail-mode-hook - 'vm-mime-8bit-composition-charset - 'vm-mime-8bit-text-transfer-encoding - 'vm-mime-alternative-select-method - 'vm-mime-attachment-auto-type-alist - 'vm-mime-attachment-save-directory - 'vm-mime-avoid-folding-content-type - 'vm-mime-base64-decoder-program - 'vm-mime-base64-decoder-switches - 'vm-mime-base64-encoder-program - 'vm-mime-base64-encoder-switches - 'vm-mime-button-face - 'vm-mime-charset-font-alist - 'vm-mime-default-face-charsets - 'vm-mime-digest-discard-header-regexp - 'vm-mime-digest-headers - 'vm-mime-display-function - 'vm-mime-external-content-types-alist - 'vm-mime-ignore-mime-version - 'vm-mime-internal-content-types - 'vm-mime-max-message-size - 'vm-mode-hook - 'vm-mode-hooks - 'vm-mosaic-program - 'vm-mosaic-program-switches - 'vm-move-after-deleting - 'vm-move-after-undeleting - 'vm-move-messages-physically - 'vm-movemail-program - 'vm-mutable-frames - 'vm-mutable-windows - 'vm-netscape-program - 'vm-netscape-program-switches - 'vm-pop-bytes-per-session - 'vm-pop-max-message-size - 'vm-pop-messages-per-session - 'vm-pop-md5-program - 'vm-popup-menu-on-mouse-3 - 'vm-preferences-file - 'vm-preview-lines - 'vm-preview-read-messages - 'vm-primary-inbox - 'vm-quit-hook - 'vm-recognize-pop-maildrops - 'vm-reply-hook -;; don't feed the spammers or crackers -;; 'vm-reply-ignored-addresses - 'vm-reply-ignored-reply-tos - 'vm-reply-subject-prefix - 'vm-resend-bounced-discard-header-regexp - 'vm-resend-bounced-headers - 'vm-resend-bounced-message-hook - 'vm-resend-discard-header-regexp - 'vm-resend-headers - 'vm-resend-message-hook - 'vm-retrieved-spooled-mail-hook - 'vm-rfc1153-digest-discard-header-regexp - 'vm-rfc1153-digest-headers - 'vm-rfc934-digest-discard-header-regexp - 'vm-rfc934-digest-headers - 'vm-search-using-regexps - 'vm-select-message-hook - 'vm-select-new-message-hook - 'vm-select-unread-message-hook - 'vm-send-digest-hook - 'vm-send-using-mime - 'vm-skip-deleted-messages - 'vm-skip-read-messages -;; don't send vm-spool-files by default, might contain passwords -;; 'vm-spool-files - 'vm-spool-file-suffixes - 'vm-startup-with-summary - 'vm-strip-reply-headers - 'vm-summary-format - 'vm-summary-highlight-face - 'vm-summary-mode-hook - 'vm-summary-mode-hooks - 'vm-summary-redo-hook - 'vm-summary-show-threads - 'vm-summary-thread-indent-level - 'vm-summary-uninteresting-senders - 'vm-summary-uninteresting-senders-arrow - 'vm-tale-is-an-idiot - 'vm-toolbar-pixmap-directory - 'vm-temp-file-directory - 'vm-trust-From_-with-Content-Length - 'vm-undisplay-buffer-hook - 'vm-unforwarded-header-regexp - 'vm-url-browser - 'vm-url-search-limit - 'vm-use-menus - 'vm-use-toolbar - 'vm-virtual-folder-alist - 'vm-virtual-mirror - 'vm-visible-headers - 'vm-visit-folder-hook - 'vm-visit-when-saving - 'vm-warp-mouse-to-new-frame - 'vm-window-configuration-file -;; see what the user had loaded - 'features - ) - nil - nil - "Please change the Subject header to a concise bug description.\nRemember to cover the basics, that is, what you expected to\nhappen and what in fact did happen. Please remove these\ninstructions from your message.") - (save-excursion - (goto-char (point-min)) - (mail-position-on-field "Subject") - (beginning-of-line) - (delete-region (point) (progn (forward-line) (point))) - (insert "Subject: VM " vm-version " induces a brain tumor in the user.\n It is the tumor that creates the hallucinations.\n")))) - -(defun vm-load-init-file (&optional interactive) - (interactive "p") - (if (or (not vm-init-file-loaded) interactive) - (load vm-init-file (not interactive) (not interactive) t)) - (setq vm-init-file-loaded t) - (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file))) - -(defun vm-check-emacs-version () - (cond ((and vm-xemacs-p - (or (< emacs-major-version 19) - (and (= emacs-major-version 19) - (< emacs-minor-version 14)))) - (error "VM %s must be run on XEmacs 19.14 or a later version." - vm-version)) - ((and vm-fsfemacs-19-p - (or (< emacs-major-version 19) - (and (= emacs-major-version 19) - (< emacs-minor-version 34)))) - (error "VM %s must be run on Emacs 19.34 or a later version." - vm-version)))) - -(defun vm-set-debug-flags () - (or stack-trace-on-error - debug-on-error - (setq stack-trace-on-error - '( - wrong-type-argument - wrong-number-of-arguments - args-out-of-range - void-function - void-variable - )))) - -(defun vm-session-initialization () - (vm-note-emacs-version) - (vm-check-emacs-version) -;; (vm-set-debug-flags) - ;; If this is the first time VM has been run in this Emacs session, - ;; do some necessary preparations. - (if (or (not (boundp 'vm-session-beginning)) - vm-session-beginning) - (progn - (random t) - (vm-load-init-file) - (if (not vm-window-configuration-file) - (setq vm-window-configurations vm-default-window-configuration) - (or (vm-load-window-configurations vm-window-configuration-file) - (setq vm-window-configurations vm-default-window-configuration))) - (setq vm-buffers-needing-display-update (make-vector 29 0)) - ;; default value of vm-mime-button-face is 'gui-button-face - ;; this face doesn't exist by default in FSF Emacs 19.34. - ;; Create it. - (and (fboundp 'make-face) (make-face 'gui-button-face)) - (and (vm-mouse-support-possible-p) - (vm-mouse-install-mouse)) - (and (vm-menu-support-possible-p) - vm-use-menus - (vm-menu-fsfemacs-menus-p) - (vm-menu-initialize-vm-mode-menu-map)) - (setq vm-session-beginning nil)))) - -(autoload 'reporter-submit-bug-report "reporter") -(autoload 'timezone-make-date-sortable "timezone") -(autoload 'rfc822-addresses "rfc822") -(autoload 'mail-strip-quoted-names "mail-utils") -(autoload 'mail-fetch-field "mail-utils") -(autoload 'mail-position-on-field "mail-utils") -(autoload 'mail-send "sendmail") -(autoload 'mail-mode "sendmail") -(autoload 'mail-extract-address-components "mail-extr") -(autoload 'set-tapestry "tapestry") -(autoload 'tapestry "tapestry") -(autoload 'tapestry-replace-tapestry-element "tapestry") -(autoload 'tapestry-nullify-tapestry-elements "tapestry") -(autoload 'tapestry-remove-frame-parameters "tapestry") -(autoload 'vm-easy-menu-define "vm-easymenu" nil 'macro) -(autoload 'vm-easy-menu-do-define "vm-easymenu")
--- a/lisp/vm/vm-summary.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1013 +0,0 @@ -;;; Summary gathering and formatting routines for VM -;;; Copyright (C) 1989-1995 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-summary) - -(defun vm-summary-mode-internal () - (setq mode-name "VM Summary" - major-mode 'vm-summary-mode - mode-line-format vm-mode-line-format - ;; must come after the setting of major-mode - mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 - (vm-menu-support-possible-p) - (vm-menu-mode-menu)) - buffer-read-only t - vm-summary-pointer nil - vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "") - vm-summary-no-=> (make-string (length vm-summary-=>) ? ) - truncate-lines t) - ;; horizontal scrollbar off by default - ;; user can turn it on in summary hook if desired. - (and vm-xemacs-p (featurep 'scrollbar) - (set-specifier scrollbar-height (cons (current-buffer) 0))) - (use-local-map vm-summary-mode-map) - (and (vm-menu-support-possible-p) - (vm-menu-install-menus)) - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) - (vm-mouse-xemacs-mouse-p) - (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) - (if (and vm-mutable-frames (or vm-frame-per-folder vm-frame-per-summary)) - (vm-set-hooks-for-frame-deletion)) - (run-hooks 'vm-summary-mode-hook) - ;; Lucid Emacs apparently used this name - (run-hooks 'vm-summary-mode-hooks)) - -(fset 'vm-summary-mode 'vm-mode) -(put 'vm-summary-mode 'mode-class 'special) - -(defun vm-summarize (&optional display raise) - "Summarize the contents of the folder in a summary buffer. -The format is as described by the variable vm-summary-format. Generally -one line per message is most pleasing to the eye but this is not -mandatory." - (interactive "p\np") - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (if (null vm-summary-buffer) - (let ((b (current-buffer)) - (read-only vm-folder-read-only)) - (setq vm-summary-buffer - (get-buffer-create (format "%s Summary" (buffer-name)))) - (save-excursion - (set-buffer vm-summary-buffer) - (abbrev-mode 0) - (auto-fill-mode 0) - (if (fboundp 'buffer-disable-undo) - (buffer-disable-undo (current-buffer)) - ;; obfuscation to make the v19 compiler not whine - ;; about obsolete functions. - (let ((x 'buffer-flush-undo)) - (funcall x (current-buffer)))) - (setq vm-mail-buffer b - vm-folder-read-only read-only) - (vm-summary-mode-internal)) - (vm-set-summary-redo-start-point t))) - (if display - (save-excursion - (vm-goto-new-summary-frame-maybe) - (vm-display vm-summary-buffer t - '(vm-summarize - vm-summarize-other-frame) - (list this-command) (not raise)) - ;; need to do this after any frame creation because the - ;; toolbar sets frame-specific height and width specifiers. - (set-buffer vm-summary-buffer) - (and (vm-toolbar-support-possible-p) vm-use-toolbar - (vm-toolbar-install-toolbar))) - (vm-display nil nil '(vm-summarize vm-summarize-other-frame) - (list this-command))) - (vm-update-summary-and-mode-line)) - -(defun vm-summarize-other-frame (&optional display) - "Like vm-summarize, but run in a newly created frame." - (interactive "p") - (if (vm-multiple-frames-possible-p) - (vm-goto-new-frame 'summary)) - (vm-summarize display) - (if (vm-multiple-frames-possible-p) - (vm-set-hooks-for-frame-deletion))) - -(defun vm-do-summary (&optional start-point) - (let ((m-list (or start-point vm-message-list)) - mp - (n 0) - ;; Just for laughs, make the update interval vary. - (modulus (+ (% (vm-abs (random)) 11) 10)) - (mouse-track-func - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) - (vm-mouse-fsfemacs-mouse-p) - (function vm-mouse-set-mouse-track-highlight))) - summary) - (setq mp m-list) - (save-excursion - (set-buffer vm-summary-buffer) - (let ((buffer-read-only nil) - (modified (buffer-modified-p))) - (unwind-protect - (progn - (if start-point - (if (vm-su-start-of (car mp)) - (progn - (goto-char (vm-su-start-of (car mp))) - (delete-region (point) (point-max))) - (goto-char (point-max))) - (erase-buffer) - (setq vm-summary-pointer nil)) - ;; avoid doing long runs down the marker chain while - ;; building the summary. use integers to store positions - ;; and then convert them to markers after all the - ;; insertions are done. - (while mp - (setq summary (vm-su-summary (car mp))) - (vm-set-su-start-of (car mp) (point)) - (insert vm-summary-no-=>) - (vm-tokenized-summary-insert (car mp) (vm-su-summary (car mp))) - (vm-set-su-end-of (car mp) (point)) - (setq mp (cdr mp) n (1+ n)) - (if (zerop (% n modulus)) - (message "Generating summary... %d" n))) - ;; now convert the ints to markers. - (if (>= n modulus) - (message "Generating summary markers... ")) - (setq mp m-list) - (while mp - (and mouse-track-func (funcall mouse-track-func - (vm-su-start-of (car mp)) - (vm-su-end-of (car mp)))) - (vm-set-su-start-of (car mp) (vm-marker (vm-su-start-of (car mp)))) - (vm-set-su-end-of (car mp) (vm-marker (vm-su-end-of (car mp)))) - (setq mp (cdr mp)))) - (set-buffer-modified-p modified)) - (run-hooks 'vm-summary-redo-hook))) - (if (>= n modulus) - (message "Generating summary... done")))) - -(defun vm-do-needed-summary-rebuild () - (if (and vm-summary-redo-start-point vm-summary-buffer) - (progn - (vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads) - (vm-do-summary (and (consp vm-summary-redo-start-point) - vm-summary-redo-start-point)) - (setq vm-summary-redo-start-point nil) - (and vm-message-pointer - (vm-set-summary-pointer (car vm-message-pointer))) - (setq vm-need-summary-pointer-update nil)) - (and vm-need-summary-pointer-update - vm-summary-buffer - vm-message-pointer - (progn - (vm-set-summary-pointer (car vm-message-pointer)) - (setq vm-need-summary-pointer-update nil))))) - -(defun vm-update-message-summary (m) - (if (and (vm-su-start-of m) - (marker-buffer (vm-su-start-of m))) - (let ((modified (buffer-modified-p)) - (mouse-track-func - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) - (vm-mouse-fsfemacs-mouse-p) - (function vm-mouse-set-mouse-track-highlight))) - summary) - (save-excursion - (setq summary (vm-su-summary m)) - (set-buffer (marker-buffer (vm-su-start-of m))) - (let ((buffer-read-only nil) - (selected nil) - (modified (buffer-modified-p))) - (unwind-protect - (save-excursion - (goto-char (vm-su-start-of m)) - (setq selected (not (looking-at vm-summary-no-=>))) - ;; We do a little dance to update the text in - ;; order to make the markers in the text do - ;; what we want. - ;; - ;; 1. We need to avoid having the su-start-of - ;; and su-end-of markers clumping together at - ;; the start position. - ;; - ;; 2. We want the window point marker (w->pointm - ;; in the Emacs display code) to move to the - ;; start of the summary entry if it is - ;; anywhere within the su-start-of to - ;; su-end-of region. - ;; - ;; We achieve (2) by deleting before inserting. - ;; Reversing the order of insertion/deletion - ;; pushes the point marker into the next - ;; summary entry. We achieve (1) by inserting a - ;; placeholder character at the end of the - ;; summary entry before deleting the region. - (goto-char (vm-su-end-of m)) - (insert-before-markers "z") - (goto-char (vm-su-start-of m)) - (delete-region (point) (1- (vm-su-end-of m))) - (if (not selected) - (insert vm-summary-no-=>) - (insert vm-summary-=>)) - (vm-tokenized-summary-insert m (vm-su-summary m)) - (delete-char 1) - (run-hooks 'vm-summary-update-hook) - (and mouse-track-func (funcall mouse-track-func - (vm-su-start-of m) - (vm-su-end-of m))) - (if (and selected vm-summary-highlight-face) - (vm-summary-highlight-region (vm-su-start-of m) (point) - vm-summary-highlight-face))) - (set-buffer-modified-p modified))))))) - -(defun vm-set-summary-pointer (m) - (if vm-summary-buffer - (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) - (mouse-track-func - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) - (vm-mouse-fsfemacs-mouse-p) - (function vm-mouse-set-mouse-track-highlight))) - (old-window nil)) - (vm-save-buffer-excursion - (unwind-protect - (progn - (set-buffer vm-summary-buffer) - (if w - (progn - (setq old-window (selected-window)) - (select-window w))) - (let ((buffer-read-only nil)) - (if (and vm-summary-pointer - (vm-su-start-of vm-summary-pointer)) - (progn - (goto-char (vm-su-start-of vm-summary-pointer)) - (insert vm-summary-no-=>) - (delete-char (length vm-summary-=>)) - (and mouse-track-func - (funcall mouse-track-func - (- (point) (length vm-summary-=>)) - (point))))) - (setq vm-summary-pointer m) - (goto-char (vm-su-start-of m)) - (let ((modified (buffer-modified-p))) - (unwind-protect - (progn - (insert vm-summary-=>) - (delete-char (length vm-summary-=>)) - (and mouse-track-func - (funcall mouse-track-func - (- (point) (length vm-summary-=>)) - (point)))) - (set-buffer-modified-p modified))) - (forward-char (- (length vm-summary-=>))) - (if vm-summary-highlight-face - (vm-summary-highlight-region - (vm-su-start-of m) (vm-su-end-of m) - vm-summary-highlight-face)) - (and w vm-auto-center-summary (vm-auto-center-summary)) - (run-hooks 'vm-summary-pointer-update-hook))) - (and old-window (select-window old-window))))))) - -(defun vm-summary-highlight-region (start end face) - (cond (vm-fsfemacs-19-p - (if (and vm-summary-overlay (overlay-buffer vm-summary-overlay)) - (move-overlay vm-summary-overlay start end) - (setq vm-summary-overlay (make-overlay start end)) - (overlay-put vm-summary-overlay 'evaporate nil) - (overlay-put vm-summary-overlay 'face face))) - (vm-xemacs-p - (if (and vm-summary-overlay (extent-end-position vm-summary-overlay)) - (set-extent-endpoints vm-summary-overlay start end) - (setq vm-summary-overlay (make-extent start end)) - ;; the reason this isn't needed under FSF Emacs is - ;; that insert-before-markers also inserts before - ;; overlays! so a summary update of an entry just - ;; before this overlay in the summary buffer won't - ;; leak into the overlay, but it _will_ leak into an - ;; XEmacs extent. - (set-extent-property vm-summary-overlay 'start-open t) - (set-extent-property vm-summary-overlay 'detachable nil) - (set-extent-property vm-summary-overlay 'face face))))) - -(defun vm-auto-center-summary () - (if vm-auto-center-summary - (if (or (eq vm-auto-center-summary t) (not (one-window-p t))) - (recenter '(4))))) - -(defun vm-sprintf (format-variable message &optional tokenize) - ;; compile the format into an eval'able s-expression - ;; if it hasn't been compiled already. - (if (not (eq (get format-variable 'vm-compiled-format) - (symbol-value format-variable))) - (vm-compile-format format-variable tokenize)) - ;; The local variable name `vm-su-message' is mandatory here for - ;; the format s-expression to work. - (let ((vm-su-message message)) - (eval (get format-variable 'vm-format-sexp)))) - -(defun vm-tokenized-summary-insert (message tokens) - (if (stringp tokens) - (insert tokens) - (let (token) - (while tokens - (setq token (car tokens)) - (cond ((stringp token) - (if vm-display-using-mime - (insert (vm-decode-mime-encoded-words-in-string token)) - (insert token))) - ((eq token 'number) - (insert (vm-padded-number-of message))) - ((eq token 'mark) - (insert (vm-su-mark message))) - ((eq token 'thread-indent) - (if (and vm-summary-show-threads - (natnump vm-summary-thread-indent-level)) - (insert-char ?\ (* vm-summary-thread-indent-level - (vm-th-thread-indentation message)))))) - (setq tokens (cdr tokens)))))) - -(defun vm-compile-format (format-variable &optional tokenize) - (let ((format (symbol-value format-variable)) - (case-fold-search nil) - (done nil) - (list nil) - (sexp nil) - (sexp-fmt nil) - (last-match-end 0) - token conv-spec) - (store-match-data nil) - (while (not done) - (setq token nil) - (while - (and (not token) - (string-match - "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([aAcdfFhHiIlLmMnstTwyz*%]\\|U[A-Za-z]\\)" - format (match-end 0))) - (setq conv-spec (aref format (match-beginning 5))) - (if (memq conv-spec '(?a ?A ?c ?d ?f ?F ?h ?H ?i ?L ?I ?l ?M - ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* )) - (progn - (cond ((= conv-spec ?a) - (setq sexp (cons (list 'vm-su-attribute-indicators - 'vm-su-message) sexp))) - ((= conv-spec ?A) - (setq sexp (cons (list 'vm-su-attribute-indicators-long - 'vm-su-message) sexp))) - ((= conv-spec ?c) - (setq sexp (cons (list 'vm-su-byte-count - 'vm-su-message) sexp))) - ((= conv-spec ?d) - (setq sexp (cons (list 'vm-su-monthday - 'vm-su-message) sexp))) - ((= conv-spec ?f) - (setq sexp (cons (list 'vm-su-interesting-from - 'vm-su-message) sexp))) - ((= conv-spec ?F) - (setq sexp (cons (list 'vm-su-interesting-full-name - 'vm-su-message) sexp))) - ((= conv-spec ?h) - (setq sexp (cons (list 'vm-su-hour - 'vm-su-message) sexp))) - ((= conv-spec ?H) - (setq sexp (cons (list 'vm-su-hour-short - 'vm-su-message) sexp))) - ((= conv-spec ?i) - (setq sexp (cons (list 'vm-su-message-id - 'vm-su-message) sexp))) - ((= conv-spec ?I) - (if tokenize - (setq token ''thread-indent) - (setq sexp (cons (list 'vm-su-thread-indent - 'vm-su-message) sexp)))) - ((= conv-spec ?l) - (setq sexp (cons (list 'vm-su-line-count - 'vm-su-message) sexp))) - ((= conv-spec ?L) - (setq sexp (cons (list 'vm-su-labels - 'vm-su-message) sexp))) - ((= conv-spec ?m) - (setq sexp (cons (list 'vm-su-month - 'vm-su-message) sexp))) - ((= conv-spec ?M) - (setq sexp (cons (list 'vm-su-month-number - 'vm-su-message) sexp))) - ((= conv-spec ?n) - (if tokenize - (setq token ''number) - (setq sexp (cons (list 'vm-padded-number-of - 'vm-su-message) sexp)))) - ((= conv-spec ?s) - (setq sexp (cons (list 'vm-su-subject - 'vm-su-message) sexp))) - ((= conv-spec ?T) - (setq sexp (cons (list 'vm-su-to-names - 'vm-su-message) sexp))) - ((= conv-spec ?t) - (setq sexp (cons (list 'vm-su-to - 'vm-su-message) sexp))) - ((= conv-spec ?U) - (setq sexp - (cons (list 'vm-run-user-summary-function - (list 'quote - (intern - (concat - "vm-summary-function-" - (substring - format - (1+ (match-beginning 5)) - (+ 2 (match-beginning 5)))))) - 'vm-su-message) sexp))) - ((= conv-spec ?w) - (setq sexp (cons (list 'vm-su-weekday - 'vm-su-message) sexp))) - ((= conv-spec ?y) - (setq sexp (cons (list 'vm-su-year - 'vm-su-message) sexp))) - ((= conv-spec ?z) - (setq sexp (cons (list 'vm-su-zone - 'vm-su-message) sexp))) - ((= conv-spec ?*) - (if tokenize - (setq token ''mark) - (setq sexp (cons (list 'vm-su-mark - 'vm-su-message) sexp))))) - (cond ((and (not token) vm-display-using-mime) - (setcar sexp - (list 'vm-decode-mime-encoded-words-in-string - (car sexp))))) - (cond ((and (not token) (match-beginning 1)) - (setcar sexp - (list 'vm-left-justify-string (car sexp) - (string-to-int - (substring format - (match-beginning 2) - (match-end 2)))))) - ((and (not token) (match-beginning 2)) - (setcar sexp - (list 'vm-right-justify-string (car sexp) - (string-to-int - (substring format - (match-beginning 2) - (match-end 2))))))) - (cond ((and (not token) (match-beginning 3)) - (setcar sexp - (list 'vm-truncate-string (car sexp) - (string-to-int - (substring format - (match-beginning 4) - (match-end 4))))))) - (cond ((and (not token) vm-display-using-mime) - (setcar sexp - (list 'vm-reencode-mime-encoded-words-in-string - (car sexp))))) - (setq sexp-fmt - (cons (if token "" "%s") - (cons (substring format - last-match-end - (match-beginning 0)) - sexp-fmt)))) - (setq sexp-fmt - (cons "%%" - (cons (substring format - (or last-match-end 0) - (match-beginning 0)) - sexp-fmt)))) - (setq last-match-end (match-end 0))) - (if (not token) - (setq sexp-fmt - (cons (substring format last-match-end (length format)) - sexp-fmt) - done t)) - (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) - (if sexp - (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) - (setq sexp sexp-fmt)) - (if tokenize - (setq list (nconc list (if (equal sexp "") nil (list sexp)) - (and token (list token))) - sexp nil - sexp-fmt nil))) - (put format-variable 'vm-compiled-format format) - (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp)))) - -(defun vm-get-header-contents (message header-name-regexp &optional clump-sep) - (let ((contents nil) - regexp) - (setq regexp (concat "^\\(" header-name-regexp "\\)") - message (vm-real-message-of message)) - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of message))) - (save-restriction - (widen) - (goto-char (vm-headers-of message)) - (let ((case-fold-search t)) - (while (and (or (null contents) clump-sep) - (re-search-forward regexp (vm-text-of message) t) - (save-excursion (goto-char (match-beginning 0)) - (vm-match-header))) - (if contents - (setq contents - (concat contents clump-sep (vm-matched-header-contents))) - (setq contents (vm-matched-header-contents)))))) - contents ))) - -(defun vm-left-justify-string (string width) - (if (>= (length string) width) - string - (concat string (make-string (- width (length string)) ?\ )))) - -(defun vm-right-justify-string (string width) - (if (>= (length string) width) - string - (concat (make-string (- width (length string)) ?\ ) string))) - -(defun vm-truncate-string (string width) - (cond -;; doesn't work because the width of wide chars such as the Kanji -;; glyphs as not even multiples of the default face's font width. -;; ((fboundp 'char-width) -;; (let ((i 0) -;; (lim (length string)) -;; (total 0)) -;; (while (and (< i lim) (<= total width)) -;; (setq total (+ total (char-width (aref string i))) -;; i (1+ i))) -;; (if (<= total width) -;; string -;; (substring string 0 (1- i))))) - ((<= (length string) width) - string) - ((< width 0) - (substring string width)) - (t - (substring string 0 width)))) - -(defun vm-su-attribute-indicators (m) - (concat - (cond ((vm-deleted-flag m) "D") - ((vm-new-flag m) "N") - ((vm-unread-flag m) "U") - (t " ")) - (cond ((vm-filed-flag m) "F") - ((vm-written-flag m) "W") - (t " ")) - (cond ((vm-replied-flag m) "R") - ((vm-forwarded-flag m) "Z") - ((vm-redistributed-flag m) "B") - (t " ")) - (cond ((vm-edited-flag m) "E") - (t " ")))) - -(defun vm-su-attribute-indicators-long (m) - (concat - (cond ((vm-deleted-flag m) "D") - ((vm-new-flag m) "N") - ((vm-unread-flag m) "U") - (t " ")) - (if (vm-replied-flag m) "r" " ") - (if (vm-forwarded-flag m) "z" " ") - (if (vm-redistributed-flag m) "b" " ") - (if (vm-filed-flag m) "f" " ") - (if (vm-written-flag m) "w" " ") - (if (vm-edited-flag m) "e" " "))) - -(defun vm-su-byte-count (m) - (or (vm-byte-count-of m) - (vm-set-byte-count-of - m - (int-to-string - (- (vm-text-end-of (vm-real-message-of m)) - (vm-text-of (vm-real-message-of m))))))) - -(defun vm-su-weekday (m) - (or (vm-weekday-of m) - (progn (vm-su-do-date m) (vm-weekday-of m)))) - -(defun vm-su-monthday (m) - (or (vm-monthday-of m) - (progn (vm-su-do-date m) (vm-monthday-of m)))) - -(defun vm-su-month (m) - (or (vm-month-of m) - (progn (vm-su-do-date m) (vm-month-of m)))) - -(defun vm-su-month-number (m) - (or (vm-month-number-of m) - (progn (vm-su-do-date m) (vm-month-number-of m)))) - -(defun vm-su-year (m) - (or (vm-year-of m) - (progn (vm-su-do-date m) (vm-year-of m)))) - -(defun vm-su-hour-short (m) - (let ((string (vm-su-hour m))) - (if (> (length string) 5) - (substring string 0 5) - string))) - -(defun vm-su-hour (m) - (or (vm-hour-of m) - (progn (vm-su-do-date m) (vm-hour-of m)))) - -(defun vm-su-zone (m) - (or (vm-zone-of m) - (progn (vm-su-do-date m) (vm-zone-of m)))) - -(defun vm-su-mark (m) (if (vm-mark-of m) "*" " ")) - -;; Some yogurt-headed delivery agents don't provide a Date: header. -(defun vm-grok-From_-date (message) - ;; This works only on the From_ types, obviously - (if (not (memq (vm-message-type-of message) - '(From_ From_-with-Content-Length))) - nil - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of message))) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-start-of message)) - (let ((case-fold-search nil)) - (if (or (looking-at - ;; special case this so that the "remote from blah" - ;; isn't included. - "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") - (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) - (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))))))) - -(defun vm-parse-date (date) - (let ((weekday "") - (monthday "") - (month "") - (year "") - (hour "") - (timezone "") - (start nil) - string - (case-fold-search t)) - (if (string-match "sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat" date) - (setq weekday (substring date (match-beginning 0) (match-end 0)))) - (if (string-match "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|jul\\|aug\\|sep\\|oct\\|nov\\|dec" date) - (setq month (substring date (match-beginning 0) (match-end 0)))) - (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(:[0-9][0-9]\\)?" date) - (setq hour (substring date (match-beginning 0) (match-end 0)))) - (if (or (string-match "[^a-z][+---][0-9][0-9][0-9][0-9]" date) - (string-match "e[ds]t\\|c[ds]t\\|p[ds]t\\|m[ds]t" date) - (string-match "ast\\|nst\\|met\\|eet\\|jst\\|bst\\|ut" date) - (string-match "gmt\\([+---][0-9]+\\)?" date)) - (setq timezone (substring date (match-beginning 0) (match-end 0)))) - (while (string-match "\\(\\`\\|[^:+---0-9]\\|[a-z]-\\)[0-9]+\\(\\'\\|[^:]\\)" - date start) - (setq string (substring date (match-end 1) (match-beginning 2)) - start (match-end 0)) - (cond ((string-match "\\`[4-9]." string) - ;; Assume that any two digits less than 40 are a date and not - ;; a year. The world will surely end soon. - (setq year (concat "19" string))) - ((< (length string) 3) - (setq monthday string)) - (t (setq year string)))) - - (aset vm-parse-date-workspace 0 weekday) - (aset vm-parse-date-workspace 1 monthday) - (aset vm-parse-date-workspace 2 month) - (aset vm-parse-date-workspace 3 year) - (aset vm-parse-date-workspace 4 hour) - (aset vm-parse-date-workspace 5 timezone) - vm-parse-date-workspace)) - -(defun vm-su-do-date (m) - (let ((case-fold-search t) - vector date) - (setq date (or (vm-get-header-contents m "Date:") (vm-grok-From_-date m))) - (cond - ((null date) - (vm-set-weekday-of m "") - (vm-set-monthday-of m "") - (vm-set-month-of m "") - (vm-set-month-number-of m "") - (vm-set-year-of m "") - (vm-set-hour-of m "") - (vm-set-zone-of m "")) - ((string-match -;; The date format recognized here is the one specified in RFC 822. -;; Some slop is allowed e.g. dashes between the monthday, month and year -;; because such malformed headers have been observed. -"\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)" - date) - (if (match-beginning 2) - (vm-set-weekday-of m (substring date (match-beginning 2) - (match-end 2))) - (vm-set-weekday-of m "")) - (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3))) - (vm-su-do-month m (substring date (match-beginning 4) (match-end 4))) - (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) - (if (= 2 (length (vm-year-of m))) - (vm-set-year-of m (concat "19" (vm-year-of m)))) - (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6))) - (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7)))) - ((string-match -;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for -;; the possibility of a timezone at the end. -"\\([a-z][a-z][a-z]\\)[ \t\n]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?" - date) - (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1))) - (vm-su-do-month m (substring date (match-beginning 2) (match-end 2))) - (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3))) - (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4))) - (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) - (if (match-beginning 6) - (vm-set-zone-of m (substring date (match-beginning 6) - (match-end 6))) - (vm-set-zone-of m ""))) - (t - (setq vector (vm-parse-date date)) - (vm-set-weekday-of m (elt vector 0)) - (vm-set-monthday-of m (elt vector 1)) - (vm-su-do-month m (elt vector 2)) - (vm-set-year-of m (elt vector 3)) - (vm-set-hour-of m (elt vector 4)) - (vm-set-zone-of m (elt vector 5))))) - - ;; Normalize all hour and date specifications to avoid jagged margins. - ;; If the hour is " 3:..." or "3:...", turn it into "03:...". - ;; If the date is "03", turn it into " 3". - (cond ((null (vm-hour-of m)) nil) - ((string-match "\\`[0-9]:" (vm-hour-of m)) - (vm-set-hour-of m (concat "0" (vm-hour-of m))))) - (cond ((null (vm-monthday-of m)) nil) - ((string-match "\\`0[0-9]\\'" (vm-monthday-of m)) - (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2)))) - ) - -(defun vm-su-do-month (m month-abbrev) - (let ((val (assoc (downcase month-abbrev) vm-month-alist))) - (if val - (progn (vm-set-month-of m (nth 1 val)) - (vm-set-month-number-of m (nth 2 val))) - (vm-set-month-of m "") - (vm-set-month-number-of m "")))) - -(defun vm-run-user-summary-function (function message) - (let ((message (vm-real-message-of message))) - (save-excursion - (set-buffer (vm-buffer-of message)) - (save-restriction - (widen) - (save-excursion - (narrow-to-region (vm-headers-of message) (vm-text-end-of message)) - (funcall function message)))))) - -(defun vm-su-full-name (m) - (or (vm-full-name-of m) - (progn (vm-su-do-author m) (vm-full-name-of m)))) - -(defun vm-su-interesting-full-name (m) - (if vm-summary-uninteresting-senders - (let ((case-fold-search nil)) - (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) - (concat vm-summary-uninteresting-senders-arrow (vm-su-to-names m)) - (vm-su-full-name m))) - (vm-su-full-name m))) - -(defun vm-su-from (m) - (or (vm-from-of m) - (progn (vm-su-do-author m) (vm-from-of m)))) - -(defun vm-su-interesting-from (m) - (if vm-summary-uninteresting-senders - (let ((case-fold-search nil)) - (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) - (concat vm-summary-uninteresting-senders-arrow (vm-su-to m)) - (vm-su-from m))) - (vm-su-from m))) - -;; Some yogurt-headed delivery agents don't even provide a From: header. -(defun vm-grok-From_-author (message) - ;; This works only on the From_ types, obviously - (if (not (memq (vm-message-type-of message) - '(From_ From_-with-Content-Length))) - nil - (save-excursion - (set-buffer (vm-buffer-of message)) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-start-of message)) - (let ((case-fold-search nil)) - (if (looking-at "From \\([^ \t\n]+\\)") - (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))))))) - -(defun vm-su-do-author (m) - (let ((full-name (vm-get-header-contents m "Full-Name:")) - (from (or (vm-get-header-contents m "From:" ", ") - (vm-grok-From_-author m))) - pair i) - (if (and full-name (string-match "^[ \t]*$" full-name)) - (setq full-name nil)) - (if (null from) - (progn - (setq from "???") - (if (null full-name) - (setq full-name "???"))) - (setq pair (funcall vm-chop-full-name-function from) - from (or (nth 1 pair) from) - full-name (or full-name (nth 0 pair) from))) - (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) - (setq full-name - (substring full-name (match-beginning 1) (match-end 1)))) - (while (setq i (string-match "\n" full-name i)) - (aset full-name i ?\ )) - (vm-set-full-name-of m full-name) - (vm-set-from-of m from))) - -(defun vm-default-chop-full-name (address) - (let ((from address) - (full-name nil)) - (cond ((string-match -"\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*<\\([^>]+\\)>[ \t\n]*\\'" - address) - (if (match-beginning 1) - (setq full-name - (substring address (match-beginning 1) (match-end 1)))) - (setq from - (substring address (match-beginning 3) (match-end 3)))) - ((string-match -"\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'" - address) - (if (match-beginning 3) - (setq full-name - (substring address (match-beginning 3) (match-end 3)))) - (setq from - (substring address (match-beginning 1) (match-end 1))))) - (list full-name from))) - -;; test for existence and functionality of mail-extract-address-components -;; there are versions out there that don't work right, so we run -;; some test data through it to see if we can trust it. -(defun vm-choose-chop-full-name-function (address) - (let ((test-data '(("kyle@uunet.uu.net" . - (nil "kyle@uunet.uu.net")) - ("c++std=lib@inet.research.att.com" . - (nil "c++std=lib@inet.research.att.com")) - ("\"Piet.Rypens\" <rypens@reks.uia.ac.be>" . - ("Piet Rypens" "rypens@reks.uia.ac.be")) - ("makke@wins.uia.ac.be (Marc.Gemis)" . - ("Marc Gemis" "makke@wins.uia.ac.be")) - ("" . (nil nil)))) - (failed nil) - result) - (while test-data - (setq result (condition-case nil - (mail-extract-address-components (car (car test-data))) - (error nil))) - (if (not (equal result (cdr (car test-data)))) - ;; failed test, use default - (setq failed t - test-data nil) - (setq test-data (cdr test-data)))) - (if failed - ;; it failed, use default - (setq vm-chop-full-name-function 'vm-default-chop-full-name) - ;; it passed the tests - (setq vm-chop-full-name-function 'mail-extract-address-components)) - (funcall vm-chop-full-name-function address))) - -(defun vm-su-do-recipients (m) - (let ((mail-use-rfc822 t) i names addresses to cc all list full-name) - (setq to (or (vm-get-header-contents m "To:" ", ") - (vm-get-header-contents m "Apparently-To:" ", ") - ;; desperation.... - (user-login-name)) - cc (vm-get-header-contents m "Cc:" ", ") - all to - all (if all (concat all ", " cc) cc) - addresses (rfc822-addresses all)) - (setq list (vm-parse-addresses all)) - (while list - ;; Just like vm-su-do-author: - (setq full-name (or (nth 0 (funcall vm-chop-full-name-function - (car list))) - (car list))) - ;; If double quoted are around the full name, fish the name out. - (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) - (setq full-name - (substring full-name (match-beginning 1) (match-end 1)))) - (while (setq i (string-match "\n" full-name i)) - (aset full-name i ?\ )) - (setq names (cons full-name names)) - (setq list (cdr list))) - (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses - (vm-set-to-of m (mapconcat 'identity addresses ", ")) - (vm-set-to-names-of m (mapconcat 'identity names ", ")))) - -(defun vm-su-to (m) - (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m)))) - -(defun vm-su-to-names (m) - (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m)))) - -(defun vm-su-message-id (m) - (or (vm-message-id-of m) - (vm-set-message-id-of - m - (or (let ((id (vm-get-header-contents m "Message-Id:"))) - (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)")))) - ;; try running md5 on the message body to produce an ID - ;; better than nothing. - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of m))) - (save-restriction - (widen) - (condition-case nil - (concat "<fake-VM-id." - (vm-pop-md5-string - (buffer-substring - (vm-text-of (vm-real-message-of m)) - (vm-text-end-of (vm-real-message-of m)))) - "@talos.iv>") - (error nil)))) - (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>"))))) - -(defun vm-su-line-count (m) - (or (vm-line-count-of m) - (vm-set-line-count-of - m - (save-excursion - (set-buffer (vm-buffer-of (vm-real-message-of m))) - (save-restriction - (widen) - (int-to-string - (count-lines (vm-text-of (vm-real-message-of m)) - (vm-text-end-of (vm-real-message-of m))))))))) - -(defun vm-su-subject (m) - (or (vm-subject-of m) - (vm-set-subject-of - m - (let ((subject (or (vm-get-header-contents m "Subject:" " ") "")) - (i nil)) - (while (setq i (string-match "\n" subject i)) - (aset subject i ?\ )) - subject )))) - -(defun vm-su-summary (m) - (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m))) - (or (vm-virtual-summary-of m) - (save-excursion - (vm-select-folder-buffer) - (vm-set-virtual-summary-of m (vm-sprintf 'vm-summary-format m t)) - (vm-virtual-summary-of m))) - (or (vm-summary-of m) - (save-excursion - (vm-select-folder-buffer) - (vm-set-summary-of m (vm-sprintf 'vm-summary-format m t)) - (vm-summary-of m))))) - -(defun vm-fix-my-summary!!! () - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (message "Fixing your summary...") - (let ((mp vm-message-list)) - (while mp - (vm-set-summary-of (car mp) nil) - (vm-mark-for-summary-update (car mp)) - (setq mp (cdr mp))) - (vm-stuff-folder-attributes nil) - (set-buffer-modified-p t) - (vm-update-summary-and-mode-line)) - (message "Fixing your summary... done")) - -(defun vm-su-thread-indent (m) - (if (natnump vm-summary-thread-indent-level) - (make-string (* (vm-th-thread-indentation m) - vm-summary-thread-indent-level) - ?\ ) - "" )) - -(defun vm-su-labels (m) - (or (vm-label-string-of m) - (vm-set-label-string-of - m - (mapconcat 'identity (vm-labels-of m) ",")) - (vm-label-string-of m)))
--- a/lisp/vm/vm-thread.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,294 +0,0 @@ -;;; Thread support for VM -;;; Copyright (C) 1994 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-thread) - -(defun vm-toggle-threads-display () - "Toggle the threads display on and off. -When the threads display is on, the folder will be sorted by -thread and thread indentation (via the %I summary format specifier) -will be visible." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-set-summary-redo-start-point t) - (setq vm-summary-show-threads (not vm-summary-show-threads)) - (if vm-summary-show-threads - (vm-sort-messages "thread") - (vm-sort-messages "physical-order"))) - -(defun vm-build-threads (message-list) - (if (null vm-thread-obarray) - (setq vm-thread-obarray (make-vector 641 0) - vm-thread-subject-obarray (make-vector 641 0))) - (let ((mp (or message-list vm-message-list)) - (n 0) - ;; Just for laughs, make the update interval vary. - (modulus (+ (% (vm-abs (random)) 11) 40)) - ;; no need to schedule reindents of reparented messages - ;; unless there were already messages present. - (schedule-reindents message-list) - m parent parent-sym id id-sym date refs old-parent-sym) - (while mp - (setq m (car mp) - parent (vm-th-parent m) - id (vm-su-message-id m) - id-sym (intern id vm-thread-obarray) - date (vm-so-sortable-datestring m)) - (put id-sym 'messages (cons m (get id-sym 'messages))) - (if (and (null (cdr (get id-sym 'messages))) - schedule-reindents) - (vm-thread-mark-for-summary-update (get id-sym 'children))) - (if parent - (progn - (setq parent-sym (intern parent vm-thread-obarray)) - (cond ((or (not (boundp id-sym)) - (null (symbol-value id-sym)) - (eq (symbol-value id-sym) parent-sym)) - (set id-sym parent-sym)) - (t - (setq old-parent-sym (symbol-value id-sym)) - (put old-parent-sym 'children - (let ((kids (get old-parent-sym 'children)) - (msgs (get id-sym 'messages))) - (while msgs - (setq kids (delq m kids) - msgs (cdr msgs))) - kids )) - (set id-sym parent-sym) - (if schedule-reindents - (vm-thread-mark-for-summary-update - (get id-sym 'messages))))) - (put parent-sym 'children - (cons m (get parent-sym 'children)))) - (if (not (boundp id-sym)) - (set id-sym nil))) - ;; use the references header to set parenting information - ;; for ancestors of this message. This does not override - ;; a parent pointer for a message if it already exists. - (if (cdr (setq refs (vm-th-references m))) - (let (parent-sym id-sym msgs) - (setq parent-sym (intern (car refs) vm-thread-obarray) - refs (cdr refs)) - (while refs - (setq id-sym (intern (car refs) vm-thread-obarray)) - (if (and (boundp id-sym) (symbol-value id-sym)) - nil - (set id-sym parent-sym) - (if (setq msgs (get id-sym 'messages)) - (put parent-sym 'children - (append msgs (get parent-sym 'children)))) - (if schedule-reindents - (vm-thread-mark-for-summary-update msgs))) - (setq parent-sym id-sym - refs (cdr refs))))) - (if vm-thread-using-subject - ;; inhibit-quit because we need to make sure the asets - ;; below are an atomic group. - (let* ((inhibit-quit t) - (subject (vm-so-sortable-subject m)) - (subject-sym (intern subject vm-thread-subject-obarray))) - ;; if this subject never seen before create the - ;; information vector. - (if (not (boundp subject-sym)) - (set subject-sym - (vector id-sym (vm-so-sortable-datestring m) - nil (list m))) - ;; this subject seen before - (aset (symbol-value subject-sym) 3 - (cons m (aref (symbol-value subject-sym) 3))) - (if (string< date (aref (symbol-value subject-sym) 1)) - (let* ((vect (symbol-value subject-sym)) - (i-sym (aref vect 0))) - ;; optimization: if we know that this message - ;; already has a parent, then don't bother - ;; adding it to the list of child messages - ;; since we know that it will be threaded and - ;; unthreaded using the parent information. - (if (or (not (boundp i-sym)) - (null (symbol-value i-sym))) - (aset vect 2 (append (get i-sym 'messages) - (aref vect 2)))) - (aset vect 0 id-sym) - (aset vect 1 date) - ;; this loops _and_ recurses and I'm worried - ;; about it going into a spin someday. So I - ;; unblock interrupts here. It's not critical - ;; that it finish... the summary will just be out - ;; of sync. - (if schedule-reindents - (let ((inhibit-quit nil)) - (vm-thread-mark-for-summary-update (aref vect 2))))) - ;; optimization: if we know that this message - ;; already has a parent, then don't bother adding - ;; it to the list of child messages, since we - ;; know that it will be threaded and unthreaded - ;; using the parent information. - (if (null parent) - (aset (symbol-value subject-sym) 2 - (cons m (aref (symbol-value subject-sym) 2)))))))) - (setq mp (cdr mp) n (1+ n)) - (if (zerop (% n modulus)) - (message "Building threads... %d" n))) - (if (> n modulus) - (message "Building threads... done")))) - -(defun vm-thread-mark-for-summary-update (message-list) - (let (m) - (while message-list - (setq m (car message-list)) - ;; if thread-list is null then we've already marked this - ;; message, or it doesn't need marking. - (if (null (vm-thread-list-of m)) - nil - (vm-mark-for-summary-update m t) - (vm-set-thread-list-of m nil) - (vm-set-thread-indentation-of m nil) - (vm-thread-mark-for-summary-update - (get (intern (vm-su-message-id m) vm-thread-obarray) - 'children))) - (setq message-list (cdr message-list))))) - -(defun vm-thread-list (message) - (let ((done nil) - (m message) - thread-list id-sym subject-sym loop-sym root-date) - (save-excursion - (set-buffer (vm-buffer-of m)) - (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray) - thread-list (list id-sym)) - (fillarray vm-thread-loop-obarray 0) - (while (not done) - (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) - (if (boundp loop-sym) - ;; loop detected, bail... - (setq done t) - (set loop-sym t) - (if (and (boundp id-sym) (symbol-value id-sym)) - (progn - (setq id-sym (symbol-value id-sym) - thread-list (cons id-sym thread-list) - m (car (get id-sym 'messages)))) - (if (null m) - (setq done t) - (if (null vm-thread-using-subject) - nil - (setq subject-sym - (intern (vm-so-sortable-subject m) - vm-thread-subject-obarray)) - (if (or (not (boundp subject-sym)) - (eq (aref (symbol-value subject-sym) 0) id-sym)) - (setq done t) - (setq id-sym (aref (symbol-value subject-sym) 0) - thread-list (cons id-sym thread-list) - m (car (get id-sym 'messages))))))))) - ;; save the date of the oldest message in this thread - (setq root-date (get id-sym 'oldest-date)) - (if (or (null root-date) - (string< (vm-so-sortable-datestring message) root-date)) - (put id-sym 'oldest-date (vm-so-sortable-datestring message))) - thread-list ))) - -;; remove message struct from thread data. -;; -;; optional second arg non-nil means forget information that -;; might be different if the message contents changed. -;; -;; message must be a real (non-virtual) message -(defun vm-unthread-message (message &optional message-changing) - (save-excursion - (let ((mp (cons message (vm-virtual-messages-of message))) - m id-sym subject-sym vect p-sym) - (while mp - (setq m (car mp)) - (let ((inhibit-quit t)) - (vm-set-thread-list-of m nil) - (vm-set-thread-indentation-of m nil) - (set-buffer (vm-buffer-of m)) - (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray) - subject-sym (intern (vm-so-sortable-subject m) - vm-thread-subject-obarray)) - (if (boundp id-sym) - (progn - (put id-sym 'messages (delq m (get id-sym 'messages))) - (vm-thread-mark-for-summary-update (get id-sym 'children)) - (setq p-sym (symbol-value id-sym)) - (and p-sym (put p-sym 'children - (delq m (get p-sym 'children)))) - (if message-changing - (set id-sym nil)))) - (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym))) - (if (not (eq id-sym (aref vect 0))) - (aset vect 2 (delq m (aref vect 2))) - (if message-changing - (if (null (cdr (aref vect 3))) - (makunbound subject-sym) - (let ((p (aref vect 3)) - oldest-msg oldest-date children) - (setq oldest-msg (car p) - oldest-date (vm-so-sortable-datestring (car p)) - p (cdr p)) - (while p - (if (and (string-lessp (vm-so-sortable-datestring (car p)) - oldest-date) - (not (eq m (car p)))) - (setq oldest-msg (car p) - oldest-date (vm-so-sortable-datestring (car p)))) - (setq p (cdr p))) - (aset vect 0 (intern (vm-su-message-id oldest-msg) - vm-thread-obarray)) - (aset vect 1 oldest-date) - (setq children (delq oldest-msg (aref vect 2))) - (aset vect 2 children) - (aset vect 3 (delq m (aref vect 3))) - ;; I'm not sure there aren't situations - ;; where this might loop forever. - (let ((inhibit-quit nil)) - (vm-thread-mark-for-summary-update children)))))))) - (setq mp (cdr mp)))))) - -(defun vm-th-references (m) - (or (vm-references-of m) - (vm-set-references-of - m - (let (references) - (setq references (vm-get-header-contents m "References:" " ")) - (and references (vm-parse references "[^<]*\\(<[^>]+>\\)")))))) - -(defun vm-th-parent (m) - (or (vm-parent-of m) - (vm-set-parent-of - m - (or (car (vm-last (vm-th-references m))) - (let (in-reply-to) - (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " ")) - (and in-reply-to - (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)")))))))) - -(defun vm-th-thread-indentation (m) - (or (vm-thread-indentation-of m) - (let ((p (vm-th-thread-list m))) - (while (and p (null (get (car p) 'messages))) - (setq p (cdr p))) - (vm-set-thread-indentation-of m (1- (length p))) - (vm-thread-indentation-of m)))) - -(defun vm-th-thread-list (m) - (or (vm-thread-list-of m) - (progn - (vm-set-thread-list-of m (vm-thread-list m)) - (vm-thread-list-of m))))
--- a/lisp/vm/vm-toolbar.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,469 +0,0 @@ -;;; Toolbar related functions and commands -;;; Copyright (C) 1995-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-toolbar) - -(defvar vm-toolbar-specifier nil) - -(defvar vm-toolbar-next-button - [vm-toolbar-next-icon - vm-toolbar-next-command - (vm-toolbar-any-messages-p) - "Go to the next message.\n -The command `vm-toolbar-next-command' is run, which is normally -fbound to `vm-next-message'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-next-command 'some-other-command)"]) -(defvar vm-toolbar-next-icon nil) -(or (fboundp 'vm-toolbar-next-command) - (fset 'vm-toolbar-next-command 'vm-next-message)) - -(defvar vm-toolbar-previous-button - [vm-toolbar-previous-icon - vm-toolbar-previous-command - (vm-toolbar-any-messages-p) - "Go to the previous message.\n -The command `vm-toolbar-previous-command' is run, which is normally -fbound to `vm-previous-message'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-previous-command 'some-other-command)"]) -(defvar vm-toolbar-previous-icon nil) -(or (fboundp 'vm-toolbar-previous-command) - (fset 'vm-toolbar-previous-command 'vm-previous-message)) - -(defvar vm-toolbar-autofile-button - [vm-toolbar-autofile-icon - vm-toolbar-autofile-message - (vm-toolbar-can-autofile-p) - "Save the current message to a folder selected using vm-auto-folder-alist."]) -(defvar vm-toolbar-autofile-icon nil) - -(defvar vm-toolbar-file-button - [vm-toolbar-file-icon vm-toolbar-file-command (vm-toolbar-any-messages-p) - "Save the current message to a folder.\n -The command `vm-toolbar-file-command' is run, which is normally -fbound to `vm-save-message'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-file-command 'some-other-command)"]) -(defvar vm-toolbar-file-icon nil) -(or (fboundp 'vm-toolbar-file-command) - (fset 'vm-toolbar-file-command 'vm-save-message)) - -(defvar vm-toolbar-getmail-button - [vm-toolbar-getmail-icon vm-toolbar-getmail-command - (vm-toolbar-mail-waiting-p) - "Retrieve spooled mail for the current folder.\n -The command `vm-toolbar-getmail-command' is run, which is normally -fbound to `vm-get-new-mail'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-getmail-command 'some-other-command)"]) -(defvar vm-toolbar-getmail-icon nil) -(or (fboundp 'vm-toolbar-getmail-command) - (fset 'vm-toolbar-getmail-command 'vm-get-new-mail)) - -(defvar vm-toolbar-print-button - [vm-toolbar-print-icon - vm-toolbar-print-command - (vm-toolbar-any-messages-p) - "Print the current message.\n -The command `vm-toolbar-print-command' is run, which is normally -fbound to `vm-print-message'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-print-command 'some-other-command)"]) -(defvar vm-toolbar-print-icon nil) -(or (fboundp 'vm-toolbar-print-command) - (fset 'vm-toolbar-print-command 'vm-print-message)) - -(defvar vm-toolbar-visit-button - [vm-toolbar-visit-icon vm-toolbar-visit-command t - "Visit a different folder.\n -The command `vm-toolbar-visit-command' is run, which is normally -fbound to `vm-visit-folder'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-visit-command 'some-other-command)"]) -(defvar vm-toolbar-visit-icon nil) -(or (fboundp 'vm-toolbar-visit-command) - (fset 'vm-toolbar-visit-command 'vm-visit-folder)) - -(defvar vm-toolbar-reply-button - [vm-toolbar-reply-icon - vm-toolbar-reply-command - (vm-toolbar-any-messages-p) - "Reply to the current message.\n -The command `vm-toolbar-reply-command' is run, which is normally -fbound to `vm-followup-include-text'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-reply-command 'some-other-command)"]) -(defvar vm-toolbar-reply-icon nil) -(or (fboundp 'vm-toolbar-reply-command) - (fset 'vm-toolbar-reply-command 'vm-followup-include-text)) - -(defvar vm-toolbar-compose-button - [vm-toolbar-compose-icon vm-toolbar-compose-command t - "Compose a new message.\n -The command `vm-toolbar-compose-command' is run, which is normally -fbound to `vm-mail'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-compose-command 'some-other-command)"]) -(defvar vm-toolbar-compose-icon nil) -(or (fboundp 'vm-toolbar-compose-command) - (fset 'vm-toolbar-compose-command 'vm-mail)) - -(defvar vm-toolbar-decode-mime-button - [vm-toolbar-decode-mime-icon vm-toolbar-decode-mime-command - (vm-toolbar-can-decode-mime-p) - "Decode the MIME objects in the current message.\n -The objects might be displayed immediately, or buttons might be -displayed that you need to click on to view the object. See the -documentation for the variables vm-mime-internal-content-types -and vm-mime-external-content-types-alist to see how to control -whether you see buttons or objects.\n -The command `vm-toolbar-decode-mime-command' is run, which is normally -fbound to `vm-decode-mime-messages'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-decode-mime-command 'some-other-command)"]) -(defvar vm-toolbar-decode-mime-icon nil) -(or (fboundp 'vm-toolbar-decode-mime-command) - (fset 'vm-toolbar-decode-mime-command 'vm-decode-mime-message)) - -(defvar vm-toolbar-delete-icon nil) - -(defvar vm-toolbar-undelete-icon nil) - -(defvar vm-toolbar-delete/undelete-button - [vm-toolbar-delete/undelete-icon - vm-toolbar-delete/undelete-message - (vm-toolbar-any-messages-p) - "Delete the current message, or undelete it if it is already deleted."]) -(defvar vm-toolbar-delete/undelete-icon nil) -(make-variable-buffer-local 'vm-toolbar-delete/undelete-icon) - -(defvar vm-toolbar-help-icon nil) - -(defvar vm-toolbar-recover-icon nil) - -(defvar vm-toolbar-helper-icon nil) -(make-variable-buffer-local 'vm-toolbar-helper-icon) - -(defvar vm-toolbar-help-button - [vm-toolbar-helper-icon vm-toolbar-helper-command - (vm-toolbar-can-help-p) - "Don't Panic.\n -VM uses this button to offer help if you're in trouble. -Under normal circumstances, this button runs `vm-help'.\n -If the current folder looks out-of-date relative to its auto-save -file then this button will run `recover-file'."]) - -(defvar vm-toolbar-helper-command nil) -(make-variable-buffer-local 'vm-toolbar-helper-command) - -(defun vm-toolbar-helper-command () - (interactive) - (setq this-command vm-toolbar-helper-command) - (call-interactively vm-toolbar-helper-command)) - -(defvar vm-toolbar-quit-button - [vm-toolbar-quit-icon vm-toolbar-quit-command - (vm-toolbar-can-quit-p) - "Quit visiting this folder.\n -The command `vm-toolbar-quit-command' is run, which is normally -fbound to `vm-quit'. -You can make this button run some other command by using a Lisp -s-expression like this one in your .vm file: - (fset 'vm-toolbar-quit-command 'some-other-command)"]) -(defvar vm-toolbar-quit-icon nil) -(or (fboundp 'vm-toolbar-quit-command) - (fset 'vm-toolbar-quit-command 'vm-quit)) - -(defun vm-toolbar-any-messages-p () - (condition-case nil - (save-excursion - (vm-check-for-killed-folder) - (vm-select-folder-buffer) - vm-message-list) - (error nil))) - -(defun vm-toolbar-delete/undelete-message (&optional prefix-arg) - (interactive "P") - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (let ((current-prefix-arg prefix-arg)) - (if (vm-deleted-flag (car vm-message-pointer)) - (call-interactively 'vm-undelete-message) - (call-interactively 'vm-delete-message)))) - -(defun vm-toolbar-can-autofile-p () - (interactive) - (condition-case nil - (save-excursion - (vm-check-for-killed-folder) - (vm-select-folder-buffer) - (and vm-message-pointer - (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) - (error nil))) - -(defun vm-toolbar-autofile-message () - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) - (if file - (progn - (vm-save-message file 1) - (message "Message saved to %s" file)) - (error "No match for message in vm-auto-folder-alist.")))) - -(defun vm-toolbar-can-recover-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (and vm-folder-read-only - buffer-file-name - buffer-auto-save-file-name - (null (buffer-modified-p)) - (file-newer-than-file-p - buffer-auto-save-file-name - buffer-file-name))) - (error nil))) - -(defun vm-toolbar-can-decode-mime-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (and - vm-display-using-mime - vm-message-pointer - vm-presentation-buffer - (not vm-mime-decoded) - (not (vm-mime-plain-message-p (car vm-message-pointer))))) - (error nil))) - -(defun vm-toolbar-can-quit-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - (memq major-mode '(vm-mode vm-virtual-mode))) - (error nil))) - -(defun vm-toolbar-mail-waiting-p () - (condition-case nil - (save-excursion - (vm-select-folder-buffer) - vm-spooled-mail-waiting) - (error nil))) - -(fset 'vm-toolbar-can-help-p 'vm-toolbar-can-quit-p) - -(defun vm-toolbar-update-toolbar () - (if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer))) - (setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon) - (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)) - (cond ((vm-toolbar-can-recover-p) - (setq vm-toolbar-helper-command 'recover-file - vm-toolbar-helper-icon vm-toolbar-recover-icon)) - ((vm-toolbar-mail-waiting-p) - (setq vm-toolbar-helper-command 'vm-get-new-mail - vm-toolbar-helper-icon vm-toolbar-getmail-icon)) - ((vm-toolbar-can-decode-mime-p) - (setq vm-toolbar-helper-command 'vm-decode-mime-message - vm-toolbar-helper-icon vm-toolbar-decode-mime-icon)) - (t - (setq vm-toolbar-helper-command 'vm-help - vm-toolbar-helper-icon vm-toolbar-help-icon))) - (if vm-summary-buffer - (vm-copy-local-variables vm-summary-buffer - 'vm-toolbar-delete/undelete-icon - 'vm-toolbar-helper-command - 'vm-toolbar-helper-icon)) - (if vm-presentation-buffer - (vm-copy-local-variables vm-presentation-buffer - 'vm-toolbar-delete/undelete-icon - 'vm-toolbar-helper-command - 'vm-toolbar-helper-icon)) - (and vm-toolbar-specifier - (progn - (set-specifier vm-toolbar-specifier (cons (current-buffer) nil)) - (set-specifier vm-toolbar-specifier (cons (current-buffer) - vm-toolbar))))) - -(defun vm-toolbar-install-toolbar () - (vm-toolbar-initialize) - (let ((height (+ 4 (glyph-height (car vm-toolbar-help-icon)))) - (width (+ 4 (glyph-width (car vm-toolbar-help-icon)))) - (frame (selected-frame)) - (buffer (current-buffer)) - (tag-set '(win)) - (myframe (vm-created-this-frame-p)) - toolbar ) - ;; glyph-width and glyph-height return 0 at startup sometimes - ;; use reasonable values if they fail. - (if (= width 4) - (setq width 68)) - (if (= height 4) - (setq height 46)) - ;; honor user setting of vm-toolbar if they are daring enough - ;; to set it. - (if vm-toolbar - (setq toolbar vm-toolbar) - (setq toolbar (vm-toolbar-make-toolbar-spec) - vm-toolbar toolbar)) - (cond ((eq vm-toolbar-orientation 'right) - (setq vm-toolbar-specifier right-toolbar) - (if myframe - (set-specifier right-toolbar toolbar frame tag-set)) - (set-specifier right-toolbar toolbar buffer) - (set-specifier right-toolbar-width width frame tag-set)) - ((eq vm-toolbar-orientation 'left) - (setq vm-toolbar-specifier left-toolbar) - (if myframe - (set-specifier left-toolbar toolbar frame tag-set)) - (set-specifier left-toolbar toolbar buffer) - (set-specifier left-toolbar-width width frame tag-set)) - ((eq vm-toolbar-orientation 'bottom) - (setq vm-toolbar-specifier bottom-toolbar) - (if myframe - (set-specifier bottom-toolbar toolbar frame tag-set)) - (set-specifier bottom-toolbar toolbar buffer) - (set-specifier bottom-toolbar-height height frame tag-set)) - (t - (setq vm-toolbar-specifier top-toolbar) - (if myframe - (set-specifier top-toolbar toolbar frame tag-set)) - (set-specifier top-toolbar toolbar buffer) - (set-specifier top-toolbar-height height frame tag-set))))) - -(defun vm-toolbar-make-toolbar-spec () - (let ((button-alist '( - (autofile . vm-toolbar-autofile-button) - (compose . vm-toolbar-compose-button) - (delete/undelete . vm-toolbar-delete/undelete-button) - (file . vm-toolbar-file-button) - (getmail . vm-toolbar-getmail-button) - (help . vm-toolbar-help-button) - (mime . vm-toolbar-decode-mime-button) - (next . vm-toolbar-next-button) - (previous . vm-toolbar-previous-button) - (print . vm-toolbar-print-button) - (quit . vm-toolbar-quit-button) - (reply . vm-toolbar-reply-button) - (visit . vm-toolbar-visit-button) - )) - (button-list vm-use-toolbar) - cons - (toolbar nil)) - (while button-list - (if (null (car button-list)) - (setq toolbar (cons nil toolbar)) - (setq cons (assq (car button-list) button-alist)) - (if cons - (setq toolbar (cons (symbol-value (cdr cons)) toolbar)))) - (setq button-list (cdr button-list))) - (nreverse toolbar) )) - -(defun vm-toolbar-initialize () - ;; drag these in now instead of waiting for them to be - ;; autoloaded. the "loading..." messages could come at a bad - ;; moment and wipe an important echo area message, like "Auto - ;; save file is newer..." - (require 'vm-save) - (require 'vm-summary) - (cond - ((null vm-toolbar-help-icon) - (let ((tuples - (if (featurep 'xpm) - (list - (if (and (device-on-window-system-p) - (>= (device-bitplanes) 16)) - '(vm-toolbar-decode-mime-icon "mime-colorful-up.xpm" - "mime-colorful-dn.xpm" - "mime-colorful-xx.xpm") - '(vm-toolbar-decode-mime-icon "mime-simple-up.xpm" - "mime-simple-dn.xpm" - "mime-simple-xx.xpm")) - '(vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm") - '(vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm" - "previous-dn.xpm") - '(vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm") - '(vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm" - "undelete-dn.xpm") - '(vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm" - "autofile-dn.xpm") - '(vm-toolbar-getmail-icon "getmail-up.xpm" "getmail-dn.xpm" "getmail-dn.xpm") - '(vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm") - '(vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm") - '(vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm") - '(vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm") - '(vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm") - '(vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm") - '(vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm") - '(vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm") - ) - '( - (vm-toolbar-decode-mime-icon "mime-up.xbm" "mime-dn.xbm" "mime-xx.xbm") - (vm-toolbar-next-icon "next-up.xbm" "next-dn.xbm" "next-xx.xbm") - (vm-toolbar-previous-icon "previous-up.xbm" "previous-dn.xbm" - "previous-xx.xbm") - (vm-toolbar-delete-icon "delete-up.xbm" "delete-dn.xbm" "delete-xx.xbm") - (vm-toolbar-undelete-icon "undelete-up.xbm" "undelete-dn.xbm" - "undelete-xx.xbm") - (vm-toolbar-autofile-icon "autofile-up.xbm" "autofile-dn.xbm" - "autofile-xx.xbm") - (vm-toolbar-getmail-icon "getmail-up.xbm" "getmail-dn.xbm" "getmail-xx.xbm") - (vm-toolbar-file-icon "file-up.xbm" "file-dn.xbm" "file-xx.xbm") - (vm-toolbar-reply-icon "reply-up.xbm" "reply-dn.xbm" "reply-xx.xbm") - (vm-toolbar-compose-icon "compose-up.xbm" "compose-dn.xbm" "compose-xx.xbm") - (vm-toolbar-print-icon "print-up.xbm" "print-dn.xbm" "print-xx.xbm") - (vm-toolbar-visit-icon "visit-up.xbm" "visit-dn.xbm" "visit-xx.xbm") - (vm-toolbar-quit-icon "quit-up.xbm" "quit-dn.xbm" "quit-xx.xbm") - (vm-toolbar-help-icon "help-up.xbm" "help-dn.xbm" "help-xx.xpm") - (vm-toolbar-recover-icon "recover-up.xbm" "recover-dn.xbm" "recover-xx.xpm") - ))) - tuple files var) - (if (not (file-directory-p vm-toolbar-pixmap-directory)) - (error "Bad toolbar pixmap directory: %s" - vm-toolbar-pixmap-directory) - (while tuples - (setq tuple (car tuples) - var (car tuple) - files (cdr tuple)) - (set var (mapcar - (function - (lambda (f) - (make-glyph - (expand-file-name f vm-toolbar-pixmap-directory)))) - files)) - (setq tuples (cdr tuples))))))) - (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) - (setq-default vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) - (setq vm-toolbar-helper-command 'vm-help) - (setq vm-toolbar-helper-icon vm-toolbar-help-icon) - (setq-default vm-toolbar-helper-icon vm-toolbar-help-icon))
--- a/lisp/vm/vm-undo.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,468 +0,0 @@ -;;; Commands to undo message attribute changes in VM -;;; Copyright (C) 1989-1995 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-undo) - -(defun vm-set-buffer-modified-p (flag &optional buffer) - (save-excursion - (and buffer (set-buffer buffer)) - (set-buffer-modified-p flag) - (vm-increment vm-modification-counter) - (intern (buffer-name) vm-buffers-needing-display-update) - (if (null flag) - (setq vm-messages-not-on-disk 0)))) - -(defun vm-undo-boundary () - (if (car vm-undo-record-list) - (setq vm-undo-record-list (cons nil vm-undo-record-list)))) - -(defun vm-clear-expunge-invalidated-undos () - (let ((udp vm-undo-record-list) udp-prev) - (while udp - (cond ((null (car udp)) - (setq udp-prev udp)) - ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p)) - ;; delete flag == expunged is the - ;; indicator of an expunged message - (eq (vm-deleted-flag (car (cdr (car udp)))) 'expunged)) - (cond (udp-prev (setcdr udp-prev (cdr udp))) - (t (setq vm-undo-record-list (cdr udp))))) - (t (setq udp-prev udp))) - (setq udp (cdr udp)))) - (vm-clear-modification-flag-undos)) - -(defun vm-clear-virtual-quit-invalidated-undos () - (let ((udp vm-undo-record-list) udp-prev) - (while udp - (cond ((null (car udp)) - (setq udp-prev udp)) - ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p)) - ;; message-id-number == "Q" is the - ;; indicator of a dead message - (equal (vm-message-id-number-of (car (cdr (car udp)))) "Q")) - (cond (udp-prev (setcdr udp-prev (cdr udp))) - (t (setq vm-undo-record-list (cdr udp))))) - (t (setq udp-prev udp))) - (setq udp (cdr udp)))) - (vm-clear-modification-flag-undos)) - -(defun vm-clear-modification-flag-undos () - (let ((udp vm-undo-record-list) udp-prev) - (while udp - (cond ((null (car udp)) - (setq udp-prev udp)) - ((eq (car (car udp)) 'vm-set-buffer-modified-p) - (cond (udp-prev (setcdr udp-prev (cdr udp))) - (t (setq vm-undo-record-list (cdr udp))))) - (t (setq udp-prev udp))) - (setq udp (cdr udp))) - (vm-squeeze-consecutive-undo-boundaries))) - -;; squeeze out consecutive record separators left by record deletions -(defun vm-squeeze-consecutive-undo-boundaries () - (let ((udp vm-undo-record-list) udp-prev) - (while udp - (cond ((and (null (car udp)) udp-prev (null (car udp-prev))) - (setcdr udp-prev (cdr udp))) - (t (setq udp-prev udp))) - (setq udp (cdr udp))) - (if (equal '(nil) vm-undo-record-list) - (setq vm-undo-record-list nil))) - ;; for the Undo button on the menubar, if present - (and (null vm-undo-record-list) - (vm-menu-support-possible-p) - (vm-menu-xemacs-menus-p) - (vm-menu-set-menubar-dirty-flag))) - -(defun vm-undo-record (sexp) - ;; for the Undo button on the menubar, if present - (and (null vm-undo-record-list) - (vm-menu-support-possible-p) - (vm-menu-xemacs-menus-p) - (vm-menu-set-menubar-dirty-flag)) - (setq vm-undo-record-list (cons sexp vm-undo-record-list))) - -(defun vm-undo-describe (record) - (let ((cell - (assq (car record) - '((vm-set-new-flag "new" "old") - (vm-set-unread-flag "unread" "read") - (vm-set-deleted-flag "deleted" "undeleted") - (vm-set-forwarded-flag "forwarded" "unforwarded") - (vm-set-replied-flag "answered" "unanswered") - (vm-set-redistributed-flag "redistributed" "unredistributed") - (vm-set-filed-flag "filed" "unfiled") - (vm-set-written-flag "written" "unwritten")))) - (m (nth 1 record)) - labels) - (cond (cell - (message "VM Undo! %s/%s %s -> %s" - (buffer-name (vm-buffer-of m)) - (vm-number-of m) - (if (nth 2 record) - (nth 2 cell) - (nth 1 cell)) - (if (nth 2 record) - (nth 1 cell) - (nth 2 cell)))) - ((eq (car cell) 'vm-set-labels) - (setq labels (nth 2 record)) - (message "VM Undo! %s/%s %s%s" - (buffer-name (vm-buffer-of m)) - (vm-number-of m) - (if (null labels) - "lost all its labels" - "labels set to ") - (if (null labels) - "" - (mapconcat 'identity labels ", "))))))) - -(defun vm-undo-set-message-pointer (record) - (if (and (not (eq (car record) 'vm-set-buffer-modified-p)) - (not (eq (nth 1 record) vm-message-pointer))) - (progn - (vm-record-and-change-message-pointer - vm-message-pointer - (or (cdr (vm-reverse-link-of (nth 1 record))) - vm-message-list)) - ;; make folder read-only to avoid modifications when we - ;; do this. - (let ((vm-folder-read-only t)) - (vm-preview-current-message))))) - -(defun vm-undo () - "Undo last change to message attributes in the current folder. -Consecutive invocations of this command cause sequentially earlier -changes to be undone. After an intervening command between undos, -the undos themselves become undoable." - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-display nil nil '(vm-undo) '(vm-undo)) - (let ((modified (buffer-modified-p))) - (if (not (eq last-command 'vm-undo)) - (setq vm-undo-record-pointer vm-undo-record-list)) - (if (not vm-undo-record-pointer) - (error "No further VM undo information available")) - ;; skip current record boundary - (setq vm-undo-record-pointer (cdr vm-undo-record-pointer)) - (while (car vm-undo-record-pointer) - (vm-undo-set-message-pointer (car vm-undo-record-pointer)) - (vm-undo-describe (car vm-undo-record-pointer)) - (eval (car vm-undo-record-pointer)) - (setq vm-undo-record-pointer (cdr vm-undo-record-pointer))) - (and modified (not (buffer-modified-p)) - (delete-auto-save-file-if-necessary)) - (vm-update-summary-and-mode-line))) - -(defun vm-set-message-attributes (string count) - "Set message attributes. -Use this command to change attributes like `deleted' or -`replied'. Interactively you will be prompted for the attributes -to be changed, and only the attributes you enter will be altered. -You can use completion to expand the attribute names. The names -should be entered as a space separated list. - -A numeric prefix argument COUNT causes the current message and -the next COUNT-1 message to have their attributes altered. A -negative COUNT arg causes the current message and the previous -COUNT-1 messages to be altered. COUNT defaults to one." - (interactive - (let ((last-command last-command) - (this-command this-command)) - ;; so the user can see what message they are about to - ;; modify. - (vm-follow-summary-cursor) - (list - (vm-read-string "Set attributes: " vm-supported-attribute-names t) - (prefix-numeric-value current-prefix-arg)))) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (vm-display nil nil '(vm-set-message-attributes) - '(vm-set-message-attributes)) - (let ((name-list (vm-parse string "[ \t]*\\([^ \t]+\\)")) - (m-list (vm-select-marked-or-prefixed-messages count)) - n-list name m) - (while m-list - (setq m (car m-list) - n-list name-list) - (while n-list - (setq name (car n-list)) - (cond ((string= name "new") - (vm-set-new-flag m t)) - ((string= name "recent") - (vm-set-new-flag m t)) - ((string= name "unread") - (vm-set-unread-flag m t)) - ((string= name "unseen") - (vm-set-unread-flag m t)) - ((string= name "read") - (vm-set-new-flag m nil) - (vm-set-unread-flag m nil)) - ((string= name "deleted") - (vm-set-deleted-flag m t)) - ((string= name "replied") - (vm-set-replied-flag m t)) - ((string= name "answered") - (vm-set-replied-flag m t)) - ((string= name "forwarded") - (vm-set-forwarded-flag m t)) - ((string= name "redistributed") - (vm-set-redistributed-flag m t)) - ((string= name "filed") - (vm-set-filed-flag m t)) - ((string= name "written") - (vm-set-written-flag m t)) - ((string= name "edited") - (vm-set-edited-flag-of m t)) - ((string= name "undeleted") - (vm-set-deleted-flag m nil)) - ((string= name "unreplied") - (vm-set-replied-flag m nil)) - ((string= name "unanswered") - (vm-set-replied-flag m nil)) - ((string= name "unforwarded") - (vm-set-forwarded-flag m nil)) - ((string= name "unredistributed") - (vm-set-redistributed-flag m nil)) - ((string= name "unfiled") - (vm-set-filed-flag m nil)) - ((string= name "unwritten") - (vm-set-written-flag m nil)) - ((string= name "unedited") - (vm-set-edited-flag-of m nil))) - (setq n-list (cdr n-list))) - (setq m-list (cdr m-list))) - (vm-update-summary-and-mode-line))) - -(defun vm-add-message-labels (string count) - "Attach some labels to a message. -These are arbitrary user-defined labels, not to be confused with -message attributes like `new' and `deleted'. Interactively you -will be prompted for the labels to be added. You can use -completion to expand the label names, with the completion list -being all the labels that have ever been used in this folder. -The names should be entered as a space separated list. Label -names are compared case-insensitively. - -A numeric prefix argument COUNT causes the current message and -the next COUNT-1 message to have the labels added. A -negative COUNT arg causes the current message and the previous -COUNT-1 messages to be altered. COUNT defaults to one." - (interactive - (let ((last-command last-command) - (this-command this-command) - (vm-completion-auto-correct nil) - (completion-ignore-case t)) - ;; so the user can see what message they are about to - ;; modify. - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (list - (vm-read-string "Add labels: " - (vm-obarray-to-string-list vm-label-obarray) t) - (prefix-numeric-value current-prefix-arg)))) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (vm-add-or-delete-message-labels string count t)) - -(defun vm-delete-message-labels (string count) - "Delete some labels from a message. -These are arbitrary user-defined labels, not to be confused with -message attributes like `new' and `deleted'. Interactively you -will be prompted for the labels to be deleted. You can use -completion to expand the label names, with the completion list -being all the labels that have ever been used in this folder. -The names should be entered as a space separated list. Label -names are compared case-insensitively. - -A numeric prefix argument COUNT causes the current message and -the next COUNT-1 message to have the labels deleted. A -negative COUNT arg causes the current message and the previous -COUNT-1 messages to be altered. COUNT defaults to one." - (interactive - (let ((last-command last-command) - (this-command this-command) - (vm-completion-auto-correct nil) - (completion-ignore-case t)) - ;; so the user can see what message they are about to - ;; modify. - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (list - (vm-read-string "Delete labels: " - (vm-obarray-to-string-list vm-label-obarray) t) - (prefix-numeric-value current-prefix-arg)))) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-read-only) - (vm-error-if-folder-empty) - (vm-add-or-delete-message-labels string count nil)) - -(defun vm-add-or-delete-message-labels (string count add) - (vm-display nil nil '(vm-add-message-labels vm-delete-message-labels) - (list this-command)) - (setq string (downcase string)) - (let ((m-list (vm-select-marked-or-prefixed-messages count)) - (action-labels (vm-parse string -"[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*")) - labels act-labels) - (if (and add m-list) - (progn - (setq act-labels action-labels) - (while act-labels - (intern (car act-labels) vm-label-obarray) - (setq act-labels (cdr act-labels))))) - (while m-list - (setq act-labels action-labels - labels (copy-sequence (vm-labels-of (car m-list)))) - (if add - (while act-labels - (setq labels (cons (car act-labels) labels) - act-labels (cdr act-labels))) - (while act-labels - (setq labels (vm-delqual (car act-labels) labels) - act-labels (cdr act-labels)))) - (if add - (setq labels (vm-delete-duplicates labels))) - (vm-set-labels (car m-list) labels) - (setq m-list (cdr m-list)))) - (vm-update-summary-and-mode-line)) - -(defun vm-set-xxxx-flag (m flag norecord function attr-index) - (let ((m-list nil) vmp) - (cond - ((and (not vm-folder-read-only) - (or (not (vm-virtual-messages-of m)) - (not (save-excursion - (set-buffer - (vm-buffer-of - (vm-real-message-of m))) - vm-folder-read-only)))) - (cond - ((not norecord) - (setq vmp (cons (vm-real-message-of m) (vm-virtual-messages-of m))) - (while vmp - (if (eq (vm-attributes-of m) (vm-attributes-of (car vmp))) - (setq m-list (cons (car vmp) m-list))) - (setq vmp (cdr vmp))) - (if (null m-list) - (setq m-list (cons m m-list))) - (while m-list - (save-excursion - (set-buffer (vm-buffer-of (car m-list))) - (cond ((not (buffer-modified-p)) - (vm-set-buffer-modified-p t) - (vm-undo-record (list 'vm-set-buffer-modified-p nil)))) - (vm-undo-record (list function (car m-list) (not flag))) - (vm-undo-boundary) - (vm-increment vm-modification-counter)) - (setq m-list (cdr m-list))))) - (aset (vm-attributes-of m) attr-index flag) - (vm-mark-for-summary-update m) - (if (not norecord) - (if (eq vm-flush-interval t) - (vm-stuff-virtual-attributes m) - (vm-set-modflag-of m t))))))) - - -(defun vm-set-labels (m labels) - (let ((m-list nil) - (old-labels (vm-labels-of m)) - vmp) - (cond - ((and (not vm-folder-read-only) - (or (not (vm-virtual-messages-of m)) - (not (save-excursion - (set-buffer - (vm-buffer-of - (vm-real-message-of m))) - vm-folder-read-only)))) - (setq vmp (cons (vm-real-message-of m) (vm-virtual-messages-of m))) - (while vmp - (if (eq (vm-attributes-of m) (vm-attributes-of (car vmp))) - (setq m-list (cons (car vmp) m-list))) - (setq vmp (cdr vmp))) - (if (null m-list) - (setq m-list (cons m m-list))) - (while m-list - (save-excursion - (set-buffer (vm-buffer-of (car m-list))) - (cond ((not (buffer-modified-p)) - (vm-set-buffer-modified-p t) - (vm-undo-record (list 'vm-set-buffer-modified-p nil)))) - (vm-undo-record (list 'vm-set-labels m old-labels)) - (vm-undo-boundary) - (vm-increment vm-modification-counter)) - (setq m-list (cdr m-list))) - (vm-set-labels-of m labels) - (vm-set-label-string-of m nil) - (vm-mark-for-summary-update m) - (if (eq vm-flush-interval t) - (vm-stuff-virtual-attributes m) - (vm-set-modflag-of m t)))))) - - -(defun vm-set-new-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-new-flag 0)) - -(defun vm-set-unread-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-unread-flag 1)) - -(defun vm-set-deleted-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-deleted-flag 2)) - -(defun vm-set-filed-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-filed-flag 3)) - -(defun vm-set-replied-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-replied-flag 4)) - -(defun vm-set-written-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-written-flag 5)) - -(defun vm-set-forwarded-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-forwarded-flag 6)) - -(defun vm-set-redistributed-flag (m flag &optional norecord) - (vm-set-xxxx-flag m flag norecord 'vm-set-forwarded-flag 8)) - -;; use these to avoid undo and summary update. -(defun vm-set-new-flag-of (m flag) (aset (aref m 2) 0 flag)) -(defun vm-set-unread-flag-of (m flag) (aset (aref m 2) 1 flag)) -(defun vm-set-deleted-flag-of (m flag) (aset (aref m 2) 2 flag)) -(defun vm-set-filed-flag-of (m flag) (aset (aref m 2) 3 flag)) -(defun vm-set-replied-flag-of (m flag) (aset (aref m 2) 4 flag)) -(defun vm-set-written-flag-of (m flag) (aset (aref m 2) 5 flag)) -(defun vm-set-forwarded-flag-of (m flag) (aset (aref m 2) 6 flag)) -(defun vm-set-redistributed-flag-of (m flag) (aset (aref m 2) 8 flag)) - -;; this is solely for the use of vm-stuff-attributes and appears here -;; only because this function should be grouped with others of its kind -;; for maintenance purposes. -(defun vm-set-deleted-flag-in-vector (v flag) - (aset v 2 flag)) -;; ditto. this is for vm-read-attributes. -(defun vm-set-new-flag-in-vector (v flag) - (aset v 0 flag))
--- a/lisp/vm/vm-user.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -;;; Interface functions to VM internal data -;;; Copyright (C) 1997 Kyle E. Jones -;;; -;;; This program 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. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-user) - -(defun vm-user-composition-folder-buffer () - "Returns the folder buffer associated with the current buffer. -The current buffer must be a composition buffer created by VM for -a reply, resend or forward. - -Nil is returned if the current buffer is not assocaited with any -VM folder. - -Note that the buffer returned might be a virtual folder buffer, -which might have several underlying real folders associated with -it. To get the list of real folder buffers associated with a -composition buffer, use vm-user-composition-real-folder-buffers -instead." - (if (eq major-mode 'mail-mode) - vm-mail-buffer - nil )) - -(defun vm-user-composition-real-folder-buffers () - "Returns a list of the real folder buffers associated with the current -buffer. The current buffer must be a composition buffer created -by VM for a reply, resend or forward." - (if (eq major-mode 'mail-mode) - (let ((list nil) (newlist nil)) - (cond ((eq vm-system-state 'replying) - (setq list vm-reply-list)) - ((eq vm-system-state 'forwarding) - (setq list vm-forward-list)) - ((eq vm-system-state 'redistributing) - (setq list vm-redistribute-list))) - (while list - (setq newlist (cons (vm-buffer-of (vm-real-message-of (car list))) - newlist) - list (cdr list))) - newlist ) - nil ))
--- a/lisp/vm/vm-vars.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3100 +0,0 @@ -;;; VM user and internal variable initialization -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-vars) - -(defvar vm-init-file "~/.vm" - "*Startup file for VM that is loaded the first time you run VM -in an Emacs session.") - -(defvar vm-preferences-file "~/.vm.preferences" - "*Secondary startup file for VM, loaded after vm-init-file. -This file is written and overwritten by VM and is not meant for -users to edit directly.") - -(defvar vm-primary-inbox "~/INBOX" - "*Mail is moved from the system mailbox to this file for reading.") - -(defvar vm-crash-box "~/INBOX.CRASH" - "*File in which to store mail temporarily while it is transferred from -the system mailbox to the primary inbox. If a crash occurs -during this mail transfer, any missing mail will be found in this -file. VM will do crash recovery from this file automatically at -startup, as necessary.") - -(defvar vm-keep-crash-boxes nil - "*Non-nil value should be a string specifying a directory where -your crash boxes should be moved after VM has copied new mail -out of them. This is a safety measure. In at least one case a -pointer corruption bug inside Emacs has caused VM to believe that -it had copied information out of the crash box when it in fact -had not. VM then deleted the crash box, losing the batch of -incoming mail. This is an exceedingly rare problem, but if you -want to avoid losing mail if it happens, set vm-keep-crash-boxes -to point to a directory in the same filesystem as all your -crash boxes. Each saved crash box will have a unique name based -on the current date and time the box was saved. You will need to -clean out this directory from time to time; VM does not do so. - -A nil value means VM should just delete crash boxes after it -has copied out the mail.") - -;; use this function to access vm-spool-files on the fly. this -;; allows us to use environmental variables without setting -;; vm-spool-files at load time and thereby making it hard to dump an -;; Emacs containing a preloaded VM. -(defun vm-spool-files () - (or vm-spool-files - (and (setq vm-spool-files (getenv "MAILPATH")) - (setq vm-spool-files - (vm-parse vm-spool-files - "\\([^:%?]+\\)\\([%?][^:]*\\)?\\(:\\|$\\)"))) - (and (setq vm-spool-files (getenv "MAIL")) - (setq vm-spool-files (list vm-spool-files))))) - -(defvar vm-spool-files nil - "*If non-nil this variable's value should be a list of strings -or a list of lists. - -If the value is a list of strings, the strings should name files -that VM will check for incoming mail instead of the default place -VM thinks your system mailbox is. Mail will be moved from these -mailboxes to your primary inbox as specified by vm-primary-inbox, -using vm-crash-box as a waystation. - -If the value is a list of lists, each sublist should be of the form - - (INBOX SPOOLNAME CRASHBOX) - -INBOX, SPOOLNAME and CRASHBOX are all strings. - -INBOX is the folder where you want your new mail to be moved when -you type 'g' (running vm-get-new-mail) in VM. It is where you -will read the mail. - -SPOOLNAME is where the mail system leaves your incoming mail, -e.g. /var/spool/mail/kyle. It can also be a POP maildrop, -provided it can be matched by the value of vm-recognize-pop-maildrops. - - A POP maildrop specification has the following format: - - \"HOST:PORT:AUTH:USER:PASSWORD\" - - HOST is the host name of the POP server - PORT is the TCP port number to connect to (should normally be 110). - USER is the user name sent to the server. - PASSWORD is the secret shared by you and the server for - authentication purposes. How is it used depends on the value of - the AUTH parameter. If the PASSWORD is \"*\", VM will prompt - you for the password the first time you try to retrieve mail from - maildrop. If the password is valid, VM will not ask you for the - password again during this Emacs session. - - AUTH is the authentication method used to convince the server you - should have access to the maildrop. Acceptable values are - \"pass\", \"rpop\" and \"apop\". For \"pass\", the PASSWORD is sent to - the server with the POP PASS command. For \"rpop\", the PASSWORD - should be the string to be sent to the server via the RPOP - command. In this case the string is not really a secret; - authentication is done by other means. For \"apop\", an MD5 digest - of the PASSWORD appended to the server timestamp will be sent to - the server with the APOP command. In order to use \"apop\" you - will have to set the value of vm-pop-md5-program appropriately to - point at the program that will generate the MD5 digest that VM - needs. - -CRASHBOX is the temporary file that VM uses to store mail in -between the SPOOLNAME and the INBOX. If the system crashes or -Emacs dies while mail is being moved, and the new mail is not in -the SPOOLNAME or the INBOX, then it will be in the CRASHBOX. - -There can be multiple entries with the same INBOX value, but a -particular SPOOLNAME should appear only once. CRASHBOXes should -not be shared among different INBOXes, but you can use the same -CRASHBOX/INBOX pair with a different SPOOLNAME. - -NOTE: The values of vm-primary-inbox and vm-crash-box are ignored -when getting new mail if vm-spool-files is a list of lists. - -vm-spool-files will default to the value of the shell -environmental variables MAILPATH or MAIL if either of these -variables are defined and no particular value for vm-spool-files -has been specified.") - -(defvar vm-spool-file-suffixes nil - "*List of suffixes to be used to create possible spool file names -for folders. Example: - - (setq vm-spool-file-suffixes '(\".spool\" \"-\")) - -If you visit a folder ~/mail/beekeeping, when VM attempts to -retrieve new mail for that folder it will look for mail in -~/mail/beekeeping.spool and ~/mail/beekeeping- in addition to -scanning vm-spool-files for matches. - -The value of vm-spool-files-suffixes will not be used unless -vm-crash-box-suffix is also defined, since a crash box is -required for all mail retrieval from spool files.") - -(defvar vm-crash-box-suffix nil - "*String suffix used to create possible crash box file names for folders. -When VM uses vm-spool-file-suffixes to create a spool file name, -it will append the value of vm-crash-box-suffix to the folder's -file name to create a crash box name.") - -(defvar vm-make-spool-file-name nil - "*Non-nil value should be a function that returns a spool file name -for a folder. The function will be called with one argument, the -folder's file name. If the folder does not have a file name, -the function will not be called.") - -(defvar vm-make-crash-box-name nil - "*Non-nil value should be a function that returns a crash box file name -for a folder. The function will be called with one argument, the -folder's file name. If the folder does not have a file name, -the function will not be called.") - -(defvar vm-pop-md5-program "md5" - "*Program that reads a message on its standard input and writes an -MD5 digest on its output.") - -(defvar vm-pop-max-message-size nil - "*If VM is about to retrieve via POP a message larger than this size -(in bytes) it will ask the you whether it should retrieve the message. - -If VM is retrieving mail automatically because vm-auto-get-new-mail is -set to a numeric value then you will not be prompted about large messages. -This is to avoid prompting you while you're typing in another buffer. -In this case the large message will be skipped with a warning -message. - -A nil value for vm-pop-max-message-size means no size limit.") - -(defvar vm-pop-messages-per-session nil - "*Non-nil value should be a integer specifying how many messages to -retrieve per POP session. When you type 'g' to get new mail, VM -will only retrieve that many messages from any particular POP maildrop. -To retrieve more messages, type 'g' again. - -A nil value means there's no limit.") - -(defvar vm-pop-bytes-per-session nil - "*Non-nil value should be a integer specifying how many bytes to -retrieve per POP session. When you type 'g' to get new mail, VM -will only retrieve messages until the byte limit is reached on -any particular POP maildrop. To retrieve more messages, type 'g' -again. - -A nil value means there's no limit.") - -(defvar vm-recognize-pop-maildrops "^[^:]+:[^:]+:[^:]+:[^:]+:[^:]+" - "*Value if non-nil should be a regular expression that matches -spool names found in vm-spool-files that should be considered POP -maildrops. A nil value tells VM that all the spool names are to -be considered files.") - -(defvar vm-auto-get-new-mail t - "*Non-nil value causes VM to automatically move mail from spool files -to a mail folder when the folder is first visited. Nil means -you must always use vm-get-new-mail to pull in newly arrived messages. - -If the value is a number, then it specifies how often (in -seconds) VM should check for new mail and try to retrieve it. -This is done asynchronously and may occur while you are editing -other files. It should not disturb your editing, except perhaps -for a pause while the check is being done.") - -(defvar vm-mail-check-interval 300 - "*Numeric value specifies the number of seconds between checks -for new mail. The maildrops for all visited folders are checked. - -A nil value means don't check for new mail. - -Note that mail if new mail is found, it is not retrieved. The -buffer local variable vm-spooled-mail-waiting is set non-nil in -the buffers of those folders that have mail waiting. VM uses -the displays \"Mail\" in the mode line of folders that have mail -waiting.") - -(defvar vm-spooled-mail-waiting nil - "Value is non-nil if there is mail waiting for the current folder. -This variable's value is local in all buffers. -VM maintains this variable, you should not set it.") -(make-variable-buffer-local 'vm-spooled-mail-waiting) - -(defvar vm-default-folder-type - (cond ((not (boundp 'system-configuration)) - 'From_) - ((or (string-match "-solaris" system-configuration) - (string-match "usg-unix-v" system-configuration) - (string-match "-ibm-aix" system-configuration)) - 'From_-with-Content-Length) - ((string-match "-sco" system-configuration) - 'mmdf) - (t 'From_)) - "*Default folder type for empty folders. -If VM has to add messages that have no specific folder type to an -empty folder, the folder will become this default type. -Allowed types are: - - From_ - From_-with-Content-Length - mmdf - babyl - -Value must be a symbol, not a string. i.e. write - - (setq vm-default-folder-type 'From_) - -in your .emacs or .vm file. - -If you set this variable's value to From_-with-Content-Length you -must set vm-trust-From_-with-Content-Length non-nil.") - -(defvar vm-check-folder-types t - "*Non-nil value causes VM to check folder and message types for -compatibility before it performs certain operations. - -Before saving a message to a folder, VM will check that the destination folder -is of the same type as the message to be saved. - -Before incorporating message into a visited folder, VM will check that the -messages are of the same type as that folder. - -A nil value means don't do the checks. - -If non-nil, VM will either convert the messages to the appropriate -type before saving or incorporating them, or it will signal an -error. The value of vm-convert-folder-types determines which -action VM will take.") - -(defvar vm-convert-folder-types t - "*Non-nil value means that when VM checks folder types and finds -a mismatch (see vm-check-folder-types), it will convert the -source messages to the type of the destination folder, if it can. - -If vm-check-folder-types is nil, then this variable isn't -consulted.") - -(defvar vm-trust-From_-with-Content-Length - (eq vm-default-folder-type 'From_-with-Content-Length) - "*Non-nil value means that if the first message in a folder contains -a Content-Length header and begins with \"From \" VM can safely -assume that all messages in the folder have Content-Length headers -that specify the length of the text section of each message. VM -will then use these headers to determine message boundaries -instead of the usual way of searching for two newlines followed by a -line that begins with \"From \". - -If you set vm-default-folder-type to From_-with-Content-Length you -must set this variable non-nil.") - -(defvar vm-visible-headers - '("Resent-" - "From:" "Sender:" - "To:" "Apparently-To:" "Cc:" - "Subject:" - "Date:") - "*List of headers that should be visible when VM first displays a message. -These should be listed in the order you wish them presented. -Regular expressions are allowed. There's no need to anchor -patterns with \"^\", as searches always start at the beginning of -a line. Put a colon at the end of patterns to get exact matches. -For example, \"Date\" matches \"Date\" and \"Date-Sent\". Header names -are always matched case insensitively. - -If the value of vm-invisible-header-regexp is nil, only the -headers matched by vm-visible-headers will be displayed. -Otherwise all headers are displayed except those matched by -vm-invisible-header-regexp. In this case vm-visible-headers -specifies the order in which headers are displayed. Headers not -matching vm-visible-headers are display last.") - -(defvar vm-invisible-header-regexp nil - "*Non-nil value should be a regular expression that tells what headers -VM should NOT normally display when presenting a message. All other -headers will be displayed. The variable vm-visible-headers specifies -the presentation order of headers; headers not matched by -vm-visible-headers are displayed last. - -Nil value causes VM to display ONLY those headers specified in -vm-visible-headers.") - -(defvar vm-highlighted-header-regexp nil - "*Value specifies which headers to highlight. -This is a regular expression that matches the names of headers that should -be highlighted when a message is first presented. For example setting -this variable to \"From:\\\\|Subject:\" causes the From and Subject -headers to be highlighted. - -This does not work under version 18 Emacs. - -If you're using XEmacs, you might want to use the builtin -`highlight-headers' package instead. If so, then you should set -the variable vm-use-lucid-highlighting non-nil. You'll need to -set the various variables used by the highlight-headers package -to customize highlighting. vm-highlighted-header-regexp is -ignored in this case.") - -(defvar vm-use-lucid-highlighting - ;; (not (not ...)) to avoid the confusing value of 6. - (not (not (string-match "XEmacs" emacs-version))) - "*Non-nil means to use the `highlight-headers' package in XEmacs. -Nil means just use VM's builtin header highlighting code. - -FSF Emacs always uses VM's builtin highlighting code.") - -(defvar vm-highlighted-header-face 'bold - "*Face to be used to highlight headers. -The headers to highlight are specified by the vm-highlighted-header-regexp -variable. - -This variable is ignored under XEmacs if vm-use-lucid-highlighting is -nil. XEmacs' highlight-headers package is used instead. See the -documentation for the function `highlight-headers' to find out how to -customize header highlighting using this package.") - -(defvar vm-preview-lines 0 - "*Non-nil value N causes VM to display the visible headers + N lines of text -of a message when it is first presented. The message is not actually -flagged as read until it is exposed in its entirety. - -A value of t causes VM to display as much of the message as will -fit in the window associated with the folder buffer. - -A nil value causes VM not to preview messages; no text lines are hidden and -messages are immediately flagged as read.") - -(defvar vm-preview-read-messages nil - "*Non-nil value means to preview messages even if they've already been read. -A nil value causes VM to preview messages only if new or unread.") - -(defvar vm-display-using-mime t - "*Non-nil value means VM should display messages using MIME. -MIME (Multipurpose Internet Mail Extensions) is a set of -extensions to the standard Internet message format that allows -reliable tranmission and reception of arbitrary data including -images, audio and video as well as ordinary text. - -A non-nil value for this variable means that VM will recognize -MIME encoded messages and display them as specified by the -various MIME standards specifications. - -A nil value means VM will not display MIME messages any -differently than any other message.") - -;; this is t because at this time (11 April 1997) Solaris is -;; generated too many mangled MIME version headers. For the same -;; reason vm-mime-avoid-folding-content-type is also set to t. -(defvar vm-mime-ignore-mime-version t - "*Non-nil value means ignore the version number in the MIME-Version -header. VM only knows how to decode and display MIME version 1.0 -messages. Some systems scramble the MIME-Version header, causing -VM to believe that it cannot display a message that it actually -can display. You can set vm-mime-ignore-mime-version non-nil if -you use such systems.") - -;; try to avoid bad interaction with TM -(defvar vm-send-using-mime (not (featurep 'mime-setup)) - "*Non-nil value means VM should support sending messages using MIME. -MIME (Multipurpose Internet Mail Extensions) is a set of -extensions to the standard Internet message format that allows -reliable tranmission and reception of arbitrary data including -images, audio and video as well as traditional text. - -A non-nil value for this variable means that VM will - - - allow you to attach files and messages to your outbound message. - - analyze the composition buffer when you send off a message and - encode it as needed. - -A nil value means VM will not offer any support for composing -MIME messages.") - -(defvar vm-honor-mime-content-disposition nil - "*Non-nil value means use information from the Content-Disposition header -to display MIME messages. The Content-Disposition header -specifies whether a MIME object should be displayed inline or -treated as an attachment. For VM, ``inline'' display means -displaying the object in the Emacs buffer, if possible. -Attachments will be displayed as a button that you can use -mouse-2 to activate or mouse-3 to pull up a menu of options.") - -(defvar vm-auto-decode-mime-messages nil - "*Non-nil value causes MIME decoding to occur automatically -when a message containing MIME objects is exposed. A nil value -means that you will have to run the `vm-decode-mime-message' -command (normally bound to `D') manually to decode and display -MIME objects.") - -(defvar vm-auto-displayed-mime-content-types '("text" "multipart") - "*List of MIME content types that should be displayed immediately -after decoding. Other types will be displayed as a button that -the user must activate to display the object. - -A value of t means that all types should be displayed immediately. -A nil value means never display MIME objects immediately; only use buttons. - -If the value is a list, it should be a list of strings, which -should all be types or type/subtype pairs. Example: - - (setq vm-auto-displayed-mime-content-types '(\"text\" \"image/jpeg\")) - -If a top-level type is listed without a subtype, all subtypes of -that type are assumed to be included. - -Note that some types are processed specially, and this variable does not -apply to them. - - multipart/digest messages are always displayed as a button to - avoid automatically visiting a new folder while you are moving - around in the current folder. - - message/partial messages are always displayed as a button, - because there always needs to be a way to trigger the assembly - of the parts into a full message. - -Any type that cannot be displayed internally or externally will -be displayed as a button that allows you to save the body to a -file.") - -(defvar vm-mime-internal-content-types t - "*List of MIME content types that should be displayed internally -if Emacs is capable of doing so. A value of t means that VM -should always display an object internally if possible. A nil -value means never display MIME objects internally, which means VM -have to run an external viewer to display MIME objects. - -If the value is a list, it should be a list of strings. Example: - - (setq vm-mime-internal-content-types '(\"text\" \"image/jpeg\")) - -If a top-level type is listed without a subtype, all subtypes of -that type are assumed to be included. - -Note that all multipart types are always handled internally. -There is no need to list them here.") - -(defvar vm-mime-external-content-types-alist nil - "*Alist of MIME content types and the external programs used to display them. -If VM cannot display a type internally or has been instructed not -to (see the documentation for the vm-mime-internal-content-types -variable) it will try to launch an external program to display that -type. - -The alist format is - - ( (TYPE PROGRAM ARG ARG ... ) ... ) - -TYPE is a string specifying a MIME type or type/subtype pair. -Example \"text\" or \"image/jpeg\". If a top-level type is -listed without a subtype, all subtypes of that type are assumed -to be included. - -PROGRAM is a string naming a program to run to display an object. -Any ARGS will be passed to the program as arguments. The octets -that compose the object will be written into a file and the name -of the file will be passed to the program as its last argument. - -Example: - - (setq vm-mime-external-content-types-alist - '( - (\"text/html\" \"netscape\") - (\"image/gif\" \"xv\") - (\"image/jpeg\" \"xv\") - (\"video/mpeg\" \"mpeg_play\") - (\"video\" \"xanim\") - ) - ) - -The first matching list element will be used. - -No multipart message will ever be sent to an external viewer.") - -(defvar vm-mime-type-converter-alist nil - "*Alist of MIME types and programs that can convert between them. -If VM cannot display a content type, it will scan this list to -see if the type can be converted into a type that it can display. - -The alist format is - - ( (START-TYPE END-TYPE COMMAND-LINE ) ... ) - -START-TYPE is a string specifying a MIME type or type/subtype pair. -Example \"text\" or \"image/jpeg\". If a top-level type is -listed without a subtype, all subtypes of that type are assumed -to be included. - -END-TYPE must be an exact type/subtype pair. This is the type -to which START-TYPE will be converted. - -COMMAND-LINE is a string giving a command line to be passed to -the shell. The octets that compose the object will be written to -the standard input of the shell command. - -Example: - - (setq vm-mime-type-converter-alist - '( - (\"image/jpeg\" \"image/gif\" \"jpeg2gif\") - (\"text/html\" \"text/plain\" \"striptags\") - ) - ) - -The first matching list element will be used.") - -(defvar vm-mime-alternative-select-method 'best-internal - "*Value tells how to choose which multipart/alternative part to display. -A MIME message of type multipart/alternative has multiple message -parts containing the same information, but each part may be -formatted differently. VM will display only one of the parts. -This variable tells VM how to choose which part to display. - -A value of 'best means choose the part that is the most faithful to -the sender's original content that can be displayed. - -A value of 'best-internal means choose the best part that can be -displayed internally, i.e. with the built-in capabilities of Emacs. -If none of the parts can be displayed internally, behavior reverts to -that of 'best.") - -(defvar vm-mime-default-face-charsets '("us-ascii" "iso-8859-1") - "*List of character sets that can use the `default' face. -For other characters sets VM will have to create a new face and assign -a font to it that can be used to display that character set.") - -(defvar vm-mime-charset-font-alist nil - "*Assoc list of character sets and fonts that can be used to display them. -The format of the list is: - - ( (CHARSET . FONT) ...) - -CHARSET is a string naming a MIME registered character set such -as \"iso-8859-5\". Character set names should be specified in -lower case. - -FONT is a string naming a font that can be used to display CHARSET. - -An example setup might be: - - (setq vm-mime-charset-font-alist - '( - (\"iso-8859-7\" . \"-*-*-medium-r-normal-*-16-160-72-72-c-80-iso8859-7\") - ) - ) - -This variable is only useful for character sets whose characters -can all be encoded in single 8-bit bytes. Also multiple fonts -can only be displayed if you're running under a window system -e.g. X windows. So this variable will have no effect if you're -running Emacs on a tty. - -Note that under FSF Emacs any fonts you use must be the same height -as your default font. XEmacs does not have this limitation.") - -(defvar vm-mime-button-face 'gui-button-face - "*Face used for text in buttons that trigger the display of MIME objects.") - -(defvar vm-mime-8bit-composition-charset "iso-8859-1" - "*Character set that VM should assume if it finds non-US-ASCII characters -in a composition buffer. Composition buffers are assumed to use -US-ASCII unless the buffer contains a byte with the high bit set. -This variable specifies what character set VM should assume if -such a character is found. - -This variable is unused in XEmacs/MULE. Since multiple character -sets can be displayed in a single buffer under MULE, VM will map -the file coding system of the buffer to a single MIME character -set that can display all the buffer's characters.") - -(defvar vm-mime-8bit-text-transfer-encoding 'quoted-printable - "*Symbol specifying what kind of transfer encoding to use on 8bit -text. Characters with the high bit set cannot safely pass -through all mail gateways and mail transport software. MIME has -two transfer encodings that convert 8-bit data to 7-bit for safe -transport. Quoted-printable leaves the text mostly readable even -if the recipient does not have a MIME-capable mail reader. BASE64 -is unreadable without a MIME-capable mail reader, unless your name -is U3BvY2s=. - -A value of 'quoted-printable, means to use quoted-printable encoding. -A value of 'base64 means to use BASE64 encoding. -A value of '8bit means to send the message as is. - -Note that this variable usually only applies to textual MIME -content types. Images, audio, video, etc. typically will have -some attribute that makes VM consider them to be \"binary\", -which moves them outside the scope of this variable. For -example, messages with line lengths of 1000 characters or more -are considered binary, as are messages that contain carriage -returns (ascii code 13) or NULs (ascii code 0).") - -(defvar vm-mime-composition-armor-from-lines nil - "*Non-nil value means \"From \" lines should be armored before sending. -A line beginning with \"From \" is considered a message separator -by many mail delivery agents. These agents will often insert a > -before the word \"From\" to prevent mail readers from being -confused. This is proper behavior, but it breaks digitally signed -messages, which require bit-perfect transport in order for the -message contents to be considered genuine. - -If vm-mime-composition-armor-from-lines is non-nil, a line -beginning with \"From \" will cause VM to encode the message -using either quoted-printable or BASE64 encoding so that the From -line can be protected.") - -(defvar vm-mime-attachment-auto-type-alist - '( - ("\\.jpe?g" . "image/jpeg") - ("\\.gif" . "image/gif") - ("\\.png" . "image/png") - ("\\.tiff?" . "image/tiff") - ("\\.html?" . "text/html") - ("\\.au" . "audio/basic") - ("\\.mpe?g" . "video/mpeg") - ("\\.ps" . "application/postscript") - ) - "*Alist used to guess a MIME content type based on a file name. -The list format is - - ((REGEXP . TYPE) ...) - -REGEXP is a string that specifies a regular expression. -TYPE is a string specifying a MIME content type. - -When a non-MIME file is attached to a MIME composition buffer, -this list will be scanned until a REGEXP matches the file's name. -The corresponding TYPE will be offered as a default when you are -prompted for the file's type.") - -(defvar vm-mime-max-message-size nil - "*Largest MIME message that VM should send without fragmentation. -The value should be a integer which specifies the size in bytes. -A message larger than this value will be split into multiple parts -for transmission using the MIME message/partial type.") - -(defvar vm-mime-attachment-save-directory nil - "*Non-nil value is a default directory for saving MIME attachments. -When VM prompts you for a target file name when saving a MIME body, -any relative pathnames will be relative to this directory.") - -(defvar vm-mime-avoid-folding-content-type t - "*Non-nil means don't send folded Content- headers in MIME messages. -`Folded' headers are headers broken into multiple lines as specified -in RFC822 for readability and to avoid excessive line lengths. At -least one major UNIX vendor ships a version of sendmail that believes -a folded Content-Type header is a syntax error, and returns any such -message to sender. A typical error message from such a sendmail -version is, - -553 header syntax error, line \" charset=us-ascii\" - -If you see one of these, setting vm-mime-avoid-folding-content-type -non-nil may let your mail get through.") - -(defvar vm-mime-base64-decoder-program nil - "*Non-nil value should be a string that names a MIME base64 decoder. -The program should expect to read base64 data on its standard -input and write the converted data to its standard output.") - -(defvar vm-mime-base64-decoder-switches nil - "*List of command line flags passed to the command named by -vm-mime-base64-decoder-program.") - -(defvar vm-mime-base64-encoder-program nil - "*Non-nil value should be a string that names a MIME base64 encoder. -The program should expect arbitrary data on its standard -input and write base64 data to its standard output.") - -(defvar vm-mime-base64-encoder-switches nil - "*List of command line flags passed to the command named by -vm-mime-base64-encoder-program.") - -(defvar vm-auto-next-message t - "*Non-nil value causes VM to use vm-next-message to advance to the next -message in the folder if the user attempts to scroll past the end of the -current messages. A nil value disables this behavior.") - -(defvar vm-honor-page-delimiters nil - "*Non-nil value causes VM to honor page delimiters (as specified by the -Emacs page-delimiter variable) when scrolling through a message.") - -(defvar vm-default-window-configuration - ;; startup = full screan summary - ;; quitting = full screen folder - ;; reading-message = folder on bottom, summary on top - ;; composing-message = full screen composition - ;; editing-message = full screen edit - ;; vm-summarize = folder on bottom, summary on top - '( - (startup - ((((top . 70) (left . 70))) - (((- (0 0 80 10) (0 10 80 40)) - ((nil summary) (nil message)) - ((nil nil nil t) (nil nil nil nil)))))) - (quitting - ((((top . 70) (left . 70))) - (((0 0 80 40) - ((nil message)) - ((nil nil nil t)))))) - (reading-message - ((((top . 70) (left . 70))) - (((- (0 0 80 10) (0 10 80 40)) - ((nil summary) (nil message)) - ((nil nil nil t) (nil nil nil nil)))))) - (composing-message - ((((top . 70) (left . 70))) - (((0 0 80 40) - ((nil composition)) - ((nil nil nil t)))))) - (editing-message - ((((top . 70) (left . 70))) - (((0 0 80 40) - ((nil edit)) - ((nil nil nil t)))))) - (vm-summarize - ((((top . 70) (left . 70))) - (((- (0 0 80 10) (0 10 80 40)) - ((nil summary) (nil message)) - ((nil nil nil t) (nil nil nil nil)))))) - ) - "Default window configuration for VM if the user does not specify one. -If you want to completely turn off VM's window configuration -feature, set this variable and vm-window-configuration-file to -nil in your .vm file. - -If you want to have a different window configuration setup than -this, you should not set this variable directly. Rather you -should set the variable vm-window-configuration-file to point at -a file, and use the command vm-save-window-configuration -(normally bound to `WS') to modify part of this configuration to -your liking. - -WARNING: Don't point vm-window-configuration-file at your .vm or -.emacs file. Your window configuration file should start out as -an empty or nonexistent file. VM will repeatedly overwrite this -file as you update your window configuration settings, so -anything else you put into this file will go away.") - -(defvar vm-window-configuration-file "~/.vm.windows" - "*Non-nil value should be a string that tells VM where to load -and save your window configuration settings. Your window -configuration settings are loaded automatically the first time -you run VM in an Emacs session, and tells VM how to set up -windows depending on what you are doing inside VM. - -The commands vm-save-window-configuration (normally bound to `WS') and -vm-delete-window-configuration (bound to `WD') let you update this -information; see their documentation for more information. - -You cannot change your window configuration setup without giving -vm-window-configuration-file a non-nil value. A nil value causes -VM to use the default window setup specified by the value of -vm-default-window-configuration. - -WARNING: Don't point vm-window-configuration-file at your .vm or -.emacs file. Your window configuration file should start out as -an empty or nonexistent file. VM will repeatedly overwrite this -file as you update your window configuration settings, so -anything else you put into this file will go away.") - -(defvar vm-confirm-quit 0 - "*Value of t causes VM to always ask for confirmation before quitting -a VM visit of a folder. A nil value means VM will ask only when messages -will be lost unwittingly by quitting, i.e. not removed by intentional -delete and expunge. A value that is not nil and not t causes VM to ask -only when there are unsaved changes to message attributes, or when messages -will be unwittingly lost.") - -(defvar vm-folder-directory nil - "*Directory where folders of mail are kept.") - -(defvar vm-confirm-new-folders nil - "*Non-nil value causes interactive calls to vm-save-message -to ask for confirmation before creating a new folder.") - -(defvar vm-delete-empty-folders t - "*Non-nil value means remove empty (zero length) folders after saving -A value of t means always remove the folders. -A value of nil means never remove empty folders. -A value that's not t or nil means ask before removing empty folders.") - -(defvar vm-flush-interval 90 - "*Non-nil value specifies how often VM flushes its cached internal -data. A numeric value gives the number of seconds between -flushes. A value of t means flush every time there is a change. -Nil means don't do flushing until a message or folder is saved. - -Normally when a message attribute is changed. VM keeps the record -of the change in its internal memory and doesn't insert the -changed data into the folder buffer until a particular message or -the whole folder is saved to disk. This makes normal Emacs -auto-saving useless for VM folder buffers because the information -you'd want to auto-save, i.e. the attribute changes are not in -the buffer when it is auto-saved. - -Setting vm-flush-interval to a numeric value will cause the VM's -internal memory caches to be periodically flushed to the folder -buffer. This is done non-obtrusively, so that if you type -something while flushing is occurring, the flush will abort -cleanly and Emacs will respond to your keystrokes as usual.") - -(defvar vm-visit-when-saving 0 - "*Value determines whether VM will visit folders when saving messages. -`Visiting' means that VM will read the folder into Emacs and append the -message to the buffer instead of appending to the folder file directly. -This behavior is ideal when folders are encrypted or compressed since -appending plaintext directly to such folders is a ghastly mistake. - -A value of t means VM will always visit folders when saving. - -A nil value means VM will never visit folders before saving to them, and -VM will generate an error if you attempt to save messages to a folder -that is being visited. The latter restriction is necessary to insure -that the buffer and disk copies of the folder being visited remain -consistent. - -A value that is not nil and not t means VM will save to a folder's -buffer if that folder is being visited, otherwise VM saves to the folder -file itself.") - -(defvar vm-auto-folder-alist nil - "*Non-nil value should be an alist that VM will use to choose a default -folder name when messages are saved. The alist should be of the form -\((HEADER-NAME-REGEXP - (REGEXP . FOLDER-NAME) ... - ...)) -where HEADER-NAME-REGEXP and REGEXP are strings, and FOLDER-NAME -is a string or an s-expression that evaluates to a string. - -If any part of the contents of the message header whose name is -matched by HEADER-NAME-REGEXP is matched by the regular -expression REGEXP, VM will evaluate the corresponding FOLDER-NAME -and use the result as the default when prompting for a folder to -save the message in. If the resulting folder name is a relative -pathname, then it will be rooted in the directory named by -vm-folder-directory, or the default-directory of the currently -visited folder if vm-folder-directory is nil. - -When FOLDER-NAME is evaluated, the current buffer will contain -only the contents of the header matched by HEADER-NAME-REGEXP. -It is safe to modify this buffer. You can use the match data -from any \\( ... \\) grouping constructs in REGEXP along with the -function buffer-substring to build a folder name based on the -header information. If the result of evaluating FOLDER-NAME is a -list, then the list will be treated as another auto-folder-alist -and will be descended recursively. - -Whether REGEXP is matched case sensitively depends on the value -of the variable vm-auto-folder-case-fold-search. Header names -are always matched case insensitively.") - -(defvar vm-auto-folder-case-fold-search nil - "*Non-nil value means VM will ignore case when matching header -contents while doing automatic folder selection via the variable -vm-auto-folder-alist.") - -(defvar vm-virtual-folder-alist nil - "*Non-nil value should be a list of virtual folder definitions. - -A virtual folder is a mapping of messages from one or more real folders -into what appears to be a single folder. A virtual folder definition -specifies which real folders should be searched for prospective messages -and what the inclusion criteria are. - -Each virtual folder definition should have the following form: - - (VIRTUAL-FOLDER-NAME - ( (FOLDER-NAME ...) - (SELECTOR [ARG ...]) ... ) - ... ) - -VIRTUAL-FOLDER-NAME is the name of the virtual folder being defined. -This is the name by which you and VM will refer to this folder. - -FOLDER-NAME should be the name of a real folder. There may be more than -one FOLDER-NAME listed, the SELECTORs within that sublist will apply to -them all. If FOLDER-NAME is a directory, VM will assume this to mean that -all the folders in that directory should be searched. - -The SELECTOR is a Lisp symbol that tells VM how to decide whether a message -from one of the folders specified by the FOLDER-NAMEs should be included -in the virtual folder. Some SELECTORs require an argument ARG; unless -otherwise noted ARG may be omitted. - -The recognized SELECTORs are: - - author - matches message if ARG matches the author; ARG should be a - regular expression. - and - matches the message if all its argument - selectors match the message. Example: - (and (author \"Derek McGinty\") (new)) - matches all new messages from Derek McGinty. - `and' takes any number of arguments. - any - matches any message. - deleted - matches message if it is flagged for deletion. - edited - matches message if it has been edited. - filed - matched message if it has been saved with its headers. - forwarded - matches message if it has been forwarded. - header - matches message if ARG matches any part of the header - portion of the message; ARG should be a - regular expression. - label - matches message if message has a label named ARG. - less-chars-than - matches message if message has less than ARG - characters. ARG should be a number. - less-lines-than - matches message if message has less than ARG - lines. ARG should be a number. - more-chars-than - matches message if message has more than ARG - characters. ARG should be a number. - more-lines-than - matches message if message has more than ARG - lines. ARG should be a number. - marked - matches message if it is marked, as with vm-mark-message. - new - matches message if it is new. - not - matches message only if its selector argument - does NOT match the message. Example: - (not (deleted)) - matches messages that are not deleted. - or - matches the message if any of its argument - selectors match the message. Example: - (or (author \"Dave Weckl\") (subject \"drum\")) - matches messages from Dave Weckl or messages - with the word \"drum\" in their Subject header. - `or' takes any number of arguments. - read - matches message if it is neither new nor unread. - recipient - matches message if ARG matches any part of the recipient - list of the message. ARG should be a regular expression. - replied - matches message if it has been replied to. - sent-after - matches message if it was sent after the date ARG. - A fully specified date looks like this: - \"31 Dec 1999 23:59:59 GMT\" - although the parts can appear in any order. - You can leave out any part and it will - default to the current date's value for that - part, with the exception of the hh:mm:ss - part which defaults to midnight. - sent-before - matches message if it was sent before the date ARG. - A fully specified date looks like this: - \"31 Dec 1999 23:59:59 GMT\" - although the parts can appear in any order. - You can leave out any part and it will - default to the current date's value for that - part, with the exception of the hh:mm:ss - part which defaults to midnight. - subject - matches message if ARG matches any part of the message's - subject; ARG should be a regular expression. - text - matches message if ARG matches any part of the text - portion of the message; ARG should be a - regular expression. - unread - matches message if it is old but unread. - written - matches message if it has been saved without its headers. -") - -(defvar vm-virtual-mirror t - "*Non-nil value causes the attributes of messages in virtual folders -to mirror the changes in the attributes of the underlying real messages. -Similarly, changes in the attributes of virtual messages will change the -attributes of the underlying real messages. A nil value causes virtual -messages to have their own distinct set of attributes, apart from the -underlying real message. - -This variable automatically becomes buffer-local when set in any -fashion. You should set this variable only in your .vm or .emacs -file. Use setq-default. Once VM has been started, you should not -set this variable directly, rather you should use the command -vm-toggle-virtual-mirror, normally bound to `V M'.") -(make-variable-buffer-local 'vm-virtual-mirror) - -(defvar vm-folder-read-only nil - "*Non-nil value causes a folder to be considered unmodifiable by VM. -Commands that modify message attributes or messages themselves are disallowed. -Commands that add or delete messages from the folder are disallowed. -Commands that scan or allow the reading of messages are allowed but the -`new' and `unread' message flags are not changed by them. - -This variable automatically becomes buffer-local when set in any -fashion. You should set this variable only in your .vm or .emacs -file. Use setq-default. Once VM has been started, you should not -set this variable directly, rather you should use the command -vm-toggle-read-only, normally bound to C-x C-q.") -(make-variable-buffer-local 'vm-folder-read-only) - -(defvar vm-included-text-prefix " > " - "*String used to prefix included text in replies.") - -(defvar vm-keep-sent-messages 1 - "*Non-nil value N causes VM to keep the last N messages sent from within VM. -`Keep' means that VM will not kill the VM mail buffer after you send a message -with C-c C-c (vm-mail-send-and-exit). A value of 0 or nil causes VM never -to keep such buffers. A value of t causes VM never to kill such buffers. - -Note that these buffers will vanish once you exit Emacs. To keep a permanent -record of your outgoing mail, use the mail-archive-file-name variable.") - -(defvar vm-confirm-mail-send nil - "*Non-nil means ask before sending a mail message. -This affects vm-mail-send and vm-mail-send-and-exit in Mail mode.") - -(defvar vm-mail-header-from nil - "*Non-nil value should be a string that will be appear as the body -of the From header in outbound mail messages. A nil value means don't -insert a From header. This variable also controls the inclusion and -format of the Resent-From header, when resending a message with -vm-resend-message.") - -(defvar vm-reply-subject-prefix nil - "*Non-nil value should be a string that VM should add to the beginning -of the Subject header in replies, if the string is not already present. -Nil means don't prefix the Subject header.") - -(defvar vm-reply-ignored-addresses nil - "*Non-nil value should be a list of regular expressions that match -addresses that VM should automatically remove from the recipient -headers of replies. These addresses are removed from the headers -before you are placed in the message composition buffer. So if -you see an address in the header you don't want you should remove -it yourself. - -Case is ignored when matching the addresses.") - -(defvar vm-reply-ignored-reply-tos nil - "*Non-nil value should be a list of regular expressions that match -addresses that, if VM finds in a message's Reply-To header, VM -should ignore the Reply-To header and not use it for replies. VM -will use the From header instead. - -Case is ignored when matching the addresses. - -This variable exists solely to provide a escape chute from -mailing lists that add a Reply-To: mailing list header, thereby -leaving no way to reply to just the author of a message.") - -(defvar vm-in-reply-to-format "%i" - "*String which specifies the format of the contents of the In-Reply-To -header that is generated for replies. See the documentation for the -variable vm-summary-format for information on what this string may -contain. The format should *not* end with a newline. -Nil means don't put an In-Reply-To header in replies.") - -(defvar vm-included-text-attribution-format "%F writes:\n" - "*String which specifies the format of the attribution that precedes the -included text from a message in a reply. See the documentation for the -variable vm-summary-format for information on what this string may contain. -Nil means don't attribute included text in replies.") - -(defvar vm-included-text-headers nil - "*List of headers that should be retained in a message included in -a reply. These should be listed in the order you wish them to -appear in the included text. Regular expressions are allowed. -There's no need to anchor patterns with \"^\", as searches always -start at the beginning of a line. Put a colon at the end of -patterns to get exact matches. (E.g. \"Date\" matches \"Date\" -and \"Date-Sent\".) Header names are always matched case -insensitively. - -If the value of vm-included-text-discard-header-regexp is nil, -the headers matched by vm-included-text-headers are the only -headers that will be retained. - -If vm-included-text-discard-header-regexp is non-nil, then only -headers matched by that variable will be omitted; all others will -be included. vm-included-text-headers determines the header -order in that case, with headers not matching any in the -vm-included-text-headers list appearing last in the header -section of the included text.") - -(defvar vm-included-text-discard-header-regexp nil - "*Non-nil value should be a regular expression header that tells -what headers should not be retained in a message included in a -reply. This variable along with vm-included-text-headers determines -which headers are retained. - -If the value of vm-included-text-discard-header-regexp is nil, -the headers matched by vm-included-text-headers are the only headers -that will be retained. - -If vm-included-text-discard-header-regexp is non-nil, then only -headers matched by this variable will not be retained; all -others will be included. vm-included-text-headers determines the -header order in that case, with headers not matching any in -the vm-included-text-headers list appearing last in the header -section of the included text.") - -(defvar vm-forwarding-subject-format "forwarded message from %F" - "*String which specifies the format of the contents of the Subject -header that is generated for a forwarded message. See the documentation -for the variable vm-summary-format for information on what this string -may contain. The format should *not* end with nor contain a newline. -Nil means leave the Subject header empty when forwarding.") - -(defvar vm-forwarded-headers nil - "*List of headers that should be forwarded by vm-forward-message. -These should be listed in the order you wish them to appear in -the forwarded message. Regular expressions are allowed. -There's no need to anchor patterns with \"^\", as searches always -start at the beginning of a line. Put a colon at the end of -patterns to get exact matches. (E.g. \"Date\" matches \"Date\" -and \"Date-Sent\".) Header names are always matched case -insensitively. - -If the value of vm-unforwarded-header-regexp is nil, the headers -matched by vm-forwarded-headers are the only headers that will be -forwarded. - -If vm-unforwarded-header-regexp is non-nil, then only headers -matched by that variable will be omitted; all others will be -forwarded. vm-forwarded-headers determines the forwarding order -in that case, with headers not matching any in the -vm-forwarded-headers list appearing last in the header section of -the forwarded message.") - -(defvar vm-unforwarded-header-regexp "only-drop-this-header" - "*Non-nil value should be a regular expression header that tells -what headers should not be forwarded by vm-forward-message. This -variable along with vm-forwarded-headers determines which headers -are forwarded. - -If the value of vm-unforwarded-header-regexp is nil, the headers -matched by vm-forwarded-headers are the only headers that will be -forwarded. - -If vm-unforwarded-header-regexp is non-nil, then only headers -matched by this variable will not be forwarded; all others will -be forwarded. vm-forwarded-headers determines the forwarding -order in that case, with headers not matching any in the -vm-forwarded-headers list appearing last in the header section of -the forwarded message.") - -(defvar vm-forwarding-digest-type "mime" - "*Non-nil value should be a string that specifies the type of -message encapsulation format to use when forwarding a message. -Legal values of this variable are: - -\"rfc934\" -\"rfc1153\" -\"mime\" -nil - -A nil value means don't use a digest, just mark the beginning and -end of the forwarded message.") - -(defvar vm-burst-digest-messages-inherit-labels t - "*Non-nil values means messages from a digest inherit the digest's labels. -Labels are added to messages with vm-add-message-labels, normally -bound to `l a'.") - -(defvar vm-digest-preamble-format "\"%s\" (%F)" - "*String which specifies the format of the preamble lines generated by -vm-send-digest when it is invoked with a prefix argument. One -line will be generated for each message put into the digest. See the -documentation for the variable vm-summary-format for information -on what this string may contain. The format should *not* end -with nor contain a newline.") - -(defvar vm-digest-center-preamble t - "*Non-nil value means VM will center the preamble lines that precede -the start of a digest. How the lines will be centered depends on the -ambient value of fill-column. A nil value suppresses centering.") - -(defvar vm-digest-identifier-header-format "X-Digest: %s\n" - "*Header to insert into messages burst from a digest. -Value should be a format string of the same type as vm-summary-format -that describes a header to be inserted into each message burst from a -digest. The format string must end with a newline.") - -(defvar vm-digest-burst-type "guess" - "*Value specifies the default digest type offered by vm-burst-digest -when it asks you what type of digest you want to unpack. Allowed -values of this variable are: - - \"rfc934\" - \"rfc1153\" - \"mime\" - \"guess\" - -rfc1153 digests have a preamble, followed by a line of exactly 70 -dashes, with digested messages separated by lines of exactly 30 dashes. - -rfc934 digests separate messages on any line that begins with a few -dashes, but doesn't require lines with only dashes or lines with a -specific number of dashes. In the text of the message, any line -beginning with dashes is textually modified to be preceded by a dash -and a space to prevent confusion with message separators. - -MIME digests use whatever boundary that is specified by the -boundary parameter in the Content-Type header of the digest. - -If the value is \"guess\", and you take the default -response when vm-burst-digest queries you, VM will try to guess -the digest type.") - -(defvar vm-digest-send-type "mime" - "*String that specifies the type of digest vm-send-digest will use. -Legal values of this variable are: - -\"rfc934\" -\"rfc1153\" -\"mime\" - -") - -(defvar vm-rfc934-digest-headers - '("Resent-" - "From:" "Sender:" - "To:" "Cc:" - "Subject:" - "Date:" - "Message-ID:" - "Keywords:") - "*List of headers that should be appear in RFC 934 digests -created by VM. These should be listed in the order you wish them -to appear in the digest. Regular expressions are allowed. -There's no need to anchor patterns with \"^\", as searches always -start at the beginning of a line. Put a colon at the end of -patterns to get exact matches. (E.g. \"Date\" matches \"Date\" -and \"Date-Sent\".) Header names are always matched case -insensitively. - -If the value of vm-rfc934-digest-discard-header-regexp is nil, the headers -matched by vm-rfc934-digest-headers are the only headers that will be -kept. - -If vm-rfc934-digest-discard-header-regexp is non-nil, then only -headers matched by that variable will be discarded; all others -will be kept. vm-rfc934-digest-headers determines the order of -appearance in that case, with headers not matching any in the -vm-rfc934-digest-headers list appearing last in the headers -of the digestified messages.") - -(defvar vm-rfc934-digest-discard-header-regexp nil - "*Non-nil value should be a regular expression header that tells -what headers should not appear in RFC 934 digests created by VM. This -variable along with vm-rfc934-digest-headers determines which headers -are kept and which are discarded. - -If the value of vm-rfc934-digest-discard-header-regexp is nil, the headers -matched by vm-rfc934-digest-headers are the only headers that will be -kept. - -If vm-rfc934-digest-discard-header-regexp is non-nil, then only -headers matched by this variable will be discarded; all others -will be kept. vm-rfc934-digest-headers determines the order of -appearance in that case, with headers not matching any in the -vm-rfc934-digest-headers list appearing last in the headers -of the digestified messages.") - -(defvar vm-rfc1153-digest-headers - '("Resent-" - "Date:" - "From:" "Sender:" - "To:" "Cc:" - "Subject:" - "Message-ID:" - "Keywords:") - "*List of headers that should be appear in RFC 1153 digests -created by VM. These should be listed in the order you wish them -to appear in the digest. Regular expressions are allowed. -There is no need to anchor patterns with \"^\", as searches always -start at the beginning of a line. Put a colon at the end of -patterns to get exact matches. (E.g. \"Date\" matches \"Date\" -and \"Date-Sent\".) Header names are always matched case -insensitively. - -If the value of vm-rfc1153-digest-discard-header-regexp is nil, the headers -matched by vm-rfc1153-digest-headers are the only headers that will be -kept. - -If vm-rfc1153-digest-discard-header-regexp is non-nil, then only -headers matched by that variable will be discarded; all others -will be kept. vm-rfc1153-digest-headers determines the order of -appearance in that case, with headers not matching any in the -vm-rfc1153-digest-headers list appearing last in the headers of -the digestified messages.") - -(defvar vm-rfc1153-digest-discard-header-regexp "\\(X400-\\)?Received:" - "*Non-nil value should be a regular expression header that tells -what headers should not appear in RFC 1153 digests created by VM. This -variable along with vm-rfc1153-digest-headers determines which headers -are kept and which headers are discarded. - -If the value of vm-rfc1153-digest-discard-header-regexp is nil, the headers -matched by vm-rfc1153-digest-headers are the only headers that will be -kept. - -If vm-rfc1153-digest-discard-header-regexp is non-nil, then only -headers matched by this variable will be discarded; all others -will be kept. vm-rfc1153-digest-headers determines the order of -appearance in that case, with headers not matching any in the -vm-rfc1153-digest-headers list appearing last in the headers of -the digestified messages.") - -(defvar vm-mime-digest-headers - '("Resent-" - "From:" "Sender:" - "To:" "Cc:" - "Subject:" - "Date:" - "Message-ID:" - "Keywords:" - "MIME-Version:" - "Content-") - "*List of headers that should be appear in MIME digests -created by VM. These should be listed in the order you wish them -to appear in the messages in the digest. Regular expressions are -allowed. There's no need to anchor patterns with \"^\", as -searches always start at the beginning of a line. Put a colon at -the end of patterns to get exact matches. (E.g. \"Date\" matches -\"Date\" and \"Date-Sent\".) Header names are always matched -case insensitively. - -If the value of vm-mime-digest-discard-header-regexp is nil, the headers -matched by vm-mime-digest-headers are the only headers that will be -kept. - -If vm-mime-digest-discard-header-regexp is non-nil, then only -headers matched by that variable will be discarded; all others -will be kept. vm-mime-digest-headers determines the order of -appearance in that case, with headers not matching any in the -vm-mime-digest-headers list appearing last in the headers -of the digestified messages.") - -(defvar vm-mime-digest-discard-header-regexp nil - "*Non-nil value should be a regular expression header that tells -which headers should not appear in MIME digests created -by VM. This variable along with vm-mime-digest-headers -determines which headers are kept and which are discarded. - -If the value of vm-mime-digest-discard-header-regexp is nil, the headers -matched by vm-mime-digest-headers are the only headers that will be -kept. - -If vm-mime-digest-discard-header-regexp is non-nil, then only -headers matched by this variable will be discarded; all others -will be kept. vm-mime-digest-headers determines the order of -appearance in that case, with headers not matching any in the -vm-mime-digest-headers list appearing last in the headers -of the digestified messages.") - -(defvar vm-resend-bounced-headers - '("MIME-Version:" "Content-" - "From:" "Sender:" "Reply-To:" - "To:" "Cc:" - "Subject:" - "Newsgroups:" - "In-Reply-To:" "References:" - "Keywords:" - "X-") - "*List of headers that should be appear in messages resent with -vm-resend-bounced-message. These should be listed in the order you wish them -to appear in the message. Regular expressions are allowed. -There is no need to anchor patterns with \"^\", as searches always -start at the beginning of a line. Put a colon at the end of -patterns to get exact matches. (E.g. \"Date\" matches \"Date\" -and \"Date-Sent\".) Header names are always matched case -insensitively. - -If the value of vm-resend-bounced-discard-header-regexp is nil, the headers -matched by vm-resend-bounced-headers are the only headers that will be -kept. - -If vm-resend-bounced-discard-header-regexp is non-nil, then only -headers matched by that variable will be discarded; all others -will be kept. vm-resend-bounced-headers determines the order of -appearance in that case, with headers not matching any in the -vm-resend-bounced-headers list appearing last in the headers of -the message.") - -(defvar vm-resend-bounced-discard-header-regexp nil - "*Non-nil value should be a regular expression that tells -what headers should not appear in a resent bounced message. This -variable along with vm-resend-bounced-headers determines which headers -are kept and which headers are discarded. - -If the value of vm-resend-bounced-discard-header-regexp is nil, -the headers matched by vm-resend-bounced-headers are the only -headers that will be kept. - -If vm-resend-bounced-discard-header-regexp is non-nil, then only -headers matched by this variable will be discarded; all others -will be kept. vm-resend-bounced-headers determines the order of -appearance in that case, with headers not matching any in the -vm-resend-bounced-headers list appearing last in the headers of -the message.") - -(defvar vm-resend-headers nil - "*List of headers that should be appear in messages resent with -vm-resend-message. These should be listed in the order you wish them -to appear in the message. Regular expressions are allowed. -There is no need to anchor patterns with \"^\", as searches always -start at the beginning of a line. Put a colon at the end of -patterns to get exact matches. (E.g. \"Date\" matches \"Date\" -and \"Date-Sent\".) Header names are always matched case -insensitively. - -If the value of vm-resend-discard-header-regexp is nil, the headers -matched by vm-resend-headers are the only headers that will be -kept. - -If vm-resend-discard-header-regexp is non-nil, then only -headers matched by that variable will be discarded; all others -will be kept. vm-resend-headers determines the order of -appearance in that case, with headers not matching any in the -vm-resend-headers list appearing last in the headers of -the message.") - -(defvar vm-resend-discard-header-regexp "\\(\\(X400-\\)?Received:\\|Resent-\\)" - "*Non-nil value should be a regular expression that tells -what headers should not appear in a resent message. This -variable along with vm-resend-headers determines which -headers are kept and which headers are discarded. - -If the value of vm-resend-discard-header-regexp is nil, -the headers matched by vm-resend-headers are the only -headers that will be kept. - -If vm-resend-discard-header-regexp is non-nil, then only -headers matched by this variable will be discarded; all others -will be kept. vm-resend-headers determines the order of -appearance in that case, with headers not matching any in the -vm-resend-headers list appearing last in the headers of -the message.") - -(defvar vm-summary-format "%n %*%a %-17.17F %-3.3m %2d %4l/%-5c %I\"%s\"\n" - "*String which specifies the message summary line format. -The string may contain the printf-like `%' conversion specifiers which -substitute information about the message into the final summary line. - -Recognized specifiers are: - a - attribute indicators (always four characters wide) - The first char is `D', `N', `U' or ` ' for deleted, new, unread - and read messages respectively. - The second char is `F', `W' or ` ' for filed (saved) or written - messages. - The third char is `R', `Z' or ` ' for messages replied to, - and forwarded messages. - The fourth char is `E' if the message has been edited, ` ' otherwise. - A - longer version of attributes indicators (seven characters wide) - The first char is `D', `N', `U' or ` ' for deleted, new, unread - and read messages respectively. - The second is `r' or ` ', for message replied to. - The third is `z' or ` ', for messages forwarded. - The fourth is `b' or ` ', for messages redistributed. - The fifth is `f' or ` ', for messages filed. - The sixth is `w' or ` ', for messages written. - The seventh is `e' or ` ', for messages that have been edited. - c - number of characters in message (ignoring headers) - d - numeric day of month message sent - f - author's address - F - author's full name (same as f if full name not found) - h - hour:min:sec message sent - H - hour:min message sent - i - message ID - I - thread indentation - l - number of lines in message (ignoring headers) - L - labels (as a comma list) - m - month message sent - M - numeric month message sent (January = 1) - n - message number - s - message subject - t - addresses of the recipients of the message, in a comma-separated list - T - full names of the recipients of the message, in a comma-separated list - If a full name cannot be found, the corresponding address is used - instead. - U - user defined specifier. The next character in the format - string should be a letter. VM will call the function - vm-summary-function-<letter> (e.g. vm-summary-function-A for - \"%UA\") in the folder buffer with the message being summarized - bracketed by (point-min) and (point-max). The function - will be passed a message struct as an argument. - The function should return a string, which VM will insert into - the summary as it would for information from any other summary - specifier. - w - day of the week message sent - y - year message sent - z - timezone of date when the message was sent - * - `*' if the message is marked, ` ' otherwise - -Use %% to get a single %. - -A numeric field width may be given between the `%' and the specifier; -this causes right justification of the substituted string. A negative field -width causes left justification. - -The field width may be followed by a `.' and a number specifying -the maximum allowed length of the substituted string. If the -string is longer than this value the right end of the string is -truncated. If the value is negative, the string is truncated on -the left instead of the right. - -The summary format need not be one line per message but it must end with -a newline, otherwise the message pointer will not be displayed correctly -in the summary window.") - -(defvar vm-summary-arrow "->" - "*String that is displayed to the left of the summary of the -message VM consider to be the current message. The value takes -effect when the summary buffer is created. Changing this -variable's value has no effect on existing summary buffers.") - -(defvar vm-summary-highlight-face 'bold - "*Face to use to highlight the summary entry for the current message. -Nil means don't highlight the current message's summary entry.") - -(defvar vm-mouse-track-summary t - "*Non-nil value means highlight summary lines as the mouse passes -over them.") - -(defvar vm-summary-show-threads nil - "*Non-nil value means VM should display and maintain -message thread trees in the summary buffer. This means that -messages with a common ancestor will be displayed contiguously in -the summary. (If you have vm-move-messages-physically set -non-nil the folder itself will be reordered to match the thread -ordering.) If you use the `%I' summary format specifier in your -vm-summary-format, indentation will be provided as described in the -documentation for vm-summary-thread-indent-level (which see). - -A nil value means don't display thread information. The `%I' -specifier does nothing in the summary format. - -This variable automatically becomes buffer-local when set in any -fashion. You should set this variable only in your .vm or .emacs -file. Use setq-default. Once VM has been started, you should not -set this variable directly, rather you should use the command -vm-toggle-threads-display, normally bound to C-t.") -(make-variable-buffer-local 'vm-summary-show-threads) - -(defvar vm-summary-thread-indent-level 2 - "*Value should be a number that specifies how much -indentation the '%I' summary format specifier should provide per -thread level. A message's `thread level' refers to the number of -direct ancestors from the message to the oldest ancestor the -message has that is in the current folder. For example, the -first message of a thread is generally a message about a new -topic, e.g. a message that is not a reply to some other message. -Therefore it has no ancestor and would cause %I to generate no -indentation. A reply to this message will be indented by the value -of vm-summary-thread-indent-level. A reply to that reply will be -indented twice the value of vm-summary-thread-indent-level.") - -(defvar vm-thread-using-subject t - "*Non-nil value causes VM to use the Subject header to thread messages. -Messages with the same subject will be grouped together. - -A nil value means VM will disregard the Subject header when -threading messages.") - -(defvar vm-summary-uninteresting-senders nil - "*Non-nil value should be a regular expression that matches -addresses that you don't consider interesting enough to -appear in the summary. When such senders would be displayed by -the %F or %f summary format specifiers VM will substitute the -value of vm-summary-uninteresting-senders-arrow (default \"To: -\") followed by what would be shown by the %T and %t specifiers -respectively.") - -(defvar vm-summary-uninteresting-senders-arrow "To: " - "*String to display before the string that is displayed instead of an -\"uninteresting\" sender. See vm-summary-uninteresting-senders.") - -(defvar vm-auto-center-summary nil - "*Value controls whether VM will keep the summary arrow vertically -centered within the summary window. A value of t causes VM to always -keep arrow centered. A value of nil means VM will never bother centering -the arrow. A value that is not nil and not t causes VM to center the -arrow only if the summary window is not the only existing window.") - -(defvar vm-subject-ignored-prefix "^\\(re: *\\)+" - "*Non-nil value should be a regular expression that matches -strings at the beginning of the Subject header that you want VM to ignore -when threading, sorting, marking, and killing messages by subject. - -Matches are done case-insensitively.") - -(defvar vm-subject-ignored-suffix "\\( (fwd)\\| \\)+$" - "*Non-nil value should be a regular expression that matches -strings at the end of the Subject header that you want VM to ignore -when threading, sorting, marking and killing messages by subject. - -Matches are done case-insensitively.") - -(defvar vm-mutable-windows pop-up-windows - "*This variable's value controls VM's window usage. - -A non-nil value gives VM free run of the Emacs display; it will commandeer -the entire screen for its purposes. - -A value of nil restricts VM's window usage to the window from which -it was invoked. VM will not create, delete, or use any other windows, -nor will it resize its own window.") - -(defvar vm-mutable-frames t - "*Non-nil value means VM is allowed to create and destroy frames -to display and undisplay buffers. Whether VM actually does -so depends on the value of the variables with names prefixed by -`vm-frame-per-'. - -VM can create a frame to display a buffer, and delete frame to -undisplay a buffer. A nil value means VM should not create or -delete frames. - -This variable used to have a different meaning but it was changed -to better reflect what users expected. This variable is now a -frame analogue of vm-mutable-windows. - -This variable does not apply to the VM commands whose -names end in -other-frame, which always create a new frame.") - -(defvar vm-raise-frame-at-startup t - "*Specifies whether VM should raise its frame at startup. -A value of nil means never raise the frame. -A value of t means always raise the frame. -Other values are reserved for future use.") - -(defvar vm-frame-per-folder t - "*Non-nil value causes the folder visiting commands to visit in a new frame. -Nil means the commands will use the current frame. This variable -does not apply to the VM commands whose names end in --other-frame, which always create a new frame. - -This variable has no meaning if you're not running under an Emacs -capable of displaying multiple real or virtual frames. Note that -Emacs supports multiple virtual frames on dumb terminals, and -VM will use them.") - -(defvar vm-frame-per-summary nil - "*Non-nil value causes VM to display the folder summary in its own frame. -Nil means the vm-summarize command will use the current frame. -This variable does not apply to vm-summarize-other-frame, which -always create a new frame. - -This variable has no meaning if you're not running under an Emacs -capable of displaying multiple real or virtual frames. Note that -Emacs supports multiple virtual frames on dumb terminals, and -VM will use them.") - -(defvar vm-frame-per-composition t - "*Non-nil value causes the mail composition commands to open a new frame. -Nil means the commands will use the current frame. This variable -does not apply to the VM commands whose names end in --other-frame, which always create a new frame. - -This variable has no meaning if you're not running under an Emacs -capable of displaying multiple real or virtual frames. Note that -Emacs supports multiple virtual frames on dumb terminals, and -VM will use them.") - -(defvar vm-frame-per-edit t - "*Non-nil value causes vm-edit-message to open a new frame. -Nil means the vm-edit-message will use the current frame. This -variable does not apply to vm-edit-message-other-frame, which -always create a new frame. - -This variable has no meaning if you're not running under an Emacs -capable of displaying multiple real or virtual frames. Note that -Emacs support multiple virtual frames on dumb terminals, and -VM will use them.") - -(defvar vm-frame-per-help nil - "*Non-nil value causes VM to open a new frame to display help buffers. -Nil means the VM will use the current frame. - -This variable has no meaning if you're not running under an Emacs -capable of displaying multiple real or virtual frames. Note that -Emacs supports multiple virtual frames on dumb terminals, and -VM will use them.") - -(defvar vm-frame-per-completion t - "*Non-nil value causes VM to open a new frame on mouse -initiated completing reads. A mouse initiated completing read -occurs when you invoke a VM command using the mouse, either with a -menu or a toolbar button. That command must then prompt you for -information, and there must be a limited set of proper responses. - -If these conditions are met and vm-frame-per-completion's value -is non-nil, VM will create a new frame containing a list of -responses that you can select with the mouse. - -A nil value means the current frame will be used to display the -list of choices. - -This variable has no meaning if you're not running Emacs native -under X Windows or some other window system that allows multiple -real Emacs frames. Note that Emacs supports virtual frames under -ttys but VM will not use these to display completion information.") - -(defvar vm-frame-parameter-alist nil - "*Non-nil value is an alist of types and lists of frame parameters. -This list tells VM what frame parameters to associate with each -new frame it creates of a specific type. - -The alist should be of this form - - ((SYMBOL PARAMLIST) (SYMBOL2 PARAMLIST2) ...) - -SYMBOL must be one of `completion', `composition', `edit', -`folder', `primary-folder' or `summary'. It specifies the type -of frame that the following PARAMLIST applies to. - -`completion' specifies parameters for frames that display list of - choices generated by a mouse-initiated completing read. - (See vm-frame-per-completion.) -`composition' specifies parameters for mail composition frames. -`edit' specifies parameters for message edit frames - (e.g. created by vm-edit-message-other-frame) -`folder' specifies parameters for frames created by `vm' and the - `vm-visit-' commands. -`primary-folder' specifies parameters for the frame created by running - `vm' without any arguments. -`summary' specifies parameters for frames that display a summary buffer - (e.g. created by vm-summarize-other-frame) - -PARAMLIST is a list of pairs as described in the documentation for -the function `make-frame'.") - -(defvar vm-search-other-frames t - "*Non-nil means VM should search frames other than the selected frame -when looking for a window that is already displaying a buffer that -VM wants to display or undisplay.") - -(defvar vm-image-directory - (expand-file-name (concat data-directory "vm/")) - "*Value specifies the directory VM should find its artwork.") - -(defvar vm-use-toolbar - '(next previous delete/undelete autofile file - reply compose print visit quit nil help) - "*Non-nil value causes VM to provide a toolbar interface. -Value should be a list of symbols that will determine which -toolbar buttons will appear and in what order. Valid symbol -value within the list are: - - autofile - compose - delete/undelete - file - getmail - help - mime - next - previous - print - quit - reply - visit - nil - -If nil appears in the list, it should appear exactly once. All -buttons after nil in the list will be displayed flushright in -top/bottom toolbars and flushbottom in left/right toolbars. - -This variable only has meaning under XEmacs 19.12 and beyond. -See also vm-toolbar-orientation to control where the toolbar is placed.") - -(defvar vm-toolbar-orientation 'left - "*Value is a symbol that specifies where the VM toolbar is located. -Legal values are `left', `right' `top' and `bottom'. Any other -value will be interpreted as `top'. - -This variable only has meaning under XEmacs 19.12 and beyond.") - -(defvar vm-toolbar-pixmap-directory vm-image-directory - "*Value specifies the directory VM should find its toolbar pixmaps.") - -(defvar vm-toolbar nil - "*Non-nil value should be a list of toolbar button descriptors. -See the documentation for the variable default-toolbar for a -definition of what a toolbar button descriptor is. - -If vm-toolbar is set non-nil VM will use its value as a toolbar -instantiator instead of the usual beavior of building a button -list based on the value of vm-use-toolbar. vm-use-toolbar still -must be set non-nil for a toolbar to appear, however. - -Consider this variable experimental; it may not be supported forever.") - -(defvar vm-use-menus - (nconc (list 'folder 'motion 'send 'mark 'label 'sort 'virtual) - (cond ((string-match ".*-.*-\\(win95\\|nt\\)" system-configuration) - nil) - (t (list 'undo))) - (list 'dispose) - (cond ((string-match ".*-.*-\\(win95\\|nt\\)" system-configuration) - nil) - (t (list 'emacs))) - (list nil 'help)) - "*Non-nil value causes VM to provide a menu interface. -A value that is a list causes VM to install its own menubar. -A value of 1 causes VM to install a \"VM\" item in the Emacs menubar. - -If the value of vm-use-menus is a list, it should be a list of -symbols. The symbols and the order that they are listed -determine what menus will be in the menubar and how they are -ordered. Valid symbols values are: - -dispose -emacs -folder -help -label -mark -motion -send -sort -undo -virtual -nil - -If nil appears in the list, it should appear exactly once. All -menus after nil in the list will be displayed flushright in -menubar. - -This variable only has meaning in Emacs environments where menus -are provided, which usually means Emacs has to be running under a -window system.") - -(defvar vm-popup-menu-on-mouse-3 t - "*Non-nil value means VM should provide context-sensitive menus on mouse-3. -A nil value means VM should not change the binding of mouse-3.") - -(defvar vm-warp-mouse-to-new-frame nil - "*Non-nil value causes VM to move the mouse cursor into newly created frames. -This is useful to give the new frame the focus under some window managers -that randomly place newly created frames. - -Nil means don't move the mouse cursor.") - -(defvar vm-url-browser - (cond ((fboundp 'w3-fetch-other-frame) - 'w3-fetch-other-frame) - ((fboundp 'w3-fetch) - 'w3-fetch) - (t 'vm-mouse-send-url-to-netscape)) - "*Non-nil value means VM should enable URL passing. -This means that VM will search for URLs (Uniform Resource -Locators) in messages and make it possible for you to pass them -to a World Wide Web browser. - -Clicking mouse-2 on the URL will send it to the browser. - -By default clicking mouse-3 on the URL will pop up a menu of -browsers and you can pick which one you want to use. If -vm-popup-menu-on-mouse-3 is set to nil, you will not see the menu. - -Moving point to a character within the URL and pressing RETURN -will send the URL to the browser. - -If the value of vm-url-browser is a string, it should specify -name of an external browser to run. The URL will be passed to -the program as its first argument. - -If the value of vm-url-browser is a symbol, it should specify a -Lisp function to call. The URL will be passed to the program as -its first and only argument. Use - - (setq vm-url-browser 'vm-mouse-send-url-to-netscape) - -for Netscape, and - - (setq vm-url-browser 'vm-mouse-send-url-to-mosaic) - -for Mosaic. The advantage of using them is that they will display -an URL using on existing Mosaic or Netscape process, if possible. - -A nil value means VM should not enable URL passing to browsers.") - -(defvar vm-highlight-url-face 'bold-italic - "*Non-nil value should be a face to use display URLs found in messages. -Nil means don't highlight URLs.") - -(defvar vm-url-search-limit 12000 - "*Non-nil numeric value tells VM how hard to search for URLs. -The number specifies the maximum message size in characters that -VM will search for URLs. For message larger than this value, VM -will search from the beginning of the mssage to a point -vm-url-search-limit / 2 characters into the message. Then VM will -search from a point vm-url-search-limit / 2 characters from the -end of the message to the end of message.") - -(defvar vm-display-xfaces nil - "*Non-nil means display images as specifies in X-Face headers. -This requires at least XEmacs 19.12 with native xface support compiled in.") - -(defvar vm-startup-with-summary t - "*Value tells VM whether to generate a summary when a folder is visited. -Nil means don't automatically generate a summary. - -A value of t means always generate a summary. - -A positive numeric value N means only generate a summary if there -are N or more messages. - -A negative numeric value -N means only generate a summary if -there are N or less messages.") - -(defvar vm-follow-summary-cursor t - "*Non-nil value causes VM to select the message under the cursor in the -summary window before executing commands that operate on the current message. -This occurs only when the summary buffer window is the selected window.") - -(defvar vm-jump-to-new-messages t - "*Non-nil value causes VM to jump to the first new message -whenever such messages arrive in a folder or the first time a -folder is visited. - -See also vm-jump-to-unread-messages.") - -(defvar vm-jump-to-unread-messages t - "*Non-nil value causes VM to jump to the first unread message -whenever such messages arrive in a folder or the first time a -folder is visited. New messages are considered unread in this -context so new messages will be jumped to as well. - -The value of vm-jump-to-new-messages takes precedence over the -setting of this variable. So if there are unread messages and -new messages VM will jump to the first new message, even if an -unread message appears before it in the folder, provided -vm-jump-to-new-messages is non-nil.") - -(defvar vm-skip-deleted-messages t - "*Non-nil value causes VM's `n' and 'p' commands to skip over -deleted messages. A value of t causes deleted messages to always be skipped. -A value that is not nil and not t causes deleted messages to be skipped only -if there are other messages that are not flagged for deletion in the desired -direction of motion.") - -(defvar vm-skip-read-messages nil - "*Non-nil value causes VM's `n' and `p' commands to skip over -messages that have already been read, in favor of new or unread messages. -A value of t causes read messages to always be skipped. A value that is -not nil and not t causes read messages to be skipped only if there are -unread messages in the desired direction of motion.") - -(defvar vm-move-after-deleting nil - "*Non-nil value causes VM's `d' command to automatically invoke -vm-next-message or vm-previous-message after deleting, to move -past the deleted messages. A value of t means motion should -honor the value of vm-circular-folders. A value that is not t -and not nil means that motion should be done as if -vm-circular-folders is set to nil.") - -(defvar vm-move-after-undeleting nil - "*Non-nil value causes VM's `u' command to automatically invoke -vm-next-message or vm-previous-message after undeleting, to move -past the undeleted messages. A value of t means motion should -honor the value of vm-circular-folders. A value that is not t -and not nil means that motion should be done as if -vm-circular-folders is set to nil.") - -(defvar vm-move-after-killing nil - "*Non-nil value causes VM's `k' command to automatically invoke -vm-next-message or vm-previous-message after killing messages, to try -to move past the deleted messages. A value of t means motion -should honor the value of vm-circular-folders. A value that is -not t and not nil means that motion should be done as if -vm-circular-folders is set to nil.") - -(defvar vm-delete-after-saving nil - "*Non-nil value causes VM automatically to mark messages for deletion -after successfully saving them to a folder.") - -(defvar vm-delete-after-archiving nil - "*Non-nil value causes VM automatically to mark messages for deletion -after successfully auto-archiving them with the vm-auto-archive-messages -command.") - -(defvar vm-delete-after-bursting nil - "*Non-nil value causes VM automatically to mark a message for deletion -after it has been successfully burst by the vm-burst-digest command.") - -(defvar vm-circular-folders 0 - "*Value determines whether VM folders will be considered circular by -various commands. `Circular' means VM will wrap from the end of the folder -to the start and vice versa when moving the message pointer, or deleting, -undeleting or saving messages before or after the current message. - -A value of t causes all VM commands to consider folders circular. - -A value of nil causes all of VM commands to signal an error if the start -or end of the folder would have to be passed to complete the command. -For movement commands, this occurs after the message pointer has been -moved as far as possible in the specified direction. For other commands, -the error occurs before any part of the command has been executed, i.e. -no deletions, saves, etc. will be done unless they can be done in their -entirety. - -A value that is not nil and not t causes only VM's movement commands to -consider folders circular. Saves, deletes and undelete commands will -behave the same as if the value is nil.") - -(defvar vm-search-using-regexps nil - "*Non-nil value causes VM's search command to interpret user input as a -regular expression instead of as a literal string.") - -(defvar vm-move-messages-physically nil - "*Non-nil value causes VM's commands that change the message order -of a folder to always move the physical messages involved and not -just change the presentation order. Nil means that commands just -change the order in which VM displays messages and leave the -folder itself undisturbed.") - -(defvar vm-edit-message-mode 'text-mode - "*Major mode to use when editing messages in VM.") - -(defvar vm-print-command lpr-command - "*Command VM uses to print messages.") - -(defvar vm-print-command-switches lpr-switches - "*List of command line flags passed to the command named by vm-print-command. -VM uses vm-print-command to print messages.") - -(defvar vm-berkeley-mail-compatibility - (memq system-type '(berkeley-unix netbsd)) - "*Non-nil means to read and write BSD Mail(1) style Status: headers. -This makes sense if you plan to use VM to read mail archives created by -Mail.") - -(defvar vm-strip-reply-headers nil - "*Non-nil value causes VM to strip away all comments and extraneous text -from the headers generated in reply messages. If you use the \"fakemail\" -program as distributed with Emacs, you probably want to set this variable -to t, because as of Emacs v18.52 \"fakemail\" could not handle unstripped -headers.") - -(defvar vm-select-new-message-hook nil - "*List of hook functions called every time a message with the 'new' -attribute is made to be the current message. When the hooks are run the -current buffer will be the folder containing the message and the -start and end of the message will be bracketed by (point-min) and -(point-max).") - -(defvar vm-select-unread-message-hook nil - "*List of hook functions called every time a message with the 'unread' -attribute is made to be the current message. When the hooks are run the -current buffer will be the folder containing the message and the -start and end of the message will be bracketed by (point-min) and -(point-max).") - -(defvar vm-select-message-hook nil - "*List of hook functions called every time a message -is made to be the current message. When the hooks are run the -current buffer will be the folder containing the message and the -start and end of the message will be bracketed by (point-min) and -(point-max).") - -(defvar vm-arrived-message-hook nil - "*List of hook functions called once for each message gathered from -the system mail spool, or from another folder with -vm-get-new-mail, or from a digest with vm-burst-digest. When the -hooks are run the current buffer will be the folder containing -the message and the start and end of the message will be -bracketed by (point-min) and (point-max).") - -(defvar vm-arrived-messages-hook nil - "*List of hook functions called after VM has gathered a group of -messages from the system mail spool, or from another folder with -vm-get-new-mail, or from a digest with vm-burst-digest. When the -hooks are run, the new messages will have already been added to -the message list but may not yet appear in the summary. When the -hooks are run the current buffer will be the folder containing -the messages.") - -(defvar vm-reply-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created for a reply. VM runs this -hook and then runs vm-mail-mode-hook before leaving the user in -the Mail mode buffer.") - -(defvar vm-forward-message-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created to forward a message. VM -runs this hook and then runs vm-mail-mode-hook before leaving the -user in the Mail mode buffer.") - -(defvar vm-resend-bounced-message-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created to resend a bounced message. -VM runs this hook and then runs vm-mail-mode-hook before leaving -the user in the Mail mode buffer.") - -(defvar vm-resend-message-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created to resend a message. -VM runs this hook and then runs vm-mail-mode-hook before leaving -the user in the Mail mode buffer.") - -(defvar vm-send-digest-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created to send a digest. -VM runs this hook and then runs vm-mail-mode-hook before leaving -the user in the Mail mode buffer.") - -(defvar vm-mail-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created to send a non specialized -message, i.e. a message that is not a reply, forward, digest, -etc. VM runs this hook and then runs vm-mail-mode-hook before -leaving the user in the Mail mode buffer.") - -(defvar vm-summary-update-hook nil - "*List of hook functions called just after VM updates an existing -entry a folder summary.") - -(defvar vm-summary-redo-hook nil - "*List of hook functions called just after VM adds or deletes -entries from a folder summary.") - -(defvar vm-visit-folder-hook nil - "*List of hook functions called just after VM visits a folder. -It doesn't matter if the folder buffer already exists, this hook -is run each time vm or vm-visit-folder is called interactively. -It is NOT run after vm-mode is called.") - -(defvar vm-retrieved-spooled-mail-hook nil - "*List of hook functions called just after VM has retrieved -a group of messages from your system mailbox(es). When these -hooks are run, the messages have been added to the folder buffer -but not the message list or summary. When the hooks are run, the -current buffer will be the folder where the messages were -incorporated.") - -(defvar vm-edit-message-hook nil - "*List of hook functions to be run just before a message is edited. -This is the last thing vm-edit-message does before leaving the user -in the edit buffer.") - -(defvar vm-mail-mode-hook nil - "*List of hook functions to be run after a Mail mode -composition buffer has been created. This is the last thing VM -does before leaving the user in the Mail mode buffer.") - -(defvar vm-mode-hook nil - "*List of hook functions to run when a buffer enters vm-mode. -These hook functions should generally be used to set key bindings -and local variables.") - -(defvar vm-mode-hooks nil - "*Old name for vm-mode-hook. -Supported for backward compatibility. -You should use the new name.") - -(defvar vm-summary-mode-hook nil - "*List of hook functions to run when a VM summary buffer is created. -The current buffer will be that buffer when the hooks are run.") - -(defvar vm-summary-mode-hooks nil - "*Old name for vm-summary-mode-hook. -Supported for backward compatibility. -You should use the new name.") - -(defvar vm-virtual-mode-hook nil - "*List of hook functions to run when a VM virtual folder buffer is created. -The current buffer will be that buffer when the hooks are run.") - -(defvar vm-presentation-mode-hook nil - "*List of hook functions to run when a VM presentation buffer is created. -The current buffer will be that buffer when the hooks are run. -Presentation buffers are used to display messages when some type of decoding -must be done to the message to make it presentable. E.g. MIME decoding.") - -(defvar vm-quit-hook nil - "*List of hook functions to run when you quit VM. -This applies to any VM quit command.") - -(defvar vm-summary-pointer-update-hook nil - "*List of hook functions to run when VM summary pointer is updated. -When the hooks are run, the current buffer will be the summary buffer.") - -(defvar vm-display-buffer-hook nil - "*List of hook functions that are run every time VM wants to -display a buffer. When the hooks are run the current buffer will -be the buffer that VM wants to display. The hooks are expected -to select a window and VM will display the buffer in that -window. - -If you use display hooks, you should not use VM's builtin window -configuration system as the result is likely to be confusing.") - -(defvar vm-undisplay-buffer-hook nil - "*List of hook functions that are run every time VM wants to -remove a buffer from the display. When the hooks are run the -current buffer will be the buffer that VM wants to disappear. -The hooks are expected to do the work of removing the buffer from -the display. The hook functions should not kill the buffer. - -If you use undisplay hooks, you should not use VM's builtin -window configuration system as the result is likely to be -confusing.") - -(defvar vm-iconify-frame-hook nil - "*List of hook functions that are run whenever VM iconifies a frame.") - -(defvar vm-menu-setup-hook nil - "*List of hook functions that are run just after all menus are initialized.") - -(defvar vm-mime-display-function nil - "*If non-nil, this should name a function to be called inside -vm-decode-mime-message to do the MIME display the current -message. The function is called with no arguments, and at the -time of the call the current buffer will be the `presentation' -buffer for the folder, which is a temporary buffer that VM uses -for the display of MIME messages. A copy of the current message -will be in the presentation buffer at that time. The normal work -that vm-decode-mime-message would do is not done, because this -function is expected to subsume all of it.") - -(defvar mail-yank-hooks nil - "Hooks called after a message is yanked into a mail composition. - -(This hook is deprecated, you should use mail-citation-hook instead.) - -Value is a list of functions to be run. -Each hook function can find the newly yanked message between point and mark. -Each hook function should return with point and mark around the yanked message. - -See the documentation for vm-yank-message to see when VM will run -these hooks.") - -(defvar mail-citation-hook nil - "*Hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between (point) and (mark t). -And each hook function should leave point and mark around the citation -text as modified. - -If this hook is entirely empty (nil), a default action is taken -instead of no action.") - -(defvar mail-default-headers nil - "*A string containing header lines, to be inserted in outgoing messages. -It is inserted before you edit the message, -so you can edit or delete these lines.") - -(defvar mail-signature nil - "*Text inserted at end of mail buffer when a message is initialized. -If t, it means to insert the contents of the file `~/.signature'.") - -(defvar vm-rename-current-buffer-function nil - "*Non-nil value should be a function to call to rename a buffer. -Value should be something that can be passed to `funcall'. If -this variable is non-nil, VM will use this function instead of -its own buffer renaming code. The buffer to be renamed will be -the current buffer when the function is called.") - -(defvar mode-popup-menu nil - "The mode-specific popup menu. Automatically buffer local. -By default, when you press mouse-3 in VM, this menu is popped up.") -(make-variable-buffer-local 'mode-popup-menu) - -(defvar vm-movemail-program "movemail" - "*Name of program to use to move mail from the system spool -to another location. Normally this should be the movemail program -distributed with Emacs.") - -(defvar vm-netscape-program "netscape" - "*Name of program to use to run Netscape. -vm-mouse-send-url-to-netscape uses this.") - -(defvar vm-netscape-program-switches nil - "*List of command line switches to pass to Netscape.") - -(defvar vm-mosaic-program "Mosaic" - "*Name of program to use to run Mosaic. -vm-mouse-send-url-to-mosaic uses this.") - -(defvar vm-mosaic-program-switches nil - "*List of command line switches to pass to Mosaic.") - -(defvar vm-temp-file-directory - (or (and (file-directory-p "/tmp") "/tmp") - (and (file-directory-p "C:\\") "C:\\") - "/tmp") - "*Name of a directory where VM can put temporary files. -This name must not end with a slash.") - -(defvar vm-tale-is-an-idiot nil - "*Non-nil value causes vm-mail-send to check multi-line recipient -headers of outbound mail for lines that don't end with a -comma. If such a line is found, an error is signaled and the -mail is not sent.") - -(defvar vm-maintainer-address "bug-vm@uunet.uu.net" - "Where to send VM bug reports.") - -(defvar vm-mode-map - (let ((map (make-sparse-keymap))) -;; unneeded now that VM buffers all have buffer-read-only == t. -;; (suppress-keymap map) - (define-key map "h" 'vm-summarize) - (define-key map "\M-n" 'vm-next-unread-message) - (define-key map "\M-p" 'vm-previous-unread-message) - (define-key map "n" 'vm-next-message) - (define-key map "p" 'vm-previous-message) - (define-key map "N" 'vm-next-message-no-skip) - (define-key map "P" 'vm-previous-message-no-skip) - (define-key map "\C-\M-n" 'vm-move-message-forward) - (define-key map "\C-\M-p" 'vm-move-message-backward) - (define-key map "\t" 'vm-goto-message-last-seen) - (define-key map "\r" 'vm-goto-message) - (define-key map "^" 'vm-goto-parent-message) - (define-key map "t" 'vm-expose-hidden-headers) - (define-key map " " 'vm-scroll-forward) - (define-key map "b" 'vm-scroll-backward) - (define-key map 'delete 'vm-scroll-backward) - (define-key map 'backspace 'vm-scroll-backward) - (define-key map "D" 'vm-decode-mime-message) - (define-key map "d" 'vm-delete-message) - (define-key map "\C-d" 'vm-delete-message-backward) - (define-key map "u" 'vm-undelete-message) - (define-key map "U" 'vm-unread-message) - (define-key map "e" 'vm-edit-message) - (define-key map "a" 'vm-set-message-attributes) - (define-key map "j" 'vm-discard-cached-data) - (define-key map "k" 'vm-kill-subject) - (define-key map "f" 'vm-followup) - (define-key map "F" 'vm-followup-include-text) - (define-key map "r" 'vm-reply) - (define-key map "R" 'vm-reply-include-text) - (define-key map "\M-r" 'vm-resend-bounced-message) - (define-key map "B" 'vm-resend-message) - (define-key map "z" 'vm-forward-message) - (define-key map "c" 'vm-continue-composing-message) - (define-key map "@" 'vm-send-digest) - (define-key map "*" 'vm-burst-digest) - (define-key map "m" 'vm-mail) - (define-key map "g" 'vm-get-new-mail) - (define-key map "G" 'vm-sort-messages) - (define-key map "v" 'vm-visit-folder) - (define-key map "s" 'vm-save-message) - (define-key map "w" 'vm-save-message-sans-headers) - (define-key map "A" 'vm-auto-archive-messages) - (define-key map "S" 'vm-save-folder) - (define-key map "|" 'vm-pipe-message-to-command) - (define-key map "#" 'vm-expunge-folder) - (define-key map "q" 'vm-quit) - (define-key map "x" 'vm-quit-no-change) - (define-key map "i" 'vm-iconify-frame) - (define-key map "?" 'vm-help) - (define-key map "\C-_" 'vm-undo) - (define-key map "\C-xu" 'vm-undo) - (define-key map "!" 'shell-command) - (define-key map "<" 'vm-beginning-of-message) - (define-key map ">" 'vm-end-of-message) - (define-key map "\M-s" 'vm-isearch-forward) - (define-key map "=" 'vm-summarize) - (define-key map "L" 'vm-load-init-file) - (define-key map "l" (make-sparse-keymap)) - (define-key map "la" 'vm-add-message-labels) - (define-key map "ld" 'vm-delete-message-labels) - (define-key map "V" (make-sparse-keymap)) - (define-key map "VV" 'vm-visit-virtual-folder) - (define-key map "VC" 'vm-create-virtual-folder) - (define-key map "VA" 'vm-apply-virtual-folder) - (define-key map "VM" 'vm-toggle-virtual-mirror) - (define-key map "V?" 'vm-virtual-help) - (define-key map "M" (make-sparse-keymap)) - (define-key map "MN" 'vm-next-command-uses-marks) - (define-key map "Mn" 'vm-next-command-uses-marks) - (define-key map "MM" 'vm-mark-message) - (define-key map "MU" 'vm-unmark-message) - (define-key map "Mm" 'vm-mark-all-messages) - (define-key map "Mu" 'vm-clear-all-marks) - (define-key map "MC" 'vm-mark-matching-messages) - (define-key map "Mc" 'vm-unmark-matching-messages) - (define-key map "MT" 'vm-mark-thread-subtree) - (define-key map "Mt" 'vm-unmark-thread-subtree) - (define-key map "MS" 'vm-mark-messages-same-subject) - (define-key map "Ms" 'vm-unmark-messages-same-subject) - (define-key map "MA" 'vm-mark-messages-same-author) - (define-key map "Ma" 'vm-unmark-messages-same-author) - (define-key map "MR" 'vm-mark-summary-region) - (define-key map "Mr" 'vm-unmark-summary-region) - (define-key map "M?" 'vm-mark-help) - (define-key map "W" (make-sparse-keymap)) - (define-key map "WW" 'vm-apply-window-configuration) - (define-key map "WS" 'vm-save-window-configuration) - (define-key map "WD" 'vm-delete-window-configuration) - (define-key map "W?" 'vm-window-help) - (define-key map "\C-t" 'vm-toggle-threads-display) - (define-key map "\C-x\C-s" 'vm-save-buffer) - (define-key map "\C-x\C-w" 'vm-write-file) - (define-key map "\C-x\C-q" 'vm-toggle-read-only) - (define-key map "%" 'vm-change-folder-type) - (define-key map "\M-C" 'vm-show-copying-restrictions) - (define-key map "\M-W" 'vm-show-no-warranty) - ;; suppress-keymap provides these, but now that we don't use - ;; suppress-keymap anymore... - (define-key map "0" 'digit-argument) - (define-key map "1" 'digit-argument) - (define-key map "2" 'digit-argument) - (define-key map "3" 'digit-argument) - (define-key map "4" 'digit-argument) - (define-key map "5" 'digit-argument) - (define-key map "6" 'digit-argument) - (define-key map "7" 'digit-argument) - (define-key map "8" 'digit-argument) - (define-key map "9" 'digit-argument) - (define-key map "-" 'negative-argument) - (cond ((fboundp 'set-keymap-name) - (set-keymap-name map 'vm-mode-map) - (set-keymap-name (lookup-key map "l") - "VM mode message labels map") - (set-keymap-name (lookup-key map "V") - "VM mode virtual folders map") - (set-keymap-name (lookup-key map "M") - "VM mode message marks map") - (set-keymap-name (lookup-key map "W") - "VM mode window configuration map"))) - - map ) - "Keymap for VM mode.") - -(defvar vm-summary-mode-map vm-mode-map - "Keymap for VM Summary mode") - -(defvar vm-mail-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-v" vm-mode-map) - (define-key map "\C-c\C-p" 'vm-mime-preview-composition) - (define-key map "\C-c\C-e" 'vm-mime-encode-composition) - (define-key map "\C-c\C-a" 'vm-mime-attach-file) -;; (define-key map "\C-c\C-m" 'vm-mime-attach-mime-file) - (define-key map "\C-c\C-y" 'vm-yank-message) - (define-key map "\C-c\C-s" 'vm-mail-send) - (define-key map "\C-c\C-c" 'vm-mail-send-and-exit) - (cond ((fboundp 'set-keymap-name) - (set-keymap-name map 'vm-mail-mode-map))) - map ) - "Keymap for VM Mail mode buffers. -Its parent keymap is mail-mode-map.") - -(defvar vm-edit-message-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-v" vm-mode-map) - (define-key map "\C-c\e" 'vm-edit-message-end) - (define-key map "\C-c\C-c" 'vm-edit-message-end) - (define-key map "\C-c\C-]" 'vm-edit-message-abort) - (cond ((fboundp 'set-keymap-name) - (set-keymap-name map 'vm-edit-message-map))) - map ) - "Keymap for the buffers created by VM's vm-edit-message command.") - -(defvar vm-folder-history nil - "List of folders visited this Emacs session.") - -;; internal vars -(defvar vm-folder-type nil) -(make-variable-buffer-local 'vm-folder-type) -(defvar vm-message-list nil) -(make-variable-buffer-local 'vm-message-list) -(defvar vm-virtual-folder-definition nil) -(make-variable-buffer-local 'vm-virtual-folder-definition) -(defvar vm-virtual-buffers nil) -(make-variable-buffer-local 'vm-virtual-buffers) -(defvar vm-real-buffers nil) -(make-variable-buffer-local 'vm-real-buffers) -(defvar vm-message-pointer nil) -(make-variable-buffer-local 'vm-message-pointer) -(defvar vm-message-order-changed nil) -(make-variable-buffer-local 'vm-message-order-changed) -(defvar vm-message-order-header-present nil) -(make-variable-buffer-local 'vm-message-order-header-present) -(defvar vm-last-message-pointer nil) -(make-variable-buffer-local 'vm-last-message-pointer) -(defvar vm-mail-buffer nil) -(make-variable-buffer-local 'vm-mail-buffer) -(defvar vm-presentation-buffer nil) -(make-variable-buffer-local 'vm-presentation-buffer) -(defvar vm-presentation-buffer-handle nil) -(make-variable-buffer-local 'vm-presentation-buffer-handle) -(defvar vm-mime-decoded nil) -(make-variable-buffer-local 'vm-mime-decoded) -(defvar vm-summary-buffer nil) -(make-variable-buffer-local 'vm-summary-buffer) -(defvar vm-summary-pointer nil) -(make-variable-buffer-local 'vm-summary-pointer) -(defvar vm-system-state nil) -(make-variable-buffer-local 'vm-system-state) -(defvar vm-undo-record-list nil) -(make-variable-buffer-local 'vm-undo-record-list) -(defvar vm-saved-undo-record-list nil) -(make-variable-buffer-local 'vm-saved-undo-record-list) -(defvar vm-undo-record-pointer nil) -(make-variable-buffer-local 'vm-undo-record-pointer) -(defvar vm-last-save-folder nil) -(make-variable-buffer-local 'vm-last-save-folder) -(defvar vm-last-written-file nil) -(make-variable-buffer-local 'vm-last-written-file) -(defvar vm-last-visit-folder nil) -(defvar vm-last-pipe-command nil) -(make-variable-buffer-local 'vm-last-pipe-command) -(defvar vm-messages-not-on-disk 0) -(make-variable-buffer-local 'vm-messages-not-on-disk) -(defvar vm-totals nil) -(make-variable-buffer-local 'vm-totals) -(defvar vm-modification-counter 0) -(make-variable-buffer-local 'vm-modification-counter) -(defvar vm-flushed-modification-counter nil) -(make-variable-buffer-local 'vm-flushed-modification-counter) -(defvar vm-tempfile-counter 0) -(defvar vm-messages-needing-summary-update nil) -(defvar vm-buffers-needing-display-update nil) -(defvar vm-numbering-redo-start-point nil) -(make-variable-buffer-local 'vm-numbering-redo-start-point) -(defvar vm-numbering-redo-end-point nil) -(make-variable-buffer-local 'vm-numbering-redo-end-point) -(defvar vm-summary-redo-start-point nil) -(make-variable-buffer-local 'vm-summary-redo-start-point) -(defvar vm-need-summary-pointer-update nil) -(make-variable-buffer-local 'vm-need-summary-pointer-update) -(defvar vm-thread-obarray nil) -(make-variable-buffer-local 'vm-thread-obarray) -(defvar vm-thread-subject-obarray nil) -(make-variable-buffer-local 'vm-thread-subject-obarray) -(defvar vm-label-obarray nil) -(make-variable-buffer-local 'vm-label-obarray) -(defvar vm-block-new-mail nil) -(make-variable-buffer-local 'vm-block-new-mail) -(defvar vm-saved-buffer-modified-p nil) -(make-variable-buffer-local 'vm-saved-buffer-modified-p) -(defvar vm-kept-mail-buffers nil) -(defvar vm-inhibit-write-file-hook nil) -;; used to choose between the default and -;; mail-extract-address-components but I don't see the utility of -;; it anymore. It tries to be too smart. -;;(defvar vm-chop-full-name-function 'vm-choose-chop-full-name-function) -(defvar vm-chop-full-name-function 'vm-default-chop-full-name) -(defvar vm-session-beginning t) -(defvar vm-init-file-loaded nil) -(defvar vm-window-configurations nil) -(defvar vm-window-configuration nil) -(defvar vm-message-id-number 0) -(defconst vm-spool-directory - (or (and (boundp 'rmail-spool-directory) rmail-spool-directory) - "/usr/spool/mail/")) -(defconst vm-content-length-search-regexp "^Content-Length:.*\n\\|\\(\n\n\\)") -(defconst vm-content-length-header "Content-Length:") -(defconst vm-attributes-header-regexp - "^X-VM-\\(Attributes\\|v5-Data\\):\\(.*\n\\([ \t].*\n\\)*\\)") -(defconst vm-attributes-header "X-VM-v5-Data:") -(defconst vm-message-order-header-regexp "^X-VM-Message-Order:") -(defconst vm-message-order-header "X-VM-Message-Order:") -(defconst vm-bookmark-header-regexp "^X-VM-Bookmark:") -(defconst vm-bookmark-header "X-VM-Bookmark:") -(defconst vm-summary-header-regexp "^X-VM-Summary-Format:") -(defconst vm-summary-header "X-VM-Summary-Format:") -(defconst vm-vheader-header-regexp "^X-VM-VHeader:") -(defconst vm-vheader-header "X-VM-VHeader:") -(defconst vm-labels-header-regexp "^X-VM-Labels:") -(defconst vm-labels-header "X-VM-Labels:") -(defconst vm-berkeley-mail-status-header "Status: ") -(defconst vm-berkeley-mail-status-header-regexp "^Status: \\(..?\\)\n") -(defvar vm-matched-header-vector (make-vector 6 nil)) -(defconst vm-supported-folder-types - '("From_" "From_-with-Content-Length" "mmdf" "babyl")) -(defconst vm-supported-window-configurations - '( - ("default") - ("startup") - ("quitting") - ("composing-message") - ("editing-message") - ("marking-message") - ("reading-message") - ("searching-message") - ("vm") - ("vm-add-message-labels") - ("vm-apply-virtual-folder") - ("vm-auto-archive-messages") - ("vm-beginning-of-message") - ("vm-burst-digest") - ("vm-burst-mime-digest") - ("vm-burst-rfc1153-digest") - ("vm-burst-rfc934-digest") - ("vm-change-folder-type") - ("vm-clear-all-marks") - ("vm-continue-composing-message") - ("vm-create-virtual-folder") - ("vm-decode-mime-message") - ("vm-delete-message") - ("vm-delete-message-backward") - ("vm-delete-message-labels") - ("vm-discard-cached-data") - ("vm-edit-message") - ("vm-edit-message-abort") - ("vm-edit-message-end") - ("vm-edit-message-other-frame") - ("vm-end-of-message") - ("vm-expose-hidden-headers") - ("vm-expunge-folder") - ("vm-followup") - ("vm-followup-include-text") - ("vm-followup-include-text-other-frame") - ("vm-followup-other-frame") - ("vm-forward-message") - ("vm-forward-message-all-headers") - ("vm-forward-message-all-headers-other-frame") - ("vm-forward-message-other-frame") - ("vm-get-new-mail") - ("vm-goto-message") - ("vm-goto-message-last-seen") - ("vm-goto-parent-message") - ("vm-help") - ("vm-isearch-forward") - ("vm-kill-subject") - ("vm-load-init-file") - ("vm-mail") - ("vm-mail-other-frame") - ("vm-mail-other-window") - ("vm-mail-send") - ("vm-mail-send-and-exit") - ("vm-mark-all-messages") - ("vm-mark-help") - ("vm-mark-matching-messages") - ("vm-mark-message") - ("vm-mark-messages-same-author") - ("vm-mark-messages-same-subject") - ("vm-mark-summary-region") - ("vm-mark-thread-subtree") - ("vm-mode") - ("vm-move-message-backward") - ("vm-move-message-backward-physically") - ("vm-move-message-forward") - ("vm-move-message-forward-physically") - ("vm-next-command-uses-marks") - ("vm-next-message") - ("vm-next-message-no-skip") - ("vm-next-message-no-skip") - ("vm-next-message-same-subject") - ("vm-next-unread-message") - ("vm-other-frame") - ("vm-other-window") - ("vm-pipe-message-to-command") - ("vm-previous-message") - ("vm-previous-message-no-skip") - ("vm-previous-message-no-skip") - ("vm-previous-message-same-subject") - ("vm-previous-unread-message") - ("vm-quit") - ("vm-quit-just-bury") - ("vm-quit-just-iconify") - ("vm-quit-no-change") - ("vm-reply") - ("vm-reply-include-text") - ("vm-reply-include-text-other-frame") - ("vm-reply-other-frame") - ("vm-resend-bounced-message") - ("vm-resend-bounced-message-other-frame") - ("vm-resend-message") - ("vm-resend-message-other-frame") - ("vm-save-and-expunge-folder") - ("vm-save-buffer") - ("vm-save-folder") - ("vm-save-message") - ("vm-save-message-sans-headers") - ("vm-scroll-backward") - ("vm-scroll-forward") - ("vm-send-digest") - ("vm-send-digest-other-frame") - ("vm-send-mime-digest") - ("vm-send-mime-digest-other-frame") - ("vm-send-rfc1153-digest") - ("vm-send-rfc1153-digest-other-frame") - ("vm-send-rfc934-digest") - ("vm-send-rfc934-digest-other-frame") - ("vm-set-message-attributes") - ("vm-show-copying-restrictions") - ("vm-show-no-warranty") - ("vm-sort-messages") - ("vm-submit-bug-report") - ("vm-summarize") - ("vm-summarize-other-frame") - ("vm-toggle-read-only") - ("vm-toggle-threads-display") - ("vm-undelete-message") - ("vm-undo") - ("vm-unmark-matching-messages") - ("vm-unmark-message") - ("vm-unmark-messages-same-author") - ("vm-unmark-messages-same-subject") - ("vm-unmark-summary-region") - ("vm-unmark-thread-subtree") - ("vm-unread-message") - ("vm-virtual-help") - ("vm-visit-folder") - ("vm-visit-folder-other-frame") - ("vm-visit-folder-other-window") - ("vm-visit-virtual-folder") - ("vm-visit-virtual-folder-other-frame") - ("vm-visit-virtual-folder-other-window") - ("vm-write-file") - ("vm-yank-message") - ("vm-yank-message-other-folder") -)) -(defconst vm-supported-sort-keys - '("date" "reversed-date" - "author" "reversed-author" - "subject" "reversed-subject" - "recipients" "reversed-recipients" - "line-count" "reversed-line-count" - "byte-count" "reversed-byte-count" - "physical-order" "reversed-physical-order")) -(defconst vm-supported-interactive-virtual-selectors - '(("any") - ("header") - ("label") - ("text") - ("recipient") - ("author") - ("subject") - ("sent-before") - ("sent-after") - ("more-chars-than") - ("less-chars-than") - ("more-lines-than") - ("less-lines-than") - ("new") - ("unread") - ("read") - ("deleted") - ("replied") - ("forwarded") - ("filed") - ("written") - ("edited") - ("marked"))) -(defconst vm-supported-attribute-names - '("new" - "unread" - "read" - "deleted" - "replied" - "forwarded" - "redistributed" - "filed" - "written" - "edited" - "undeleted" - "unreplied" - "unforwarded" - "unredistributed" - "unfiled" - "unwritten" - "unedited" - ;; for babyl cogniscenti - "recent" - "unseen" - "answered" - "unanswered")) - -(defvar vm-key-functions nil) -(defconst vm-digest-type-alist '(("rfc934") ("rfc1153") ("mime"))) -(defvar vm-completion-auto-correct t - "Non-nil means that minibuffer-complete-file should aggressively erase -the trailing part of a word that caused completion to fail, and retry -the completion with the resulting word.") -(defvar vm-minibuffer-completion-table nil - "Completion table used by vm-minibuffer-complete-word. -Should be just a list of strings, not an alist or an obarray.") -(defvar vm-completion-auto-space t - "Non-nil value means that vm-minibuffer-complete-word should automatically -append a space to words that complete unambiguously.") -(defconst vm-attributes-vector-length 9) -(defconst vm-cache-vector-length 21) -(defconst vm-softdata-vector-length 18) -(defconst vm-location-data-vector-length 6) -(defconst vm-mirror-data-vector-length 5) -(defconst vm-startup-message-lines - '("Please use \\[vm-submit-bug-report] to report bugs." - "For discussion about the VM mail reader, see the gnu.emacs.vm.info newsgroup" - "You may give out copies of VM. Type \\[vm-show-copying-restrictions] to see the conditions" - "VM comes with ABSOLUTELY NO WARRANTY; type \\[vm-show-no-warranty] for full details" - "In Stereo (where available)")) -(defconst vm-startup-message-displayed nil) -;; for the mode line -(defvar vm-mode-line-format - '("" " %&%& " - ("VM " vm-version ": " - (vm-folder-read-only "read-only ") - (vm-virtual-folder-definition (vm-virtual-mirror "mirrored ")) - "%b" - (vm-mail-buffer (vm-ml-sort-keys ("" " by " vm-ml-sort-keys))) - (vm-message-list - (" " vm-ml-message-number - " (of " vm-ml-highest-message-number ")") - (vm-folder-type - " (unrecognized folder type)" - " (no messages)"))) - (vm-spooled-mail-waiting " Mail") - (vm-message-list - (" %[ " vm-ml-message-attributes-alist - (vm-ml-labels ("; " vm-ml-labels)) " %] ") - (" %[%] ")) - "%p" " " global-mode-string)) - -(defvar vm-ml-message-attributes-alist - '((vm-ml-message-new - "new" - (vm-ml-message-unread - "unread" - (vm-ml-message-read "read"))) - (vm-ml-message-edited " edited") - (vm-ml-message-filed " filed") - (vm-ml-message-written " written") - (vm-ml-message-replied " replied") - (vm-ml-message-forwarded " forwarded") - (vm-ml-message-redistributed " redistributed") - (vm-ml-message-deleted " deleted") - (vm-ml-message-marked " MARKED"))) -(defvar vm-ml-message-number nil) -(make-variable-buffer-local 'vm-ml-message-number) -(defvar vm-ml-highest-message-number nil) -(make-variable-buffer-local 'vm-ml-highest-message-number) -(defvar vm-ml-sort-keys nil) -(make-variable-buffer-local 'vm-ml-sort-keys) -(defvar vm-ml-labels nil) -(make-variable-buffer-local 'vm-ml-labels) -; unused now -;(defvar vm-ml-attributes-string nil) -;(make-variable-buffer-local 'vm-ml-attributes-string) -(defvar vm-ml-message-new nil) -(make-variable-buffer-local 'vm-ml-message-new) -(defvar vm-ml-message-unread nil) -(make-variable-buffer-local 'vm-ml-message-unread) -(defvar vm-ml-message-read nil) -(make-variable-buffer-local 'vm-ml-message-read) -(defvar vm-ml-message-edited nil) -(make-variable-buffer-local 'vm-ml-message-edited) -(defvar vm-ml-message-replied nil) -(make-variable-buffer-local 'vm-ml-message-replied) -(defvar vm-ml-message-forwarded nil) -(make-variable-buffer-local 'vm-ml-message-forwarded) -(defvar vm-ml-message-redistributed nil) -(make-variable-buffer-local 'vm-ml-message-redistributed) -(defvar vm-ml-message-deleted nil) -(make-variable-buffer-local 'vm-ml-message-deleted) -(defvar vm-ml-message-filed nil) -(make-variable-buffer-local 'vm-ml-message-filed) -(defvar vm-ml-message-written nil) -(make-variable-buffer-local 'vm-ml-message-written) -(defvar vm-ml-message-marked nil) -(make-variable-buffer-local 'vm-ml-message-marked) -;; to make the tanjed compiler shut up -(defvar vm-pop-read-point nil) -(defvar vm-pop-ok-to-ask nil) -(defvar vm-reply-list nil) -(defvar vm-forward-list nil) -(defvar vm-redistribute-list nil) -(defvar current-itimer nil) -(defvar current-menubar nil) -(defvar scrollbar-height nil) -(defvar top-toolbar nil) -(defvar top-toolbar-height nil) -(defvar bottom-toolbar nil) -(defvar bottom-toolbar-height nil) -(defvar right-toolbar nil) -(defvar right-toolbar-width nil) -(defvar left-toolbar nil) -(defvar left-toolbar-width nil) -;; this defvar matches the XEmacs one so it doesn't matter if VM -;; is loaded before highlight-headers.el -(defvar highlight-headers-regexp "Subject[ \t]*:") -(defvar vm-url-regexp - "<URL:\\([^>\n]+\\)>\\|\\(\\(file\\|ftp\\|gopher\\|http\\|https\\|news\\|wais\\|www\\)://[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)\\|\\(mailto:[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)" - "Regular expression that matches an absolute URL. -The URL itself must be matched by a \\(..\\) grouping. -VM will extract the URL by copying the lowest number grouping -that has a match.") -(defconst vm-month-alist - '(("jan" "January" "1") - ("feb" "February" "2") - ("mar" "March" "3") - ("apr" "April" "4") - ("may" "May" "5") - ("jun" "June" "6") - ("jul" "July" "7") - ("aug" "August" "8") - ("sep" "September" "9") - ("oct" "October" "10") - ("nov" "November" "11") - ("dec" "December" "12"))) -(defvar vm-pop-passwords nil) -(defvar pop-up-frames nil) -(defvar vm-parse-date-workspace (make-vector 6 nil)) -;; cache so we don't call timezone-make-date-sortable so much. -;; messages have their own cache; this is for the virtual folder -;; alist selectors. -(defvar vm-sortable-date-alist nil) -(defvar vm-summary-=> nil) -(defvar vm-summary-no-=> nil) -(defvar vm-summary-overlay nil) -(make-variable-buffer-local 'vm-summary-overlay) -(defvar vm-thread-loop-obarray (make-vector 29 0)) -(defvar vm-delete-duplicates-obarray (make-vector 29 0)) -(defvar vm-image-obarray (make-vector 29 0)) -(defvar vm-mail-mode-map-parented nil) -(defvar vm-xface-cache (make-vector 29 0)) -(defconst vm-mime-base64-alphabet - (concat - [ - 65 66 67 68 69 70 71 72 73 74 75 76 77 - 78 79 80 81 82 83 84 85 86 87 88 89 90 - 97 98 99 100 101 102 103 104 105 106 107 108 109 - 110 111 112 113 114 115 116 117 118 119 120 121 122 - 48 49 50 51 52 53 54 55 56 57 43 47 - ] - )) -(defconst vm-mime-base64-alphabet-decoding-vector - [ - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 62 0 0 0 63 - 52 53 54 55 56 57 58 59 60 61 0 0 0 0 0 0 - 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - 15 16 17 18 19 20 21 22 23 24 25 0 0 0 0 0 - 0 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 - 41 42 43 44 45 46 47 48 49 50 51 0 0 0 0 0 - ]) - -;;(defconst vm-mime-base64-alphabet-decoding-alist -;; '( -;; ( 65 . 00) ( 66 . 01) ( 67 . 02) ( 68 . 03) ( 69 . 04) ( 70 . 05) -;; ( 71 . 06) ( 72 . 07) ( 73 . 08) ( 74 . 09) ( 75 . 10) ( 76 . 11) -;; ( 77 . 12) ( 78 . 13) ( 79 . 14) ( 80 . 15) ( 81 . 16) ( 82 . 17) -;; ( 83 . 18) ( 84 . 19) ( 85 . 20) ( 86 . 21) ( 87 . 22) ( 88 . 23) -;; ( 89 . 24) ( 90 . 25) ( 97 . 26) ( 98 . 27) ( 99 . 28) (100 . 29) -;; (101 . 30) (102 . 31) (103 . 32) (104 . 33) (105 . 34) (106 . 35) -;; (107 . 36) (108 . 37) (109 . 38) (110 . 39) (111 . 40) (112 . 41) -;; (113 . 42) (114 . 43) (115 . 44) (116 . 45) (117 . 46) (118 . 47) -;; (119 . 48) (120 . 49) (121 . 50) (122 . 51) ( 48 . 52) ( 49 . 53) -;; ( 50 . 54) ( 51 . 55) ( 52 . 56) ( 53 . 57) ( 54 . 58) ( 55 . 59) -;; ( 56 . 60) ( 57 . 61) ( 43 . 62) ( 47 . 63) -;; )) -;; -;;(defvar vm-mime-base64-alphabet-decoding-vector -;; (let ((v (make-vector 123 nil)) -;; (p vm-mime-base64-alphabet-decoding-alist)) -;; (while p -;; (aset v (car (car p)) (cdr (car p))) -;; (setq p (cdr p))) -;; v )) - -(defvar vm-message-garbage-alist nil) -(make-variable-buffer-local 'vm-message-garbage-alist) -(defvar vm-folder-garbage-alist nil) -(make-variable-buffer-local 'vm-folder-garbage-alist) -(defconst vm-mime-header-list '("MIME-Version:" "Content-")) -(defconst vm-mime-mule-charset-to-coding-alist - '( - ("us-ascii" no-conversion) - ("iso-8859-1" no-conversion) - ("iso-8859-2" iso-8859-2) - ("iso-8859-3" iso-8859-3) - ("iso-8859-4" iso-8859-4) - ("iso-8859-5" iso-8859-5) - ("iso-8859-6" iso-8859-6) - ("iso-8859-7" iso-8859-7) - ("iso-8859-8" iso-8859-8) - ("iso-8859-9" iso-8859-9) - ("iso-2022-jp" iso-2022-jp) - ;; probably not correct, but probably better than nothing. - ("iso-2022-jp-2" iso-2022-jp) - ("iso-2022-int-1" iso-2022-int-1) - ("iso-2022-kr" iso-2022-kr) - ("euc-kr" iso-2022-kr) - )) -(defvar vm-mime-mule-charset-to-charset-alist - '( - (latin-iso8859-1 "iso-8859-1") - (latin-iso8859-2 "iso-8859-2") - (latin-iso8859-3 "iso-8859-3") - (latin-iso8859-4 "iso-8859-4") - (cyrillic-iso8859-5 "iso-8859-5") - (arabic-iso8859-6 "iso-8859-6") - (greek-iso8859-7 "iso-8859-7") - (hebrew-iso8859-8 "iso-8859-8") - (latin-iso8859-9 "iso-8859-9") - (japanese-jisx0208 "iso-2022-jp") - (korean-ksc5601 "iso-2022-kr") - (chinese-gb2312 "iso-2022-jp") - (sisheng "iso-2022-jp") - (thai-tis620 "iso-2022-jp") - )) -(defvar vm-mime-mule-coding-to-charset-alist - '( - (iso-2022-8 "iso-2022-jp") - (iso-2022-7-unix "iso-2022-jp") - (iso-2022-7-dos "iso-2022-jp") - (iso-2022-7-mac "iso-2022-jp") - )) -(defconst vm-mime-charset-completion-alist - '( - ("us-ascii") - ("iso-8859-1") - ("iso-8859-2") - ("iso-8859-3") - ("iso-8859-4") - ("iso-8859-5") - ("iso-8859-6") - ("iso-8859-7") - ("iso-8859-8") - ("iso-8859-9") - ("iso-2022-jp") - ("iso-2022-jp-2") - ("iso-2022-int-1") - ("iso-2022-kr") - )) -(defconst vm-mime-type-completion-alist - '( - ("text/plain") - ("text/enriched") - ("text/html") - ("audio/basic") - ("image/jpeg") - ("image/png") - ("image/gif") - ("image/tiff") - ("video/mpeg") - ("application/postscript") - ("application/octet-stream") - ("message/rfc822") - ("message/news") - )) -(defconst vm-mime-encoded-word-regexp - "=\\?\\([^?]+\\)\\?\\([BQ]\\)\\?\\([^?]+\\)\\?=") -;; for MS-DOS and Windows NT -;; nil value means text file -;; t value means binary file -;; presumably it controls whether LF -> CRLF mapping is done -;; when writing to files. -(defvar buffer-file-type) -(defvar vm-frame-list nil) -(if (not (boundp 'shell-command-switch)) - (defvar shell-command-switch "-c")) - -(defconst vm-xemacs-p nil) -(defconst vm-xemacs-mule-p nil) -(defconst vm-fsfemacs-19-p nil) -(defun vm-xemacs-p () vm-xemacs-p) -(defun vm-xemacs-mule-p () vm-xemacs-mule-p) -(defun vm-fsfemacs-19-p () vm-fsfemacs-19-p) -(defun vm-note-emacs-version () - (setq vm-xemacs-p (string-match "XEmacs" emacs-version) - vm-xemacs-mule-p (and vm-xemacs-p (featurep 'mule) - ;; paranoia - (fboundp 'set-file-coding-system)) - vm-fsfemacs-19-p (not vm-xemacs-p))) -(vm-note-emacs-version)
--- a/lisp/vm/vm-version.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -(provide 'vm) - -(provide 'vm-version) - -(defconst vm-version "6.34" - "Version number of VM.") - -(defun vm-version () - "Returns the value of the variable vm-version." - vm-version)
--- a/lisp/vm/vm-virtual.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,631 +0,0 @@ -;;; Virtual folders for VM -;;; Copyright (C) 1990-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-virtual) - -;; This function builds the virtual message list. -;; -;; If the new-messages argument is nil, the message list is -;; derived from the folders listed in the virtual folder -;; definition and selected by the various selectors. The -;; resulting message list is assigned to vm-message-list. -;; -;; If new-messages is non-nil then it is a list of messages to be -;; tried against the selector parts of the virtual folder -;; definition. Matching messages are added to -;; vm-message-list, instead of replacing it. -;; -;; The messages in new-messages must all be in the same real folder. -(defun vm-build-virtual-message-list (new-messages) - (vm-with-virtual-selector-variables - (let ((clauses (cdr vm-virtual-folder-definition)) - (message-set (make-vector 311 0)) - (vbuffer (current-buffer)) - (mirrored vm-virtual-mirror) - (case-fold-search t) - (tail-cons (vm-last vm-message-list)) - (new-message-list nil) - virtual location-vector - message mp folders folder - selectors sel-list selector arglist i - real-buffers-used) - ;; Since there is at most one virtual message in the folder - ;; buffer of a virtual folder, the location data vector (and - ;; the markers in it) of all virtual messages in a virtual - ;; folder is shared. We initialize the vector here if it - ;; hasn't been created already. - (if vm-message-list - (setq location-vector (vm-location-data-of (car vm-message-pointer))) - (setq i 0 - location-vector (make-vector vm-location-data-vector-length nil)) - (while (< i vm-location-data-vector-length) - (aset location-vector i (vm-marker nil)) - (vm-increment i))) - ;; To keep track of the messages in a virtual folder to - ;; prevent duplicates we create and maintain a set that - ;; contain all the real messages. - (setq mp vm-message-list) - (while mp - (intern (vm-message-id-number-of (vm-real-message-of (car mp))) - message-set) - (setq mp (cdr mp))) - ;; now select the messages - (save-excursion - (while clauses - (setq folders (car (car clauses)) - selectors (cdr (car clauses))) - (while folders - (setq folder (car folders)) - (and (stringp folder) - (setq folder (expand-file-name folder vm-folder-directory))) - (and (listp folder) - (setq folder (eval folder))) - (cond - ((null folder) - ;; folder was a s-expr which returned nil - ;; skip it - nil ) - ((and (stringp folder) (file-directory-p folder)) - (setq folders (nconc folders - (vm-delete-backup-file-names - (vm-delete-auto-save-file-names - (vm-delete-directory-file-names - (directory-files folder t nil))))))) - ((or (null new-messages) - ;; If we're assimilating messages into an - ;; existing virtual folder, only allow selectors - ;; that would be normally applied to this folder. - (and (bufferp folder) - (eq (vm-buffer-of (car new-messages)) folder)) - (and (stringp folder) - (eq (vm-buffer-of (car new-messages)) - ;; letter bomb protection - ;; set inhibit-local-variables to t for v18 Emacses - ;; set enable-local-variables to nil - ;; for newer Emacses - (let ((inhibit-local-variables t) - (enable-local-variables nil)) - (find-file-noselect folder))))) - (set-buffer (or (and (bufferp folder) folder) - (vm-get-file-buffer folder) - (let ((inhibit-local-variables t) - (enable-local-variables nil)) - (find-file-noselect folder)))) - (if (eq major-mode 'vm-virtual-mode) - (setq virtual t - real-buffers-used - (append vm-real-buffers real-buffers-used)) - (setq virtual nil) - (if (not (memq (current-buffer) real-buffers-used)) - (setq real-buffers-used (cons (current-buffer) - real-buffers-used))) - (if (not (eq major-mode 'vm-mode)) - (vm-mode))) - ;; change (sexpr) into ("/file" "/file2" ...) - ;; this assumes that there will never be (sexpr sexpr2) - ;; in a virtual folder spec. - (if (bufferp folder) - (if virtual - (setcar (car clauses) - (delq nil - (mapcar 'buffer-file-name vm-real-buffers))) - (if buffer-file-name - (setcar (car clauses) (list buffer-file-name))))) - ;; if new-messages non-nil use it instead of the - ;; whole message list - (setq mp (or new-messages vm-message-list)) - (while mp - (if (and (not (intern-soft - (vm-message-id-number-of - (vm-real-message-of (car mp))) - message-set)) - (if virtual - (save-excursion - (set-buffer - (vm-buffer-of - (vm-real-message-of - (car mp)))) - (apply 'vm-vs-or (car mp) selectors)) - (apply 'vm-vs-or (car mp) selectors))) - (progn - (intern - (vm-message-id-number-of - (vm-real-message-of (car mp))) - message-set) - (setq message (copy-sequence - (vm-real-message-of (car mp)))) - (if mirrored - () - (vm-set-mirror-data-of - message - (make-vector vm-mirror-data-vector-length nil)) - (vm-set-virtual-messages-sym-of - message (make-symbol "<v>")) - (vm-set-virtual-messages-of message nil) - (vm-set-attributes-of - message - (make-vector vm-attributes-vector-length nil))) - (vm-set-location-data-of message location-vector) - (vm-set-softdata-of - message - (make-vector vm-softdata-vector-length nil)) - (vm-set-real-message-sym-of - message - (vm-real-message-sym-of (car mp))) - (vm-set-message-type-of message vm-folder-type) - (vm-set-message-id-number-of message - vm-message-id-number) - (vm-increment vm-message-id-number) - (vm-set-buffer-of message vbuffer) - (vm-set-reverse-link-sym-of message (make-symbol "<--")) - (vm-set-reverse-link-of message tail-cons) - (if (null tail-cons) - (setq new-message-list (list message) - tail-cons new-message-list) - (setcdr tail-cons (list message)) - (if (null new-message-list) - (setq new-message-list (cdr tail-cons))) - (setq tail-cons (cdr tail-cons))))) - (setq mp (cdr mp))))) - (setq folders (cdr folders))) - (setq clauses (cdr clauses)))) - ;; this doesn't need to work currently, but it might someday - ;; (if virtual - ;; (setq real-buffers-used (vm-delete-duplicates real-buffers-used))) - (vm-increment vm-modification-counter) - ;; Until this point the user doesn't really have a virtual - ;; folder, as the virtual messages haven't been linked to the - ;; real messages, virtual buffers to the real buffers, and no - ;; message list has been installed. - ;; - ;; Now we tie it all together, with this section of code being - ;; uninterruptible. - (let ((inhibit-quit t) - (label-obarray vm-label-obarray)) - (if (null vm-real-buffers) - (setq vm-real-buffers real-buffers-used)) - (save-excursion - (while real-buffers-used - (set-buffer (car real-buffers-used)) - ;; inherit the global label lists of all the associated - ;; real folders. - (mapatoms (function (lambda (x) (intern (symbol-name x) - label-obarray))) - vm-label-obarray) - (if (not (memq vbuffer vm-virtual-buffers)) - (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers))) - (setq real-buffers-used (cdr real-buffers-used)))) - (setq mp new-message-list) - (while mp - (vm-set-virtual-messages-of - (vm-real-message-of (car mp)) - (cons (car mp) (vm-virtual-messages-of (car mp)))) - (setq mp (cdr mp))) - (if vm-message-list - (progn - (vm-set-summary-redo-start-point new-message-list) - (vm-set-numbering-redo-start-point new-message-list)) - (vm-set-summary-redo-start-point t) - (vm-set-numbering-redo-start-point t) - (setq vm-message-list new-message-list)))))) - -(defun vm-create-virtual-folder (selector &optional arg read-only) - "Create a new virtual folder from messages in the current folder. -The messages will be chosen by applying the selector you specify, -which is normally read from the minibuffer. - -Prefix arg means the new virtual folder should be visited read only." - (interactive - (let ((last-command last-command) - (this-command this-command) - (prefix current-prefix-arg)) - (vm-select-folder-buffer) - (nconc (vm-read-virtual-selector "Create virtual folder of messages: ") - (list prefix)))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let (vm-virtual-folder-alist name) - (if arg - (setq name (format "%s %s %s" (buffer-name) selector arg)) - (setq name (format "%s %s" (buffer-name) selector))) - (setq vm-virtual-folder-alist - (list - (list name - (list (list (list 'get-buffer (buffer-name))) - (if arg (list selector arg) (list selector)))))) - (vm-visit-virtual-folder name read-only)) - ;; have to do this again here because the known virtual - ;; folder menu is now hosed because we installed it while - ;; vm-virtual-folder-alist was bound to the temp value above - (if vm-use-menus - (vm-menu-install-known-virtual-folders-menu))) - - -(defun vm-apply-virtual-folder (name &optional read-only) - "Apply the selectors of a named virtual folder to the current folder -and create a virtual folder containing the selected messages. - -Prefix arg means the new virtual folder should be visited read only." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (list - (completing-read "Apply this virtual folder's selectors: " - vm-virtual-folder-alist nil t) - current-prefix-arg))) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((vfolder (assoc name vm-virtual-folder-alist)) - clauses vm-virtual-folder-alist) - (or vfolder (error "No such virtual folder, %s" name)) - (setq vfolder (vm-copy vfolder)) - (setq clauses (cdr vfolder)) - (while clauses - (setcar (car clauses) (list (list 'get-buffer (buffer-name)))) - (setq clauses (cdr clauses))) - (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder))) - (setq vm-virtual-folder-alist (list vfolder)) - (vm-visit-virtual-folder (car vfolder) read-only)) - ;; have to do this again here because the known virtual - ;; folder menu is now hosed because we installed it while - ;; vm-virtual-folder-alist was bound to the temp value above - (if vm-use-menus - (vm-menu-install-known-virtual-folders-menu))) - -(defun vm-toggle-virtual-mirror () - (interactive) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (if (not (eq major-mode 'vm-virtual-mode)) - (error "This is not a virtual folder.")) - (let ((mp vm-message-list) - (inhibit-quit t) - modified undo-list) - (setq undo-list vm-saved-undo-record-list - vm-saved-undo-record-list vm-undo-record-list - vm-undo-record-list undo-list - vm-undo-record-pointer undo-list) - (setq modified vm-saved-buffer-modified-p - vm-saved-buffer-modified-p (buffer-modified-p)) - (set-buffer-modified-p modified) - (if vm-virtual-mirror - (while mp - (vm-set-attributes-of - (car mp) (or (vm-saved-virtual-attributes-of (car mp)) - (make-vector vm-attributes-vector-length nil))) - (vm-set-mirror-data-of - (car mp) (or (vm-saved-virtual-mirror-data-of (car mp)) - (make-vector vm-mirror-data-vector-length nil))) - (vm-mark-for-summary-update (car mp) t) - (setq mp (cdr mp))) - (while mp - ;; mark for summary update _before_ we set this message to - ;; be mirrored. this will prevent the real message and - ;; the other messages that will share attributes with - ;; this message from having their summaries - ;; updated... they don't need it. - (vm-mark-for-summary-update (car mp) t) - (vm-set-saved-virtual-attributes-of - (car mp) (vm-attributes-of (car mp))) - (vm-set-saved-virtual-mirror-data-of - (car mp) (vm-mirror-data-of (car mp))) - (vm-set-attributes-of - (car mp) (vm-attributes-of (vm-real-message-of (car mp)))) - (vm-set-mirror-data-of - (car mp) (vm-mirror-data-of (vm-real-message-of (car mp)))) - (setq mp (cdr mp)))) - (setq vm-virtual-mirror (not vm-virtual-mirror)) - (vm-increment vm-modification-counter)) - (vm-update-summary-and-mode-line) - (message "Virtual folder now %s the underlying real folder%s." - (if vm-virtual-mirror "mirrors" "does not mirror") - (if (cdr vm-real-buffers) "s" ""))) - -(defun vm-virtual-help () - (interactive) - (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help)) - (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror")) - -(defun vm-vs-or (m &rest selectors) - (let ((result nil) selector arglist) - (while selectors - (setq selector (car (car selectors)) - arglist (cdr (car selectors)) - result (apply (symbol-value selector) m arglist) - selectors (if result nil (cdr selectors)))) - result )) - -(defun vm-vs-and (m &rest selectors) - (let ((result t) selector arglist) - (while selectors - (setq selector (car (car selectors)) - arglist (cdr (car selectors)) - result (apply (symbol-value selector) m arglist) - selectors (if (null result) nil (cdr selectors)))) - result )) - -(defun vm-vs-not (m arg) - (let ((selector (car arg)) - (arglist (cdr arg))) - (not (apply (symbol-value selector) m arglist)))) - -(defun vm-vs-any (m) t) - -(defun vm-vs-author (m arg) - (or (string-match arg (vm-su-full-name m)) - (string-match arg (vm-su-from m)))) - -(defun vm-vs-recipient (m arg) - (or (string-match arg (vm-su-to m)) - (string-match arg (vm-su-to-names m)))) - -(defun vm-vs-subject (m arg) - (string-match arg (vm-su-subject m))) - -(defun vm-vs-sent-before (m arg) - (string< (vm-so-sortable-datestring m) (vm-timezone-make-date-sortable arg))) - -(defun vm-vs-sent-after (m arg) - (string< (vm-timezone-make-date-sortable arg) (vm-so-sortable-datestring m))) - -(defun vm-vs-header (m arg) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-headers-of (vm-real-message-of m))) - (re-search-forward arg (vm-text-of (vm-real-message-of m)) t)))) - -(defun vm-vs-label (m arg) - (vm-member arg (vm-labels-of m))) - -(defun vm-vs-text (m arg) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-text-of (vm-real-message-of m))) - (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t)))) - -(defun vm-vs-more-chars-than (m arg) - (> (string-to-int (vm-su-byte-count m)) arg)) - -(defun vm-vs-less-chars-than (m arg) - (< (string-to-int (vm-su-byte-count m)) arg)) - -(defun vm-vs-more-lines-than (m arg) - (> (string-to-int (vm-su-line-count m)) arg)) - -(defun vm-vs-less-lines-than (m arg) - (< (string-to-int (vm-su-line-count m)) arg)) - -(defun vm-vs-new (m) (vm-new-flag m)) -(defun vm-vs-unread (m) (vm-unread-flag m)) -(defun vm-vs-read (m) (not (or (vm-new-flag m) (vm-unread-flag m)))) -(defun vm-vs-deleted (m) (vm-deleted-flag m)) -(defun vm-vs-replied (m) (vm-replied-flag m)) -(defun vm-vs-forwarded (m) (vm-forwarded-flag m)) -(defun vm-vs-filed (m) (vm-filed-flag m)) -(defun vm-vs-written (m) (vm-written-flag m)) -(defun vm-vs-marked (m) (vm-mark-of m)) -(defun vm-vs-edited (m) (vm-edited-flag m)) - -(put 'header 'vm-virtual-selector-clause "with header matching") -(put 'label 'vm-virtual-selector-clause "with label of") -(put 'text 'vm-virtual-selector-clause "with text matching") -(put 'recipient 'vm-virtual-selector-clause "with recipient matching") -(put 'author 'vm-virtual-selector-clause "with author matching") -(put 'subject 'vm-virtual-selector-clause "with subject matching") -(put 'sent-before 'vm-virtual-selector-clause "sent before") -(put 'sent-after 'vm-virtual-selector-clause "sent after") -(put 'more-chars-than 'vm-virtual-selector-clause - "with more characters than") -(put 'less-chars-than 'vm-virtual-selector-clause - "with less characters than") -(put 'more-lines-than 'vm-virtual-selector-clause "with more lines than") -(put 'less-lines-than 'vm-virtual-selector-clause "with less lines than") - -(defun vm-read-virtual-selector (prompt) - (let (selector (arg nil)) - (setq selector - (vm-read-string prompt vm-supported-interactive-virtual-selectors) - selector (intern selector)) - (if (memq selector '(header label text recipient - author subject - sent-before sent-after - more-chars-than more-lines-than - less-chars-than less-lines-than)) - (progn - (setq prompt (concat (substring prompt 0 -2) " " - (get selector 'vm-virtual-selector-clause) - ": ")) - (cond ((memq selector '(more-chars-than more-lines-than - less-chars-than less-lines-than)) - (setq arg (vm-read-number prompt))) - ((eq selector 'label) - (let ((vm-completion-auto-correct nil) - (completion-ignore-case t)) - (setq arg (downcase - (vm-read-string - prompt - (vm-obarray-to-string-list - vm-label-obarray) - nil))))) - (t (setq arg (read-string prompt)))))) - (or (fboundp (intern (concat "vm-vs-" (symbol-name selector)))) - (error "Invalid selector")) - (list selector arg))) - -;; clear away links between real and virtual folders when -;; a vm-quit is performed in either type folder. -(defun vm-virtual-quit () - (save-excursion - (cond ((eq major-mode 'vm-virtual-mode) - ;; don't trust blindly, user might have killed some of - ;; these buffers. - (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) - (let ((bp vm-real-buffers) - (mp vm-message-list) - (b (current-buffer)) - ;; lock out interrupts here - (inhibit-quit t)) - (while bp - (set-buffer (car bp)) - (setq vm-virtual-buffers (delq b vm-virtual-buffers) - bp (cdr bp))) - (while mp - (vm-set-virtual-messages-of - (vm-real-message-of (car mp)) - (delq (car mp) (vm-virtual-messages-of - (vm-real-message-of (car mp))))) - (setq mp (cdr mp))))) - ((eq major-mode 'vm-mode) - ;; don't trust blindly, user might have killed some of - ;; these buffers. - (setq vm-virtual-buffers - (vm-delete 'buffer-name vm-virtual-buffers t)) - (let ((bp vm-virtual-buffers) - (mp vm-message-list) - vmp - (b (current-buffer)) - ;; lock out interrupts here - (inhibit-quit t)) - (while mp - (setq vmp (vm-virtual-messages-of (car mp))) - (while vmp - ;; we'll clear these messages from the virtual - ;; folder by looking for messages that have a "Q" - ;; id number associated with them. - (vm-set-message-id-number-of (car vmp) "Q") - (setq vmp (cdr vmp))) - (vm-set-virtual-messages-of (car mp) nil) - (setq mp (cdr mp))) - (while bp - (set-buffer (car bp)) - (setq vm-real-buffers (delq b vm-real-buffers)) - ;; set the message pointer to a new value if it is - ;; now invalid. - (cond - ((and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (vm-garbage-collect-message) - (setq vmp vm-message-pointer) - (while (and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (setq vm-message-pointer - (cdr vm-message-pointer))) - ;; if there were no good messages ahead, try going - ;; backward. - (if (null vm-message-pointer) - (progn - (setq vm-message-pointer vmp) - (while (and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (setq vm-message-pointer - (vm-reverse-link-of - (car vm-message-pointer)))))))) - ;; expunge the virtual messages associated with - ;; real messages that are going away. - (setq vm-message-list - (vm-delete (function - (lambda (m) - (equal "Q" (vm-message-id-number-of m)))) - vm-message-list nil)) - (if (null vm-message-pointer) - (setq vm-message-pointer vm-message-list)) - ;; same for vm-last-message-pointer - (if (null vm-last-message-pointer) - (setq vm-last-message-pointer nil)) - (vm-clear-virtual-quit-invalidated-undos) - (vm-reverse-link-messages) - (vm-set-numbering-redo-start-point t) - (vm-set-summary-redo-start-point t) - (if vm-message-pointer - (vm-preview-current-message) - (vm-update-summary-and-mode-line)) - (setq bp (cdr bp)))))))) - -(defun vm-virtual-save-folder (prefix) - (save-excursion - ;; don't trust blindly, user might have killed some of - ;; these buffers. - (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) - (let ((bp vm-real-buffers)) - (while bp - (set-buffer (car bp)) - (vm-save-folder prefix) - (setq bp (cdr bp))))) - (vm-set-buffer-modified-p nil) - (vm-clear-modification-flag-undos) - (vm-update-summary-and-mode-line)) - -(defun vm-virtual-get-new-mail () - (save-excursion - ;; don't trust blindly, user might have killed some of - ;; these buffers. - (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) - (let ((bp vm-real-buffers)) - (while bp - (set-buffer (car bp)) - (condition-case error-data - (vm-get-new-mail) - (folder-read-only - (message "Folder is read only: %s" - (or buffer-file-name (buffer-name))) - (sit-for 1)) - (unrecognized-folder-type - (message "Folder type is unrecognized: %s" - (or buffer-file-name (buffer-name))) - (sit-for 1))) - (setq bp (cdr bp))))) - (vm-emit-totals-blurb)) - -(defun vm-make-virtual-copy (m) - (widen) - (let ((virtual-buffer (current-buffer)) - (real-m (vm-real-message-of m)) - (buffer-read-only nil) - (modified (buffer-modified-p))) - (unwind-protect - (save-excursion - (set-buffer (vm-buffer-of real-m)) - (save-restriction - (widen) - ;; must reference this now so that headers will be in - ;; their final position before the message is copied. - ;; otherwise the vheader offset computed below will be wrong. - (vm-vheaders-of real-m) - (copy-to-buffer virtual-buffer (vm-start-of real-m) - (vm-end-of real-m)))) - (set-buffer-modified-p modified)) - (set-marker (vm-start-of m) (point-min)) - (set-marker (vm-headers-of m) (+ (vm-start-of m) - (- (vm-headers-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-vheaders-of m) (+ (vm-start-of m) - (- (vm-vheaders-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-text-of m) (+ (vm-start-of m) (- (vm-text-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-text-end-of m) (+ (vm-start-of m) - (- (vm-text-end-of real-m) - (vm-start-of real-m)))) - (set-marker (vm-end-of m) (+ (vm-start-of m) (- (vm-end-of real-m) - (vm-start-of real-m))))))
--- a/lisp/vm/vm-window.el Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,645 +0,0 @@ -;;; Window management code for VM -;;; Copyright (C) 1989-1997 Kyle E. Jones -;;; -;;; This program 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 1, or (at your option) -;;; any later version. -;;; -;;; This program 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 this program; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(provide 'vm-window) - -(defun vm-display (buffer display commands configs - &optional do-not-raise) -;; the clearinghouse VM display function. -;; -;; First arg BUFFER non-nil is a buffer to display or undisplay. -;; nil means there is no request to display or undisplay a -;; buffer. -;; -;; Second arg DISPLAY non-nil means to display the buffer, nil means -;; to undisplay it. This function guarantees to display the -;; buffer if requested. Undisplay is not guaranteed. -;; -;; Third arg COMMANDS is a list of symbols. this-command must -;; match one of these symbols for a window configuration to be -;; applied. -;; -;; Fourth arg CONFIGS is a list of window configurations to try. -;; vm-set-window-configuration will step through the list looking -;; for an existing configuration, and apply the one it finds. -;; -;; Display is done this way: -;; 1. if the buffer is visible in an invisible frame, make that frame visible -;; 2. if the buffer is already displayed, quit -;; 3. if vm-display-buffer-hook in non-nil -;; run the hooks -;; use the selected window/frame to display the buffer -;; quit -;; 4. apply a window configuration -;; if the buffer is displayed now, quit -;; 5. call vm-display-buffer which will display the buffer. -;; -;; Undisplay is done this way: -;; 1. if the buffer is not displayed, quit -;; 2. if vm-undisplay-buffer-hook is non-nil -;; run the hooks -;; quit -;; 3. apply a window configuration -;; 4, if a window configuration was applied -;; quit -;; 5. call vm-undisplay-buffer which will make the buffer -;; disappear from at least one window/frame. -;; -;; If display/undisplay is not requested, only window -;; configuration is done, and only then if the value of -;; this-command is found in the COMMANDS list. - (vm-save-buffer-excursion - (let* ((w (and buffer (vm-get-buffer-window buffer))) - (wf (and w (vm-window-frame w)))) - (and buffer (set-buffer buffer)) - (if (and w display (not do-not-raise)) - (vm-raise-frame wf)) - (if (and w display (not (eq (vm-selected-frame) wf))) - (vm-select-frame wf)) - (cond ((and buffer display) - (if (and vm-display-buffer-hook - (null (vm-get-visible-buffer-window buffer))) - (progn (run-hooks 'vm-display-buffer-hook) - (switch-to-buffer buffer)) - (if (not (and (memq this-command commands) - (apply 'vm-set-window-configuration configs) - (vm-get-visible-buffer-window buffer))) - (vm-display-buffer buffer)))) - ((and buffer (not display)) - (if (and vm-undisplay-buffer-hook - (vm-get-visible-buffer-window buffer)) - (progn (set-buffer buffer) - (run-hooks 'vm-undisplay-buffer-hook)) - (if (not (and (memq this-command commands) - (apply 'vm-set-window-configuration configs))) - (vm-undisplay-buffer buffer)))) - ((memq this-command commands) - (apply 'vm-set-window-configuration configs)))))) - -(defun vm-display-buffer (buffer) - (let ((pop-up-windows (eq vm-mutable-windows t)) - (pop-up-frames (and pop-up-frames vm-mutable-frames))) - (if (or pop-up-frames - (and (eq vm-mutable-windows t) - (symbolp - (vm-buffer-to-label - (window-buffer - (selected-window)))))) - (select-window (display-buffer buffer)) - (switch-to-buffer buffer)))) - -(defun vm-undisplay-buffer (buffer) - (vm-save-buffer-excursion - (let ((vm-mutable-frames (and vm-mutable-frames pop-up-frames))) - (vm-maybe-delete-windows-or-frames-on buffer)) - (let (w) - (while (setq w (vm-get-buffer-window buffer)) - (set-window-buffer w (other-buffer buffer)))))) - -(defun vm-load-window-configurations (file) - (save-excursion - (let ((work-buffer nil)) - (unwind-protect - (progn - (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) - (erase-buffer) - (setq vm-window-configurations - (condition-case () - (progn - (insert-file-contents file) - (read (current-buffer))) - (error nil)))) - (and work-buffer (kill-buffer work-buffer)))))) - -(defun vm-store-window-configurations (file) - (save-excursion - (let ((work-buffer nil)) - (unwind-protect - (progn - (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) - ;; for XEmacs/MULE - (and vm-xemacs-mule-p - (set-buffer-file-coding-system 'no-conversion)) - (erase-buffer) - (print vm-window-configurations (current-buffer)) - (write-region (point-min) (point-max) file nil 0)) - (and work-buffer (kill-buffer work-buffer)))))) - -(defun vm-set-window-configuration (&rest tags) - (catch 'done - (if (not vm-mutable-windows) - (throw 'done nil)) - (let ((nonexistent " *vm-nonexistent*") - (nonexistent-summary " *vm-nonexistent-summary*") - (selected-frame (vm-selected-frame)) - summary message composition edit config) - (while (and tags (null config)) - (setq config (assq (car tags) vm-window-configurations) - tags (cdr tags))) - (or config (setq config (assq 'default vm-window-configurations))) - (or config (throw 'done nil)) - (setq config (vm-copy config)) - (setq composition (vm-find-composition-buffer t)) - (cond ((eq major-mode 'vm-summary-mode) - (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) - (throw 'done nil) - (setq summary (current-buffer)) - (setq message vm-mail-buffer))) - ((eq major-mode 'vm-mode) - (setq message (current-buffer))) - ((eq major-mode 'vm-presentation-mode) - (setq message vm-mail-buffer)) - ((eq major-mode 'vm-virtual-mode) - (setq message (current-buffer))) - ((eq major-mode 'mail-mode) - (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) - (throw 'done nil) - (setq message vm-mail-buffer - ;; assume that the proximity implies affinity - composition (current-buffer)))) - ((eq vm-system-state 'editing) - (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) - (throw 'done nil) - (setq edit (current-buffer)) - (setq message vm-mail-buffer))) - ;; not in a VM related buffer, bail... - (t (throw 'done nil))) - (set-buffer message) - (vm-check-for-killed-presentation) - (if vm-presentation-buffer - (setq message vm-presentation-buffer)) - (vm-check-for-killed-summary) - (or summary (setq summary (or vm-summary-buffer nonexistent-summary))) - (or composition (setq composition nonexistent)) - (or edit (setq edit nonexistent)) - (tapestry-replace-tapestry-element (nth 1 config) 'buffer-name - (function - (lambda (x) - (if (symbolp x) - (symbol-value x) - x )))) - (set-tapestry (nth 1 config) 1) - (and (get-buffer nonexistent) - (vm-maybe-delete-windows-or-frames-on nonexistent)) - (if (and (vm-get-buffer-window nonexistent-summary) - (not (vm-get-buffer-window message))) - ;; user asked for summary to be displayed but doesn't - ;; have one, nor is the folder buffer displayed. Help - ;; the user not to lose here. - (vm-replace-buffer-in-windows nonexistent-summary message) - (and (get-buffer nonexistent-summary) - (vm-maybe-delete-windows-or-frames-on nonexistent-summary))) - config ))) - -(defun vm-save-window-configuration (tag) - "Name and save the current window configuration. -With this command you associate the current window setup with an -action. Each time you perform this action VM will duplicate this -window setup. - -Nearly every VM command can have a window configuration -associated with it. VM also allows some category configurations, -`startup', `reading-message', `composing-message', `editing-message', -`marking-message' and `searching-message' for the commands that -do these things. There is also a `default' configuration that VM -will use if no other configuration is applicable. Command -specific configurations are searched for first, then the category -configurations and then the default configuration. The first -configuration found is the one that is applied. - -The value of vm-mutable-windows must be non-nil for VM to use -window configurations." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (if (null vm-window-configuration-file) - (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) - (list - (intern - (completing-read "Name this window configuration: " - vm-supported-window-configurations - 'identity t))))) - (if (null vm-window-configuration-file) - (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) - (let (map p) - (setq map (tapestry (list (vm-selected-frame)))) - ;; set frame map to nil since we don't use it. this prevents - ;; cursor objects and any other objects that have an - ;; "unreadable" read syntax appearing in the window - ;; configuration file by way of frame-parameters. - (setcar map nil) - (tapestry-replace-tapestry-element map 'buffer-name 'vm-buffer-to-label) - (tapestry-nullify-tapestry-elements map t nil t t t nil) - (setq p (assq tag vm-window-configurations)) - (if p - (setcar (cdr p) map) - (setq vm-window-configurations - (cons (list tag map) vm-window-configurations))) - (vm-store-window-configurations vm-window-configuration-file) - (message "%s configuration recorded" tag))) - -(defun vm-buffer-to-label (buf) - (save-excursion - (set-buffer buf) - (cond ((eq major-mode 'vm-summary-mode) - 'summary) - ((eq major-mode 'mail-mode) - 'composition) - ((eq major-mode 'vm-mode) - 'message) - ((eq major-mode 'vm-virtual-mode) - 'message) - ((eq vm-system-state 'editing) - 'edit) - (t buf)))) - -(defun vm-delete-window-configuration (tag) - "Delete the configuration saved for a particular action. -This action will no longer have an associated window configuration. -The action will be read from the minibuffer." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (if (null vm-window-configuration-file) - (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) - (list - (intern - (completing-read "Delete window configuration: " - (mapcar (function - (lambda (x) - (list (symbol-name (car x))))) - vm-window-configurations) - 'identity t))))) - (if (null vm-window-configuration-file) - (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) - (let (p) - (setq p (assq tag vm-window-configurations)) - (if p - (if (eq p (car vm-window-configurations)) - (setq vm-window-configurations (cdr vm-window-configurations)) - (setq vm-window-configurations (delq p vm-window-configurations))) - (error "No window configuration set for %s" tag))) - (vm-store-window-configurations vm-window-configuration-file) - (message "%s configuration deleted" tag)) - -(defun vm-apply-window-configuration (tag) - "Change the current window configuration to be one -associated with a particular action. The action will be read -from the minibuffer." - (interactive - (let ((last-command last-command) - (this-command this-command)) - (list - (intern - (completing-read "Apply window configuration: " - (mapcar (function - (lambda (x) - (list (symbol-name (car x))))) - vm-window-configurations) - 'identity t))))) - (vm-set-window-configuration tag)) - -(defun vm-window-help () - (interactive) - (message "WS = save configuration, WD = delete configuration, WW = apply configuration")) - -(defun vm-iconify-frame () - "Iconify the current frame. -Run the hooks in vm-iconify-frame-hook before doing so." - (interactive) - (vm-check-for-killed-summary) - (vm-select-folder-buffer) - (if (vm-multiple-frames-possible-p) - (progn - (run-hooks 'vm-iconify-frame-hook) - (vm-iconify-frame-xxx)))) - -(defun vm-window-loop (action obj-1 &optional obj-2) - (let ((delete-me nil) - (done nil) - (all-frames (if vm-search-other-frames t nil)) - start w) - (setq start (next-window (selected-window) 'nomini all-frames) - w start) - (and obj-1 (setq obj-1 (get-buffer obj-1))) - (while (not done) - (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini)))) - (progn - (delete-window delete-me) - (if (eq delete-me start) - (setq start nil)) - (setq delete-me nil))) - (cond ((and (eq action 'delete) (eq obj-1 (window-buffer w))) - ;; a deleted window has no next window, so we - ;; defer the deletion until after we've moved - ;; to the next window. - (setq delete-me w)) - ((and (eq action 'replace) (eq obj-1 (window-buffer w))) - (set-window-buffer w obj-2))) - (setq done (eq start - (setq w - (condition-case nil - (next-window w 'nomini all-frames) - (wrong-number-of-arguments - (next-window w 'nomini)))))) - (if (null start) - (setq start w))) - (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini)))) - (delete-window delete-me)))) - -(defun vm-frame-loop (action obj-1) - (if (fboundp 'vm-next-frame) - (let ((start (vm-next-frame (vm-selected-frame))) - (delete-me nil) - (done nil) - f) - (setq f start) - (and obj-1 (setq obj-1 (get-buffer obj-1))) - (while (not done) - (if delete-me - (progn - (condition-case nil - (progn - (if (vm-created-this-frame-p delete-me) - (vm-delete-frame delete-me)) - (if (eq delete-me start) - (setq start nil))) - (error nil)) - (setq delete-me nil))) - (cond ((and (eq action 'delete) - ;; one-window-p doesn't take a frame argument - (eq (next-window (vm-frame-selected-window f) 'nomini) - (previous-window (vm-frame-selected-window f) - 'nomini)) - ;; the next-window call is to avoid looking - ;; at the minibuffer window - (eq obj-1 (window-buffer - (next-window - (vm-frame-selected-window f) - 'nomini)))) - ;; a deleted frame has no next frame, so we - ;; defer the deletion until after we've moved - ;; to the next frame. - (setq delete-me f)) - ((eq action 'bury) - (bury-buffer obj-1))) - (setq done (eq start (setq f (vm-next-frame f)))) - (if (null start) - (setq start f))) - (if delete-me - (progn - (vm-error-free-call 'vm-delete-frame delete-me) - (setq delete-me nil)))))) - -(defun vm-maybe-delete-windows-or-frames-on (buffer) - (and (eq vm-mutable-windows t) (vm-window-loop 'delete buffer)) - (and vm-mutable-frames (vm-frame-loop 'delete buffer))) - -(defun vm-replace-buffer-in-windows (old new) - (vm-window-loop 'replace old new)) - -(defun vm-bury-buffer (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (if vm-xemacs-p - (if (vm-multiple-frames-possible-p) - (vm-frame-loop 'bury buffer) - (bury-buffer buffer)) - (bury-buffer buffer))) - -(defun vm-unbury-buffer (buffer) - (save-excursion - (save-window-excursion - (switch-to-buffer buffer)))) - -(defun vm-get-buffer-window (buffer) - (condition-case nil - (or (get-buffer-window buffer nil nil) - (and vm-search-other-frames - (get-buffer-window buffer t t))) - (wrong-number-of-arguments - (condition-case nil - (or (get-buffer-window buffer nil) - (and vm-search-other-frames - (get-buffer-window buffer t))) - (wrong-number-of-arguments - (get-buffer-window buffer)))))) - -(defun vm-get-visible-buffer-window (buffer) - (condition-case nil - (or (get-buffer-window buffer nil nil) - (and vm-search-other-frames - (get-buffer-window buffer t nil))) - (wrong-number-of-arguments - (condition-case nil - (or (get-buffer-window buffer nil) - (and vm-search-other-frames - (get-buffer-window buffer 'visible))) - (wrong-number-of-arguments - (get-buffer-window buffer)))))) - -(defun vm-set-hooks-for-frame-deletion () - (make-local-variable 'vm-undisplay-buffer-hook) - (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) - (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) - -(defun vm-created-this-frame-p (&optional frame) - (memq (or frame (vm-selected-frame)) vm-frame-list)) - -(defun vm-delete-buffer-frame () - ;; kludge. we only want to this to run on VM related buffers - ;; but this function is generally on a global hook. Check for - ;; vm-undisplay-buffer-hook set; this is a good sign that this - ;; is a VM buffer. - (if vm-undisplay-buffer-hook - (save-excursion - ;; run once only per buffer. - (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) - (let* ((w (vm-get-visible-buffer-window (current-buffer))) - (b (current-buffer)) - (wf (and w (vm-window-frame w)))) - (and w (eq (vm-selected-frame) wf) (vm-created-this-frame-p wf) - (vm-error-free-call 'vm-delete-frame wf)) - (and w (let ((vm-mutable-frames t)) - (vm-maybe-delete-windows-or-frames-on b))))))) - -(defun vm-register-frame (frame) - (setq vm-frame-list (cons frame vm-frame-list))) - -(defun vm-goto-new-frame (&rest types) - (let ((params nil)) - (while (and types (null params)) - (setq params (car (cdr (assq (car types) vm-frame-parameter-alist))) - types (cdr types))) - ;; these functions might be defined in an Emacs that isn't - ;; running under a window system, but VM always checks for - ;; multi-frame support before calling this function. - (cond ((fboundp 'make-frame) - (select-frame (make-frame params))) - ((fboundp 'make-screen) - (select-screen (make-screen params))) - ((fboundp 'new-screen) - (select-screen (new-screen params)))) - (vm-register-frame (vm-selected-frame)) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-selected-frame))))) - -(defun vm-goto-new-summary-frame-maybe () - (if (and vm-mutable-frames vm-frame-per-summary - (vm-multiple-frames-possible-p)) - (let ((w (vm-get-buffer-window vm-summary-buffer))) - (if (null w) - (progn - (vm-goto-new-frame 'summary) - (vm-set-hooks-for-frame-deletion)) - (save-excursion - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) - -(defun vm-goto-new-folder-frame-maybe (&rest types) - (if (and vm-mutable-frames vm-frame-per-folder - (vm-multiple-frames-possible-p)) - (let ((w (or (vm-get-buffer-window (current-buffer)) - ;; summary == folder for the purpose - ;; of frame reuse. - (and vm-summary-buffer - (vm-get-buffer-window vm-summary-buffer)) - ;; presentation == folder for the purpose - ;; of frame reuse. - (and vm-presentation-buffer - (vm-get-buffer-window vm-presentation-buffer))))) - (if (null w) - (progn - (apply 'vm-goto-new-frame types) - (vm-set-hooks-for-frame-deletion)) - (save-excursion - (select-window w) - (and vm-warp-mouse-to-new-frame - (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) - -(defun vm-warp-mouse-to-frame-maybe (&optional frame) - (or frame (setq frame (vm-selected-frame))) - (if (vm-mouse-support-possible-here-p) - (cond ((vm-mouse-xemacs-mouse-p) - (cond ((fboundp 'mouse-position);; XEmacs 19.12 - (let ((mp (mouse-position))) - (if (and (car mp) - (eq (window-frame (car mp)) (selected-frame))) - nil - (set-mouse-position (frame-highest-window frame) - (/ (frame-width frame) 2) - (/ (frame-height frame) 2))))) - (t ;; XEmacs 19.11 - ;; use (apply 'screen-...) instead of - ;; (screen-...) to avoid stimulating a - ;; byte-compiler bug in Emacs 19.29 that - ;; happens when it encounters 'obsolete' - ;; functions. puke, puke, puke. - (let ((mp (read-mouse-position frame))) - (if (and (>= (car mp) 0) - (<= (car mp) (apply 'screen-width frame)) - (>= (cdr mp) 0) - (<= (cdr mp) (apply 'screen-height frame))) - nil - (set-mouse-position frame - (/ (apply 'screen-width frame) 2) - (/ (apply 'screen-height frame) 2))))))) - ((vm-fsfemacs-19-p) - (let ((mp (mouse-position))) - (if (and (eq (car mp) frame) - ;; nil coordinates mean that the mouse - ;; pointer isn't really within the frame - (car (cdr mp))) - nil - (set-mouse-position frame - (/ (frame-width frame) 2) - (/ (frame-height frame) 2)) - ;; doc for set-mouse-position says to do this - (unfocus-frame))))))) - -(fset 'vm-selected-frame - (symbol-function - (cond ((fboundp 'selected-frame) 'selected-frame) - ((fboundp 'selected-screen) 'selected-screen) - (t 'ignore)))) - -(fset 'vm-delete-frame - (symbol-function - (cond ((fboundp 'delete-frame) 'delete-frame) - ((fboundp 'delete-screen) 'delete-screen) - (t 'ignore)))) - -;; xxx because vm-iconify-frame is a command -(defun vm-iconify-frame-xxx (&optional frame) - (cond ((fboundp 'iconify-frame) - (iconify-frame frame)) - ((fboundp 'iconify-screen) - (iconify-screen (or frame (selected-screen)))))) - -(fset 'vm-raise-frame - (symbol-function - (cond ((fboundp 'raise-frame) 'raise-frame) - ((fboundp 'raise-screen) 'raise-screen) - (t 'ignore)))) - -(fset 'vm-frame-visible-p - (symbol-function - (cond ((fboundp 'frame-visible-p) 'frame-visible-p) - ((fboundp 'screen-visible-p) 'screen-visible-p) - (t 'ignore)))) - -(if (fboundp 'frame-iconified-p) - (fset 'vm-frame-iconified-p 'frame-iconified-p) - (defun vm-frame-iconified-p (&optional frame) - (eq (vm-frame-visible-p frame) 'icon))) - -;; frame-totally-visible-p is broken under XEmacs 19.14 and is -;; absent under Emacs 19.34. So vm-frame-per-summary won't work -;; quite right under these Emacs versions. XEmacs 19.15 should -;; have a working version of this function. -;; 2 April 1997, frame-totally-visible-p apparently still broken -;; under 19.15. I give up for now. -;;(if (and (fboundp 'frame-totally-visible-p) -;; vm-xemacs-p -;; (or (>= emacs-major-version 20) -;; (>= emacs-minor-version 15))) -;; (fset 'vm-frame-totally-visible-p 'frame-totally-visible-p) -;; (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p)) -(fset 'vm-frame-totally-visible-p 'vm-frame-visible-p) - -(fset 'vm-window-frame - (symbol-function - (cond ((fboundp 'window-frame) 'window-frame) - ((fboundp 'window-screen) 'window-screen) - (t 'ignore)))) - -(cond ((fboundp 'next-frame) - (fset 'vm-next-frame (symbol-function 'next-frame)) - (fset 'vm-select-frame (symbol-function 'select-frame)) - (fset 'vm-frame-selected-window - (symbol-function 'frame-selected-window))) - ((fboundp 'next-screen) - (fset 'vm-next-frame (symbol-function 'next-screen)) - (fset 'vm-select-frame (symbol-function 'select-screen)) - (fset 'vm-frame-selected-window - (if (fboundp 'epoch::selected-window) - (symbol-function 'epoch::selected-window) - (symbol-function 'screen-selected-window)))) - (t - ;; it is useful for this to be a no-op, but don't bind the - ;; others. - (fset 'vm-select-frame 'ignore)))
--- a/lisp/x11/custom-load.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/x11/custom-load.el Mon Aug 13 10:03:52 2007 +0200 @@ -1,14 +1,13 @@ ;;; custom-load.el --- automatically extracted custom dependencies -;; Created by SL Baur on Thu Oct 9 20:52:30 1997 ;;; Code: -(custom-put 'menu 'custom-loads '("x-menubar")) -(custom-put 'environment 'custom-loads '("x-toolbar")) -(custom-put 'buffers-menu 'custom-loads '("x-menubar")) -(custom-put 'toolbar 'custom-loads '("x-toolbar")) -(custom-put 'info 'custom-loads '("x-toolbar")) -(custom-put 'x 'custom-loads '("x-font-menu")) +(custom-add-loads 'menu '("x-menubar")) +(custom-add-loads 'environment '("x-toolbar")) +(custom-add-loads 'buffers-menu '("x-menubar")) +(custom-add-loads 'toolbar '("x-toolbar")) +(custom-add-loads 'info '("x-toolbar")) +(custom-add-loads 'x '("x-faces" "x-font-menu")) ;;; custom-load.el ends here
--- a/lisp/x11/x-faces.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/x11/x-faces.el Mon Aug 13 10:03:52 2007 +0200 @@ -169,10 +169,13 @@ If it fails, it returns nil." (try-font-name (x-frob-font-weight font "medium") device)) -(defvar *try-oblique-before-italic-fonts* nil - "*If NIL, italic fonts are searched before oblique fonts. If -non-NIL, oblique fonts are tried before italic fonts. This is mostly -applicable to adobe-courier fonts") +(defcustom *try-oblique-before-italic-fonts* nil + "*If nil, italic fonts are searched before oblique fonts. +If non-nil, oblique fonts are tried before italic fonts. This is mostly +applicable to adobe-courier fonts" + :type 'boolean + :tag "Try Oblique Before Italic Fonts" + :group 'x) (defun x-make-font-italic (font &optional device) "Given an X font specification, this attempts to make an `italic' font.
--- a/lisp/x11/x-menubar.el Mon Aug 13 10:02:48 2007 +0200 +++ b/lisp/x11/x-menubar.el Mon Aug 13 10:03:52 2007 +0200 @@ -155,16 +155,16 @@ ["Sunrise/Sunset" sunrise-sunset t] ) ("Games" - ["Mine Game" xmine t] - ["Tetris" tetris t] - ["Quote from Zippy" yow t] - ["Psychoanalyst" doctor t] - ["Psychoanalyze Zippy!" psychoanalyze-pinhead t] - ["Random Flames" flame t] - ["Dunnet (Adventure)" dunnet t] - ["Towers of Hanoi" hanoi t] - ["Game of Life" life t] - ["Multiplication Puzzle" mpuz t] + ["Mine Game" xmine (fboundp 'xmine)] + ["Tetris" tetris (fboundp 'tetris)] + ["Quote from Zippy" yow (fboundp 'yow)] + ["Psychoanalyst" doctor (fboundp 'doctor)] + ["Psychoanalyze Zippy!" psychoanalyze-pinhead (fboundp 'psychoanalyze-pinhead)] + ["Random Flames" flame (fboundp 'flame)] + ["Dunnet (Adventure)" dunnet (fboundp 'dunnet)] + ["Towers of Hanoi" hanoi (fboundp 'hanoi)] + ["Game of Life" life (fboundp 'life)] + ["Multiplication Puzzle" mpuz (fboundp 'mpuz)] ) ) @@ -402,25 +402,25 @@ (and (integerp font-lock-maximum-decoration) (>= font-lock-maximum-decoration 3))))] "-----" - ["Lazy" (progn (require 'lazy-lock) - (if (and (boundp 'lazy-lock-mode) lazy-lock-mode) + ["Lazy" (progn (require 'lazy-shot) + (if (and (boundp 'lazy-shot-mode) lazy-shot-mode) (progn - (lazy-lock-mode 0) + (lazy-shot-mode 0) ;; this shouldn't be necessary so there has to ;; be a redisplay bug lurking somewhere (or ;; possibly another event handler bug) (redraw-modeline) (remove-hook 'font-lock-mode-hook - 'turn-on-lazy-lock)) + 'turn-on-lazy-shot)) (if font-lock-mode (progn - (lazy-lock-mode 1) + (lazy-shot-mode 1) (redraw-modeline) (add-hook 'font-lock-mode-hook - 'turn-on-lazy-lock))))) + 'turn-on-lazy-shot))))) :active font-lock-mode :style toggle - :selected (and (boundp 'lazy-lock-mode) lazy-lock-mode)] + :selected (and (boundp 'lazy-shot-mode) lazy-shot-mode)] ["Caching" (progn (require 'fast-lock) (if fast-lock-mode (progn @@ -1156,7 +1156,8 @@ '(overwrite-mode 1)) `(setq-default case-fold-search ,(default-value 'case-fold-search)) case-replace - (if pending-delete-mode + (if (and (boundp 'pending-delete-mode) + pending-delete-mode) '(pending-delete-mode 1)) zmacs-regions mouse-yank-at-point @@ -1199,9 +1200,9 @@ '(add-hook 'font-lock-mode-hook 'turn-on-fast-lock) '(remove-hook 'font-lock-mode-hook 'turn-on-fast-lock)) (if (and (boundp 'font-lock-mode-hook) - (memq 'turn-on-lazy-lock font-lock-mode-hook)) - '(add-hook 'font-lock-mode-hook 'turn-on-lazy-lock) - '(remove-hook 'font-lock-mode-hook 'turn-on-lazy-lock)) + (memq 'turn-on-lazy-shot font-lock-mode-hook)) + '(add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) + '(remove-hook 'font-lock-mode-hook 'turn-on-lazy-shot)) ;; Paren Highlighting (if paren-mode @@ -1559,7 +1560,8 @@ (global-set-key 'button3 'popup-mode-menu) ;; shift button3 and shift button2 are reserved for Hyperbole (global-set-key '(meta control button3) 'popup-buffer-menu) -(global-set-key '(meta shift button3) 'popup-menubar-menu) +;; The following command is way too dangerous with Custom. +;; (global-set-key '(meta shift button3) 'popup-menubar-menu) ;; Here's a test of the cool new menu features (from Stig).
--- a/lwlib/xlwmenu.c Mon Aug 13 10:02:48 2007 +0200 +++ b/lwlib/xlwmenu.c Mon Aug 13 10:03:52 2007 +0200 @@ -100,6 +100,10 @@ offset(menu.foreground), XtRString, "XtDefaultForeground"}, {XtNbuttonForeground, XtCButtonForeground, XtRPixel, sizeof(Pixel), offset(menu.button_foreground), XtRString, "XtDefaultForeground"}, + {XtNhighlightForeground, XtCHighlightForeground, XtRPixel, sizeof(Pixel), + offset(menu.highlight_foreground), XtRString, "XtDefaultForeground"}, + {XtNtitleForeground, XtCTitleForeground, XtRPixel, sizeof(Pixel), + offset(menu.title_foreground), XtRString, "XtDefaultForeground"}, {XtNmargin, XtCMargin, XtRDimension, sizeof(Dimension), offset(menu.margin), XtRImmediate, (XtPointer)2}, {XmNmarginWidth, XmCMarginWidth, XmRHorizontalDimension, sizeof(Dimension), @@ -110,9 +114,15 @@ offset(menu.column_spacing), XtRImmediate, (XtPointer)4}, {XmNindicatorSize, XmCIndicatorSize, XtRDimension, sizeof(Dimension), offset(menu.indicator_size), XtRImmediate, (XtPointer)0}, +#if 0 {XmNshadowThickness, XmCShadowThickness, XmRHorizontalDimension, sizeof (Dimension), offset (menu.shadow_thickness), XtRImmediate, (XtPointer) 2}, +#else + {XmNshadowThickness, XmCShadowThickness, XtRDimension, + sizeof (Dimension), offset (menu.shadow_thickness), + XtRImmediate, (XtPointer) 2}, +#endif {XmNselectColor, XmCSelectColor, XtRPixel, sizeof (Pixel), offset (menu.select_color), XtRImmediate, (XtPointer)-1}, {XmNtopShadowColor, XmCTopShadowColor, XtRPixel, sizeof (Pixel), @@ -1549,17 +1559,25 @@ unsigned binding_tab) { int y_offset = mw->menu.shadow_thickness + mw->menu.vertical_margin; + GC gc; if (!label_offset) label_offset = mw->menu.shadow_thickness + mw->menu.horizontal_margin; + if (highlighted && (in_menubar || val->contents)) + gc = mw->menu.highlight_gc; + else if (in_menubar || val->contents) + gc = mw->menu.foreground_gc; + else + gc = mw->menu.title_gc; + /* * Draw the label string. */ string_draw_u (mw, window, x + label_offset, y + y_offset, - mw->menu.foreground_gc, + gc, resource_widget_value (mw, val)); } @@ -1615,7 +1633,14 @@ if (!label_offset) label_offset = mw->menu.shadow_thickness + mw->menu.horizontal_margin; - if (menu_pb) + if (highlighted) + { + if (val->enabled) + gc = mw->menu.highlight_gc; + else + gc = mw->menu.inactive_button_gc; + } + else if (menu_pb) { if (val->enabled) gc = mw->menu.button_gc; @@ -1779,6 +1804,13 @@ if (rv > (mw->menu.font_ascent+mw->menu.font_descent)) rv = mw->menu.font_ascent+mw->menu.font_descent; + /* + * radio button can't be smaller than its border or a filling + * error will occur. + */ + if (rv < 2 * mw->menu.shadow_thickness) + rv = 2 * mw->menu.shadow_thickness; + return rv; } @@ -2650,6 +2682,14 @@ (flags | GCFillStyle | GCStipple), &xgcv); + xgcv.foreground = mw->menu.highlight_foreground; + xgcv.background = mw->core.background_pixel; + mw->menu.highlight_gc = XtGetGC ((Widget)mw, flags, &xgcv); + + xgcv.foreground = mw->menu.title_foreground; + xgcv.background = mw->core.background_pixel; + mw->menu.title_gc = XtGetGC ((Widget)mw, flags, &xgcv); + xgcv.foreground = mw->menu.button_foreground; xgcv.background = mw->core.background_pixel; mw->menu.button_gc = XtGetGC ((Widget)mw, flags, &xgcv); @@ -2666,6 +2706,8 @@ { XtReleaseGC ((Widget) mw, mw->menu.foreground_gc); XtReleaseGC ((Widget) mw, mw->menu.button_gc); + XtReleaseGC ((Widget) mw, mw->menu.highlight_gc); + XtReleaseGC ((Widget) mw, mw->menu.title_gc); XtReleaseGC ((Widget) mw, mw->menu.inactive_gc); XtReleaseGC ((Widget) mw, mw->menu.inactive_button_gc); XtReleaseGC ((Widget) mw, mw->menu.background_gc); @@ -2673,6 +2715,8 @@ /* let's get some segvs if we try to use these... */ mw->menu.foreground_gc = (GC) -1; mw->menu.button_gc = (GC) -1; + mw->menu.highlight_gc = (GC) -1; + mw->menu.title_gc = (GC) -1; mw->menu.inactive_gc = (GC) -1; mw->menu.inactive_button_gc = (GC) -1; mw->menu.background_gc = (GC) -1;
--- a/lwlib/xlwmenu.h Mon Aug 13 10:02:48 2007 +0200 +++ b/lwlib/xlwmenu.h Mon Aug 13 10:03:52 2007 +0200 @@ -12,6 +12,10 @@ /* Resource names used by the XlwMenu widget */ #define XtNbuttonForeground "buttonForeground" #define XtCButtonForeground "ButtonForeground" +#define XtNhighlightForeground "highlightForeground" +#define XtCHighlightForeground "HighlightForeground" +#define XtNtitleForeground "titleForeground" +#define XtCTitleForeground "TitleForeground" #define XtNmargin "margin" #define XtNhorizontalSpacing "horizontalSpacing" #define XtNverticalSpacing "verticalSpacing"
--- a/lwlib/xlwmenuP.h Mon Aug 13 10:02:48 2007 +0200 +++ b/lwlib/xlwmenuP.h Mon Aug 13 10:03:52 2007 +0200 @@ -36,6 +36,8 @@ Pixel foreground; Pixel button_foreground; + Pixel highlight_foreground; + Pixel title_foreground; Dimension margin; Dimension horizontal_margin; Dimension vertical_margin; @@ -79,6 +81,8 @@ GC shadow_top_gc; GC shadow_bottom_gc; GC select_gc; + GC highlight_gc; + GC title_gc; Cursor cursor; Boolean popped_up; Pixmap gray_pixmap;
--- a/man/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/man/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,3 +1,17 @@ +1997-10-30 SL Baur <steve@altair.xemacs.org> + + * Makefile (srcs): Mailcrypt, hm--html-menus, vm, psgml and tm have + been packaged. + +1997-10-22 Hrvoje Niksic <hniksic@srce.hr> + + * xemacs-faq.texi: Added the detailed menu listing. + + * lispref/extents.texi (Extent Properties): Documented + `set-extent-properties'. + + * xemacs/custom.texi (Face Customization): Updated for XEmacs. + 1997-10-07 SL Baur <steve@altair.xemacs.org> * xemacs-faq.texi (Q1.3.7): Update Russion URLs.
--- a/man/Makefile Mon Aug 13 10:02:48 2007 +0200 +++ b/man/Makefile Mon Aug 13 10:03:52 2007 +0200 @@ -37,16 +37,15 @@ RECURSIVE_MAKE = $(MAKE) $(MFLAGS) MAKEINFO='$(MAKEINFO)' TEXI2DVI='$(TEXI2DVI)' # Subdirectories to make recursively. -SUBDIR = xemacs lispref new-users-guide internals tm gnats +SUBDIR = xemacs lispref new-users-guide internals gnats ../info/%.info : %.texi -$(MAKEINFO) -o $@ $< -srcs = cc-mode cl custom ediff efs external-widget forms \ - hm--html-mode \ - hyperbole ilisp info ispell mailcrypt oo-browser \ - pcl-cvs ph psgml psgml-api standards supercite term \ - termcap texinfo vhdl-mode viper vm widget xemacs-faq +srcs = cc-mode cl custom external-widget forms \ + hyperbole ilisp info ispell oo-browser \ + pcl-cvs ph standards supercite term \ + termcap texinfo vhdl-mode widget xemacs-faq info = $(srcs:%=../info/%.info) dvi = $(srcs:%=%.dvi)
--- a/man/ediff.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2287 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c documentation for Ediff -@c Written by Michael Kifer - -@comment %**start of header (This is for running Texinfo on a region.) - -@comment Using ediff.info instead of ediff in setfilename breaks DOS. -@comment @setfilename ediff -@comment @setfilename ediff.info -@setfilename ../info/ediff - -@settitle Ediff User's Manual -@synindex vr cp -@synindex fn cp -@synindex pg cp -@iftex -@finalout -@end iftex -@c @smallbook -@comment %**end of header (This is for running Texinfo on a region.) - -@ifinfo -This file documents Ediff, a comprehensive visual interface to Unix diff -and patch utilities. - -Permission is granted to make and distribute verbatim copies of this -manual provided the copyright notice and this permission notice are -preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission notice -identical to this one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -@end ifinfo - -@iftex -@titlepage -@title Ediff User's Manual -@sp 4 -@subtitle Ediff version 2.67 -@sp 1 -@subtitle August 1997 -@sp 5 -@author Michael Kifer -@page - -@vskip 0pt plus 1filll -@noindent -Copyright @copyright{} 1995, 1996, 1997 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. -@end titlepage -@page -@end iftex - -@node Top, Introduction, (dir), (dir) - - -@menu -* Introduction:: About Ediff 2.67. -* Major Entry Points:: How to use Ediff. -* Session Commands:: Ediff commands used within a session. -* Registry of Ediff Sessions:: Keeping track of multiple Ediff sessions. -* Session Groups:: Comparing and merging directories. -* Remote and Compressed Files:: You may want to know about this. -* Customization:: How to make Ediff work the way YOU want. -* Credits:: Thanks to those who helped. -* Index:: -@end menu - -@node Introduction, Major Entry Points, Top, Top -@chapter Introduction - -@cindex Comparing files and buffers -@cindex Merging files and buffers -@cindex Patching files and buffers -@cindex Finding differences - -Ediff provides a convenient way for simultaneous browsing through -the differences between a pair (or a triple) of files or buffers -(which are called @samp{variants} for our purposes). The -files being compared, file-A, file-B, and file-C (if applicable) are -shown in separate windows (side by side, one above the another, or in -separate frames), and the differences are highlighted as you step -through them. You can also copy difference regions from one buffer to -another (and recover old differences if you change your mind). - -Another powerful feature is the ability to merge a pair of files into a -third buffer. Merging with an ancestor file is also supported. -Furthermore, Ediff is equipped with directory-level capabilities that -allow the user to conveniently launch browsing or merging sessions on -groups of files in two (or three) different directories. - -In addition, Ediff can apply a patch to a file and then let you step though -both files, the patched and the original one, simultaneously, -difference-by-difference. You can even apply a patch right out of a mail -buffer, i.e., patches received by mail don't even have to be saved. Since -Ediff lets you copy differences between variants, you can, in effect, apply -patches selectively (i.e., you can copy a difference region from -@file{file.orig} to @file{file}, thereby undoing any particular patch that -you don't like). - -Ediff even understands multi-file patches and can apply them interactively! -(Ediff can recognize multi-file patches only if they are in the context -format or GNU unified format. All other patches are treated as 1-file -patches. Ediff is [hopefully] using the same algorithm as @file{patch} to -determine which files need to be patched.) - -Ediff is aware of version control, which lets you compare -files with their older versions. Ediff also works with remote and -compressed files, automatically ftp'ing them over and uncompressing them. -@xref{Remote and Compressed Files}, for details. - -This package builds upon ideas borrowed from Emerge, and several of Ediff's -functions are adaptations from Emerge. Although Ediff subsumes and greatly -extends Emerge, much of the functionality in Ediff is influenced by Emerge. -The architecture and the interface are, of course, drastically different. - -@node Major Entry Points, Session Commands, Introduction, Top -@chapter Major Entry Points - -Ediff can be invoked interactively using the following functions, which can -be run either from the minibuffer or from the menu bar. In the menu bar, -all Ediff's entry points belong to three submenus of the Tools menu: -Compare, Merge, and Apply Patch. - -@table @code -@item ediff-files -@itemx ediff -@findex ediff-files -@findex ediff -Compare two files. - -@item ediff-buffers -@findex ediff-buffers -Compare two buffers. - -@item ediff-files3 -@itemx ediff3 -@findex ediff-files3 -@findex ediff3 -Compare three files. - -@item ediff-buffers3 -@findex ediff-buffers3 -Compare three buffers. - -@item edirs -@itemx ediff-directories -@findex edirs -@findex ediff-directories - Compare files common to two directories. -@item edirs3 -@itemx ediff-directories3 -@findex edirs3 -@findex ediff-directories3 - Compare files common to three directories. -@item edir-revisions -@itemx ediff-directory-revisions -@findex ediff-directory-revisions -@findex edir-revisions - Compare versions of files in a given directory. Ediff selects only the -files that are under version control. -@item edir-merge-revisions -@itemx ediff-merge-directory-revisions -@findex edir-merge-revisions -@findex ediff-merge-directory-revisions - Merge versions of files in a given directory. Ediff selects only the -files that are under version control. -@item edir-merge-revisions-with-ancestor -@itemx ediff-merge-directory-revisions-with-ancestor -@findex edir-merge-revisions-with-ancestor -@findex ediff-merge-directory-revisions-with-ancestor - Merge versions of files in a given directory using other versions as -ancestors. Ediff selects only the files that are under version control. - -@item ediff-windows-wordwise -@findex ediff-windows-wordwise -Compare windows word-by-word. - -@item ediff-windows-linewise -@findex ediff-windows-linewise -Compare windows line-by-line. - -@item ediff-regions-wordwise -@findex ediff-regions-wordwise -Compare regions word-by-word. - -@item ediff-regions-linewise -@findex ediff-regions-linewise -Compare regions line-by-line. - -@item ediff-revision -@findex ediff-revision - Compare versions of the current buffer, if the buffer is visiting - a file under version control. - -@item ediff-patch-file -@itemx epatch -@findex ediff-patch-file -@findex epatch - -Patch a file or multiple files, then compare. If the patch applies to just -one file, Ediff will invoke a regular comparison session. If it is a -multi-file patch, then a session group interface will be used and the user -will be able to patch the files selectively. @xref{Session Groups}, for -more details. - -Note that @code{ediff-patch-file} will actually use the @file{patch} -utility to change the the original files on disk. This is not that -dangerous, since you will always have the original contents of the file -saved in another file that has the extension @file{.orig}. -Furthermore, if the file is under version control, then you can always back -out to one of the previous versions (see the section on Version Countrol in -Emacs manual). - -@code{ediff-patch-file} is careful about versions control: if the file -to be patched is checked in, then Ediff will offer to check it out, because -failing to do so may result in the loss of the changes when the file is -checked out the next time. - -If you don't intend to modify the file via the patch and just want to see -what the patch is all about (and decide later), then -@code{ediff-patch-buffer} might be a better choice. - -@item ediff-patch-buffer -@itemx epatch-buffer -@findex ediff-patch-buffer -@findex epatch-buffer -Patch a buffer, then compare. The buffer being patched and the file visited -by that buffer (if any) is @emph{not} modified. The result of the patch -appears in some other buffer that has the name ending with @emph{_patched}. - -This function would refuse to apply a multifile patch to a buffer. Use -@code{ediff-patch-file} for that (and when you want the original file to be -modified by the @file{patch} utility). - -@item ediff-merge-files -@itemx ediff-merge -@findex ediff-merge-files -@findex ediff-merge -Merge two files. - -@item ediff-merge-files-with-ancestor -@itemx ediff-merge-with-ancestor -@findex ediff-merge-files-with-ancestor -@findex ediff-merge-with-ancestor -Like @code{ediff-merge}, but with a third ancestor file. - -@item ediff-merge-buffers -@findex ediff-merge-buffers -Merge two buffers. - -@item ediff-merge-buffers-with-ancestor -@findex ediff-merge-buffers-with-ancestor -Same but with ancestor. - - -@item edirs-merge -@itemx ediff-merge-directories -@findex edirs-merge -@findex ediff-merge-directories - Merge files common to two directories. -@item edirs-merge-with-ancestor -@itemx ediff-merge-directories-with-ancestor -@findex edirs-merge-with-ancestor -@findex ediff-merge-directories-with-ancestor - Same but using files in a third directory as ancestors. - If a pair of files doesn't have an ancestor in the ancestor-directory, you - will still be able to merge them without the ancestor. - -@item ediff-merge-revisions -@findex ediff-merge-revisions -Merge two versions of the file visited by the current buffer. - -@item ediff-merge-revisions-with-ancestor -@findex ediff-merge-revisions-with-ancestor -Same but with ancestor. - -@item ediff-documentation -@findex ediff-documentation -Brings up this manual. - -@item ediff-show-registry -@itemx eregistry -Brings up Ediff session registry. This feature enables you to quickly find -and restart active Ediff sessions. -@end table - -@noindent -If you want Ediff to be loaded from the very beginning of your Emacs -session, you should put this line in your @file{~/.emacs} file: - -@example -(require 'ediff) -@end example - -@noindent -Otherwise, Ediff will be loaded automatically when you use one of the -above functions, either directly or through the menus. - -When the above functions are invoked, the user is prompted for all the -necessary information---typically the files or buffers to compare, merge, or -patch. Ediff tries to be smart about these prompts. For instance, in -comparing/merging files, it will offer the visible buffers as defaults. In -prompting for files, if the user enters a directory, the previously input -file name will be appended to that directory. In addition, if the variable -@code{ediff-use-last-dir} is not @code{nil}, Ediff will offer -previously entered directories as defaults (which will be maintained -separately for each type of file, A, B, or C). -@vindex @code{ediff-use-last-dir} - -All the above functions use the POSIX @code{diff} or @code{diff3} programs -to find differences between two files. They process the @code{diff} output -and display it in a convenient form. At present, Ediff understands only -the plain output from diff. Options such as @samp{-c} are not supported, -nor is the format produced by incompatible file comparison programs such as -the VMS version of @code{diff}. - -The functions @code{ediff-files}, @code{ediff-buffers}, -@code{ediff-files3}, @code{ediff-buffers3} first display the coarse, -line-based difference regions, as reported by the @file{diff} program. The -total number of difference regions and the current difference number are -always displayed in the mode line of the control window. - -Since @code{diff} may report fairly large chunks of text as being different, -even though the difference may be localized to just a few words or even -to the white space or line breaks, Ediff further @emph{refines} the -regions to indicate which exact words differ. If the only difference is -in the white space and line breaks, Ediff says so. - -On a color display, fine differences are highlighted with color; on a -monochrome display, they are underlined. @xref{Highlighting Difference -Regions}, for information on how to customize this. - -The functions @code{ediff-windows-wordwise}, -@code{ediff-windows-linewise}, @code{ediff-regions-wordwise} and -@code{ediff-regions-linewise} do comparison on parts of existing Emacs -buffers. Since @code{ediff-windows-wordwise} and -@code{ediff-regions-wordwise} are intended for relatively small segments -of buffers, comparison is done on the basis of words rather than lines. -No refinement is necessary in this case. These commands are recommended -only for relatively small regions (perhaps, up to 100 lines), because -these functions have a relatively slow startup. - -To compare large regions, use @code{ediff-regions-linewise}. This -command displays differences much like @code{ediff-files} and -@code{ediff-buffers}. - -The functions @code{ediff-patch-file} and @code{ediff-patch-buffer} apply a -patch to a file or a buffer and then run Ediff on the appropriate -files/buffers, displaying the difference regions. - -The entry points @code{ediff-directories}, @code{ediff-merge-directories}, -etc., provide a convenient interface for comparing and merging files in -different directories. The user is presented with Dired-like interface from -which one can run a group of related Ediff sessions. - -For files under version control, @code{ediff-revisions} lets you compare -the file visited by the current buffer to one of its checked-in versions. -You can also compare two checked-in versions of the visited file. -Moreover, the functions @code{ediff-directory-revisions}, -@code{ediff-merge-directory-revisions}, etc., let you run a group of -related Ediff sessions by taking a directory and comparing (or merging) -versions of files in that directory. - -@node Session Commands, Registry of Ediff Sessions, Major Entry Points, Top -@chapter Session Commands - -All Ediff commands are displayed in a Quick Help window, unless you type -@kbd{?} to shrink the window to just one line. You can redisplay the help -window by typing @kbd{?} again. The Quick Help commands are detailed below. - -Many Ediff commands take numeric prefix arguments. For instance, if you -type a number, say 3, and then @kbd{j} (@code{ediff-jump-to-difference}), -Ediff moves to the third difference region. Typing 3 and then @kbd{a} -(@code{ediff-diff-to-diff}) copies the 3d difference region from variant A -to variant B. Likewise, 4 followed by @kbd{ra} restores the 4th difference -region in buffer A (if it was previously written over via the command -@kbd{a}). - -Some commands take negative prefix arguments as well. For instance, typing -@kbd{-} and then @kbd{j} will make the last difference region -current. Typing @kbd{-2} then @kbd{j} makes the penultimate difference -region current, etc. - -Without the prefix argument, all commands operate on the currently -selected difference region. You can make any difference region -current using the various commands explained below. - -For some commands, the actual value of the prefix argument is -immaterial. However, if supplied, the prefix argument may modify the -command (see @kbd{ga}, @kbd{gb}, and @kbd{gc}). - -@menu -* Quick Help Commands:: Frequently used commands. -* Other Session Commands:: Commands that are not bound to keys. -@end menu - -@node Quick Help Commands,Other Session Commands,,Session Commands -@section Quick Help Commands - -@table @kbd -@item ? -Toggles the Ediff Quick Help window ON and OFF. -@item G -Prepares a mail buffer for sending a praise or a curse to the Ediff maintainer. - -@item E -Brings up the top node of this manual, where you can find further -information on the various Ediff functions and advanced issues, such as -customization, session groups, etc. - -@item v -Scrolls up buffers A and B (and buffer C where appropriate) in a -coordinated fashion. -@item V -Scrolls the buffers down. - -@item < -Scrolls the buffers to the left simultaneously. -@item > -Scrolls buffers to the right. - -@item wd -Saves the output from the diff utility, for further reference. - -With prefix argument, saves the plain output from @file{diff} (see -@code{ediff-diff-program} and @code{ediff-diff-options}). Without the -argument, it saves customized @file{diff} output (see -@code{ediff-custom-diff-program} and @code{ediff-custom-diff-options}), if -it is available. - -@item wa -Saves buffer A, if it was modified. -@item wb -Saves buffer B, if it was modified. -@item wc -Saves buffer C, if it was modified (if you are in a session that -compares three files simultaneously). - -@item a -@emph{In comparison sessions:} -Copies the current difference region (or the region specified as the prefix -to this command) from buffer A to buffer B. -Ediff saves the old contents of buffer B's region; it can -be restored via the command @kbd{rb}, which see. - -@emph{In merge sessions:} -Copies the current difference region (or the region specified as the prefix -to this command) from buffer A to the merge buffer. The old contents of -this region in buffer C can be restored via the command @kbd{r}. - -@item b -Works similarly, but copies the current difference region from buffer B to -buffer A (in @emph{comparison sessions}) or the merge buffer (in -@emph{merge sessions}). - -Ediff saves the old contents of the difference region copied over; it can -be reinstated via the command @kbd{ra} in comparison sessions and -@kbd{r} in merge sessions. - -@item ab -Copies the current difference region (or the region specified as the prefix -to this command) from buffer A to buffer B. This (and the next five) -command is enabled only in sessions that compare three files -simultaneously. The old region in buffer B is saved and can be restored -via the command @kbd{rb}. -@item ac -Copies the difference region from buffer A to buffer C. -The old region in buffer C is saved and can be restored via the command -@kbd{rc}. -@item ba -Copies the difference region from buffer B to buffer A. -The old region in buffer A is saved and can be restored via the command -@kbd{ra}. -@item bc -Copies the difference region from buffer B to buffer C. -The command @kbd{rc} undoes this. -@item ca -Copies the difference region from buffer C to buffer A. -The command @kbd{ra} undoes this. -@item cb -Copies the difference region from buffer C to buffer B. -The command @kbd{rb} undoes this. - -@item p -@itemx DEL -Makes the previous difference region current. -@item n -@itemx SPC -Makes the next difference region current. - -@item j -@itemx -j -@itemx Nj -Makes the very first difference region current. - -@kbd{-j} makes the last region current. Typing a number, N, and then `j' -makes the difference region N current. Typing -N (a negative number) then -`j' makes current the region Last - N. - -@item ga -Makes current the difference region closest to the position of the point in -buffer A. - -However, with a prefix argument, Ediff would position all variants -around the area indicated by the current point in buffer A: if -the point is inside a difference region, then the variants will be -positioned at this difference region. If the point is not in any difference -region, then it is in an area where all variants agree with each other. In -this case, the variants will be positioned so that each would display this -area (of agreement). -@item gb -Makes current the difference region closest to the position of the point in -buffer B. - -With a prefix argument, behaves like @kbd{ga}, but with respect to buffer B. -@item gc -@emph{In merge sessions:} -makes current the difference region closest to the point in the merge buffer. - -@emph{In 3-file comparison sessions:} -makes current the region closest to the point in buffer C. - -With a prefix argument, behaves like @kbd{ga}, but with respect to buffer C. - -@item ! -Recomputes the difference regions, bringing them up to date. This is often -needed because it is common to do all sorts of editing during Ediff -sessions, so after a while, the highlighted difference regions may no -longer reflect the actual differences among the buffers. - -@item * -Forces refinement of the current difference region, which highlights the exact -words of disagreement among the buffers. With a negative prefix argument, -unhighlights the current region. - -Forceful refinement may be needed if Ediff encounters a difference region -that is larger than @code{ediff-auto-refine-limit}. In this situation, -Ediff doesn't do automatic refinement in order to improve response time. -(Ediff doesn't auto-refine on dumb terminals as well, but @kbd{*} still -works there. However, the only useful piece of information it can tell you -is whether or not the difference regions disagree only in the amount of -white space.) - -This command is also useful when the highlighted fine differences are -no longer current, due to user editing. - -@item m -Displays the current Ediff session in a frame as wide as the physical -display. This is useful when comparing files side-by-side. Typing `m' again -restores the original size of the frame. - -@item | -Toggles the horizontal/vertical split of the Ediff display. Horizontal -split is convenient when it is possible to compare files -side-by-side. If the frame in which files are displayed is too narrow -and lines are cut off, typing @kbd{m} may help some. - -@item @@ -Toggles auto-refinement of difference regions (i.e., automatic highlighting -of the exact words that differ among the variants). Auto-refinement is -turned off on devices where Emacs doesn't support highlighting. - -On slow machines, it may be advantageous to turn auto-refinement off. The -user can always forcefully refine specific difference regions by typing -@kbd{*}. - -@item h -Cycles between full highlighting, the mode where fine differences are not -highlighted (but computed), and the mode where highlighting is done with -ASCII strings. The latter is not really recommended, unless on a dumb TTY. - -@item r -Restores the old contents of the region in the merge buffer. -(If you copied a difference region from buffer A or B into the merge buffer -using the commands @kbd{a} or @kbd{b}, Ediff saves the old contents of the -region in case you change your mind.) - -This command is enabled in merge sessions only. - -@item ra -Restores the old contents of the current difference region in buffer A, -which was previously saved when the user invoked one of these commands: -@kbd{b}, @kbd{ba}, @kbd{ca}, which see. This command is enabled in -comparison sessions only. -@item rb -Restores the old contents of the current difference region in buffer B, -which was previously saved when the user invoked one of these commands: -@kbd{a}, @kbd{ab}, @kbd{cb}, which see. This command is enabled in -comparison sessions only. -@item rc -Restores the old contents of the current difference region in buffer C, -which was previously saved when the user invoked one of these commands: -@kbd{ac}, @kbd{bc}, which see. This command is enabled in 3-file -comparison sessions only. - -@item ## -Tell Ediff to skip over regions that disagree among themselves only in the -amount of white space and line breaks. - -Even though such regions will be skipped over, you can still jump to any -one of them by typing the region number and then `j'. Typing @kbd{##} -again puts Ediff back in the original state. - -@item #h -@itemx #f -Ediff works hard to ameliorate the effects of boredom in the workplace... - -Quite often differences are due to identical replacements (e.g., the word -`foo' is replaced with the word `bar' everywhere). If the number of regions -with such boring differences exceeds your tolerance threshold, you may be -tempted to tell Ediff to skip these regions altogether (you will still be able -to jump to them via the command @kbd{j}). The above commands, @kbd{#h} -and @kbd{#f}, may well save your day! - -@kbd{#h} prompts you to specify regular expressions for each -variant. Difference regions where each variant's region matches the -corresponding regular expression will be skipped from then on. (You can -also tell Ediff to skip regions where at least one variant matches its -regular expression.) - -@kbd{#f} does dual job: it focuses on regions that match the corresponding -regular expressions. All other regions will be skipped -over. @xref{Selective Browsing}, for more. - -@item A -Toggles the read-only property in buffer A. -If file A is under version control and is checked in, it is checked out -(with your permission). -@item B -Toggles the read-only property in buffer B. -If file B is under version control and is checked in, it is checked out. -@item C -Toggles the read-only property in buffer C (in 3-file comparison sessions). -If file C is under version control and is checked in, it is checked out. - -@item ~ -Swaps the windows where buffers A and B are displayed. If you are comparing -three buffers at once, then this command would rotate the windows among -buffers A, B, and C. - -@item i -Displays all kinds of useful data about the current Ediff session. -@item D -Runs @code{ediff-custom-diff-program} on the variants and displays the -buffer containing the output. This is useful when you must send the output -to your Mom. - -With a prefix argument, displays the plain @file{diff} output. -@xref{Patch and Diff Programs}, for details. - -@item R -Displays a list of currently active Ediff sessions---the Ediff Registry. -You can then restart any of these sessions by either clicking on a session -record or by putting the cursor over it and then typing the return key. - -(Some poor souls leave so many active Ediff sessions around that they loose -track of them completely... The `R' command is designed to save these -people from the recently discovered Ediff Proficiency Syndrome.) - -Typing @kbd{R} brings up Ediff Registry only if it is typed into an Ediff -Control Panel. If you don't have a control panel handy, type this in the -minibuffer: @kbd{M-x eregistry}. @xref{Registry of Ediff Sessions}. - -@item M -Shows the session group buffer that invoked the current Ediff session. -@xref{Session Groups}, for more information on session groups. - -@item z -Suspends the current Ediff session. (If you develop a condition known as -Repetitive Ediff Injury---a serious but curable illness---you must change -your current activity. This command tries hard to hide all Ediff-related -buffers.) - -The easiest way to resume a suspended Ediff session is through the registry -of active sessions. @xref{Registry of Ediff Sessions}, for details. -@item q -Terminates this Ediff session. With a prefix argument (e.g.,@kbd{1q}), asks -if you also want to delete the buffers of the variants. -Modified files and the results of merges are never deleted. - -@item % -Toggles narrowing in Ediff buffers. Ediff buffers may be narrowed if you -are comparing only parts of these buffers via the commands -@code{ediff-windows-*} and @code{ediff-regions-*}, which see. - -@item C-l -Restores the usual Ediff window setup. This is the quickest way to resume -an Ediff session, but it works only if the control panel of that session is -visible. - -@item $ -While merging with an ancestor file, Ediff is determined to reduce user's -wear and tear by saving him and her much of unproductive, repetitive -typing. If it notices that, say, file A's difference region is identical to -the same difference region in the ancestor file, then the merge buffer will -automatically get the difference region taken from buffer B. The rationale -is that this difference region in buffer A is as old as that in the -ancestor buffer, so the contents of that region in buffer B represents real -change. - -You may want to ignore such `obvious' merges and concentrate on difference -regions where both files `clash' with the ancestor, since this means that -two different people have been changing this region independently and they -had different ideas on how to do this. - -The above command does this for you by skipping the regions where only one -of the variants clashes with the ancestor but the other variant agrees with -it. Typing @kbd{$} again undoes this setting. - -@item / -Displays the ancestor file during merges. -@item & -In some situations, such as when one of the files agrees with the ancestor file -on a difference region and the other doesn't, Ediff knows what to do: it copies -the current difference region from the second buffer into the merge buffer. - -In other cases, the right course of action is not that clearcut, and Ediff -would use a default action. The above command changes the default action. -The default action can be @samp{default-A} (choose the region from buffer -A), @samp{default-B} (choose the region from buffer B), or @samp{combined} -(combine the regions from the two buffers). -@xref{Merging and diff3}, for further details. - -The command @kbd{&} also affects the regions in the merge buffers that have -@samp{default-A}, @samp{default-B}, or @samp{combined} status, provided -they weren't changed with respect to the original. For instance, if such a -region has the status @samp{default-A} then changing the default action to -@samp{default-B} will also replace this merge-buffer's region with the -corresponding region from buffer B. - -@item s -Causes the merge wondow shrink to its minimum size, thereby exposing as much -of the variant buffers as possible. Typing `s' again restores -the original size of that window. - -With a positive prefix argument, this command enlarges the merge window. -E.g., @kbd{4s} increases the size of the window by about 4 lines, if -possible. With a negative numeric argument, the size of the merge window -shrinks by that many lines, if possible. Thus, @kbd{-s} shrinks the window -by about 1 line and @kbd{-3s} by about 3 lines. - -This command is intended only for temporary viewing; therefore, Ediff -restores window C to its original size whenever it makes any other change -in the window configuration. However, redisplaying (@kbd{C-l}) or jumping -to another difference does not affect window C's size. - -The split between the merge window and the variant windows is controlled by -the variable @code{ediff-merge-window-share}, which see. - -@item + -Combines the difference regions from buffers A and B and copies the -result into the merge buffer. @xref{Merging and diff3} and the -variables @code{ediff-combine-diffs} and @code{ediff-combination-pattern}. - - -@item = -You may run into situations when a large chunk of text in one file has been -edited and then moved to a different place in another file. In such a case, -these two chunks of text are unlikely to belong to the same difference -region, so the refinement feature of Ediff will not be able to tell you -what exactly differs inside these chunks. Since eyeballing large pieces of -text is contrary to human nature, Ediff has a special command to help -reduce the risk of developing a cataract. - -The above command compares regions within Ediff buffers. This creates a -child Ediff session for comparing current Emacs regions in buffers A, B, or -C as follows: - -@emph{If you are comparing 2 files or buffers:} -Ediff would compare current Emacs regions in buffers A and B. - -@emph{If you are comparing 3 files or buffers simultaneously:} Ediff would -compare the current Emacs regions in the buffers of your choice (you will -be asked which two of the three buffers to use). - -@emph{If you are merging files or buffers (with or without ancestor):} -Ediff would take the current region in the merge buffer and compare -it to the current region in the buffer of your choice (A or B). - -Highlighting set by the parent Ediff session is removed, to avoid interference -with highlighting of the child session. When done with the child session, type -@kbd{C-l} in the parent's control panel to restore the original highlighting. - -If you temporarily switch to the parent session, parent highlighting will be -restored. If you then come back to the child session, you may want to remove -parent highlighting, so it won't interfere. Typing @kbd{h} may help here. - -@end table - -@node Other Session Commands,,Quick Help Commands,Session Commands -@section Other Session Commands - -The following commands can be invoked from within any Ediff session, -although some of them are not bound to a key. - -@table @code -@item eregistry -@itemx ediff-show-registry -@findex eregistry -@findex ediff-show-registry -This command brings up the registry of active Ediff sessions. Ediff -registry is a device that can be used to resume any active Ediff session -(which may have been postponed because the user switched to some other -activity). This command is also useful for switching between multiple -active Ediff sessions that are run at the same time. The function -@code{eregistry} is an alias for @code{ediff-show-registry}. -@xref{Registry of Ediff Sessions}, for more information on this registry. - -@item ediff-toggle-multiframe -@findex ediff-toggle-multiframe -Changes the display from the multi-frame mode (where the quick help window -is in a separate frame) to the single-frame mode (where all Ediff buffers -share the same frame), and vice versa. See -@code{ediff-window-setup-function} for details on how to make either of -these modes the default one. - -This function can also be invoked from the Menubar. However, in some -cases, the change will take place only after you execute one of the Ediff -commands, such as going to the next difference or redisplaying. -@item ediff-toggle-use-toolbar -@findex ediff-toggle-use-toolbar -Available in XEmacs only. The Ediff toolbar provides quick access to some -of the common Ediff functions. This function toggles the display of the -toolbar. If invoked from the menubar, the function may take sometimes -effect only after you execute an Ediff command, such as going to the next -difference. - -@item ediff-use-toolbar-p -@vindex ediff-use-toolbar-p -The use of the toolbar can also be specified via the variable -@code{ediff-use-toolbar-p} (default is @code{t}). This variable can be set -only in @file{.emacs} --- do @strong{not} change it interactively. Use the -function @code{ediff-toggle-use-toolbar} instead. - -@item ediff-revert-buffers-then-recompute-diffs -@findex ediff-revert-buffers-then-recompute-diffs -This command reverts the buffers you are comparing and recomputes their -differences. It is useful when, after making changes, you decided to -make a fresh start, or if at some point you changed the files being -compared but want to discard any changes to comparison buffers that were -done since then. - -This command normally asks for confirmation before reverting files. -With a prefix argument, it reverts files without asking. - - -@item ediff-profile -@findex ediff-profile -Ediff has an admittedly primitive (but useful) facility for profiling -Ediff's commands. It is meant for Ediff maintenance---specifically, for -making it run faster. The function @code{ediff-profile} toggles -profiling of ediff commands. -@end table - -@node Registry of Ediff Sessions, Session Groups, Session Commands, Top -@chapter Registry of Ediff Sessions - -Ediff maintains a registry of all its invocations that are -still @emph{active}. This feature is very convenient for switching among -active Ediff sessions or for quickly restarting a suspended Ediff session. - -The focal point of this activity is a buffer -called @emph{*Ediff Registry*}. You can display this buffer by typing -@kbd{R} in any Ediff Control Buffer or Session Group Buffer -(@pxref{Session Groups}), or by typing -@kbd{M-x eregistry} into the Minibuffer. -The latter would be the fastest way to bring up the registry -buffer if no control or group buffer is displayed in any of the visible -Emacs windows. -If you are in a habit of running multiple long Ediff sessions and often need to -suspend, resume, or switch between them, it may be a good idea to have the -registry buffer permanently displayed in a separate, dedicated window. - -The registry buffer has several convenient key bindings. -For instance, clicking mouse button 2 or typing -@kbd{RET} or @kbd{v} over any session record resumes that session. -Session records in the registry buffer provide a fairly complete -description of each session, so it is usually easy to identify the right -session to resume. - -Other useful commands are bound to @kbd{SPC} (next registry record) -and @kbd{DEL} (previous registry record). There are other commands as well, -but you don't need to memorize them, since they are listed at the top of -the registry buffer. - -@node Session Groups, Remote and Compressed Files, Registry of Ediff Sessions, Top -@chapter Session Groups - -Several major entries of Ediff perform comparison and merging on -directories. On entering @code{ediff-directories}, -@code{ediff-directories3}, -@code{ediff-merge-directories}, -@code{ediff-merge-directories-with-ancestor}, -@code{ediff-directory-revisions}, -@code{ediff-merge-directory-revisions}, or -@code{ediff-merge-directory-revisions-with-ancestor}, -the user is presented with a -Dired-like buffer that lists files common to the directories involved along -with their sizes. (The list of common files can be further filtered through -a regular expression, which the user is prompted for.) We call this buffer -@emph{Session Group Panel} because all Ediff sessions associated with the -listed files will have this buffer as a common focal point. - -Clicking button 2 or typing @kbd{RET} or @kbd{v} over a -record describing files invokes Ediff in the appropriate mode on these -files. You can come back to the session group buffer associated with a -particular invocation of Ediff by typing @kbd{M} in Ediff control buffer of -that invocation. - -Many commands are available in the session group buffer; some are -applicable only to certain types of work. The relevant commands are always -listed at the top of each session group buffer, so there is no need to -memorize them. - -In directory comparison or merging, a session group panel displays only the -files common to all directories involved. The differences are kept in a -separate buffer and are conveniently displayed by typing @kbd{D} to the -corresponding session group panel. Thus, as an added benefit, Ediff can be -used to compare the contents of up to three directories. - -Session records in session group panels are also marked with @kbd{+}, for -active sessions, and with @kbd{-}, for finished sessions. - -Sometimes, it is convenient to exclude certain sessions from a group. -Usually this happens when the user doesn't intend to run Ediff of certain -files in the group, and the corresponding session records just add clutter -to the session group buffer. To help alleviate this problem, the user can -type @kbd{h} to mark a session as a candidate for exclusion and @kbd{x} to -actually hide the marked sessions. There actions are reversible: with a -prefix argument, @kbd{h} unmarks the session under the cursor, and @kbd{x} -brings the hidden sessions into the view (@kbd{x} doesn't unmark them, -though, so the user has to explicitly unmark the sessions of interest). - -Group sessions also understand the command @kbd{m}, which marks sessions -for future operations (other than hiding) on a group of sessions. At present, -the only such group-level operation is the creation of a multi-file patch. - -@vindex ediff-autostore-merges -For group sessions created to merge files, Ediff can store all merges -automatically in a directory. The user is asked to specify such directory -if the value of @code{ediff-autostore-merges} is non-nil. If the value is -@code{nil}, nothing is done to the merge buffers---it will be the user's -responsibility to save them. If the value is @code{t}, the user will be -asked where to save the merge buffers in all merge jobs, even those that do -not originate from a session group. It the value is neither @code{nil} nor -@code{t}, the merge buffer is saved @emph{only} if this merge session was -invoked from a session group. This behavior is implemented in the function -@code{ediff-maybe-save-and-delete-merge}, which is a hook in -@code{ediff-quit-merge-hook}. The user can supply a different hook, if -necessary. - -The variable @code{ediff-autostore-merges} is buffer-local, so it can be -set in a per-buffer manner. Therefore, use @code{setq-default} to globally -change this variable. - -@cindex Multi-file patches -A multi-file patch is a concatenated output of several runs of the Unix -@file{diff} command (some versions of @file{diff} let you create a -multi-file patch in just one run). Ediff facilitates creation of -multi-file patches as follows. If you are in a session group buffer -created in response to @code{ediff-directories} or -@code{ediff-directory-revisions}, you can mark (by typing @kbd{m}) the -desired Ediff sessions and then type @kbd{P} to create a -multi-file patch of those marked sessions. -Ediff will then display a buffer containing the patch. -The patch is generated by invoking @file{diff} on all marked individual -sessions (represented by files) and session groups (represented by -directories). Ediff will also recursively descend into any @emph{unmarked} -session group and will search for marked sessions there. In this way, you -can create multi-file patches that span file subtrees that grow out of -any given directory. - -In an @code{ediff-directories} session, it is enough to just mark the -requisite sessions. In @code{ediff-directory-revisions} revisions, the -marked sessions must also be active, or else Ediff will refuse to produce a -multi-file patch. This is because, in the latter-style sessions, there are -many ways to create diff output, and it is easier to handle by running -Ediff on the inactive sessions. - -Last, but not least, by typing @kbd{=}, you can quickly find out which -sessions have identical files, so you won't have to run Ediff on those -sessions. This, however, works only on local, uncompressed files. -For compressed or local files, this command won't report anything. - - -@node Remote and Compressed Files, Customization, Session Groups, Top -@chapter Remote and Compressed Files - -Ediff works with remote, compressed, and encrypted files. Ediff -supports @file{ange-ftp.el}, @file{jka-compr.el}, @file{uncompress.el} -and @file{crypt++.el}, but it may work with other similar packages as -well. This means that you can compare files residing on another -machine, or you can apply a patch to a file on another machine. Even -the patch itself can be a remote file! - -When patching compressed or remote files, Ediff does not rename the source -file (unlike what the @code{patch} utility would usually do). Instead, the -source file retains its name and the result of applying the patch is placed -in a temporary file that has the suffix @file{_patched} attached. -Generally, this applies to files that are handled using black magic, such -as special file handlers (ange-ftp and some compression and encryption -packages also use this method). - -Regular files are treated by the @code{patch} utility in the usual manner, -i.e., the original is renamed into @file{source-name.orig} and the result -of the patch is placed into the file source-name (@file{_orig} is used -on systems like VMS, DOS, etc.) - -@node Customization, Credits, Remote and Compressed Files, Top -@chapter Customization - -Ediff has a rather self-explanatory interface, and in most cases you -won't need to change anything. However, should the need arise, there are -extensive facilities for changing the default behavior. - -Most of the customization can be done by setting various variables in the -@file{.emacs} file. Some customization (mostly window-related -customization and faces) can be done by putting appropriate lines in -@file{.Xdefaults}, @file{.xrdb}, or whatever X resource file is in use. - -With respect to the latter, please note that the X resource -for Ediff customization is `Ediff', @emph{not} `emacs'. -@xref{Window and Frame Configuration}, -@xref{Highlighting Difference Regions}, for further details. Please also -refer to Emacs manual for the information on how to set Emacs X resources. - -@menu -* Hooks:: Customization via the hooks. -* Quick Help Customization:: How to customize Ediff's quick help feature. -* Window and Frame Configuration:: Controlling the way Ediff displays things. -* Selective Browsing:: Advanced browsing through difference regions. -* Highlighting Difference Regions:: Controlling highlighting. -* Narrowing:: Comparing regions, windows, etc. -* Refinement of Difference Regions:: How to control the refinement process. -* Patch and Diff Programs:: Changing the utilities that compute differences - and apply patches. -* Merging and diff3:: How to customize Ediff in its Merge Mode. -* Support for Version Control:: Changing the version control package. - You are not likely to do that. -* Customizing the Mode Line:: Changing the look of the mode line in Ediff. -* Miscellaneous:: Other customization. -* Notes on Heavy-duty Customization:: Customization for the gurus. -@end menu - -@node Hooks, Quick Help Customization, Customization, Customization -@section Hooks - -The bulk of customization can be done via the following hooks: - -@table @code -@item ediff-load-hook -@vindex ediff-load-hook -This hook can be used to change defaults after Ediff is loaded. - -@item ediff-keymap-setup-hook -@vindex ediff-keymap-setup-hook -@vindex ediff-mode-map -This hook can be used to alter bindings in Ediff's keymap, -@code{ediff-mode-map}. These hooks are -run right after the default bindings are set but before -@code{ediff-load-hook}. The regular user needs not be concerned with this -hook---it is provided for implementors of other Emacs packages built on top -of Ediff. - -@item ediff-before-setup-windows-hook -@itemx ediff-after-setup-windows-hook -@vindex ediff-before-setup-windows-hook -@vindex ediff-after-setup-windows-hook -These two hooks are called before and after Ediff sets up its window -configuration. Can be used to save the configuration that existed -before Ediff starts or for whatever other purposes. - -@item ediff-suspend-hook -@itemx ediff-quit-hook -@vindex ediff-suspend-hook -@vindex ediff-quit-hook -These two hooks are run when you suspend or quit Ediff. They can be -used to set desired window configurations, delete files Ediff didn't -want to clean up after exiting, etc. - -By default, @code{ediff-quit-hook} holds one hook function, -@code{ediff-cleanup-mess}, which cleans after Ediff, as appropriate in -most cases. You probably won't want to change it, but you might -want to add other hook functions. - -Keep in mind that hooks executing before @code{ediff-cleanup-mess} start -in @code{ediff-control-buffer;} they should also leave -@code{ediff-control-buffer} as the current buffer when they finish. -Hooks that are executed after @code{ediff-cleanup-mess} should expect -the current buffer be either buffer A or buffer B. -@code{ediff-cleanup-mess} doesn't kill the buffers being compared or -merged (see @code{ediff-cleanup-hook}, below). - -@item ediff-cleanup-hook -@vindex ediff-cleanup-hook -This hook is run just before @code{ediff-quit-hook}. This is a good -place to do various cleanups, such as deleting the variant buffers. -Ediff provides a function, @code{ediff-janitor}, as one such possible -hook, which you can add to @code{ediff-cleanup-hook} with -@code{add-hooks}. - -@findex ediff-janitor -This function kills buffers A, B, and, possibly, C, if these buffers aren't -modified. In merge jobs, buffer C is never deleted. However, the side -effect of using this function is that you may not be able to compare the -same buffer in two separate Ediff sessions: quitting one of them will -delete this buffer in another session as well. - -@item ediff-quit-merge-hook -@vindex ediff-quit-merge-hook -@vindex ediff-autostore-merges -@findex ediff-maybe-save-and-delete-merge -This hook is called when Ediff quits a merge job. By default, the value is -@code{ediff-maybe-save-and-delete-merge}, which is a function that attempts -to save the merge buffer according to the value of -@code{ediff-autostore-merges}, as described later. - -@item ediff-before-setup-control-frame-hook -@itemx ediff-after-setup-control-frame-hook -@vindex ediff-before-setup-control-frame-hook -@vindex ediff-after-setup-control-frame-hook -These two hooks run before and after Ediff sets up the control frame. -They can be used to relocate Ediff control frame when Ediff runs in a -multiframe mode (i.e., when the control buffer is in its own dedicated -frame). Be aware that many variables that drive Ediff are local to -Ediff Control Panel (@code{ediff-control-buffer}), which requires -special care in writing these hooks. Take a look at -@code{ediff-default-suspend-hook} and @code{ediff-default-quit-hook} to -see what's involved. - -@item ediff-startup-hook -@vindex ediff-startup-hook -This hook is run at the end of Ediff startup. - -@item ediff-select-hook -@vindex ediff-select-hook -This hook is run after Ediff selects the next difference region. - -@item ediff-unselect-hook -@vindex ediff-unselect-hook -This hook is run after Ediff unselects the current difference region. - -@item ediff-prepare-buffer-hook -@vindex ediff-prepare-buffer-hook -This hook is run for each Ediff buffer (A, B, C) right after the buffer -is arranged. - -@item ediff-display-help-hook -@vindex ediff-display-help-hook -Ediff runs this hook each time after setting up the help message. It -can be used to alter the help message for custom packages that run on -top of Ediff. - -@item ediff-mode-hook -@vindex ediff-mode-hook -This hook is run just after Ediff mode is set up in the control -buffer. This is done before any Ediff window is created. You can use it to -set local variables that alter the look of the display. - -@item ediff-registry-setup-hook -@vindex ediff-registry-setup-hook -Hooks run after setting up the registry for all active Ediff session. -@xref{Session Groups}, for details. -@item ediff-session-group-setup-hook -@vindex ediff-session-group-setup-hook -Hooks run after setting up a control panel for a group of related Ediff -sessions. @xref{Session Groups}, for details. -@item ediff-quit-session-group-hook -@vindex ediff-quit-session-group-hook -Hooks run just before exiting a session group. -@item ediff-meta-buffer-keymap-setup-hook -@vindex ediff-meta-buffer-keymap-setup-hook -@vindex ediff-meta-buffer-map -Hooks run just after setting up the @code{ediff-meta-buffer-map} --- the -map that controls key bindings in the meta buffer. Since -@code{ediff-meta-buffer-map} is a local variable, you can set different -bindings for different kinds of meta buffers. -@end table - -@node Quick Help Customization, Window and Frame Configuration, Hooks, Customization -@section Quick Help Customization -@vindex ediff-use-long-help-message -@vindex ediff-control-buffer -@vindex ediff-startup-hook -@vindex ediff-help-message - -Ediff provides quick help using its control panel window. Since this window -takes a fair share of the screen real estate, you can toggle it off by -typing @kbd{?}. The control window will then shrink to just one line and a -mode line, displaying a short help message. - -The variable @code{ediff-use-long-help-message} tells Ediff whether -you use the short message or the long one. By default, it -is set to @code{nil}, meaning that the short message is used. -Set this to @code{t}, if you want Ediff to use the long -message by default. This property can always be changed interactively, by -typing @kbd{?} into Ediff Control Buffer. - -If you want to change the appearance of the help message on a per-buffer -basis, you must use @code{ediff-startup-hook} to change the value of -the variable @code{ediff-help-message}, which is local to -@code{ediff-control-buffer}. - -@node Window and Frame Configuration, Selective Browsing, Quick Help Customization, Customization -@section Window and Frame Configuration - -On a non-windowing display, Ediff sets things up in one frame, splitting -it between a small control window and the windows for buffers A, B, and C. -The split between these windows can be horizontal or -vertical, which can be changed interactively by typing @kbd{|} while the -cursor is in the control window. - -On a window display, Ediff sets up a dedicated frame for Ediff Control -Panel and then it chooses windows as follows: If one of the buffers -is invisible, it is displayed in the currently selected frame. If -a buffer is visible, it is displayed in the frame where it is visible. -If, according to the above criteria, the two buffers fall into the same -frame, then so be it---the frame will be shared by the two. The same -algorithm works when you type @kbd{C-l} (@code{ediff-recenter}), @kbd{p} -(@code{ediff-previous-difference}), @kbd{n} -(@code{ediff-next-difference}), etc. - -The above behavior also depends on whether the current frame is splittable, -dedicated, etc. Unfortunately, the margin of this book is too narrow to -present the details of this remarkable algorithm. - -The upshot of all this is that you can compare buffers in one frame or -in different frames. The former is done by default, while the latter can -be achieved by arranging buffers A, B (and C, if applicable) to be seen in -different frames. Ediff respects these arrangements, automatically -adapting itself to the multi-frame mode. - -Ediff uses the following variables to set up its control panel -(a.k.a. control buffer, a.k.a. quick help window): - -@table @code -@item ediff-control-frame-parameters -@vindex ediff-control-frame-parameters -You can change or augment this variable including the font, color, -etc. The X resource name of Ediff Control Panel frames is @samp{Ediff}. Under -X-windows, you can use this name to set up preferences in your -@file{~/.Xdefaults}, @file{~/.xrdb}, or whatever X resource file is in -use. Usually this is preferable to changing -@code{ediff-control-frame-parameters} directly. For instance, you can -specify in @file{~/.Xdefaults} the color of the control frame -using the resource @samp{Ediff*background}. - -In general, any X resource pertaining the control frame can be reached -via the prefix @code{Ediff*}. - -@item ediff-control-frame-position-function -@vindex ediff-control-frame-position-function -The preferred way of specifying the position of the control frame is by -setting the variable @code{ediff-control-frame-position-function} to an -appropriate function. -The default value of this variable is -@code{ediff-make-frame-position}. This function places the control frame in -the vicinity of the North-East corner of the frame displaying buffer A. - -@findex ediff-make-frame-position -@end table - -The following variables can be used to adjust the location produced by -@code{ediff-make-frame-position} and for related customization. - -@table @code -@item ediff-narrow-control-frame-leftward-shift -@vindex ediff-narrow-control-frame-leftward-shift -Specifies the number of characters for shifting -the control frame from the rightmost edge of frame A when the control -frame is displayed as a small window. - -@item ediff-wide-control-frame-rightward-shift -@vindex ediff-wide-control-frame-rightward-shift -Specifies the rightward shift of the control frame -from the left edge of frame A when the control frame shows the full -menu of options. - -@item ediff-control-frame-upward-shift -@vindex ediff-control-frame-upward-shift -Specifies the number of pixels for the upward shift -of the control frame. - -@item ediff-prefer-iconified-control-frame -@vindex ediff-prefer-iconified-control-frame -If this variable is @code{t}, the control frame becomes iconified -automatically when you toggle the quick help message off. This saves -valuable real estate on the screen. Toggling help back will deiconify -the control frame. - -To start Ediff with an iconified Control Panel, you should set this -variable to @code{t} and @code{ediff-prefer-long-help-message} to -@code{nil} (@pxref{Quick Help Customization}). This behavior is useful -only if the window manager is TWM or a derivative. Also, this doesn't work -under XEmacs, since this editor ignores input from icons. -@end table - -@findex ediff-setup-windows -To make more creative changes in the way Ediff sets up windows, you can -rewrite the function @code{ediff-setup-windows}. However, we believe -that detaching Ediff Control Panel from the rest and making it into a -separate frame offers an important opportunity by allowing you to -iconify that frame. Under Emacs, the icon will usually accept all of -the Ediff commands, but will free up valuable real estate on your screen -(this may depend on your window manager, though). Iconifying won't do -any good under XEmacs since XEmacs icons are not sensitive to keyboard -input. The saving grace is that, even if not iconified, the control -frame is very small, smaller than some icons, so it does not take much -space in any case. - -The following variable controls how windows are set up: - -@table @code -@item ediff-window-setup-function -@vindex ediff-window-setup-function -The multiframe setup is done by the -@code{ediff-setup-windows-multiframe} function, which is the default on -windowing displays. The plain setup, one where all windows are always -in one frame, is done by @code{ediff-setup-windows-plain}, which is the -default on a non-windowing display (or in an xterm window). In fact, -under Emacs, you can switch freely between these two setups by executing -the command @code{ediff-toggle-multiframe} using the Minibuffer of the -Menubar. -@findex ediff-setup-windows-multiframe -@findex ediff-setup-windows-plain -@findex ediff-toggle-multiframe - -If you don't like any of these setups, write your own function. See the -documentation for @code{ediff-window-setup-function} for the basic -guidelines. However, writing window setups is not easy, so you should -first take a close look at @code{ediff-setup-windows-plain} and -@code{ediff-setup-windows-multiframe}. -@end table - -You can run multiple Ediff sessions at once, by invoking Ediff several -times without exiting previous Ediff sessions. Different sessions -may even operate on the same pair of files. - -Each session has its own Ediff Control Panel and all the regarding a -particular session is local to the associated control panel buffer. You -can switch between sessions by suspending one session and then switching -to another control panel. (Different control panel buffers are -distinguished by a numerical suffix, e.g., @samp{Ediff Control Panel<3>}.) - -@node Selective Browsing, Highlighting Difference Regions, Window and Frame Configuration, Customization -@section Selective Browsing - -Sometimes it is convenient to be able to step through only some difference -regions, those that match certain regular expressions, and to ignore all -others. On other occasions, you may want to ignore difference regions that -match some regular expressions, and to look only at the rest. - -The commands @kbd{#f} and @kbd{#h} let you do precisely this. - -Typing @kbd{#f} lets you specify regular expressions that match difference -regions you want to focus on. -We shall call these regular expressions @var{regexp-A}, @var{regexp-B} and -@var{regexp-C}. -Ediff will then start stepping through only those difference regions -where the region in buffer A matches @var{regexp-A} and/or the region in -buffer B matches @var{regexp-B}, etc. Whether `and' or `or' will be used -depends on how you respond to a question. - -When scanning difference regions for the aforesaid regular expressions, -Ediff narrows the buffers to those regions. This means that you can use -the expressions @kbd{\`} and @kbd{\'} to tie search to the beginning or end -of the difference regions. - -On the other hand, typing @kbd{#h} lets you specify (hide) uninteresting -regions. That is, if a difference region in buffer A matches -@var{regexp-A}, the corresponding region in buffer B matches @var{regexp-B} -and (if applicable) buffer C's region matches @var{regexp-C}, then the -region will be ignored by the commands @kbd{n}/@key{SPC} -(@code{ediff-next-difference}) and @kbd{p}/@key{DEL} -(@code{ediff-previous-difference}) commands. - -Typing @kbd{#f} and @kbd{#h} toggles selective browsing on and off. - -Note that selective browsing affects only @code{ediff-next-difference} -and @code{ediff-previous-difference}, i.e., the commands -@kbd{n}/@key{SPC} and @kbd{p}/@key{DEL}. @kbd{#f} and @kbd{#h} do not -change the position of the point in the buffers. And you can still jump -directly (using @kbd{j}) to any numbered -difference. - -Users can supply their own functions to specify how Ediff should do -selective browsing. To change the default Ediff function, add a function to -@code{ediff-load-hook} which will do the following assignments: - -@example -(setq ediff-hide-regexp-matches-function 'your-hide-function) -(setq ediff-focus-on-regexp-matches-function 'your-focus-function) -@end example - -@strong{Useful hint}: To specify a regexp that matches everything, don't -simply type @key{RET} in response to a prompt. Typing @key{RET} tells Ediff -to accept the default value, which may not be what you want. Instead, you -should enter something like @key{^} or @key{$}. These match every -line. - -You can use the status command, @kbd{i}, to find out whether -selective browsing is currently in effect. - -The regular expressions you specified are kept in the local variables -@code{ediff-regexp-focus-A}, @code{ediff-regexp-focus-B}, -@code{ediff-regexp-focus-C}, @code{ediff-regexp-hide-A}, -@code{ediff-regexp-hide-B}, @code{ediff-regexp-hide-C}. Their default value -is the empty string (i.e., nothing is hidden or focused on). To change the -default, set these variables in @file{.emacs} using @code{setq-default}. - -In addition to the ability to ignore regions that match regular -expressions, Ediff can be ordered to start skipping over certain -``uninteresting'' difference regions. This is controlled by the following -variable: - -@table @code -@item ediff-ignore-similar-regions -@vindex ediff-ignore-similar-regions -If @code{t}, causes Ediff to skip over "uninteresting" difference regions, -which are the regions where the variants differ only in the amount of the -white space and newlines. This feature can be toggled on/off interactively, -via the command @kbd{##}. -@end table - -@strong{Note:} In order for this feature to work, auto-refining of -difference regions must be on, since otherwise Ediff won't know if there -are fine differences between regions. On devices where Emacs can display -faces, auto-refining is a default, but it is not turned on by default on -text-only terminals. In that case, you must explicitly turn auto-refining -on (such as, by typing @kbd{@@}). - -@strong{Reassurance:} If many such uninteresting regions appear in a row, -Ediff may take a long time to skip over them because it has to compute fine -differences of all intermediate regions. This delay does not indicate any -problem. - -@node Highlighting Difference Regions, Narrowing, Selective Browsing, Customization -@section Highlighting Difference Regions - -The following variables control the way Ediff highlights difference -regions: - -@table @code -@item ediff-before-flag-bol -@itemx ediff-after-flag-eol -@itemx ediff-before-flag-mol -@itemx ediff-after-flag-mol -@vindex ediff-before-flag-bol -@vindex ediff-after-flag-eol -@vindex ediff-before-flag-mol -@vindex ediff-after-flag-mol -These variables hold strings that Ediff uses to mark the beginning and the -end of the differences found in files A, B, and C on devices where Emacs -cannot display faces. Ediff uses different flags to highlight regions that -begin/end at the beginning/end of a line or in a middle of a line. - -@item ediff-current-diff-face-A -@itemx ediff-current-diff-face-B -@itemx ediff-current-diff-face-C -@vindex ediff-current-diff-face-A -@vindex ediff-current-diff-face-B -@vindex ediff-current-diff-face-C -Ediff uses these faces to highlight current differences on devices where -Emacs can display faces. These and subsequently described faces can be set -either in @file{.emacs} or in @file{.Xdefaults}. The X resource for Ediff -is @samp{Ediff}, @emph{not} @samp{emacs}. Please refer to Emacs manual for -the information on how to set X resources. -@item ediff-fine-diff-face-A -@itemx ediff-fine-diff-face-B -@itemx ediff-fine-diff-face-C -@vindex ediff-fine-diff-face-A -@vindex ediff-fine-diff-face-B -@vindex ediff-fine-diff-face-C -Ediff uses these faces to show the fine differences between the current -differences regions in buffers A, B, and C, respectively. - -@item ediff-even-diff-face-A -@itemx ediff-even-diff-face-B -@itemx ediff-even-diff-face-C -@itemx ediff-odd-diff-face-A -@itemx ediff-odd-diff-face-B -@itemx ediff-odd-diff-face-C -@vindex ediff-even-diff-face-A -@vindex ediff-even-diff-face-B -@vindex ediff-even-diff-face-C -@vindex ediff-odd-diff-face-A -@vindex ediff-odd-diff-face-B -@vindex ediff-odd-diff-face-C -Non-current difference regions are displayed using these alternating -faces. The odd and the even faces are actually identical on monochrome -displays, because without colors options are limited. -So, Ediff uses italics to highlight non-current differences. - -@item ediff-force-faces -@vindex ediff-force-faces -Ediff generally can detect when Emacs is running on a device where it can -use highlighting with faces. However, if it fails to determine that faces -can be used, the user can set this variable to @code{t} to make sure that -Ediff uses faces to highlight differences. - -@item ediff-highlight-all-diffs -@vindex ediff-highlight-all-diffs -Indicates whether---on a windowind display---Ediff should highlight -differences using inserted strings (as on text-only terminals) or using -colors and highlighting. Normally, Ediff highlights all differences, but -the selected difference is highlighted more visibly. One can cycle through -various modes of highlighting by typing @kbd{h}. By default, Ediff starts -in the mode where all difference regions are highlighted. If you prefer to -start in the mode where unselected differences are not highlighted, you -should set @code{ediff-highlight-all-diffs} to @code{nil}. Type @kbd{h} to -restore highlighting for all differences. - -Ediff lets you switch between the two modes of highlighting. That is, -you can switch interactively from highlighting using faces to -highlighting using string flags, and back. Of course, switching has -effect only under a windowing system. On a text-only terminal or in an -xterm window, the only available option is highlighting with strings. -@end table - -@noindent -If you want to change the default settings for @code{ediff-force-faces} and -@code{ediff-highlight-all-diffs}, you must do it @strong{before} Ediff is -loaded. - -You can also change the defaults for the faces used to highlight the -difference regions. There are two ways to do this. The simplest and the -preferred way is to use the customization widget accessible from the -menubar. Ediff's customization group is located under "Tools", which in -turn is under "Programming". The faces that are used to highlight -difference regions are located in the "Highlighting" subgroup of the Ediff -customization group. - -The second, much more arcane, method to change default faces is to include -some Lisp code in @file{~/.emacs}. For instance, - -@example -(setq ediff-current-diff-face-A - (copy-face 'bold-italic 'ediff-current-diff-face-A)) -@end example - -@noindent -would use the pre-defined fase @code{bold-italic} to highlight the current -difference region in buffer A (this face is not a good choice, by the way). - -If you are unhappy with just @emph{some} of the aspects of the default -faces, you can modify them when Ediff is being loaded using -@code{ediff-load-hook}. For instance: - -@smallexample -(add-hook 'ediff-load-hook - (function (lambda () - (set-face-foreground - ediff-current-diff-face-B "blue") - (set-face-background - ediff-current-diff-face-B "red") - (make-face-italic - ediff-current-diff-face-B)))) -@end smallexample - -@strong{Note:} it is not recommended to use @code{internal-get-face} (or -@code{get-face} in XEmacs) when defining Ediff's faces, since this may -cause problems when there are several frames with different font sizes. -Instead, use @code{copy-face} or @code{set/make-face-@dots{}} as shown -above. - -@node Narrowing, Refinement of Difference Regions, Highlighting Difference Regions, Customization -@section Narrowing - -If buffers being compared are narrowed at the time of invocation of -Ediff, @code{ediff-buffers} will preserve the narrowing range. However, -if @code{ediff-files} is invoked on the files visited by these buffers, -that would widen the buffers, since this command is defined to compare the -entire files. - -Calling @code{ediff-regions-linewise} or @code{ediff-windows-linewise}, or -the corresponding @samp{-wordwise} commands, narrows the variants to the -particular regions being compared. The original accessible ranges are -restored when you quit Ediff. During the command, you can toggle this -narrowing on and off with the @kbd{%} command. - -These two variables control this narrowing behavior: - -@table @code -@item ediff-start-narrowed -@vindex ediff-start-narrowed -If @code{t}, Ediff narrows the display to the appropriate range when it -is invoked with an @samp{ediff-regions@dots{}} or -@samp{ediff-windows@dots{}} command. If @code{nil}, these commands do -not automatically narrow, but you can still toggle narrowing on and off -by typing @kbd{%}. - -@item ediff-quit-widened -@vindex ediff-quit-widened -Controls whether on quitting Ediff should restore the accessible range -that existed before the current invocation. -@end table - -@node Refinement of Difference Regions, Patch and Diff Programs, Narrowing, Customization -@section Refinement of Difference Regions - -Ediff has variables to control the way fine differences are -highlighted. This feature gives you control over the process of refinement. -Note that refinement ignores spaces, tabs, and newlines. - -@table @code -@item ediff-auto-refine -@vindex ediff-auto-refine -This variable controls whether fine differences within regions are -highlighted automatically (``auto-refining''). The default is yes -(@samp{on}). - -On a slow machine, automatic refinement may be painful. In that case, -you can turn auto-refining on or off interactively by typing -@kbd{@@}. You can also turn off display of refining that has -already been done. - -When auto-refining is off, fine differences are shown only for regions -for which these differences have been computed and saved before. If -auto-refining and display of refining are both turned off, fine -differences are not shown at all. - -Typing @kbd{*} computes and displays fine differences for the current -difference region, regardless of whether auto-refining is turned on. - -@item ediff-auto-refine-limit -@vindex ediff-auto-refine-limit -If auto-refining is on, this variable limits the size of the regions to -be auto-refined. This guards against the possible slowdown that may be -caused by extraordinary large difference regions. - -You can always refine the current region by typing @kbd{*}. - -@item ediff-forward-word-function -@vindex ediff-forward-word-function -This variable controls how fine differences are computed. The -value must be a Lisp function that determines how the current difference -region should be split into words. - -@vindex ediff-diff-program -@vindex ediff-forward-word-function -@findex ediff-forward-word -Fine differences are computed by first splitting the current difference -region into words and then passing the result to -@code{ediff-diff-program}. For the default forward word function (which is -@code{ediff-forward-word}), a word is a string consisting of letters, -@samp{-}, or @samp{_}; a string of punctuation symbols; a string of digits, -or a string consisting of symbols that are neither space, nor a letter. - -This default behavior is controlled by four variables: @code{ediff-word-1}, -..., @code{ediff-word-4}. See the on-line documentation for these variables -and for the function @code{ediff-forward-word} for an explanation of how to -modify these variables. -@vindex ediff-word-1 -@vindex ediff-word-2 -@vindex ediff-word-3 -@vindex ediff-word-4 -@end table - -Sometimes, when a region has too many differences between the variants, -highlighting of fine differences is inconvenient, especially on -color displays. If that is the case, type @kbd{*} with a negative -prefix argument. This unhighlights fine differences for the current -region. - -To unhighlight fine differences in all difference regions, use the -command @kbd{@@}. Repeated typing of this key cycles through three -different states: auto-refining, no-auto-refining, and no-highlighting -of fine differences. - -@node Patch and Diff Programs, Merging and diff3, Refinement of Difference Regions, Customization -@section Patch and Diff Programs - -This section describes variables that specify the programs to be used for -applying patches and for computing the main difference regions (not the -fine difference regions): - -@table @code -@item ediff-diff-program -@itemx ediff-diff3-program -@vindex ediff-patch-program -@vindex ediff-diff-program -@vindex ediff-diff3-program -These variables specify the programs to use to produce differences -and do patching. - -@item ediff-diff-options -@itemx ediff-diff3-options -@vindex ediff-patch-options -@vindex ediff-diff-options -@vindex ediff-diff3-options -These variables specify the options to pass to the above utilities. - -In @code{ediff-diff-options}, it may be useful to specify options -such as @samp{-w} that ignore certain kinds of changes. However, -Ediff does not let you use the option @samp{-c}, as it doesn't recognize this -format yet. - -@item ediff-patch-program -The program to use to apply patches. Since there are certain -incompatibilities between the different versions of the patch program, the -best way to stay out of trouble is to use a GNU-compatible version. -Otherwise, you may have to tune the values of the variables -@code{ediff-patch-options}, @code{ediff-backup-specs}, and -@code{ediff-backup-extension} as described below. -@item ediff-patch-options -Options to pass to @code{ediff-patch-program}. - -Note: the `-b' and `-z' options should be specified in -`ediff-backup-specs', not in @code{ediff-patch-options}. - -It is recommended to pass the `-f' option to the patch program, so it won't -ask questions. However, some implementations don't accept this option, in -which case the default value of this variable should be changed. - -@item ediff-backup-extension -Backup extension used by the patch program. Must be specified, even if -@code{ediff-backup-specs} is given. -@item ediff-backup-specs -Backup directives to pass to the patch program. -Ediff requires that the old version of the file (before applying the patch) -is saved in a file named @file{the-patch-file.extension}. Usually -`extension' is `.orig', but this can be changed by the user, and may also be -system-dependent. Therefore, Ediff needs to know the backup extension used -by the patch program. - -Some versions of the patch program let the user specify `-b backup-extension'. -Other versions only permit `-b', which (usually) assumes the extension `.orig'. -Yet others force you to use `-z<backup-extension>'. - -Note that both `ediff-backup-extension' and `ediff-backup-specs' must be -properly set. If your patch program takes the option `-b', but not -`-b extension', the variable `ediff-backup-extension' must still -be set so Ediff will know which extension to use. - -@item ediff-custom-diff-program -@itemx ediff-custom-diff-options -@vindex ediff-custom-diff-program -@vindex ediff-custom-diff-options -@findex ediff-save-buffer -Because Ediff limits the options you may want to pass to the @code{diff} -program, it partially makes up for this drawback by letting you save the -output from @code{diff} in your preferred format, which is specified via -the above two variables. - -The output generated by @code{ediff-custom-diff-program} (which doesn't -even have to be a standard-style @file{diff}!) is not used by Ediff. It is -provided exclusively so that you can -refer to -it later, send it over email, etc. For instance, after reviewing the -differences, you may want to send context differences to a colleague. -Since Ediff ignores the @samp{-c} option in -@code{ediff-diff-program}, you would have to run @code{diff -c} separately -just to produce the list of differences. Fortunately, -@code{ediff-custom-diff-program} and @code{ediff-custom-diff-options} -eliminate this nuisance by keeping a copy of a difference list in the -desired format in a buffer that can be displayed via the command @kbd{D}. - -@item ediff-patch-default-directory -@vindex ediff-patch-default-directory -Specifies the default directory to look for patches. - -@end table - -@noindent -@strong{Warning:} Ediff does not support the output format of VMS -@code{diff}. Instead, make sure you are using some implementation of POSIX -@code{diff}, such as @code{gnudiff}. - -@node Merging and diff3, Support for Version Control, Patch and Diff Programs, Customization -@section Merging and diff3 - -Ediff supports three-way comparison via the functions @code{ediff-files3} and -@code{ediff-buffers3}. The interface is the same as for two-way comparison. -In three-way comparison and merging, Ediff reports if any two difference -regions are identical. For instance, if the current region in buffer A -is the same as the region in buffer C, then the mode line of buffer A will -display @samp{[=diff(C)]} and the mode line of buffer C will display -@samp{[=diff(A)]}. - -Merging is done according to the following algorithm. - -If a difference region in one of the buffers, say B, differs from the ancestor -file while the region in the other buffer, A, doesn't, then the merge buffer, -C, gets B's region. Similarly when buffer A's region differs from -the ancestor and B's doesn't, A's region is used. - -@vindex ediff-default-variant -If both regions in buffers A and B differ from the ancestor file, Ediff -chooses the region according to the value of the variable -@code{ediff-default-variant}. If its value is @code{default-A} then A's -region is chosen. If it is @code{default-B} then B's region is chosen. -If it is @code{combined} then the region in buffer C will look like -this: - -@example -#ifdef NEW /* variant A */ -difference region from buffer A -#else /* variant B */ -difference region from buffer B -#endif /* NEW */ -@end example - -@vindex ediff-combination-pattern -The actual strings that separate the regions copied from buffer A and B -are controlled by the variable @code{ediff-combination-pattern}. Its -value should be a list of three strings. The first is inserted before -the difference region of buffer A; the second string goes between the -regions; the third goes after region B, as shown in the above example. - -In addition to the state of the difference, Ediff displays the state of the -merge for each region. If a difference came from buffer A by default -(because both regions A and B were different from the ancestor and -@code{ediff-default-variant} was set to @code{default-A}) then -@samp{[=diff(A) default-A]} is displayed in the mode line. If the -difference in buffer C came, say, from buffer B because the difference -region in that buffer differs from the ancestor, but the region in buffer A -does not (if merging with an ancestor) then @samp{[=diff(B) prefer-B]} is -displayed. The indicators default-A/B and prefer-A/B are inspired by -Emerge and have the same meaning. - -Another indicator of the state of merge is @samp{combined}. It appears -with any difference region in buffer C that was obtained by combining -the difference regions in buffers A and B as explained above. - -In addition to the state of merge and state of difference indicators, while -merging with an ancestor file or buffer, Ediff informs the user when the -current difference region in the (normally invisible) ancestor buffer is -empty via the @emph{AncestorEmpty} indicator. This helps determine if the -changes made to the original in variants A and B represent pure insertion -or deletion of text: if the mode line shows @emph{AncestorEmpty} and the -corresponding region in buffers A or B is not empty, this means that new -text was inserted. If this indicator is not present and the difference -regions in buffers A or B are non-empty, this means that text was -modified. Otherwise, the original text was deleted. - -Although the ancestor buffer is normally invisible, Ediff maintains -difference regions there and advances the current difference region -accordingly. All highlighting of difference regions is provided in the -ancestor buffer, except for the fine differences. Therefore, if desired, the -user can put the ancestor buffer in a separate frame and watch it -there. However, on a TTY, only one frame can be visible at any given time, -and Ediff doesn't support any single-frame window configuration where all -buffers, including the ancestor buffer, would be visible. However, the -ancestor buffer can be displayed by typing @kbd{/} to the control -window. (Type @kbd{C-l} to hide it again.) - -Note that the state-of-difference indicators @samp{=diff(A)} and -@samp{=diff(B)} above are not redundant, even in the presence of a -state-of-merge indicator. In fact, the two serve different purposes. - -For instance, if the mode line displays @samp{=diff(B) prefer(B)} and -you copy a difference region from buffer A to buffer C then -@samp{=diff(B)} will change to @samp{diff-A} and the mode line will -display @samp{=diff(A) prefer-B}. This indicates that the difference -region in buffer C is identical to that in buffer A, but originally -buffer C's region came from buffer B. This is useful to know because -you can recover the original difference region in buffer C by typing -@kbd{r}. - - -Ediff never changes the state-of-merge indicator, except in response to -the @kbd{!} command (see below), in which case the indicator is lost. -On the other hand, the state-of-difference indicator is changed -automatically by the copying/recovery commands, @kbd{a}, @kbd{b}, @kbd{r}, -@kbd{+}. - -The @kbd{!} command loses the information about origins of the regions -in the merge buffer (default-A, prefer-B, or combined). This is because -recomputing differences in this case means running @code{diff3} on -buffers A, B, and the merge buffer, not on the ancestor buffer. (It -makes no sense to recompute differences using the ancestor file, since -in the merging mode Ediff assumes that you have not edited buffers A and -B, but that you may have edited buffer C, and these changes are to be -preserved.) Since some difference regions may disappear as a result of -editing buffer C and others may arise, there is generally no simple way -to tell where the various regions in the merge buffer came from. - -In three-way comparison, Ediff tries to disregard regions that consist -entirely of white space. For instance, if, say, the current region in -buffer A consists of the white space only (or if it is empty), Ediff will -not take it into account for the purpose of computing fine differences. The -result is that Ediff can provide a better visual information regarding the -actual fine differences in the non-white regions in buffers B and -C. Moreover, if the regions in buffers B and C differ in the white space -only, then a message to this effect will be displayed. - -@vindex ediff-merge-window-share -In the merge mode, the share of the split between window C (the window -displaying the merge-buffer) and the windows displaying buffers A and B -is controlled by the variable @code{ediff-merge-window-share}. Its -default value is 0.5. To make the merge-buffer window smaller, reduce -this amount. - -We don't recommend increasing the size of the merge-window to more than -half the frame (i.e., to increase the value of -@code{ediff-merge-window-share}) to more than 0.5, since it would be -hard to see the contents of buffers A and B. - -You can temporarily shrink the merge window to just one line by -typing @kbd{s}. This change is temporary, until Ediff finds a reason to -redraw the screen. Typing @kbd{s} again restores the original window size. - -With a positive prefix argument, the @kbd{s} command will make the merge -window slightly taller. This change is persistent. With `@kbd{-}' or -with a negative prefix argument, the command @kbd{s} makes the merge -window slightly shorter. This change also persistent. - -@vindex ediff-show-clashes-only -Ediff lets you automatically ignore the regions where only one of the -buffers A and B disagrees with the ancestor. To do this, set the -variable @code{ediff-show-clashes-only} to non-@code{nil}. - -You can toggle this feature interactively by typing @kbd{$}. - -Note that this variable affects only the show next/previous difference -commands. You can still jump directly to any difference region directly -using the command @kbd{j} (with a prefix argument specifying the difference -number). - -@vindex ediff-autostore-merges -@vindex ediff-quit-merge-hook -@findex ediff-maybe-save-and-delete-merge -The variable @code{ediff-autostore-merges} controls what happens to the -merge buffer when Ediff quits. If the value is @code{nil}, nothing is done -to the merge buffer---it will be the user's responsibility to save it. -If the value is @code{t}, the user will be asked where to save the buffer -and whether to delete it afterwards. It the value is neither @code{nil} nor -@code{t}, the merge buffer is saved @emph{only} if this merge session was -invoked from a group of related Ediff session, such as those that result -from @code{ediff-merge-directories}, -@code{ediff-merge-directory-revisions}, etc. -@xref{Session Groups}. This behavior is implemented in the function -@code{ediff-maybe-save-and-delete-merge}, which is a hook in -@code{ediff-quit-merge-hook}. The user can supply a different hook, if -necessary. - -The variable @code{ediff-autostore-merges} is buffer-local, so it can be -set in a per-buffer manner. Therefore, use @code{setq-default} to globally -change this variable. - -@node Support for Version Control, Customizing the Mode Line, Merging and diff3, Customization -@section Support for Version Control - - -Ediff supports version control and lets you compare versions of files -visited by Emacs buffers via the function @code{ediff-revision}. This -feature is controlled by the following variables: - -@table @code -@item ediff-version-control-package -@vindex ediff-version-control-package -A symbol. The default is @samp{vc}. - -If you are like most Emacs users, Ediff will use VC as the version control -package. This is the standard Emacs interface to RCS, CVS, and SCCS. - -However, if your needs are better served by other interfaces, you will -have to tell Ediff which version control package you are using, e.g., -@example -(setq ediff-version-control-package 'rcs) -@end example - -Apart from the standard @file{vc.el}, Ediff supports three other interfaces -to version control: -@file{rcs.el}, @file{pcl-cvs.el}, and @file{generic-sc.el}. -The package @file{rcs.el} is written by Sebastian Kremer -<sk@@thp.Uni-Koeln.DE> and is available as -@example -@file{ftp.cs.buffalo.edu:pub/Emacs/rcs.tar.Z} -@file{ftp.uni-koeln.de:/pub/gnu/emacs/rcs.tar.Z} -@end example -The packages @file{pcl-cvs.el} and @file{generic-sc.el} are found in XEmacs -distribution. -@pindex @file{vc.el} -@pindex @file{rcs.el} -@pindex @file{pcl-cvs.el} -@pindex @file{generic-sc.el} -@end table - -Ediff's interface to the above packages allows the user to compare the -versions of the current buffer or to merge them (with or without an -ancestor-version). These operations can also be performed on directories -containing files under version control. - -In case of @file{pcl-cvs.el}, Ediff can also be invoked via the function -@code{run-ediff-from-cvs-buffer}---see the documentation string for this -function. - -@node Customizing the Mode Line, Miscellaneous, Support for Version Control, Customization -@section Customizing the Mode Line - -When Ediff is running, the mode line of @samp{Ediff Control Panel} -buffer shows the current difference number and the total number of -difference regions in the two files. - -The mode line of the buffers being compared displays the type of the -buffer (@samp{A:}, @samp{B:}, or @samp{C:}) and (usually) the file name. -Ediff tries to be intelligent in choosing the mode line buffer -identification. In particular, it works well with the -@file{uniquify.el} and @file{mode-line.el} packages (which improve on -the default way in which Emacs displays buffer identification). If you -don't like the way Ediff changes the mode line, you can use -@code{ediff-prepare-buffer-hook} to modify the mode line. -@vindex ediff-prepare-buffer-hook -@pindex @file{uniquify.el} -@pindex @file{mode-line.el} - -@node Miscellaneous, Notes on Heavy-duty Customization, Customizing the Mode Line, Customization -@section Miscellaneous - -Here are a few other variables for customizing Ediff: - -@table @code -@item ediff-split-window-function -@vindex ediff-split-window-function -Controls the way you want the window be split between file-A and file-B -(and file-C, if applicable). It defaults to the vertical split -(@code{split-window-vertically}, but you can set it to -@code{split-window-horizontally}, if you so wish. -Ediff also lets you switch from vertical to horizontal split and back -interactively. - -Note that if Ediff detects that all the buffers it compares are displayed in -separate frames, it assumes that the user wants them to be so displayed -and stops splitting windows. Instead, it arranges for each buffer to -be displayed in a separate frame. You can switch to the one-frame mode -by hiding one of the buffers A/B/C. - -You can also swap the windows where buffers are displayed by typing -@kbd{~}. - -@item ediff-merge-split-window-function -@vindex ediff-merge-split-window-function -Controls how windows are -split between buffers A and B in the merge mode. -This variable is like @code{ediff-split-window-function}, but it defaults -to @code{split-window-horizontally} instead of -@code{split-window-vertically}. - -@item ediff-make-wide-display-function -@vindex ediff-make-wide-display-function -The value is a function to be called to widen the frame for displaying -the Ediff buffers. See the on-line documentation for -@code{ediff-make-wide-display-function} for details. It is also -recommended to look into the source of the default function -@code{ediff-make-wide-display}. - -You can toggle wide/regular display by typing @kbd{m}. In the wide -display mode, buffers A, B (and C, when applicable) are displayed in a -single frame that is as wide as the entire workstation screen. This is -useful when files are compared side-by-side. By default, the display is -widened without changing its height. - -@item ediff-use-last-dir -@vindex ediff-use-last-dir -Controls the way Ediff presents the -default directory when it prompts the user for files to compare. If -@code{nil}, -Ediff uses the default directory of the current buffer when it -prompts the user for file names. Otherwise, it will use the -directories it had previously used for files A, B, or C, respectively. - -@item ediff-no-emacs-help-in-control-buffer -@vindex ediff-no-emacs-help-in-control-buffer -If @code{t}, makes @kbd{C-h} -behave like the @key{DEL} key, i.e., it will move you back to the previous -difference rather than invoking help. This is useful when, in an xterm -window or a text-only terminal, the Backspace key is bound to @kbd{C-h} and is -positioned more conveniently than the @key{DEL} key. - -@item ediff-toggle-read-only-function -@vindex ediff-toggle-read-only-function -This variable's value is a function that Ediff uses to toggle -the read-only property in its buffers. - -The default function that Ediff uses simply toggles the read-only property, -unless the file is under version control. For a checked-in file under -version control, Ediff first tries to check the file out. - -@item ediff-make-buffers-readonly-at-startup nil -@vindex ediff-make-buffers-readonly-at-startup -If t, all variant buffers are made read-only at Ediff startup. - -@item ediff-keep-variants -@vindex @code{ediff-keep-variants} -The default is @code{t}, meaning that the buffers being compared or merged will -be preserved when Ediff quits. Setting this to @code{nil} causes Ediff to -offer the user a chance to delete these buffers (if they are not modified). -Supplying a prefix argument to the quit command (@code{q}) temporarily -reverses the meaning of this variable. This is convenient when the user -prefers one of the behaviors most of the time, but occasionally needs the -other behavior. - -However, Ediff temporarily resets this variable to @code{t} if it is -invoked via one of the "buffer" jobs, such as @code{ediff-buffers}. -This is because it is all too easy to loose day's work otherwise. -Besides, in a "buffer" job, the variant buffers have already been loaded -prior to starting Ediff, so Ediff just preserves status quo here. - -Using @code{ediff-cleanup-hook}, one can make Ediff delete the variants -unconditionally (e.g., by making @code{ediff-janitor} into one of these hooks). -@item ediff-grab-mouse -@vindex @code{ediff-grab-mouse} -Default is @code{t}. Normally, Ediff grabs mouse and puts it in its -control frame. This is useful since the user can be sure that when he -needs to type an Ediff command the focus will be in an appropriate Ediff's -frame. However, some users prefer to move the mouse by themselves. The -above variable, if set to @code{maybe}, will prevent Ediff from grabbing -the mouse in many situations, usually after commands that may take more -time than usual. In other situation, Ediff will continue grabbing the mouse -and putting it where it believes is appropriate. If the value is -@code{nil}, then mouse is entirely user's responsibility. -Try different settings and see which one is for you. -@end table - - -@node Notes on Heavy-duty Customization, , Miscellaneous, Customization -@section Notes on Heavy-duty Customization - -Some users need to customize Ediff in rather sophisticated ways, which -requires different defaults for different kinds of files (e.g., SGML, -etc.). Ediff supports this kind of customization in several ways. First, -most customization variables are buffer-local. Those that aren't are -usually accessible from within Ediff Control Panel, so one can make them -local to the panel by calling make-local-variable from within -@code{ediff-startup-hook}. - -Second, the function @code{ediff-setup} accepts an optional sixth -argument which has the form @code{((@var{var-name-1} . @var{val-1}) -(@var{var-name-2} . @var{val-2}) @dots{})}. The function -@code{ediff-setup} sets the variables in the list to the respective -values, locally in the Ediff control buffer. This is an easy way to -throw in custom variables (which usually should be buffer-local) that -can then be tested in various hooks. - -Make sure the variable @code{ediff-job-name} and @code{ediff-word-mode} are set -properly in this case, as some things in Ediff depend on this. - -Finally, if you want custom-tailored help messages, you can set the -variables @code{ediff-brief-help-message-function} and -@code{ediff-long-help-message-function} -to functions that return help strings. -@vindex ediff-startup-hook -@findex ediff-setup -@vindex ediff-job-name -@vindex ediff-word-mode -@vindex ediff-brief-help-message-function -@vindex ediff-long-help-message-function - -When customizing Ediff, some other variables are useful, although they are -not user-definable. They are local to the Ediff control buffer, so this -buffer must be current when you access these variables. The control buffer -is accessible via the variable @code{ediff-control-buffer}, which is also -local to that buffer. It is usually used for checking if the current buffer -is also the control buffer. - -Other variables of interest are: -@table @code -@item ediff-buffer-A -The first of the data buffers being compared. - -@item ediff-buffer-B -The second of the data buffers being compared. - -@item ediff-buffer-C -In three-way comparisons, this is the third buffer being compared. -In merging, this is the merge buffer. -In two-way comparison, this variable is nil. - -@item ediff-window-A -The window displaying buffer A. If buffer A is not visible, this variable -is nil or it may be a dead window. - -@item ediff-window-B -The window displaying buffer B. - -@item ediff-window-C -The window displaying buffer C, if any. - -@item ediff-control-frame -A dedicated frame displaying the control buffer, if it exists. -It is non-nil only if Ediff uses the multiframe display, i.e., when the -control buffer is in its own frame. -@end table - -@node Credits, Index, Customization, Top -@chapter Credits - -Ediff was written by Michael Kifer <kifer@@cs.sunysb.edu>. It was inspired -by emerge.el written by Dale R. Worley <drw@@math.mit.edu>. An idea due to -Boris Goldowsky <boris@@cs.rochester.edu> made it possible to highlight -fine differences in Ediff buffers. Alastair Burt <burt@@dfki.uni-kl.de> -ported Ediff to XEmacs, Eric Freudenthal <freudent@@jan.ultra.nyu.edu> -made it work with VC, Marc Paquette <marcpa@@cam.org> wrote the -toolbar support package for Ediff, and Hrvoje Niksic <hniksic@@srce.hr> -adapted it to the Emacs customization package. - -Many people provided help with bug reports, patches, and advice. -Without them, Ediff would not be nearly as useful as it is today. -Here is a full list of contributors (I hope I didn't miss anyone): - -@example -Neal Becker (neal@@ctd.comsat.com), -Alastair Burt (burt@@dfki.uni-kl.de), -Paul Bibilo (peb@@delcam.co.uk), -Kevin Broadey (KevinB@@bartley.demon.co.uk), -Harald Boegeholz (hwb@@machnix.mathematik.uni-stuttgart.de), -Bradley A. Bosch (brad@@lachman.com), -Michael D. Carney (carney@@ltx-tr.com), -Jin S. Choi (jin@@atype.com), -Scott Cummings (cummings@@adc.com), -Albert Dvornik (bert@@mit.edu), -Eric Eide (eeide@@asylum.cs.utah.edu), -Paul Eggert (eggert@@twinsun.com), -Kevin Esler (esler@@ch.hp.com), -Robert Estes (estes@@ece.ucdavis.edu), -Jay Finger (jayf@@microsoft.com), -Xavier Fornari (xavier@@europe.cma.fr), -Eric Freudenthal (freudent@@jan.ultra.nyu.edu), -Job Ganzevoort (Job.Ganzevoort@@cwi.nl), -Boris Goldowsky (boris@@cs.rochester.edu), -Allan Gottlieb (gottlieb@@allan.ultra.nyu.edu), -Xiaoli Huang (hxl@@epic.com), -Lars Magne Ingebrigtsen (larsi@@ifi.uio.no), -Larry Gouge (larry@@itginc.com), -Karl Heuer (kwzh@@gnu.ai.mit.edu), -(irvine@@lks.csi.com), -(jaffe@@chipmunk.cita.utoronto.ca), -David Karr (dkarr@@nmo.gtegsc.com), -Norbert Kiesel (norbert@@i3.informatik.rwth-aachen.de), -Leigh L Klotz (klotz@@adoc.xerox.com), -Fritz Knabe (Fritz.Knabe@@ecrc.de), -Heinz Knutzen (hk@@informatik.uni-kiel.d400.de), -Andrew Koenig (ark@@research.att.com), -Ken Laprade (laprade@@dw3f.ess.harris.com), -Will C Lauer (wcl@@cadre.com), -Richard Levitte (levitte@@e.kth.se), -Mike Long (mike.long@@analog.com), -Martin Maechler (maechler@@stat.math.ethz.ch), -Simon Marshall (simon@@gnu.ai.mit.edu), -Richard Mlynarik (mly@@adoc.xerox.com), -Chris Murphy (murphycm@@sun.aston.ac.uk), -Erik Naggum (erik@@naggum.no), -Eyvind Ness (Eyvind.Ness@@hrp.no), -Ray Nickson (nickson@@cs.uq.oz.au), -David Petchey (petchey_david@@jpmorgan.com), -Benjamin Pierce (benjamin.pierce@@cl.cam.ac.uk), -Tibor Polgar (tlp00@@spg.amdahl.com), -David Prince (dave0d@@fegs.co.uk), -Paul Raines (raines@@slac.stanford.edu), -Bill Richter (richter@@math.nwu.edu), -C.S. Roberson (roberson@@aur.alcatel.com), -Kevin Rodgers (kevin.rodgers@@ihs.com), -Sandy Rutherford (sandy@@ibm550.sissa.it), -Heribert Schuetz (schuetz@@ecrc.de), -Andy Scott (ascott@@pcocd2.intel.com), -Axel Seibert (axel@@tumbolia.ppp.informatik.uni-muenchen.de), -Scott O. Sherman (Scott.Sherman@@mci.com), -Richard Stallman (rms@@gnu.ai.mit.edu), -Richard Stanton (stanton@@haas.berkeley.edu), -Ake Stenhoff (etxaksf@@aom.ericsson.se), -Stig (stig@@hackvan.com), -Peter Stout (Peter_Stout@@cs.cmu.edu), -Chuck Thompson (cthomp@@cs.uiuc.edu), -Ray Tomlinson (tomlinso@@bbn.com), -Raymond Toy (toy@@rtp.ericsson.se), -Philippe Waroquiers (philippe.waroquiers@@eurocontrol.be), -Klaus Weber (gizmo@@zork.north.de), -Ben Wing (wing@@666.com), -Ilya Zakharevich (ilya@@math.ohio-state.edu), -Eli Zaretskii (eliz@@is.elta.co.il) -@end example - -@node Index, , Credits, Top -@unnumbered Index -@printindex cp - -@contents -@bye
--- a/man/efs.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1692 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@comment %**start of header (This is for running Texinfo on a region.) -@setfilename efs.info -@settitle EFS -@comment %**end of header (This is for running Texinfo on a region.) - -@direntry -* EFS:: Transparent remote file access via FTP. -@end direntry - -@synindex fn vr - -@node Top, What is EFS?, (dir), (dir) -@comment node-name, next, previous, up -@ifinfo -@unnumbered EFS - -This file documents EFS, a system for transparent file-transfer -between remote hosts using the FTP protocol within Emacs. - -This info is for version 1.15 of EFS. - -Documentation version: 1.0 - -Copyright @copyright{} 1991, 1992 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries a copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the -entire resulting derived work is distributed under the terms of a -permission notice identical to this one. -@end ifinfo - -@titlepage -@sp5 -@center @titlefont{EFS} -@center version 1.15 -@sp2 -@center A transparent remote file system, by Sandy Rutherford and Andy Norman -@sp7 -@center This documentation based on ange-ftp documentation by David Smith -@center and on documentation in the EFS source code -@center It was put together by Mike Sperber. - -This documentation is definitely incomplete and parts of it may be -outright incorrect or out-of-date. - -@center info-version 1.0 -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1991, 1992 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the -entire resulting derived work is distributed under the terms of a -permission notice identical to this one. -@end titlepage - -@menu -* What is EFS?:: -* Installing EFS:: Where to find it, and how to use it. -* Using EFS:: EFS -- a users' guide. -* Getting help:: Mailing lists and newsgroups. -* Bugs:: Known bugs, and a wish list. - -Indices: -* Concept Index:: -* Variable and function index:: -@end menu - - -@node What is EFS?, Installing EFS, Top, Top -@comment node-name, next, previous, up -@chapter Introducing EFS - -EFS is a system for transparent file-transfer between remote UNIX, -Guardian, DOS, Macintosh, KA9Q, Netware, NOS/VE, Plan 9, TI Explorer, -Twenex, TOPS 20, VOS, MPE, MVS, VMS, CMS or MTS hosts using FTP. This -means that you can edit, copy and otherwise manipulate files on any -machine you have access to from within Emacs as if it were a local -file. EFS works by introducing an extended filename syntax, and -overloading functions such as @code{insert-file-contents} so that -accessing a remote file causes appropriate commands to be sent to an FTP -process. EFS includes and enhanced version of Dired to facilitate -directory browsing and multiple file transfer from remote hosts. - -The authors of EFS are Sandy Rutherford (@code{sandy@@math.ubc.ca}) and -Andy (Ange) Norman (@code{ange@@hplb.hpl.hp.com}). EFS is partly based -on an earlier package called ange-ftp. The integration of EFS 1.15 into -XEmacs and numerous bug fixes were done by Mike Sperber -(@code{sperber@@informatik.uni-tuebingen.de}). - -@ifinfo -Many people have sent in enhancements for ange-ftp and EFS. -Members of the ange-ftp and EFS Hall of Fame include: - -@itemize @bullet -@item -Many thanks to Roland McGrath for improving the filename syntax handling, -for suggesting many enhancements and for numerous cleanups to the code. - -@item -Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways. - -@item -Thanks to Ken Laprade for improved @file{.netrc} parsing and password -reading, and Dired/shell autoloading. - -@item -Thanks to Sebastian Kremer for tree dired support and for many ideas and -bugfixes. - -@item -Thanks to Joe Wells for bugfixes, non-UNIX system support, VOS support, -and hostname completion. - -@item -Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help -with file-name expansion, efficiency worries, stylistic concerns and many -bugfixes. - -@item -Also, thanks to Rob Austein, Doug Bagley, Andy Caiger, Jim Franklin, -Noah Friedman, Aksnes Knut-Havard, Elmar Heeb, John Interrante, Roland -McGrath, Jeff Morgenthaler, Mike Northam, Jens Petersen, Jack Repenning, -Joerg-Martin Schwarz, Michael Sperber, Svein Tjemsland, Andy Whitcroft, -Raymond A. Wiker and many others whose names have been forgotten who -have helped to debug and fix problems. -@end itemize -@end ifinfo - -Finally, this info file was put together by Mike Sperber -(@code{sperber@@informatik.uni-tuebingen.de}) from an ange-ftp info file -written by Dave Smith (@code{dsmith@@stats.adelaide.edu.au}) and the EFS -source code. - -@node Installing EFS, Using EFS, What is EFS?, Top -@comment node-name, next, previous, up -@chapter Installing EFS - -At the time of writing of this documentation, the version of EFS -distributed with XEmacs (this means the EFS running on XEmacs -19.15/20.1) is the latest version available. It includes many bugfixes -and some enhancements over the last separately released version of EFS, -1.15. This situation will change once a new version of EFS is -available. - -Generally, EFS is pretty easy to get hold of. FTP is the probably the -simplest method, but other options such as mail are available. - -Once you have the Emacs-Lisp source, there are a few customisations you -might need to make. The ideal configuration is to have the FTP process running -on the same machine as you are running Emacs on, but this is not always -possible since some machines cannot access hosts outside the local -network. In this case, the FTP process needs to be run on a machine -which @emph{does} have access to the local world --- this is called the -@strong{gateway host}. EFS has facilities to make use of a -gateway host when accessing remote hosts. - -@menu -* Obtaining source code:: Where to find the EFS source. -* Installing source:: Where to put it, how to load it. -* Using a gateway:: If your local machine has limited access. -* Setting up a gateway:: -* Gateway types:: -* Gateway problems:: -* Other options:: More user variables to twiddle. -@end menu - -@node Obtaining source code, Installing source, Installing EFS, Installing EFS -@section How to get the EFS source code -@comment node-name, next, previous, up - -The latest separately distributed version of EFS should always be -available from Andy Norman's home page at -@example -http://www-uk.hpl.hp.com/people/ange/efs -@end example - -There are also some ftp locations: - -@table @b -@item Switzerland -@example -/anonymous@@itp.ethz.ch:/sandy/efs/ -@end example - -@item Massachusetts, USA -@example -/anonymous@@alpha.gnu.ai.mit.edu:/efs/ -@end example - -@item California, USA -@example -/anonymous@@ftp.hmc.edu:/pub/emacs/packages/efs/ -@end example -@end table - -Failing these, someone on the EFS mailing list (@xref{Getting help}) may -be able to help you find the latest version. - -@node Installing source, Using a gateway, Obtaining source code, Installing EFS -@comment node-name, next, previous, up -@section Installing the source - -For byte compiling the EFS package, a @file{Makefile} is provided. You -should follow the instructions at the top of the @file{Makefile}. If -you have any problems, please let us know so that we can fix them for -other users. Don't even consider using eFS without byte compiling it. It -will be far too slow. - -If you decide to byte compile efs by hand, it is important that the file -@file{efs-defun.el} be byte compiled first, followed by @file{efs.el}. -The other files may be byte compiled in any order. - -To use EFS, simply put the byte compiled files in your load path -and add - -@example -(require 'efs) -@end example - -in your @file{.emacs} file. Note this takes awhile, and some users have -found this to be unbearably slow. Therefore ... - -If you would like efs to be autoloaded when you attempt to access -a remote file, put - -@example -(require 'efs-auto) -@end example - -in your @file{.emacs} file. Note that there are some limitations associated -with autoloading EFS. A discussion of them is given at the top of -@file{efs-auto.el}. - -Note that, in XEmacs, EFS automatically loads @file{efs-auto} when the -user accesses a remote file. Therefore, no additional @code{require} -statements should be necessary to use EFS. Just fire away ... - -The above instructions should allow you to access all hosts that your -local machine can access. If your local host has limited access, -however, you may wish to have EFS working through a gateway -machine. If so, read on. Otherwise, @xref{Using EFS} to get started -using EFS. - -@node Using a gateway, Setting up a gateway, Installing source, Installing EFS -@comment node-name, next, previous, up -@section Using a gateway - -Sometimes it is necessary for the FTP process to be run on a different -machine than the machine running Emacs. This can happen when the -local machine has restrictions on what hosts it can access. - -Suppose you are running Emacs (and EFS, of course) on a machine X -(let's call it the `local host') and you want to access a file on a -machine Z (which we will call the `remote host'). Unfortunately, X does -not have FTP access to Z: when you try a manual FTP something like -the following happens: -@example -X$ ftp Z.foo.bar.com -ftp: connect: Host is unreachable -@end example -@noindent -However, X @emph{does} have access to a machine Y (the `gateway -machine') which @emph{can} access Z. Fortunately, you have an account on -the gateway machine, and so the solution is to login to Y, ftp to Z, -download the file you want from Z to Y, and then copy it from Y to the -local host, X. This can get a bit tedious, to say the least, but -fortunately EFS can do all the hard work for you. - -@node Setting up a gateway, Gateway types, Using a gateway, Installing EFS -@comment node-name, next, previous, up -@section Setting up a gateway - -@enumerate - -@item -Set the variable @code{efs-gateway-host} to the name of a machine -@vindex efs-gateway-host -that doesn't have the access restrictions. If you need to use a -nonstandard port to access this host for gateway use, then specify -@code{efs-gateway-host} as @code{<hostname>#<port>}. - -@item -Set the variable @code{efs-ftp-local-host-regexp} to a regular -expression -@vindex efs-ftp-local-host-regexp -that matches hosts that can be contacted from running a local ftp -process, but fails to match hosts that can't be accessed locally. - -For example: - -@example - "\\.hp\\.com$\\|^[^.]*$" -@end example - -will match all hosts that are in the @t{.hp.com} domain, or don't have -an explicit domain in their name, but will fail to match hosts with -explicit domains or that are specified by their ip address. - -@item -Set the variable @code{efs-local-host-regexp} to machines that you have -@vindex efs-local-host-regexp -direct TCP/IP access. In other words, you must be able to ping these -hosts. Usually, @code{efs-ftp-local-host-regexp} and -@code{efs-local-host-regexp} will be the same. However, they will -differ for so-called transparent gateways. See below for more -details. - -@item -Set the variable @code{efs-gateway-tmp-name-template} to the name of -@vindex efs-gateway-tmp-name-template -a directory plus an identifying filename prefix for making temporary -files on the gateway. For example: @code{"/tmp/hplose/ange/efs"} - -@item -If the gateway and the local host share cross-mounted directories, -set the value of @code{efs-gateway-mounted-dirs-alist} accordingly. It -@vindex efs-gateway-mounted-dirs-alist -is particularly useful, but not mandatory, that the directory -of @code{efs-gateway-tmp-name-template} be cross-mounted. -@vindex efs-gateway-tmp-name-template - -@item -Set the variable @code{efs-gateway-type} to the type gateway that you have. -This variable is a list, the first element of which is a symbol -denoting the type of gateway. -@end enumerate - -@node Gateway types, Gateway problems, Setting up a gateway, Installing EFS -@comment node-name, next, previous, up -@section Supported gateway types - -@vindex efs-gateway-type - -@table @samp - -@item local -This means that your local host is itself the gateway. However, -it is necessary to use a different FTP client to gain access to -the outside world. If the name of the FTP client were @t{xftp}, you might -set @code{efs-gateway-type} to - -@example -(list 'local "xftp" efs-ftp-program-args) -@end example - -If @t{xftp} required special arguments, then give them in place of -@t{efs-ftp-program-args}. -@vindex efs-ftp-program-args - -@item proxy - -This indicates that your gateway works by first FTP'ing to it, and -then issuing a @code{USER} command of the form - -@example -USER <username>@@<host> -@end example - -In this case, you might set @code{efs-gateway-type} to - -@example -(list 'proxy "ftp" efs-ftp-program-args) -@end example - -If you need to use a nonstandard client, such as @t{iftp}, give this -@pindex iftp -instead of @t{ftp}. If this client needs to take special arguments, -give them instead of @t{efs-ftp-program-args}. - -@item remsh - -For this type of gateway, you need to start a remote shell on -your gateway, using either @t{remsh} or @t{rsh}. You should set -@pindex remsh -@pindex rsh -@sc{efs-gateway-type} to something like - -@example -(list 'remsh "remsh" nil "ftp" efs-ftp-program-args) -@end example - -If you use @t{rsh} instead of @r{remsh}, change the second element from -@code{"remsh"} to @code{"rsh"}. Note that the symbol indicating the gateway -type should still be @code{'remsh}. If you want to pass arguments -to the remsh program, give them as the third element. For example, -if you need to specify a user, make this @code{(list "-l" "sandy")}. -If you need to use a nonstandard FTP client, specify that as the fourth -element. If your FTP client needs to be given special arguments, -give them instead of @code{efs-ftp-program-args}. - -@item interactive - -This indicates that you need to establish a login on the gateway, -using either @t{telnet} or @t{rlogin}. -@pindex telnet -@pindex rlogin -You should set @code{efs-gateway-type} to something like - -@example -(list 'interactive "rlogin" nil "exec ftp" efs-ftp-program-args) -@end example - -If you need to use @t{telnet}, then give @code{"telnet"} in place of the second -element @code{"rlogin"}. If your login program needs to be given arguments, -then they should be given in the third slot. The fourth element -is for the name of the FTP client program. Giving this as @code{"exec ftp"}, -instead of @code{"ftp"}, ensures that you are logged out if the FTP client -dies. If the FTP client takes special arguments, give these instead -of @code{efs-ftp-program-args}. Furthermore, you should see the documentation -at the top of @file{efs-gwp.el}. You may need to set the variables -@code{efs-gwp-setup-term-command}, and @code{efs-gwp-prompt-pattern}. -@vindex efs-gwp-setup-term-command -@vindex efs-gwp-prompt-pattern - -@item raptor -This is a type of gateway where efs is expected to specify a gateway -user, and send a password for this user using the @code{ACCOUNT} command. -For example, to log in to @samp{foobar.edu} as sandy, while using the account -ange on the gateway, the following commands would be sent: - -@example -open raptorgate.com -quote USER sandy@@foobar.edu ange -quote pass <sandy's password on foobar> -quote account <ange's password on raptorgate> -@end example - -For such a gateway, you would set @code{efs-gateway-type} to - -@example -(list 'raptor efs-ftp-program efs-ftp-program-args <GATEWAY USER>) -@end example - -where @code{<GATEWAY USER>} is the name of your account on the gateway. In -the above example, this would be @code{"ange"}. You can set your gateway -password by simply setting an account password for the gateway host. -This can be done with either efs-set-account, or within your .netrc -file. If no password is set, you will be prompted for one. - -@item interlock -This is a type of gateway where you are expected to send a PASS -command after opening the connection to the gateway. -The precise login sequence is - -@example -open interlockgate -quote PASS <sandy's password on interlockgate> -quote USER sandy@@foobar.edu -quote PASS <sandy's password on foobar.edu> -@end example - -For such a gateway, you should set @code{efs-gateway-type} to - -@example -(list 'interlock efs-ftp-program efs-ftp-program-args) -@end example - -If you need to use a nonstandard name for your FTP client, -then replace @code{efs-ftp-program} with this name. If your FTP client -needs to take nonstandard arguments, then replace @code{efs-ftp-program-args} -with these arguments. - -If your gateway returns both a 220 code and a 331 code to the -@code{"open interlockgate"} command, then you should add a regular -expression to @code{efs-skip-msgs} that matches the 220 response. -Returning two response codes to a single FTP command is not permitted -in RFC 959. It is not possible for efs to ignore the 220 by default, -because than it would hang for interlock installations which do not -require a password. - -@item kerberos -With this gateway, you need to authenticate yourself by getting a -kerberos "ticket" first. Usually, this is done with the kinit program. -Once authenticated, you connect to @samp{foobar.com} as user sandy with the -sequence: (Note that the @code{"-n"} argument inhibits automatic login. -Although, in manual use you probably don't use it, EFS always uses it.) - -@example -iftp -n -open foobar.com -user sandy@@foobar.com -@end example -@pindex iftp - -You should set @code{efs-gateway-type} to something like - -@example -(list 'kerberos "iftp" efs-ftp-program-args "kinit" <KINIT-ARGS>) -@end example - -If you use an FTP client other than @t{iftp}, insert its name instead of -@code{"iftp"} above. If your FTP client needs special arguments, give -them as a list of strings in place of @code{efs-ftp-program-args}. If -the program that you use to collect a ticket in not called -@code{"kinit"}, then give its name in place of @code{"kinit"} above. -@code{<KINIT-ARGS>} should be any arguments that you need to pass to -your kinit program, given as a list of strings. Most likely, you will -give this as nil. - -See the file @file{efs-kerberos.el} for more configuration variables. If you -need to adjust any of these variables, please report this to us so that -we can fix them for other users. - -If EFS detects that you are not authenticated to use the gateway, it -will run the kinit program automatically, prompting you for a password. -If you give a password in your @file{.netrc} file for login the value of -@code{efs-gateway-host} and user @t{kerberos}, then EFS will use this to -obtain gateway authentication. - -@item Transparent gateways - -If your gateway is completely transparent (for example it uses socks), -then you should set @code{efs-gateway-type} to @code{nil}. Also, set -@code{efs-ftp-local-host-regexp} to @code{".*"}. However, -@code{efs-local-host-regexp}, must still be set to a regular expression -matching hosts in your local domain. EFS uses this to determine which -machines that it can open-network-stream to. Furthermore, you should -still set @code{efs-gateway-host} to the name of your gateway machine. -That way EFS will know that this is a special machine having direct -TCP/IP access to both hosts in the outside world, and hosts in your -local domain. - -@end table - - - -@node Gateway problems, Other options, Gateway types, Installing EFS -@comment node-name, next, previous, up -@section Common Problems with Gateways - -@subsection Spurious 220 responses - -Some proxy-style gateways (eg gateway type @code{'proxy} or @code{'raptor}), -return two 3-digit FTP reply codes to the @code{USER} command. -For example: - -@example -open gateway.weird -220 Connected to gateway.weird -quote USER sandy@@foobar -220 Connected to foobar -331 Password required for sandy -@end example - -This is wrong, according to the FTP Protocol. Each command must return -exactly one 3-digit reply code. It may be preceded by continuation -lines. What should really be returned is: - -@example -quote USER sandy@@foobar -331-Connected to foobar. -331 Password required for sandy. -@end example - -or even - -@example -quote USER sandy@@foobar -331-220 Connected to foobar. -331 Password required for sandy. -@end example - -Even though the @samp{"331-220"} looks strange, it is correct protocol, -and EFS will parse it properly. - -If your gateway is returning a spurious 220 to @code{USER}, a work-around -is to add a regular expression to @code{efs-skip-msgs} that matches -@vindex efs-skip-msgs -this line. It must not match the 220 line returned to the open -command. This work-around may not work, as some system FTP clients -also get confused by the spurious 220. In this case, the only -solution is to patch the gateway server. In either case, please -send a bug report to the author of your gateway software. - -@subsection Case-sensitive parsing of FTP commands - -Some gateway servers seem to treat FTP commands case-sensitively. -This is incorrect, as RFC 959 clearly states that FTP commands -are always to be case-insensitive. If this is a problem with your -gateway server, you should send a bug report to its author. -If efs is using a case for FTP commands that does not suit your server, -a possible work-around is to edit the efs source so that the required -case is used. However, we will not be making any changes to the -standard EFS distribution to support this type of server behaviour. -If you need help changing the efs source, you should enquire with the -efs-help mailing list. - -@node Other options, , Gateway problems, Installing EFS -@comment node-name, next, previous, up -@section Other user options - -Here are other user options available in EFS: - -@code{efs-netrc-filename}: The name of a file in @code{netrc(5)} -format that EFS will use to match hostnames, users and their -respective passwords. Hostnames specified here are also used for hostname -completion. -The default is @code{"~/.netrc"}. -@vindex efs-netrc-filename - -@code{efs-default-user}: If this is a string, it is the username to -use when none is specified in a filename. If @code{nil}, then the -name under which the user is logged in is used. If non-@code{nil} but -not a string, the user is prompted for the name. The default is @code{nil}. -@vindex efs-default-user - -@code{efs-default-password}: The password to use when the user is the -same as @code{efs-default-user}. The default is @code{nil}. -@vindex efs-default-password - -@code{efs-default-account}: Account password to use when the user -is the same as @code{efs-default-user}. The default is @code{nil}. -@vindex efs-default-account - -@code{efs-dumb-unix-host-regexp}: The FTP servers on some machines have -problems if the @code{ls} command is used. The usual indication that -something is wrong is when EFS erroneously thinks that a directory -is just a plain file. The routine @code{efs-add-host} can -be called to tell EFS to limit itself to the @code{DIR} command and -not @code{ls} for a given host (but this change will take effect for the -current Emacs session only) when called like this: - -@example -(efs-add-host 'dumb-unix "hostname") -@end example - -If a large number of machines with similar hostnames have this problem -then it is easier to change the value of this variable to a regexp which -matches hostnames which have this problem, particularly since EFS cannot -automatically detect such hosts. The default is @code{nil}. -@vindex efs-dumb-unix-host-regexp -@findex efs-add-host - -@code{efs-binary-file-name-regexp}: By default EFS will -transfer files in ASCII mode. If a file being transferred matches the -value of this regexp then the FTP process will be toggled into BINARY -mode before the transfer and back to ASCII mode after the transfer. The -default is: -@example - (concat "\\." ; the dot - ;; extensions - "\\([zZ]\\|t?gz\\|lzh\\|arc\\|zip\\|zoo\\|ta[rz]\\|dvi\\|sit\\|" - "ps\\|elc\\|gif\\|Z-part-..\\|tpz\\|exe\\|[jm]pg\\|TZ[a-z]?\\|lib\\)" - "\\(~\\|~[0-9]+~\\)?$" ; backups - "\\|" - ;; UPPER CASE LAND - "\\." - "\\(ARC\\|ELC\\|TAGS\\|EXE\\|ZIP\\|DVI\|ZOO\\|GIF\\|T?GZ\\|" - "[JM]PG\\)" - "\\([.#;][0-9]+\\)?$" ; versions - ) -@end example -@vindex efs-binary-file-name-regexp - -@code{efs-hash-mark-size}: EFS by default requests that the -FTP process sends hash marks (just @code{#} characters) during transfers -to keep track of how much data has been sent or received. This variable, -if non-@code{nil}, should be the number of kilobytes represented by the -FTP client's hash mark. The default value of 1 doesn't work for me --- I -use 2 instead. -@vindex efs-hash-mark-size - -@code{efs-verbose}: If this is @code{t} then EFS will be chatty about -interaction with the FTP process. The default is @code{t}. -@vindex efs-process-verbose - -@code{efs-ftp-program-name}: This should be the name of the FTP -program to run on the local host. The default value of @code{"ftp"} -should be fine for most systems. -@vindex efs-ftp-program-name - -@code{efs-make-backup-files}: A list of operating systems for which -EFS will make Emacs backup files on the remote host. For example, -@code{'(unix)} makes sense, but @code{'(unix vms)} or @code{'(vms)} -would be silly, since VMS makes its own backups. The host type is -determined by the function @code{efs-host-type}. Possible host -types are: @code{dumb-unix}; @code{vos}; @code{vms}; @code{mts}; and -@code{unix}. The default of @code{nil} means make no backups on remote -hosts. -@vindex efs-make-backup-files -@cindex backup files - -@code{efs-skip-msgs}: A regular expression matching messages from -the ftp process that can be ignored. The default is -@example - (concat - "^110 \\|" ; Restart marker reply. - "^125 \\|" ; Data connection already open; transfer starting. - "^150 ") ; File status OK; about to open connection. -@end example -@noindent -but you might need to tweak it if EFS is giving up when it -shouldn't. -@vindex efs-skip-msgs - -@code{efs-fatal-msgs}: A regular expression matching messages from -the FTP process that indicate something has gone drastically wrong -attempting the action that was initiated and that the FTP process should -(or already has) been killed. The default is -@example -(concat - ;; RFC959 codes - "^221 \\|" ; Service closing control connection. - "^421 \\|" ; Service not available. - "^425 \\|" ; Can't open data connection. - "^426 \\|" ; Connection closed, transfer aborted. - "^451 \\|" ; Requested action aborted, local error in processing. - ;; RFC959 non-compliant codes - "^552 Maximum Idle Time Exceded\\.$\\|" ; Hellsoft server uses this to - ; indicate a timeout. 552 is - ; supposed to be used for exceeded - ; storage allocation. Note that - ; they also misspelled the error - ; message. - ;; client problems - "^ftp: \\|^Not connected\\|^rcmd: \\|^No control connection\\|" - "^unknown host\\|: unknown host$\\|^lost connection\\|" - "^[Ss]egmentation fault\\|" - ;; Make sure that the "local: " isn't just a message about a file. - "^local: [^/]\\|" - ;; Gateways - "^iftp: cannot authenticate to server\\b" - ) -@end example -@vindex efs-fatal-msgs - -@code{efs-gateway-fatal-msgs}: Regular expression matching messages -from the rlogin / telnet process that indicates that logging in to the -gateway machine has gone wrong. The default is -@example -"No route to host\\|Connection closed\\|No such host\\|Login incorrect" -@end example -@vindex efs-gateway-fatal-msgs - -@code{efs-tmp-name-template}: This should be a directory and a -filename prefix indicating where EFS should make temporary files. -The default of @code{"/tmp/efs"} should be fine for most systems. -@vindex efs-tmp-name-template -@cindex temporary files - -@code{efs-retry-time}: Number of seconds to wait before retrying if -a file or listing doesn't arrive. For slow connections, you might get a -``listing unreadable'' error messages -@cindex listing unreadable error -or an empty buffer for a file that you know has something in it. The -solution is to increase the value of @code{efs-retry-time}. Its default -value is 5 which is plenty for reasonable connections. However, for -some transatlantic connections 20 might be a better value. -@vindex efs-retry-time - -@node Using EFS, Getting help, Installing EFS, Top -@comment node-name, next, previous, up -@chapter Using EFS - -Once installed, efs operates largely transparently. All files normally -accessible to you on the internet, become part of a large virtual file -system. These files are accessed using an extended file name syntax. To -access file @code{<path>} on remote host @code{<host>} by logging in as -user @code{<user>}, you simply specify the full path of the file as -@code{/<user>@@<host>:<path>}. Nearly all Emacs file handling functions -work for remote files. It is not possible to access remote files using -shell commands in an emacs *shell* buffer, as such commands are passed -directly to the shell, and not handled by emacs. - -FTP is the underlying utility that efs uses to operate on remote files. - -For example, if @code{find-file} is given a filename of: - -@example -/ange@@anorman:/tmp/notes -@end example - -then EFS will spawn an FTP process, connect to the host 'anorman' as -user 'ange', get the file @file{/tmp/notes} and pop up a buffer containing the -contents of that file as if it were on the local file system. If efs -needed a password to connect then it would prompt the user in the -minibuffer. For further discussion of the EFS path syntax, see the -paragraph on extended file name syntax @ref{Remote filenames}. - -Full file-name completion is supported on every type of remote host. To -do filename completion, EFS needs a listing from the remote host. -Therefore, for very slow connections, it might not save any -time. However, the listing is cached, so subsequent uses of file-name -completion will be just as fast as for local file names. - -@menu -* Ports:: Using nonstandard ports. -* Remote filenames:: The EFS extended filename syntax. -* Passwords:: -* Using Dired:: Browsing directories. -* Using a .netrc:: Preventing password pestering. -* EFS commands:: Interactive commands supplied by EFS. -* FTP processes:: How EFS does its work -* Tips:: Some stuff to help you use EFS -* DL support:: Descriptive directory listings -* Non-Unix Hosts:: Some of what you want to know -* Completion:: Works but has its price -* Accessing the FTP process:: ... manually -@end menu - -@node Ports, Remote filenames, Using EFS, Using EFS -@comment node-name, next, previous, up -@section Using nonstandard ports - -EFS supports the use of nonstandard ports on remote hosts. To specify -that port @code{<port>} should be used, give the host name as -@code{host#<port>}. Host names may be given in this form anywhere that -efs normally expects a host name. This includes in the @file{.netrc} file. -Logically, EFS treats different ports to correspond to different remote -hosts. - -@node Remote filenames, Passwords, Ports, Using EFS -@comment node-name, next, previous, up -@section Extended filename syntax - -The default full EFS path syntax is - -@example -/<user>@@<host>#<port>:<path> -@end example - -Both the @code{#<port>'}and @code{<user>@@} may be omitted. - -If the @code{#<port>} is omitted, then the default port is taken to be 21, -the usual FTP port. For most users, the port syntax will only -very rarely be necessary. - -If the @code{<user>@@} is omitted, then EFS will use a default user. If -a login token is specified in your @file{.netrc} file, then this will be -used as the default user for @code{<host>}. Otherwise, it is determined -based on the value of the variable @code{efs-default-user}. -@vindex efs-default-user - -This EFS path syntax can be customised to a certain extent by changing a -number of variables. To -undertake such a customization requires some knowledge about the -internal workings of EFS. - -@node Passwords, Using Dired, Remote filenames, Using EFS -@comment node-name, next, previous, up -@section Passwords - -A password is required for each host / user pair. This will be prompted -for when needed, unless already set by calling @code{efs-set-passwd}, -@findex efs-set-passwd -or specified in a @emph{valid} @file{~/.netrc} file. - -When EFS prompts for a password, it provides defaults from its cache of -currently known passwords. The defaults are ordered such that passwords -for accounts which have the same user name as the login which is -currently underway have priority. You can cycle through your list of -defaults with @kbd{C-n} to cycle forwards and @kbd{C-p} to cycle -backwards. The list is circular. - -@subsection Passwords for anonymous user - -Passwords for the user @t{anonymous} (or @t{ftp}) are handled specially. -The variable @code{efs-generate-anonymous-password} controls what -\vindex efs-generate-anonymous-password happens. If the value of this -variable is a string, then this is used as the password; if -non-@code{nil}, then a password is created from the name of the user and -the hostname of the machine on which Emacs is running; if @code{nil} -(the default) then the user is prompted for a password as normal. - -@subsection Account passwords - -Some FTP servers require an additional password which is sent by the -@code{ACCOUNT} command. EFS will detect this and prompt the user for an -account password if the server expects one. Also, an account password -can be set by calling @code{efs-set-account}, or by specifying an -@findex efs-set-account -account token in the @file{.netrc} file. - -Some operating systems, such as CMS, require that @code{ACCOUNT} be used -to give a write access password for minidisks. @code{efs-set-account} can be -used to set a write password for a specific minidisk. Also, tokens of -the form - -@example -minidisk <minidisk name> <password> -@end example - -may be added to host lines in your @file{.netrc} file. Minidisk tokens -must be at the end of the host line, however there may be an arbitrary -number of them for any given host. - -@node Using Dired, Using a .netrc, Passwords, Using EFS -@comment node-name, next, previous, up -@section Using Dired - -This feature of EFS is particularly useful when file transfers, as -opposed to file editing, are the order of the day. Simply run -@code{find-file} on a directory to -get a listing of the files in that directory. For example, you might -run @code{find-file} on -@example -/anonymous@@archive.site.com:pub -@end example -@noindent -to see what's in the @file{pub} directory of your favourite archive -@cindex archive sites -site. This brings up a Dired buffer of all the files in that directory. -The @kbd{f} command is useful for looking at @file{README} files --- if -you then decide to save it @kbd{C-x C-w} is useful. You can also use -this method to copy files, but the @kbd{c} command is easier. The -@kbd{f} command can also be used to descend the directory tree by -applying it to directories. - -You can also use Dired to refresh EFS's internal cache. If you -(or anybody else) has changed a remote directory since you first accessed it -with EFS, completion is not provided on any new files that EFS -does not know about. If you have -(or create) a Dired buffer which contains the modified directory, -executing @code{revert-buffer} -@findex revert-buffer -with a prefix argument (@kbd{C-u g} in the Dired buffer) -will force a refresh of both the the buffer @emph{and also EFS's -internal cache}. If you find that filename completion isn't working on a -@cindex filename completion -file that you @emph{know} is there, this is how to fix the problem. - -Dired provides facilities for maintaining an -entire directory tree in a Dired buffer, for marking files which match a -certain regexp (or you can select files interactively) and then copying -all those files to your local host (or even a different remote host). -Another useful feature is Virtual Dired, which allows you to save Dired -@cindex virtual dired -buffers of remote hosts, allowing you to browse them at a later date -without actually needing to connect to the host. - -@node Using a .netrc, EFS commands, Using Dired, Using EFS -@comment node-name, next, previous, up -@section Using a .netrc file - -Being prompted for passwords all the time can get rather annoying, but -there is a way to fix the problem --- a @file{.netrc} (but @xref{Other -options} and @code{efs-netrc-filename} -@vindex efs-netrc-filename -if you want another -filename) file in your home directory. Basically, this is a file (in the -format of Unix @code{netrc(5)}) which -contains the names of all the machines you regularly login to, as well -as the username and password you use for that machine. You can also -supply an account password, if required. - -Your @file{.netrc} file consists of lines of the form -@example -machine <machine-name> login <user-name> password <password> -@end example -@noindent -It doesn't all have to be on the one line, though: any @code{login} or -@code{password} commands in the file refer to the previous -@code{machine} command. You can also have @code{account -<account-passwd>} commands if you need special account passwords. - -For example, you might have the following line in your @file{.netrc}: -@example -machine Y.local.lan.edu login myname password secret -@end example -@noindent -Then if you run @code{find-file} on the file @file{/Y.local.lan.edu:somefile} -you will automatically be logged in as user @code{myname} with password -@code{secret}. You can still login under another name and password, if -you so desire: just include the @code{user@@} part of the filename. - -You may also include a default option, as follows: -@example -default login <user-name> password <password> -@end example -@noindent -which applies to any other machines not mentioned elsewhere in your -@file{.netrc}. A particularly useful application of this is with -anonymous logins: -@cindex anonymous FTP -@example -default login myname password myname@@myhost.edu -@end example -@noindent -so that accessing @file{/anyhost:anyfile} will automatically log you in -anonymously, provided the host is not mentioned in the @file{.netrc}. -Note also that if the value of @code{efs-default-user} is -@vindex efs-default-user -non-@code{nil}, its value will have precedence over the username -supplied in the default option of the @file{.netrc}. - -The @file{.netrc} file is also useful in another regard: machines -included in it are provided with hostname completion. That is, for any -@cindex hostname completion -machine in the @file{.netrc}, you need only type a slash and the first -few characters of its name and then press @key{TAB} to be logged in -automatically with a username and password from the @file{.netrc} file. -So it's a good idea to put hosts you use regularly in your @file{.netrc} -as well: -@example -machine archive.site.com login anonymous password myname@@X.local.lan.edu -@end example - -@node EFS commands, FTP processes, Using a .netrc, Using EFS -@comment node-name, next, previous, up -@section EFS commands - -EFS supplies a few interactive commands to make connecting with -hosts a little easier. - -@noindent -Command @code{efs-set-user}: Prompts for a hostname and a username. -Next time access to the host is attempted, EFS will attempt to log -in again with the new username. -@findex efs-set-user - -@noindent -Command @code{efs-set-passwd}: Prompts for a hostname, user and -password. Future logins to that host as that user will use the given -password. -@findex efs-set-passwd - -@noindent -Command @code{efs-set-account}: Prompts for a hostname, user and -account. Future logins to that host as that user will use the given -account. -@findex efs-set-account - -Note that the effects of the above three commands only last the duration -of the current Emacs session. To make their effects permanent, you may -include them as lisp code in your @file{.emacs}: -@example -(efs-set-user HOST USER) -(efs-set-password HOST USER PASSWORD) -(efs-set-account HOST USER ACCOUNT) -@end example -@noindent -This is an alternative to using a @file{.netrc}; @xref{Using a .netrc}. - -@noindent -Command @code{efs-kill-ftp-process}: kill the FTP process -associated with a given buffer's filename (by default the current -buffer). This is an easy way to achieve a resynch: any future accesses -to the remote host will cause the FTP process to be recreated. -@findex efs-kill-ftp-process - -@node FTP processes, Tips, EFS commands, Using EFS -@comment node-name, next, previous, up -@section FTP processes - -When EFS starts up an FTP process, it leaves it running for speed -purposes. Some FTP servers will close the connection after a period of -time, but EFS should be able to quietly reconnect the next time that -the process is needed. - -The FTP process will be killed should the associated @samp{*ftp user@@host*} -buffer be deleted. This should not cause efs any grief. - -@subsection Showing background FTP activity on the mode-line - -After EFS is loaded, the command @code{efs-display-ftp-activity} will cause -@findex efs-display-ftp-activity -background FTP activity to be displayed on the mode line. The variable -@code{efs-mode-line-format} is used to determine how this data is displayed. -@vindex efs-mode-line-format -efs does not continuously track the number of active sessions, as this -would cause the display to change too rapidly. Rather, it uses a heuristic -algorithm to determine when there is a significant change in FTP activity. - -@subsection File types - -By default EFS will assume that all files are ASCII. If a file -being transferred matches the value of @code{efs-binary-file-name-regexp} -@vindex efs-binary-file-name-regexp -then the file will be assumed to be a binary file, and EFS will -transfer it using "type image". ASCII files will be transferred -using a transfer type which efs computes to be correct according -to its knowledge of the file system of the remote host. The -command @code{efs-prompt-for-transfer-type} toggles the variable -@findex efs-prompt-for-transfer-type -@code{efs-prompt-for-transfer-type}. When this variable is -@vindex efs-prompt-for-transfer-type -non-@code{nil}, EFS will prompt the user for the transfer type to use -for every FTP transfer. Having this set all the time is annoying, but -it is useful to give special treatment to a small set of files. There -is also a variable @code{efs-text-file-name-regexp}. This is tested -@vindex efs-text-file-name-regexp -before @code{efs-binary-file-name-regexp}, so if you set -@code{efs-text-file-name-regexp} to a non-trivial regular expression, -and @code{efs-binary-file-name-regexp} to @samp{".*"}, the result will -to make image the default tranfer type. - -Also, if you set @code{efs-treat-crlf-as-nl}, -@vindex efs-treat-crlf-as-nl -then EFS will use type image -to transfer files between hosts whose file system differ only in that -one specifies end of line as CR-LF, and the other as NL. This is useful -if you are transferring files between UNIX and DOS machines, and have a -package such as @file{dos-mode.el}, that handles the extra @key{^M}'s. - -@subsection Status reports - -Most EFS commands that talk to the FTP process output a status -message on what they are doing. In addition, efs can take advantage -of the FTP client's @code{HASH} command to display the status of transferring -files and listing directories. See the documentation for the variables -@code{efs-hash-mark-size}, -@vindex efs-hash-mark-size -@code{efs-send-hash} -@vindex efs-send-hash -and @code{efs-verbose} -@vindex efs-verbose -for more details. - -@subsection Caching of directory information - -EFS keeps an internal cache of file listings from remote hosts. -If this cache gets out of synch, it can be renewed by reverting a -dired buffer for the appropriate directory (@code{dired-revert} is usually -bound to @kbd{g}). - -Alternatively, you can add the following two lines to your @file{.emacs} file -if you want @kbd{C-r} to refresh EFS's cache whilst doing filename -completion. - -@example -(define-key minibuffer-local-completion-map "\C-r" 'efs-re-read-dir) -(define-key minibuffer-local-must-match-map "\C-r" 'efs-re-read-dir) -@end example - -@node Tips, DL support, FTP processes, Using EFS -@comment node-name, next, previous, up - -@section Tips for using EFS - -@enumerate -@item -Beware of compressing files on non-UNIX hosts. EFS will do it by -copying the file to the local machine, compressing it there, and then -sending it back. Binary file transfers between machines of different -architectures can be a risky business. Test things out first on some -test files. @xref{Bugs} Also, note that EFS sometimes -copies files by moving them through the local machine. Again, -be careful when doing this with binary files on non-Unix -machines. - -@item -Beware that dired over ftp will use your setting of -@code{dired-no-confirm} -@vindex dired-no-confirm -(list of dired commands for which confirmation is not asked). -You might want to reconsider your setting of this variable, -because you might want confirmation for more commands on remote -direds than on local direds. For example, I strongly recommend -that you not include compress in this list. If there is enough -demand it might be a good idea to have an alist -@code{efs-dired-no-confirm} of pairs @code{( TYPE . LIST )}, where @code{TYPE} is an -operating system type and @code{LIST} is a list of commands for which -confirmation would be suppressed. Then remote dired listings -would take their (buffer-local) value of @code{dired-no-confirm} from -this alist. Who votes for this? - -@item -Some combinations of FTP clients and servers break and get out of sync -when asked to list a non-existent directory. Some of the @t{ai.mit.edu} -machines cause this problem for some FTP clients. Using -@code{efs-kill-ftp-process} -@findex efs-kill-ftp-process -can be used to restart the ftp process, which -should get things back in synch. - -@item -Some ftp servers impose a length limit on the password that can -be sent. If this limit is exceeded they may bomb in an -incomprehensible way. This sort of behaviour is common with -MVS servers. Therefore, you should beware of this possibility -if you are generating a long password (like an email address) -with @code{efs-generate-anonymous-password}. -@vindex efs-generate-anonymous-password - -@item -Some antiquated FTP servers hang when asked for an @code{RNFR} command. -EFS sometimes uses this to test whether its local cache is stale. -If your server for @code{HOST} hangs when asked for this command, put - -@example -(efs-set-host-property HOST 'rnfr-failed t) -@end example - -in your @code{efs-ftp-startup-function-alist} -@vindex efs-ftp-startup-function-alist -entry for @code{HOST}. - -@item -The FTP servers on some Unix machines have problems if the @code{ls} -command is used. EFS will try to correct for this automatically, -and send the @code{dir} command instead. If it fails, you can call the -function @code{efs-add-host}, -@findex efs-add-host -and give the host type as @code{dumb-unix}. Note that this change will -take effect for the current Emacs session only. To make this -specification for future emacs sessions, put - -@example -(efs-add-host 'dumb-unix "hostname") -@end example - -in your @file{.emacs} file. Also, please report any failure to -automatically recognize dumb unix to the "bugs" address given below, so -that we can fix the auto recognition code. - -@end enumerate - -@node DL support, Non-Unix Hosts, Tips, Using EFS -@comment node-name, next, previous, up -@section Descriptive directory listings - -Some hosts (such as @code{cs.uwp.edu}) now use descriptive directory -listings -@cindex descriptive directory listings -@cindex extended directory listings -(which in fact contain @emph{less} information than the -standard listing!) when issued the @code{ls} command, and EFS has -been modified to cope with this. EFS can detect such listings, but -if you regularly use a remote host which uses this extended listing -format you should set the variable @code{efs-dl-dir-regexp} to a -@vindex efs-dl-dir-regexp -regular expression which matches directories using the extended listing -format. You shouldn't anchor the regexp with @samp{$} -- that way the -regexp will match subdirectories as well. Alternatively, you can use -the interactive command @code{efs-add-dl-dir} to temporarily add a -@findex efs-add-dl-dir -remote directory for this Emacs session only. - -Dired has been modified to work with such descriptive listings. - -@node Non-Unix Hosts, Completion, DL support, Using EFS -@comment node-name, next, previous, up -@section Using EFS with non-Unix hosts - -EFS also works with some non-Unix hosts, although not necessarily -with all the features available with Unix hosts. VMS, CMS, and MTS -systems will all now work with EFS and Dired. It also works with a whole -bunch of others, but documentation for that has not been written yet. -This section was taken straight from the ange-ftp manual, and is -therefore in all likelihood out-of-date. - -EFS should be able to automatically detect which type of host you -are using (VMS, CMS or MTS), but if it is unable to do so you can fix -the problem by setting the appropriate -@code{efs-TYPE-host-regexp} variable (where @code{TYPE} is one of -@samp{vms}, @samp{cms} or @samp{mts}) -- see below. If EFS is unable -to automatically detect any VMS, CMS or MTS host, please report this as -a bug: @xref{Bugs}. - -In all cases the file-name conventions of the remote host are converted -to a UNIX-ish format, and this is the format you should use to find -files on such hosts. - -@menu -* VMS support:: Using EFS with VMS systems -* CMS support:: Using EFS with CMS systems -* MTS support:: Using EFS with MTS systems -@end menu - -@node VMS support, CMS support, Non-Unix Hosts, Non-Unix Hosts -@comment node-name, next, previous, up -@subsection VMS support -@cindex VMS filenames -VMS filenames are of the form @code{FILE.TYPE;##}, where both -@code{FILE} and @code{TYPE} can be up to 39 characters long, and -@code{##} is an integer version number between 1 and 32,767. Valid -characters in filenames are @samp{A}-@samp{Z}, @samp{0}-@samp{9}, -@samp{_}, @samp{-} and @samp{$}, however @samp{$} cannot begin a -filename and @samp{-} cannot be used as the first or last character. - -Directories in VMS are converted to the standard UNIX @samp{/} notation. -For example, the VMS filename -@example -PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 -@end example -would be entered as -@noindent -@example -/PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 -@end example -@noindent -(The double @samp{$} is required to prevent Emacs from attempting to -expand an environment variable.) Similarly, to anonymously FTP the file -@file{[.CSV.POLICY]RULES.MEM;1} from @code{ymir.claremont.edu} you would -type @kbd{C-x C-f -/anonymous@@ymir.claremont.edu:CSV/POLICY/RULES.MEM;1}. You can always -drop off the @samp{;##} part at the end of the filename to get the -latest version. - -Sandy Rutherford provides some tips for using VMS hosts: -@itemize @bullet -@item -Although VMS is not case sensitive, EMACS running under UNIX is. -Therefore, to access a VMS file, you must enter the filename with upper -case letters. - -@item -To access the latest version of file under VMS, you use the filename -without the @samp{;} and version number. You should always edit the -latest version of a file. If you want to edit an earlier version, copy -it to a new file first. This has nothing to do with EFS, but is -simply good VMS operating practice. Therefore, to edit @file{FILE.TXT;3} -(say 3 is latest version), do @kbd{C-x C-f -/ymir.claremont.edu:FILE.TXT}. If you inadvertently do -@example -@kbd{C-x C-f /ymir.claremont.edu:FILE.TXT;3} -@end example -@noindent -you will find that VMS will not allow -you to save the file because it will refuse to overwrite -@file{FILE.TXT;3}, but instead will want to create @file{FILE.TXT;4}, -and attach the buffer to this file. To get out of this situation, -@kbd{M-x write-file /ymir.claremont.edu:FILE.TXT} will attach the buffer -to latest version of the file. For this reason, in Dired @kbd{f} -(@code{dired-find-file}), -@findex dired-find-file -always loads the file sans version, whereas @kbd{v}, -(@code{dired-view-file}), -@findex dired-view-file -always loads the explicit version number. The -reasoning being that it reasonable to view old versions of a file, but -not to edit them. - -@item -VMS filenames often contain @samp{$} characters: make sure you always -quote these as @samp{$$} and watch out for the Emacs bug which fails to -quote @samp{$}'s when defaults are presented in the minibuffer: see -@xref{Bugs}. -@end itemize - -EFS should automatically detect that you are using a VMS host. If -it fails to do so (which should be reported as a bug) you can use the -command @code{efs-add-vms-host} -@findex efs-add-vms-host -to inform EFS manually. For a more permanent effect, or -if you use a VMS host regularly, it's a good idea to set -@code{efs-vms-host-regexp} to a regular expression matching that -@vindex efs-vms-host-regexp -host's name. For instance, if use use @code{ymir.claremont.edu} a lot, -place the following in your .emacs: -@example -(setq efs-vms-host-regexp "^ymir.claremont.edu$") -@end example - -@node CMS support, MTS support, VMS support, Non-Unix Hosts -@comment node-name, next, previous, up -@subsection CMS support -EFS has full support, including Dired support, for hosts -running CMS. - -@cindex CMS filenames -CMS filenames are entered in a UNIX-y way. Minidisks are -treated as UNIX directories; for example to access the file @file{READ.ME} in -minidisk @file{*.311} on @file{cuvmb.cc.columbia.edu}, you would enter -@example -/anonymous@@cuvmb.cc.columbia.edu:/*.311/READ.ME -@end example -If @file{*.301} is the default minidisk for this account, you could access -@file{FOO.BAR} on this minidisk as -@example -/anonymous@@cuvmb.cc.columbia.edu:FOO.BAR -@end example -CMS filenames are of the form @file{FILE.TYPE}, where both @file{FILE} -and @file{TYPE} can be up to 8 characters. Again, beware that CMS -filenames are always upper case, and hence must be entered as such. - -Sandy Rutherford provides some tips on using CMS hosts: -@itemize @bullet -@item -CMS machines, with the exception of anonymous accounts, nearly always -need an account password. To have EFS send an account password, -you can either include it in your @file{.netrc} (@xref{Using a .netrc}), or use -@code{efs-set-account}. -@findex efs-set-account - -@item -EFS cannot send ``write passwords'' for a minidisk. Hopefully, we -can fix this. -@end itemize - -EFS should automatically detect that you are using a CMS host. If -it fails to do so (which should be reported as a bug) you can use the -command @code{efs-add-cms-host} -@findex efs-add-cms-host -to inform EFS manually. For a more permanent effect, or -if you use a CMS host regularly, it's a good idea to set -@code{efs-cms-host-regexp} to a regular expression matching that -@vindex efs-cms-host-regexp -host's name. - -@node MTS support, , CMS support, Non-Unix Hosts -@comment node-name, next, previous, up -@subsection MTS support -EFS has full support, including Dired support, for hosts -running the Michigan terminal system, and should be able to -automatically recognise any MTS machine. - -@cindex MTS filenames -MTS filenames are entered in a UNIX-y way. For example, if your account -was @file{YYYY}, the file @file{FILE} in the account @file{XXXX:} on -@file{mtsg.ubc.ca} would be entered as -@example -/YYYY@@mtsg.ubc.ca:/XXXX:/FILE -@end example -In other words, MTS accounts are treated as UNIX directories. Of course, -to access a file in another account, you must have access permission for -it. If @file{FILE} were in your own account, then you could enter it in a -relative path fashion as -@example -/YYYY@@mtsg.ubc.ca:FILE -@end example -MTS filenames can be up to 12 characters. Like UNIX, the structure of the -filename does not contain a type (i.e. it can have as many @samp{.}'s as you -like.) MTS filenames are always in upper case, and hence be sure to enter -them as such! MTS is not case sensitive, but an EMACS running under UNIX -is. - -EFS should automatically detect that you are using an MTS host. If -it fails to do so (which should be reported as a bug) you can use the -command @code{efs-add-mts-host} -@findex efs-add-mts-host -to inform EFS manually. For a more permanent effect, or -if you use an MTS host regularly, it's a good idea to set -@code{efs-mts-host-regexp} to a regular expression matching that -@vindex efs-mts-host-regexp -host's name. - -@node Completion, Accessing the FTP process, Non-Unix Hosts, Using EFS -@comment node-name, next, previous, up -@section File- and host-name completion - -Full filename completion is supported on all remote UNIX hosts and some -non-Unix hosts. Hostnames also have completion if they are mentioned in -the @file{.netrc} and no username is specified. However using the -filename completion feature can be a bit of a two edged sword. - -To understand why, we need to discuss how EFS works. Whenever -EFS is asked to find a remote file (or directory) an @code{ls} -command is sent to the FTP process to list all the files in the -directory. This list is maintained in an internal cache, to provide -filename completion for later requests on that directory. EFS keeps -this cache up-to-date by monitoring Emacs commands which affect files -and directories, but if a process outside Emacs (such as another user) -changes a directory (e.g. a new file is added) -completion won't work on -that file since EFS doesn't know about it yet. The solution if to -force EFS to reread the directory and update it's cache, and the -easiest way to do that is with Dired --- @xref{Using Dired} to see how. - -Another problem is that the @code{ls} command can take a long time, -especially when dealing with distant hosts over slow links. So if you're -after a file in the @file{pub/images} directory but nothing else, it's a -better idea to type @kbd{pub/images/file @key{TAB}} than @kbd{pub/im @key{TAB}} -which will force a read of the @file{pub} directory (since -EFS needs to know how to complete @code{im}). A little extra typing -can often save a lot of waiting. Don't be afraid to use the @key{TAB} -key once the directory is cached, though. - -@node Accessing the FTP process, , Completion, Using EFS -@comment node-name, next, previous, up -@section Accessing the FTP process buffer - -The FTP process used to access the remote files is available for access -if you wish. It will be in a buffer -@cindex process buffers -@cindex buffers -called @samp{"*ftp @var{remote-file-name}*"}, -i.e. if you found the file -@example -/anonymous@@archive.site.com:pub/README -@end example -@noindent -there will be a buffer -@example -*ftp anonymous@@archive.site.com* -@end example -@noindent -where all the transfers are taking place. You can have a look at the -buffer using @kbd{C-x b} as usual, and even type in commands to the FTP -process under an interface very much like @samp{shell-mode}. There are -two instances when doing this can be very useful: one is accessing -non-UNIX hosts, where Dired and filename completion may not work (if EFS -even works at all). If you are going to use @code{mget} or @code{mput}, -make sure you type @code{glob} first: EFS turns globbing off by -default. Don't be afraid of changing directories, either --- EFS always -uses absolute pathnames when communicating with the FTP process. - -You can kill the FTP process at any time simply by killing this buffer. -@cindex FTP processes -@cindex processes -You can also call @code{efs-kill-ftp-process}. -@findex efs-kill-ftp-process -This won't cause EFS any grief whatsoever --- if you later make -another request to that host, EFS will simply fire up another -process and create a new buffer to hold it. - -@node Getting help, Bugs, Using EFS, Top -@comment node-name, next, previous, up -@chapter Getting help - -EFS has its own mailing list called @t{efs-help}. All users of EFS -are welcome to subscribe (see below) and to discuss aspects of -EFS. - -To [un]subscribe to @t{efs-help}, or to report mailer problems with the -list, please mail one of the following addresses: - -@example -efs-help-request@@cuckoo.hpl.hp.com -@end example -or -@example -efs-help-request%cuckoo.hpl.hp.com@@hplb.hpl.hp.com -@end example - -Please don't forget the @t{-request} part. - -For mail to be posted directly to @t{efs-help}, send to one of the -following addresses: - -@example -efs-help@@cuckoo.hpl.hp.com -@end example -or -@example -efs-help%cuckoo.hpl.hp.com@@hplb.hpl.hp.com -@end example - -Alternatively, there is a mailing list that only gets -announcements of new EFS releases. This is called @t{efs-announce}, -and can be subscribed to by e-mailing to the @t{-request} address as -above. Please make it clear in the request which mailing list you -wish to join. - -Mailing list archives are also accessible from this web page: - -@example -http://www-uk.hpl.hp.com/people/ange/efs -@end example - - -@node Bugs, Concept Index, Getting help, Top -@comment node-name, next, previous, up -@chapter Bugs and Wish List - - -If you find any bugs or problems with this package, @strong{please} -e-mail the authors. Ideas and constructive comments are especially -welcome. So are any enhancements to EFS, preferably debugged and -documented. Also welcome are any typo fixes, corrections or additions to -this manual. - -Here is a list of known bugs: - -If you hit a bug in this list, please report it anyway. Most of -the bugs here remain unfixed because they are considered too -esoteric to be a high priority. If one of them gets reported -enough, we will likely change our view on that. - -@enumerate -@item -EFS does not check to make sure that when creating a new file, -you provide a valid filename for the remote operating system. -If you do not, then the remote FTP server will most likely -translate your filename in some way. This may cause EFS to -get confused about what exactly is the name of the file. - -@item -For CMS support, we send too many @code{cd}'s. Since @code{cd}'s are -cheap, I haven't worried about this too much. Eventually, we should have -some caching of the current minidisk. This is complicated by the fact -that some CMS servers lie about the current minidisk, so sending -redundant cd's helps us recover in this case. - -@item -The code to do compression of files over ftp is not as careful as it -should be. It deletes the old remote version of the file, before -actually checking if the local to remote transfer of the compressed file -succeeds. Of course to delete the original version of the file after -transferring the compressed version back is also dangerous, because some -OS's have severe restrictions on the length of filenames, and when the -compressed version is copied back the @code{"-Z"} or @code{".Z"} may be -truncated. Then, EFS would delete the only remaining version of the -file. Maybe EFS should make backups when it compresses files (of -course, the backup @code{"~"} could also be truncated off, sigh...). -Suggestions? - -@item -If a dir listing is attempted for an empty directory on (at least -some) VMS hosts, an ftp error is given. This is really an ftp bug, and -I don't know how to get EFS work to around it. - -@item -EFS gets confused by directories containing file names with embedded -newlines. A temporary solution is to add @code{"q"} to your dired -listing switches. As long as your dired listing switches also contain -@code{"l"} and either @code{"a"} or @code{"A"}, EFS will use these -switches to get listings for its internal cache. The "q" switch should -force listings to be exactly one file per line. You still will not be -able to access a file with embedded newlines, but at least it won't mess -up the parsing of the rest of the files. - -@item -EFS cannot parse symlinks which have an embedded @code{" -> "} in their -name. It's alright to have an embedded @code{" -> "} in the name of any -other type of file. A fix is possible, but probably not worth the -trouble. If you disagree, send us a bug report. - -@item -EFS doesn't handle context-dep. files in H-switch listings on -HP's. It wouldn't be such a big roaring deal to fix this. I'm -waiting until I get an actual bug report though. - -@item -If a hard link is added or deleted, EFS will not update its -internal cache of the link count for other names of the file. -This may cause file-nlinks to return incorrectly. Reverting -any dired buffer containing other names for the file will -cause the file data to be updated, including the link counts. -A fix for this problem is known and will be eventually -implemented. How it is implemented will depend on how we decide -to handle inodes. See below. - -@item -EFS is unable to parse R-switch listings from remote Unix hosts. -This is inefficient, because EFS will insist on doing individual -listings of the subdirectories to get its file information. -This may be fixed if there is enough demand. - -@item -In file-attributes, EFS returns a fake inode number. Of course -this is necessary, but this inode number is not even necessarily -unique. It is simply the sum of the characters (treated as -integers) in the host name, user name, and file name. Possible -ways to get a unique inode number are: - -@enumerate -@item -Simply keep a count of all remote file in the cache, and -return the file's position in this count as a negative number. -@item -For unix systems, we could actually get at the real inode number on the -remote host, by adding an @code{"i"} to the ls switches. The inode -numbers would then be removed from the listing returned by @code{efs-ls}, if -the caller hadn't requested the @code{"i"} switch. We could then make a -unique number out of the host name and the real inode number. -@end enumerate - -@item -EFS tries to determine if a file is readable or writable by comparing -the file modes, file owner, and user name under which it is logged -into the remote host. This does not take into account groups. -We simply assume that the user belongs to all groups. As a result -we may assume that a file is writable, when in fact it is not. -Groups are tough to handle correctly over FTP. Suggestions? -(For new FTP servers, can do a @code{"QUOTE SITE EXEC groups"} to -handle this.) -@end enumerate - - -@node Concept Index, Variable and function index, Bugs, Top -@comment node-name, next, previous, up -@unnumbered Concept Index - -@printindex cp - -@node Variable and function index, , Concept Index, Top -@unnumbered Variable and function index - -@printindex vr - -@contents - -@bye -
--- a/man/hm--html-mode.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2270 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@comment %**start of header (This is for running Texinfo on a region.) -@setfilename hm--html-mode.info -@settitle HM HTML Mode -@setchapternewpage odd -@comment %**end of header (This is for running Texinfo on a region.) -@comment $Id: hm--html-mode.texi,v 1.5 1997/09/17 05:19:51 steve Exp $ -@ifinfo -This file documents the Elisp package @code{hm--html-menus}. - -Copyright @copyright{} 1997 Heiko Münkel - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries a copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided also that the -sections entitled ``Distribution'' and ``General Public License'' are -included exactly as in the original, and provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that the sections entitled ``Distribution'' and ``General Public -License'' may be included in a translation approved by the author instead -of in the original English. - -@end ifinfo -@iftex -@input umlaute.texi -@end iftex -@titlepage -@sp 10 -@center @titlefont{The Elisp Package hm{-}{-}html{-}menus} - -@sp 4 -@center by Heiko Münkel -@sp 4 -@center Version 5.8, July 1997 -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1997 Heiko Münkel -@sp 4 -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries a copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided also that the -sections entitled ``Distribution'' and ``General Public License'' are -included exactly as in the original, and provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the above conditions for modified versions, -except that the sections entitled ``Distribution'' and ``General Public -License'' may be included in a translation approved by the author instead -of in the original English. - -@end titlepage - -@comment The Top node contains the master menu for the Info file. -@comment This appears only in the Info file, not in the printed manual. - -@node Top, License, (dir), (dir) -@comment node-name, next, previous, up - - - -@menu -* License:: Your rights -* Overview:: Overview -* Distribution:: How to get the latest version -* Installation:: How to install the package -* Customization:: How to customize the package -* Add New Elements:: How to add new HTML elements -* Use With Other Major Modes:: -* Internal Drag And Drop:: The HTML independent drag and drop package -* Template Minor Mode:: The HTML independent template package -* Hints For Emacs 19 Users:: Missing features in the Emacs 19 -* Bug Reports:: How and to whom you should send bug reports -* Concept Index:: Concept Index -* Function Index:: Function Index -* Variable Index:: Variable Index -@end menu - - -@node License, Overview, Top, Top -@comment node-name, next, previous, up -@chapter License -@cindex license to copy hm---html-menus -@cindex General Public License -Copyright (C) 1993 - 1997 Heiko Münkel, muenkel@@tnt.uni-hannover.de -@sp 2 -This program 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. - -This program 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 this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -@node Overview, Distribution, License, Top -@comment node-name, next, previous, up -@chapter Overview -@cindex overview -@cindex version -@findex hm--html-mode -@findex hm--html-minor-mode - -This document describes the Elisp package @emph{hm---html-menus 5.8}. - -The version of the document is:@* -$Id: hm--html-mode.texi,v 1.5 1997/09/17 05:19:51 steve Exp $ - -The package provides commands and various popup and pulldown menus for -an HTML mode called @dfn{hm---html-mode}, a mode for writing HTML pages -for the World Wide Web (WWW). It also provides a minor mode -(@dfn{hm---html-minor-mode}), which can be used together with other HTML -major modes, like the psgml-html mode in XEmacs 19.14 or other major -edit modes, like the perl-mode. - -You can easily view the HTML documents by calling the browsers w3 (a -nice elisp package from William M. Perry), Netscape, or Mosaic directly -from the pulldown menu of the mode. - -An integrated (emacs internal) drag and drop interface makes it -very easy to insert links or images, by just clicking on them. - -When appropriate, identical commands work on selected -regions. You'll see the same menu items and can use the same -keystrokes, whether a region is active or not, but if it's -active, then the commands are operating on the region. Therefore, you -don't need to learn different menus or keys for similar functions! - -One major design goal of the package was to make it easier to write a -HTML page, even if you don't know much about HTML. For that I've tried -to put more knowledge about HTML, URL's and so on in it than an SGML based -mode could find out from a DTD file. In most cases the user gets help to -construct a specific link by examples, or by a completion list with -possible input strings. And you can choose between an expert popup menu -and an novice popup menu interactively. The novice menu contains only -the basic HTML elements, so that you're not bothered by the quantity of -different HTML elements. And if you want to use more HTML elements, then -you can easily switch to the expert menus. - -You can configure the html mode with a special configuration file for -your site and with another file specific to a user. Look at the -customization chapter for this, @xref{Customization, Customization}. - - -@node Distribution, Installation, Overview, Top -@comment node-name, next, previous, up -@chapter Distribution -The name of the distribution file is -@file{hm--html-menus-<version>.tar.gz}, where @var{<version>} is the -version number. The package is part of the XEmacs. You should always -find the latest version of the package on the following ftp server: -@display -@emph{ftp.tnt.uni-hannover.de} in @file{/pub/editors/xemacs/contrib} -@end display -You should also find the package in the USA on the ftp server -(which is mirrored on many other servers in the world): -@display -@emph{sunsite.unc.edu} in @file{/pub/Linux/apps/editors/emacs} -@end display -@menu -* Contents:: Contents of the distribution -@end menu - -@node Contents, , Distribution, Distribution -@comment node-name, next, previous, up -@section Contents -@cindex contents -The package consists of the following files: - -@table @file -@item README -Please, read this first. -@itemx README-EMACS-19 -Some special hints only for GNU Emacs 19 users. -@itemx ANNOUNCEMENT -Text of the announcement of this package. -@itemx LSM -Entry for the Linux Software Map. -@itemx NEWS -The NEWS and Change log file. -@itemx adapt.el -Provides (emulates XEmacs) functions for the use of this package with -GNU Emacs 19. -@itemx drop -An xbm file with the drag and drop mouse pointer in the XEmacs. -@itemx dropmsk -An xbm file with the mask for the drag and drop mouse pointer in the XEmacs. -@itemx hm--html.el -Provides functions to write html pages. It defines all commands which -insert html elements and entities. -@itemx hm--html-indentation.el -Provides the lisp code for the indentation. -@itemx hm--html-keys.el -Defines the key bindings. -@itemx hm--html-menu.el -Provides the menus. -@itemx hm--html-mode.el -Provides the functions for the definition of the hm--html-mode and the -hm--html-minor-mode. This is the main file of the package. -@itemx hm--html-not-standard.el -Provides functions to insert some non standard html elements. This file -is not evaluated by default and it may be a bad idea to use it. -@itemx hm--html-configuration.el -Configuration file for the html mode. All the user variables are defined -in this file. -@itemx hm--html-drag-and-drop.el -Defines the HTML-specific functions for the drag and drop interface. -@itemx hm--date.el -Defines the function hm--date, which returns the date in the format -"day-month-year" like "30-Jun-1993". -@itemx html-view.el -Ron Tapia's html-view.el to view html pages in Mosaic. It is -patched for use with XEmacs. -@itemx internal-drag-and-drop.el -Provides the general (html-mode independent) functions of the drag and -drop interface. -@itemx templates.doc -Describes the syntax of the templates provided in the file -@file{tmpl-minor-mode.el} -@itemx tmpl-minor-mode.el -Provides functions for the tmpl-minor-mode. With this mode you can -expand templates, which are described in the file -@file{templates-syntax.doc} (look at the files -@file{command-description.html.tmpl} and @file{frame.html.tmpl} for -examples). Templates can be expanded automatically, if you include a -file with templates via the html pulldown menu item "Templates ..." or -with the item "Templates (fixed dirs)...". -@itemx command-description.html.tmpl -Template file for the use with the tmpl-minor-mode. -@itemx frame.html.tmpl -Template file, provides a simple frame. -@itemx doc/hm--html-mode.texinfo -Package documentation in the Texinfo format. -@itemx doc/umlaute.texinfo -Texinfo include file for German vowel mutation (deutsche Umlaute). -@end table - -@node Installation, Customization, Distribution, Top -@comment node-name, next, previous, up -@chapter Installation -@cindex installation - - -@enumerate -@item Put all the *.el files in one of your XEmacs (or emacs) lisp load -directories (e.g. site-lisp/hm--html-menus). - -@item @emph{For XEmacs only}: Put the files @file{drop} and @file{dropmsk} -in the directory specified by the lisp variable -@code{idd-data-directory}. By default it is -@file{<prefix>/lib/xemacs-<version>/etc/idd} (eg: if you have installed -the XEmacs 19.15 at your site in @file{/usr/local}, then it is the -directory @file{/usr/local/xemacs/lib/xemacs-19.15/etc/idd}. - -If you'd like to put the files in another directory, then you must set -the variable @code{idd-data-directory} to this directory (eg: -@code{(setq idd-data-directory "/usr/local/data")}) - -@item Put the following in your .emacs (or default.el or site-init.el): -@lisp -(autoload 'hm--html-mode "hm--html-mode" "HTML major mode." t) -(autoload 'hm--html-minor-mode "hm--html-mode" "HTML minor mode." t) -(or (assoc "\\.html$" auto-mode-alist) - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist))) - -(autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" - "Expand all templates in the current buffer." t) -(autoload 'tmpl-expand-templates-in-region "tmpl-minor-mode" - "Expands the templates in the region from BEGIN to END. -If BEGIN and END are nil, then the current region is used." - t) -(autoload 'tmpl-insert-template-file-from-fixed-dirs "tmpl-minor-mode" - "Inserts a template FILE and expands it, if `tmpl-automatic-expand' is t. -This command tries to read the template file from a list of -predefined directories (look at `tmpl-template-dir-list') and it filters -the contents of these directories with the regular expression -`tmpl-filter-regexp' (look also at this variable). -The command uses a history variable, which could be changed with the -variable `tmpl-history-variable-name'. - -The user of the command is able to change interactively to another -directory by entering at first the string \"Change the directory\". -This may be too difficult for the user. Therefore another command -called `tmpl-insert-template-file' exist, which doesn't use fixed -directories and filters." - t) - -(autoload 'tmpl-insert-template-file "tmpl-minor-mode" - "Inserts a template FILE and expand it, if `tmpl-automatic-expand' is t. -Look also at `tmpl-template-dir-list', to specify a default template -directory. -You should also take a look at `tmpl-insert-template-file-from-fixed-dirs' -which has additional advantages (and disadvantages :-). - -ATTENTION: The interface of this function has changed. The old -function had the argument list (&optional TEMPLATE-DIR AUTOMATIC-EXPAND). -The variables `tmpl-template-dir-list' and `tmpl-automatic-expand' must -now be used instead of the args TEMPLATE-DIR and AUTOMATIC-EXPAND." - t) - -(autoload 'html-view-start-mosaic "html-view" "Start Xmosaic." t) -(autoload 'html-view-view-buffer - "html-view" - "View the current buffer in Xmosaic." - t) -(autoload 'html-view-view-file - "html-view" - "View a file in Xmosaic." - t) -(autoload 'html-view-goto-url - "html-view" - "Goto url in Xmosaic." - t) -(autoload 'html-view-get-display - "html-view" - "Get the display for Xmosaic (i.e. hostxy:0.0)." - t) -@end lisp - -The above lines assume that you have not already installed another -html mode. If this isn't true, then you should use the following: -@lisp -(setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist)) -@end lisp - -instead of: -@lisp -(or (assoc "\\.html$" auto-mode-alist) - (setq auto-mode-alist (cons '("\\.html$" . hm--html-mode) - auto-mode-alist))) -@end lisp -If you want to use the hm--html-minor-mode together -with the psgml-html modes, then you should add the following -line (works only in XEmacs version >= 19.15 and != 20.0): -@lisp -(add-hook 'html-mode-hook 'hm--html-minor-mode) -@end lisp -@end enumerate - -@node Customization, Add New Elements, Installation, Top -@comment node-name, next, previous, up -@chapter Customization -@cindex customization -@cindex configuration - -You should be able to use the package after its installation without -any further customization. But it contains a lot of user variables to -adapt the package better to your special needs. How to do this is -described in this chapter. - -Since the XEmacs 19.15 and 20.2 a special package can be used for the -customization of lisp packages. This package uses now also this -feature. Therefore you can set all user variables with the help of the -Customize submenu, which can be selected in the Option menu. If you use -it, the variables will currently be saved in a special customization -file and not in one of the configuration files (@pxref{Customization -(Configuration) Files, Customization (Configuration) Files}) of this -package. Please look at the @file{NEWS} file or the info manuals of the -XEmacs to find out more about the customization package. - -@menu -* Customization (Configuration) Files:: -* Customization Variables:: -@end menu - -@node Customization (Configuration) Files, Customization Variables, Customization, Customization -@comment node-name, next, previous, up -@section Customization (Configuration) Files -@cindex customization files -@cindex configuration files - -This package uses 3 different files to customize the mode, but you need -not use all of them. Only one of them, the file -@file{hm--html-configuration.el} is delivered together with the package. -The reason for three different files is to provide the opportunity to -have different customization for the package, the site and the -user. There's also a pulldown menu item to reload all customization -files. The files are described in the following sections. - -@menu -* Where Are All The Customization Variables Defined:: -* Where To Put Site Specific Customization:: -* Where To Put User Specific Customization:: -@end menu - -@node Where Are All The Customization Variables Defined, Where To Put Site Specific Customization, Customization (Configuration) Files, Customization (Configuration) Files -@comment node-name, next, previous, up -@subsection Where Are All The Customization Variables Defined -@cindex package specific customization -@cindex hm--configuration.el -@vindex HTML_CONFIG_FILE - -All variables which can be used to customize the mode are defined in -the package configuration file @file{hm--configuration.el}. You should -take a look at this file if you don't find how to customize a feature -in this documentation (the documentation of a program is never as -complete as its program code :-). - -This file is searched in one of your lisp load directories. You can -change this by setting the environment variable @code{HTML_CONFIG_FILE} -to another file. But I don't recommend this. - -@emph{Note}: This file is loaded before the other customization files, -so that its definitions could be overwritten. All variables are set by -@code{defvar}, so that its values could also be overwritten with -@code{setq} in any standard emacs customization files (e.g. in -@file{.emacs}). - - -@node Where To Put Site Specific Customization, Where To Put User Specific Customization, Where Are All The Customization Variables Defined, Customization (Configuration) Files -@comment node-name, next, previous, up -@subsection Where To Put Site Specific Customization -@cindex site specific customization -@cindex hm--site-configuration-file.el -@vindex HTML_SITE_CONFIG_FILE -@vindex hm--html-site-config-file - -In general all users at a site are writing their html pages for the same -WWW server. Therefore it is very likely that most of the customizations -are site specific, and only a few are user specific. However, you -don't have to use a site specific customization if you don't want one. - -If you'd like to make a site specific customization of -@code{hm--html-mode}, it's possible to put it in a special file called -@file{hm--site-configuration-file.el}. If you do this, you have to set -either the lisp variable @code{hm--html-site-config-file} or the -environment variable @code{HTML_SITE_CONFIG_FILE} to the file and its -path. If you write the filename without its extension (.el), emacs -tries first to load a compiled version of the file. - -The environment variables overwrite the lisp variables. - -You can prevent the loading of the site specific customization file -by starting the emacs with the -no-site-file flag. - -You can also put the site specific customization in any standard emacs -customization file like, @file{default.el}. But an advantage to -using @file{hm--site-configuration-file.el} is that it is very likely -you will be able to use this file with future versions of the -package. I'll try to make it as backward compatible as possible. - -@emph{Note}: This file is loaded after the package customization file -and before the user customization file. - -@node Where To Put User Specific Customization, , Where To Put Site Specific Customization, Customization (Configuration) Files -@comment node-name, next, previous, up -@subsection Where To Put User Specific Customization -@cindex user specific customization -@cindex ~/.hm--html-configuration.el -@vindex HTML_USER_CONFIG_FILE -@vindex hm--html-user-config-file - -User specific customization can be put in the file -@file{.hm--html-configuration.el}, which is searched by default in the -home directory of the user. This can be overwritten by setting either -the environment variable @code{HTML_USER_CONFIG_FILE} or the lisp -variable @code{hm--html-user-config-file} to the name of the file and -its path. If you write the filename without its extension (.el), emacs -tries first to load a compiled version of the file. - -If neither the environment variable nor the lisp variable is set, the -variable @code{init-file-user} will be respected. This means, that -you'll get the @file{~other-user/.hm--html-configuration.el}, if you've -started the emacs with the options @code{-u other-user}. In all cases, -no user specific customization file will be loaded, if the @code{-q} -option was given to the emacs. - -You can also put the user specific customization in your -@file{.emacs}. It's up to you to decide which way is better. - -@emph{Note}: This file is loaded after the package and the site specific -one. Therefore it overwrites all other customization files. - - -@node Customization Variables, , Customization (Configuration) Files, Customization -@comment node-name, next, previous, up -@section Customization Variables - -In the following subsections the main customization variables are -described. - -@menu -* User Name/Signature:: -* Switching Between Expert And Novice Menus :: -* HTML Doctype:: -* Defaults Used For Generating Links:: -* Templates:: -* Deleting Automounter Path Prefix:: -* Automatic Insert Of Information:: -* Latin 1 Characters:: -* Drag And Drop:: -* Font Lock Keywords:: -* Prefix Keys:: -* Pulldown Menu Names:: -* Hook Variables:: -* Previewing HTML Files:: -* Meta Element:: -* Indentation:: -@end menu - - -@node User Name/Signature, Switching Between Expert And Novice Menus , Customization Variables, Customization Variables -@comment node-name, next, previous, up -@subsection User Name/Signature -@cindex user name -@cindex signature -@vindex hm--html-username -@vindex hm--html-signature-file - -@itemize @bullet -@item -@code{hm--html-username}: Your real name. This is used as the name of -the signature links. You need only specify it if your name in the -file @file{/etc/passwd} isn't the one you'd like to see in the html -files. Otherwise this may be set to @code{nil}. -@item -@code{hm--html-signature-file}: The link used in your signature. In -general this should be a link to your home page. -@end itemize - - -@node Switching Between Expert And Novice Menus , HTML Doctype, User Name/Signature, Customization Variables -@comment node-name, next, previous, up -@subsection Switching Between Expert And Novice Menus -@cindex expert menus -@cindex novice menus -@vindex hm--html-expert - -@itemize @bullet -@item -@code{hm--html-expert}: If you're a html novice and don't want to be -bothered with lots of possible html elements, then you should use the -novice popup menus. For that, set this variable to @code{nil}, -which is the default. But if you are more familiar with html and would -like to use more html elements, then you should use the expert menus and -set this variable to @code{t}. -@end itemize - - -@node HTML Doctype, Defaults Used For Generating Links, Switching Between Expert And Novice Menus , Customization Variables -@comment node-name, next, previous, up -@subsection HTML Doctype -@vindex hm--html-html-doctype-version -@cindex HTML doctype - -@itemize @bullet -@item -@code{hm--html-html-doctype-version}: The HTML version. This is used in -the doctype element. Change this if you use non HTML 3.2 elements. This -package (@xref{Overview, version}.) defines by default only HTML 3.2 elements. -@end itemize - - -@node Defaults Used For Generating Links, Templates, HTML Doctype, Customization Variables -@comment node-name, next, previous, up -@subsection Defaults Used For Generating Links -@cindex links - -One of the main features of @code{hm--html-mode} is its easy ways to -insert special links to html pages, ftp servers, news servers and so -on. I think that most people will have their own (this may be site -specific. @xref{Where To Put Site Specific Customization, Where To Put -Site Specific Customization}.) favourite servers, directories and so -on. You may customize the default values and the alists with useful -alternatives, which are used from the mode in the inserting functions -for the links. - -@menu -* Your Favourite HTTP Server:: -* Links to WWW Servers:: -* Links To Files:: -* Links To FTP Servers:: -* Links To Emacs Info Files:: -* Links To Gopher Servers:: -* Links To WAIS Gateways:: -* Links To The Mail Gateway:: -* Links For Sending Mail:: -* Links To The Program Gateway:: -* Links To The Local Program Gateway:: -* URL For Forms And Image Tags:: -* Marking Of Examples:: -@end menu - - -@node Your Favourite HTTP Server, Links to WWW Servers, Defaults Used For Generating Links, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Your Favourite HTTP Server -@cindex favourite HTTP server -@vindex hm--html-favorite-http-server-host-name - -@itemize @bullet -@item -@code{hm--html-favorite-http-server-host-name}: The name of your -favorite http server host. It must be specified! This variable is used -in many other variables. -@end itemize - - -@node Links to WWW Servers, Links To Files, Your Favourite HTTP Server, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links to WWW Server -@cindex WWW server links -@cindex HTTP links -@vindex hm--html-html-hostname:port-default -@vindex hm--html-html-hostname:port-alist -@vindex hm--html-html-path-alist - -@itemize @bullet -@item -@code{hm--html-html-hostname:port-default}: Default hostname with port -for http links to a HTML server. -@item -@code{hm--html-html-hostname:port-alist}: Alist with hostnames and ports -for http links to HTML servers. It contains useful alternatives. -@item -@code{hm--html-html-path-alist}: Alist with directories for the HTML -server. Each alist element must consist of a number and a directory -string. The number is used to select the directory during the query -about the directory for an http link. -@end itemize - - -@node Links To Files, Links To FTP Servers, Links to WWW Servers, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To Files -@cindex file gateway links -@vindex hm--html-file-path-alist - -@itemize @bullet -@item -@code{hm--html-file-path-alist}: Alist with directories for the file -gateway. Each alist element must consist of a number and a directory -string. The number is used to select the directory during the query -about the directory for a file link. -@end itemize - - -@node Links To FTP Servers, Links To Emacs Info Files, Links To Files, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To FTP Servers -@cindex FTP links -@vindex hm--html-ftp-hostname:port-default -@vindex hm--html-ftp-hostname:port-alist -@vindex hm--html-ftp-path-alist - -@itemize @bullet -@item -@code{hm--html-ftp-hostname:port-default}: Default hostname with port -for links to an ftp server. This is for the default FTP server. In general -you don't need to specify a port for this. -@item -@code{hm--html-ftp-hostname:port-alist}: Alist with hostnames and ports -for links to ftp servers. It contains useful alternatives. In general -you don't need to specify ports for the ftp servers. -@item -@code{hm--html-ftp-path-alist}: Alist with directories for the ftp -server links. It contains useful alternatives with /pub, /pub/gnu and -so on. Each alist element must consist of a number and a directory -string. The number is used to select the directory during the query -about the directory for an ftp link. -@end itemize - - -@node Links To Emacs Info Files, Links To Gopher Servers, Links To FTP Servers, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To Emacs Info Files -@cindex emacs info links -@vindex hm--html-info-hostname:port-alist -@vindex hm--html-info-hostname:port-default -@vindex hm--html-info-path-alist - -@itemize @bullet -@item -@code{hm--html-info-hostname:port-default}: Default hostname with port -for the Info gateway. -@item -@code{hm--html-info-hostname:port-alist}: Alist with hostnames and ports -for Info gateways. It contains useful alternatives. -@item -@code{hm--html-info-path-alist}: Alist with directories for the Info -gateway. This may be a list with all of your emacs info directories. -@end itemize - - -@node Links To Gopher Servers, Links To WAIS Gateways, Links To Emacs Info Files, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To Gopher Servers -@cindex Gopher gateway links -@vindex hm--html-gopher-hostname:port-default -@vindex hm--html-gopher-hostname:port-alist -@vindex hm--html-gopher-doctype-default -@vindex hm--html-gopher-doctype-alist -@vindex hm--html-gopher-anchor-alist - -There are a lot of useful gopher information servers on the Internet. -You can access them with a gopher browser or with a WWW browser. In the -latter case you have to use the gopher gateway. - -@itemize @bullet -@item -@code{hm--html-gopher-hostname:port-default}: Default hostname with port -for links to the default gopher server. -@item -@code{hm--html-gopher-hostname:port-alist}: Alist with hostnames and -ports for links to gopher servers. It contains useful alternatives. -@item -@code{hm--html-gopher-doctype-default}: For gopher links you have to -specify the doctype. In most cases this should be the string \"/1\". -Therefore this is the default doctype, but you can change it to -another. -@item -@code{hm--html-gopher-doctype-alist}: Alist with doctype strings for links -to a gopher server. The strings \"/1\", \"/11\" and \"/00\" are the only -doctype strings that I know. Please let me know if there are other -strings. -@item -@code{hm--html-gopher-anchor-alist}: Alist with directories for links to -a gopher server. It contains useful alternatives for the main gopher -servers. Each alist element must consist of a number and a directory -string. The number is used to select the directory during the query -about the directory for a local program gateway link. -@end itemize - - -@node Links To WAIS Gateways, Links To The Mail Gateway, Links To Gopher Servers, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To WAIS Gateways -@cindex WAIS gateway links -@vindex hm--html-wais-hostname:port-alist -@vindex hm--html-wais-hostname:port-default -@vindex hm--html-wais-servername:port-alist -@vindex hm--html-wais-servername:port-default -@vindex hm--html-wais-path-alist - -You can either make a link direct to a WAIS server (it may be that not -all WWW browsers support this) or an http link to a server (relay host) -which queries the WAIS server. The variables -@code{hm--html-wais-hostname:port-default} and -@code{hm--html-wais-hostname} refer to these relay hosts and the -variables @code{hm--html-wais-servername:port-default} and -@code{hm--html-wais-servername:port-alist} refer to the WAIS servers. - -@itemize @bullet -@item -@code{hm--html-wais-hostname:port-default}: Default hostname of the -relay host with port for the WAIS gateway. -@item -@code{hm--html-wais-hostname:port-alist}: Alist with hostnames of -possible relay hosts and ports for the WAIS gateway. It contains -useful alternatives. -@item -@code{hm--html-wais-servername:port-default}: Default WAIS servername -with port for the WAIS gateway. -@item -@code{hm--html-wais-servername:port-alist}: Alist with WAIS servernames -and ports for the WAIS gateway. It contains useful alternatives. -@item -@code{hm--html-wais-path-alist}: Alist with directories for the wais gateway. -@end itemize - - -@node Links To The Mail Gateway, Links For Sending Mail, Links To WAIS Gateways, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To The Mail Gateway -@cindex Mail gateway links -@cindex Mail folder links -@vindex hm--html-mail-hostname:port-default -@vindex hm--html-mail-hostname:port-alist -@vindex hm--html-mail-path-alist - -The following variables are for customizing the insertion of links to a mail -folder. You need a special server for this, which sends the email back -to the browser. - -@itemize @bullet -@item -@code{hm--html-mail-hostname:port-default}: Default hostname with port -for the mail gateway. -@item -@code{hm--html-mail-hostname:port-alist}: Alist with hostnames and ports -for the mail gateway. It contains useful alternatives. -@item -@code{hm--html-mail-path-alist}: Alist with directories for the mail -gateway. In these directories you'll probably find mail folders. Each -alist element must consist of a number and a directory string. The -number is used to select the directory during the query about the -directory for a mail folder link. -@end itemize - - -@node Links For Sending Mail, Links To The Program Gateway, Links To The Mail Gateway, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links For Sending Mail -@cindex mailto links -@vindex hm--html-mailto-alist - -@itemize @bullet -@item -@code{hm--html-mailto-alist}: Alist with mail addresses for the mailto -alist. The value of `user-mail-address' will also be added by the -package to this alist. -@end itemize - - -@node Links To The Program Gateway, Links To The Local Program Gateway, Links For Sending Mail, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To The Program Gateway -@cindex program gateway links -@vindex hm--html-proggate-hostname:port-default -@vindex hm--html-proggate-hostname:port-alist -@vindex hm--html-proggate-allowed-file - -The program gateway is a special TNT site specific gateway for starting -programs out of a html page. The programs are started by a special -server, which looks in an allowed file to determine if it is allowed to -start the program. This is necessary because the programs are running -under the user id of the server. We're only allowed to start simple -display programs like man, ls and so on. - -@itemize @bullet -@item -@code{hm--html-proggate-hostname:port-default}: Default hostname with -port for the proggate server. -@item -@code{hm--html-proggate-hostname:port-alist}: Alist with hostnames and -ports for the proggate server. It contains useful alternatives. -@item -@code{hm--html-proggate-allowed-file}: The filename (with path) of the -proggate allowed file. -@end itemize - - -@node Links To The Local Program Gateway, URL For Forms And Image Tags, Links To The Program Gateway, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Links To The Local Program Gateway -@cindex local program gateway links -@vindex hm--html-local-proggate-path-alist - -Another TNT site specific way to start programs from a html page. These -programs are started with the id of the user on the host where the -client (browser) is running. Therefore no restriction about the allowed -programs is made. With this you can start only programs and do only -things, which you can do also without the WWW browser. - -@itemize @bullet -@item -@code{hm--html-local-proggate-path-alist}: Alist with directories for -the local program gateway. Contains directories, where you can find -programs. -@end itemize - - -@node URL For Forms And Image Tags, Marking Of Examples, Links To The Local Program Gateway, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection URL For Forms And Image Tags -@cindex forms URL -@cindex image URL -@vindex hm--html-url-alist - -@itemize @bullet -@item -@code{hm--html-url-alist}: Alist with URL's for FORMS and IMAGE tags. -The cdr of each list contains symbols, which specifies the use of the -URL. -@end itemize - - -@node Marking Of Examples, , URL For Forms And Image Tags, Defaults Used For Generating Links -@comment node-name, next, previous, up -@subsubsection Marking Of Examples -@cindex color of help text -@cindex font of help text -@vindex hm--html-help-foreground -@vindex hm--html-help-background -@vindex hm--html-help-font - -The following variables are for marking the examples in the help -buffer. - -@itemize @bullet -@item -@code{hm--html-help-foreground}: The foreground color for highlighting -examples. -@item -@code{hm--html-help-background}: The background color for highlighting -examples. -@item -@code{hm--html-help-font}: The font for highlighting examples. -@end itemize - - -@node Templates, Deleting Automounter Path Prefix, Defaults Used For Generating Links, Customization Variables -@comment node-name, next, previous, up -@subsection Templates -@cindex templates -@vindex hm--html-template-dir -@vindex hm--html-frame-template-file -@vindex hm--html-automatic-expand-templates - -For inserting html template files you can customize where you keep your -templates. - -@itemize @bullet -@item -@code{hm--html-template-dir}: A directory with template files. It is now -also possible to use it as a list of directories. Look at the variable -@code{tmpl-template-dir-list} for further descriptions. If this -variable is set to a non-existent directory, then it defaults to the -directory where the package is in XEmacs. This is done during -loading the file @file{hm--html-configuration.el} (@xref{Where Are All -The Customization Variables Defined, Where Are All The Customization -Variables Defined}.). This may only be useful in XEmacs >= 19.12. -@item -@code{hm--html-frame-template-file}: File which is used as template for -a html frame. An example is in the package -@emph{hm--html-menus}. @xref{Contents, Contents}. -@item -@code{hm--html-automatic-expand-templates}: Automatic expansion of -templates. This feature needs the file @file{tmpl-minor-mode.el} from Heiko -Münkel (@cite{muenkel@@tnt.uni-hannover.de}), which is distributed with the -package hm--html-menus. -@item -@code{hm--html-template-filter-regexp}: Regexp for filtering out non -(html) template files in a directory. -@end itemize - - -@node Deleting Automounter Path Prefix, Automatic Insert Of Information, Templates, Customization Variables -@comment node-name, next, previous, up -@subsection Deleting Automounter Path Prefix -@cindex automounter path -@vindex hm--html-delete-wrong-path-prefix - -@itemize @bullet -@item -@code{hm--html-delete-wrong-path-prefix}: If non-nil, it specifies path-prefixes which should be deleted in paths. -The Sun automounter adds a temporary prefix to the automounted directories - (at our site the prefix is /tmp_mnt). But you can't select such a path -if the automounter has currently not mounted the directory, and so you -can't follow an html link which consists of such a path. To overcome -this behaviour, you can set this variable to the prefix -(e.g. "/tmp_mnt"). After that, the prefix should be stripped from the -paths during the creation of the links. ATTENTION: This variable is -used as a regular expression! It can be set to a string or to a list of -strings. -@end itemize - -@node Automatic Insert Of Information, Latin 1 Characters, Deleting Automounter Path Prefix, Customization Variables -@comment node-name, next, previous, up -@subsection Automatic Insert Of Information -@cindex automatic insert -@cindex date -@cindex changed comment -@cindex created comment -@vindex hm--html-automatic-update-title-date -@vindex hm--html-automatic-changed-comment -@vindex hm--html-automatic-create-modified-line -@vindex hm--html-automatic-update-modified-line -@vindex hm--html-changed-comment-prefix -@vindex hm--html-created-comment-prefix -@vindex hm--html-comment-infix -@vindex hm--html-modified-prefix -@vindex hm--html-modified-end-tag -@vindex hm--html-modified-insert-before -@vindex hm--html-modified-start-tag - - -The @code{hm--html-mode} automatically inserts some useful information in -html pages. This behaviour can be changed by the following variables. - -@itemize @bullet -@item -@code{hm--html-automatic-create-title-date}: t => A date string will be -inserted in the title line. This will be updated each time before file -saving, if @code{hm--html-automatic-update-title-date} is also set to t. -@item -@code{hm--html-automatic-update-title-date}: t => The date in the title -line will be updated before file saving. nil => No automatic update of -the date. -@item -@code{hm--html-automatic-created-comment}: t => A "created comment" -line will be added. nil => No automatic insert of a "created -comment" line. -@item -@code{hm--html-created-comment-prefix}: The prefix text of the "created -comment" lines. By default this is set to "Created by: ". -@item -@code{hm--html-comment-infix}: The infix (second part) of the "created -comment" and the "changed comment" lines. By default, if this variable -is nil, the value of @code{hm--html-username} or, if this variable is -also nil, the return value of @code{(user-full-name)} will be used. -In these cases the infix looks like "Heiko Münkel, ". - -Set it to an empty string, if you don't want to have your name in the -comments. -@item -@code{hm--html-automatic-changed-comment}: t => A "changed comment" -line will be added before file saving. nil => No automatic insert -of a "changed comment" line. -@item -@code{hm--html-changed-comment-prefix}: The prefix text of the "changed -comment" lines. By default this is set to "Changed by: ". -@item -@code{hm--html-automatic-create-modified-line}: t => Some commands will -insert a visible "modified" line with the current date, if such a line -does not exist already. If it already exist, the date in the line will -be updated. Visible means, that it is not a HTML comment. By default it -looks like the following: -@samp{<EM>Modified 24-May-1997</EM>} -@item -@code{hm--html-automatic-update-modified-line}: t => The visible -"modified" line will be updated with the current date before file -saving. If such a line does not exist, nothing will be done. -@item -@code{hm--html-modified-prefix}: Prefix of the "modified" line. -By default it is set to @samp{"Modified: "}. -@item -@code{hm--html-modified-start-tag}: Start tag of the modified line. -By default it is @samp{<EM>}. If you change this, you'll need to change also -@code{hm--html--modified-end-tag}. -@item -@code{hm--html-modified-end-tag}: End tag of the modified line. -By default it is @samp{</EM>}. If you change this, you'll need to change -also @code{hm--html-modified-start-tag}. -@item -@code{hm--html-modified-insert-before}: The "modified line" will be -inserted before this string. The search will be done from the end to the -beginning. And the "modified line" will be put at least before the -@samp{</HTML>} and the @samp{</BODY>} tags. -@end itemize - - -@node Latin 1 Characters, Drag And Drop, Automatic Insert Of Information, Customization Variables -@comment node-name, next, previous, up -@subsection Latin 1 Characters -@cindex latin 1 characters -@vindex hm--html-bind-latin-1-char-entities - -@itemize @bullet -@item -@code{hm--html-bind-latin-1-char-entities}: Set this to nil, if you -don't want to use the ISO Latin 1 character entities. This is only -useful if @code{hm--html-use-old-keymap} is set to nil. It is only used -when loading the html package the first time. -@end itemize - - -@node Drag And Drop, Font Lock Keywords, Latin 1 Characters, Customization Variables -@comment node-name, next, previous, up -@subsection Drag And Drop -@cindex drag and drop -@vindex hm--html-idd-create-relative-links -@vindex hm--html-idd-actions - -@itemize @bullet -@item -@code{hm--html-idd-create-relative-links}: If t, then the -@code{hm--html-idd-*} functions create relative links. Otherwise -absolute links are used. The idd functions are used for drag and drop. -@item -@code{hm--html-idd-actions}: The action list for the destination mode -@code{hm--html-mode}. Look at the description of the variable -idd-actions. -@end itemize - - -@node Font Lock Keywords, Prefix Keys, Drag And Drop, Customization Variables -@comment node-name, next, previous, up -@subsection Font Lock Keywords -@cindex font lock keywords -@vindex hm--html-font-lock-keywords-1 -@vindex hm--html-font-lock-keywords-2 -@vindex hm--html-font-lock-keywords - -@itemize @bullet -@item -@code{hm--html-font-lock-keywords-1}: Subdued level highlighting for -@code{hm--html-mode}. -@item -@code{hm--html-font-lock-keywords-2}: Gaudy level highlighting for -@code{hm--html-mode}. -@item -@code{hm--html-font-lock-keywords}: Default expressions to highlight in -the @code{hm--html-mode}. -@end itemize - - -@node Prefix Keys, Pulldown Menu Names, Font Lock Keywords, Customization Variables -@comment node-name, next, previous, up -@subsection Prefix Keys -@cindex prefix keys -@kindex prefix keys -@vindex hm--html-minor-mode-prefix-key -@vindex hm--html-mode-prefix-key - -@itemize @bullet -@item -@code{hm--html-minor-mode-prefix-key}: The prefix key for the key tables -in the minor mode @code{hm--html-minor-mode}. -@item -@code{hm--html-mode-prefix-key}: The prefix key for the keys in the -major mode @code{hm--html-mode}. -@end itemize - - -@node Pulldown Menu Names, Hook Variables, Prefix Keys, Customization Variables -@comment node-name, next, previous, up -@subsection Pulldown Menu Names -@cindex pulldown menu names -@vindex hm--html-minor-mode-pulldown-menu-name -@vindex hm--html-mode-pulldown-menu-name - -Perhaps you'd like to change the names to get the same menu -names in the major and in the minor modes of the @code{hm--html-menus} -package. - -@itemize @bullet -@item -@code{hm--html-mode-pulldown-menu-name}: The name of the pulldown menu -in the major html mode. -@item -@code{hm--html-minor-mode-pulldown-menu-name}: The name of the pulldown -menu in the minor html mode. -@end itemize - - -@node Hook Variables, Previewing HTML Files, Pulldown Menu Names, Customization Variables -@comment node-name, next, previous, up -@subsection Hook Variables -@vindex hm--html-mode-hook - -You may use the following two variables, if you'd like to call special -functions each time the major html mode is entered or the package is -loaded. - -@itemize @bullet -@item -@code{hm--html-mode-hook}: This hook will be called each time -@code{hm--html-mode} is invoked. -@item -@code{hm--html-load-hook}: Hook variable to execute functions after -loading the package. -@end itemize - - -@node Previewing HTML Files, Meta Element, Hook Variables, Customization Variables -@comment node-name, next, previous, up -@subsection Previewing HTML Files -@cindex previewing HTML files -@vindex html-view-mosaic-command -@vindex html-sigusr1-signal-value - -The following two variables are only used, if you preview html -documents with @code{Mosaic}. There are also some other variables in -@file{hmtl-view.el}. @xref{Contents, Contents}. Look at that file if -you have trouble with the functions to preview the html document with -@code{Mosaic}. - -@itemize @bullet -@item -@code{html-view-mosaic-command}: The command that runs @code{Mosaic} on your -system. -@item -@code{html-sigusr1-signal-value}: Value for the SIGUSR1 signal on your -system. See, usually, @file{/usr/include/sys/signal.h}. -@example - SunOS 4.1.x : (setq html-sigusr1-signal-value 30) - SunOS 5.x : (setq html-sigusr1-signal-value 16) - Linux : (setq html-sigusr1-signal-value 10)) -@end example -@end itemize - - -@node Meta Element, Indentation, Previewing HTML Files, Customization Variables -@comment node-name, next, previous, up -@subsection Meta Element -@cindex meta element -@vindex hm--html-meta-name-alist - -@itemize @bullet -@item -@code{hm--html-meta-name-alist}: Alist with possible names for the name -or http-equiv attribute of meta. Currently I know of the names -@code{Expires}, @code{Keys} and @code{Author}. Please send me -(@emph{muenkel@@tnt.uni-hannover.de}) an email, if you know other -standard html names for the meta element. -@end itemize - - -@node Indentation, , Meta Element, Customization Variables -@comment node-name, next, previous, up -@subsection Indentation -@cindex indentation -@vindex hm--html-disable-indentation -@vindex hm--html-inter-tag-indent -@vindex hm--html-comment-indent -@vindex hm--html-intra-tag-indent -@vindex hm--html-tag-name-alist - -@itemize @bullet -@item -@code{hm--html-disable-indentation}: Set this to t if you want to -disable indentation in @code{hm--html-mode}. And maybe send me -(@emph{muenkel@@tnt.uni-hannover.de}) a note why you did this. -@item -@code{hm--html-inter-tag-indent}: The indentation after a start tag. -@item -@code{hm--html-comment-indent}: The indentation of a comment. -@item -@code{hm--html-intra-tag-indent}: The indentation after the start of a -tag. -@item -@code{hm--html-tag-name-alist}: An alist with tag names known by -@code{hm--html-mode}. It is used to determine if a tag is a one element -tag or not. In the future it should also be used to get possible -parameters of the tag. Use lower case characters in this list!!!! If -you have problems with the indentation of -@code{:hm--html-one-or-two-element-tag} elements, then you should set -them to either @code{:hm--html-one-element-tag} or -@code{:hm--html-two-element-tag}, depending on how you use these -elements. In the future I'll try to implement a better indentation for -these elements. -@end itemize - - -@node Add New Elements, Use With Other Major Modes, Customization, Top -@comment node-name, next, previous, up -@chapter Add New Elements -@cindex add new html elements -@cindex non standard html -@vindex hm--html-tag-name-alist - -If you'd like to add new HTML elements to this package, you should first take -a look at the file @file{hm--html-not-standard.el}, which -already contains some non-standard elements. If you find your tags -there, you should uncomment the line @code{(require -'hm--html-not-standard)} in the file @file{hm--html-mode.el}. There are -also menu entries for these elements in the file -@file{hm--html-menu.el}, which are commented out. Don't forget to -recompile the changed lisp files after that! - -If you don't find your new elements there, you should do the following -steps to add them: - -@enumerate -@item -Locate a tag which is similar to the one you want to add. "Similar" -means that it is inserted in the way you want to insert the new -tags. Now let's assume, that you chose @samp{<strong></strong>}. -@item -Look at the file @file{hm--html.el} and search the function(s) which -inserts the similar tag(s). If the HTML element consists of only one -tag, then there should be only one function for inserting the tag. If -the element consists of a start and an end tag, there are at least two -functions. Only in some special cases, if it is possible to insert -elements with different attribute values, are there more than two -functions. In the case of @samp{<strong></strong>}, there are the two -functions @code{hm--html-add-strong} and -@code{hm--html-add-strong-to-region}. The first one is used if no -region is active, and the second if a region is active. The naming scheme -of these functions is always @var{hm--html-add-<tagname>} and -@var{hm--html-add-<tagname>-to-region}. @var{<tagname>} is not in all -cases the tagname. Sometimes a more human readable name is used (e.g. -bold instead of b). -@item -To get the right indentation for the new tags you should add an entry -for them to the variable @code{hm--html-tag-name-alist}, which is defined -in @file{hm--html-configuration.el}. Let's assume that the new tagname -is @samp{foo}. The entry in @code{hm--html-tag-name-alist} should -be -@lisp - ("foo" (:hm--html-one-element-tag t)) -@end lisp -if the new element consists only of one tag (@samp{img} is such an -element) or -@lisp - ("foo" (:hm--html-two-element-tag t)) -@end lisp -if the new element consists of two tags (@samp{strong} is such an -element) or -@lisp - ("foo" (:hm--html-one-or-two-element-tag t)) -@end lisp -if the new element consists of two tags, but it is permissible to use the -start tag without its end tag (@samp{p} is such an element). -@end enumerate - -Now you are ready and able to insert the new tags with -@example - M-x hm--html-add-foo -@end example -and -@example - M-x hm--html-add-foo-to-region -@end example - -If you want to add the new commands also to the popup menu, -then you have to take a look at @file{hm--html-menu.el}, where all the -menus are defined. Look at @code{hm--html-menu-noregion-expert} and -@code{hm--html-menu-region-expert}. The first one is used if no region is -active, and the second if a region is active (both are only available -if the "expert menus" are used; this is an option in the pulldown -menu). You should now add an entry like -@lisp - ["Foo" hm--html-add-foo t] -@end lisp -to the @code{hm--html-menu-noregion-expert} variable and an entry -@lisp - ["Foo" hm--html-add-foo-to-region t] -@end lisp -to the @code{hm--html-menu-region-expert} variable (only if -@code{hm--html-add-foo-to-region} exists). You can do this by setting the -whole variable to a new value or by using the function -@code{add-menu-button}. I recommend the last method. - -If you'd like to have a key sequence for inserting the new tag as well, -take a look at @file{hm--html-keys.el}. There are -different key tables defined for region and no region cases and for -different sorts of elements, like anchors, frame elements (doesn't mean -the Netscape element frame) and so on. These "groups" are the same as -the submenu groups. - - -@node Use With Other Major Modes, Internal Drag And Drop, Add New Elements, Top -@comment node-name, next, previous, up -@chapter Use With Other Major Modes -@cindex use with other major modes -@cindex use with psgml-html -@cindex psgml-html -@findex hm--html-minor-mode - -The package provides a minor mode called @code{hm--html-minor-mode}, -which could be used to join the features of this package with other HTML -packages or use it's features in other major edit modes. This is -usefull, if you'd like to extend another HTML mode or if you'll write -program code, which contain HTML parts. - -Currently this is tested with the psgml-html mode, the @code{perl-mode} -and the @code{java-mode}. Please let me know if it works or not with -other packages. - -If you'd like to use the minor mode in psgml-html mode, -put the following line in your @file{.emacs}: - -@lisp - (add-hook 'html-mode-hook 'hm--html-minor-mode) -@end lisp - -Note: This should work only in XEmacs versions greater than 19.14 and not -in 20.0. It doesn't work in other versions because the hook variable -@code{html-mode-hook} doesn't exist in those versions. Therefore in those -versions you must either call the minor mode by hand or change the -lisp file of the psgml-html mode. - - -@node Internal Drag And Drop, Template Minor Mode, Use With Other Major Modes, Top -@comment node-name, next, previous, up -@chapter Internal Drag And Drop -@cindex drag and drop -@cindex internal drag and drop -@vindex idd-actions -@vindex hm--html-idd-actions - - -The file @file{internal-drag-and-drop.el}, which is shipped with -@file{hm--html-menus}, provides a general package for internal drag and -drop in emacs. "General" means that it can be used apart from -@code{hm--html-mode} in any other mode. - -You can start such an action by clicking with the mouse in the source -buffer and then in the destination buffer. The action may depend on -the points where you've clicked with the mouse, on the state of the -region, the point, the mark and any other properties of the source and -the destination buffers. The actions are defined by the variable -@code{idd-actions}, which is a buffer local variable. - - -@menu -* Drag And Drop Customization:: -* The Drag And Drop Commands:: -@end menu - -@node Drag And Drop Customization, The Drag And Drop Commands, Internal Drag And Drop, Internal Drag And Drop -@comment node-name, next, previous, up -@section Drag And Drop Customization -@cindex customization -@cindex configuration - -Since the XEmacs 19.15 and 20.2 a special package can be used for the -customization of lisp packages. The internal drag and drop package uses -now also this feature. Therefore you can set all user variables with the -help of the Customize submenu, which can be selected in the Option menu. -If you use it, the variables will currently be saved in a special -customization file. Please look at the @file{NEWS} file or the info -manuals of the XEmacs to find out more about the customization package. - -The internal drag and drop functions may be used in all -modes. Therefore their general customization isn't done in -@file{hm--html-configuration.el}. Its variables are defined in the file -@file{internal-drag-and-drop.el} instead. You can set them in your -@file{.emacs} or in one of the other emacs init files (e.g. -@file{default.el}). The following subsections describe the main -customization variables. - - -@menu -* Defining The Drag And Drop Actions:: -* The Mouse Bindings:: -* The Drag And Drop Mouse Pointer:: -@end menu - -@node Defining The Drag And Drop Actions, The Mouse Bindings, Drag And Drop Customization, Drag And Drop Customization -@comment node-name, next, previous, up -@subsection Defining The Drag And Drop Actions -@cindex actions -@cindex drag and drop actions -@vindex idd-actions - -The drag and drop actions are commands which are called after an -internal drag and drop. They depend on the source and the destination -of the drag and drop. Drag and drop actions are defined by the -variable: - -@itemize @bullet -@item -@code{idd-actions}: A list with actions, depending on the source and the -destination of the drag and drop command. -@end itemize - -The list looks like: -@lisp -'((@var{<destination-specification-1>} (@var{<source-specification-1>} @var{<action-1-1>}) - (@var{<source-specification-2>} @var{<action-1-2>}) - : - ) - (@var{<destination-specification-2>} (@var{<source-specification-1>} @var{<action-2-1>}) - (@var{<source-specification-2>} @var{<action-2-2>}) - : - ) - : - ) -@end lisp -The @var{<source-specification>} looks like the following: -@lisp -'([(@var{<specification-type>} @var{<value>})]) -@end lisp -with -@lisp -@table @var -@item <specification-type> :== -@w{@code{idd-if-minor-mode-p}} | @w{@code{idd-if-buffer-name-p}} | -@w{@code{idd-if-region-active-p}} | @w{@code{idd-if-url-at-point-p}} | -@w{@code{idd-if-major-mode-p}} | @w{@code{idd-if-variable-non-nil-p}} | -@w{@code{idd-if-dired-file-on-line-p}} | -@w{@code{idd-if-dired-no-file-on-line-p}} | -@w{@code{idd-if-local-file-p}} | @w{@code{idd-if-buffer-name-p}} | -@w{@code{idd-if-modifiers-p}} | ... -@end table -@end lisp - -The @var{<specification-type>} - functions must have two arguments. The -first one is the source or destination and the second is the -@var{<value>}. It must return @code{nil}, if the test wasn't successful, -and a number (in general 1), which specifies the weight of the test -function. The weights of all single tests are added to a summary weight -and assigned to the action. The action with the highest weight is called -from the action handler. Look at the definition of -@w{@code{idd-if-major-mode-p}}, @w{@code{idd-if-minor-mode-p}} and so on for -examples. Look at the function -@code{idd-get-source-or-destination-alist}, if you want to know the -structure of the @code{source-or-destination} argument of these -functions. - -The @var{<destination-specification>} looks like -@var{<source-specification>}, but in general it could be set to -@code{nil} in mode specific idd-action lists. - -If @var{<destination-specification-1>} or @var{<source-specification-1>} -is set to @code{nil}, then every source or source -matches. @code{idd-actions} is a buffer local variable, which should be -at least mode depended. So if the @var{<destination-specification-1>} is -set to @code{nil} it says, that the destination buffer must only have a -specific mode. However, it's also possible to define a general -@code{idd-actions} list, where the destination mode is specified by -@code{idd-if-major-mode-p}. - -@var{<action>} is a function which has two arguments. The first -specifies the source and the second the destination. Look at the -function definition of @code{idd-action-copy-region} and -@code{idd-action-copy-replace-region}. They are examples for such -actions. - -The following is an example for @code{hm--html-mode}: - -@lisp -(defvar idd-actions - '((nil (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpq\\)")) - hm--html-idd-add-include-image-from-dired-line) - (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-no-file-on-line-p . nil)) - hm--html-idd-add-file-link-to-file-on-dired-line) - (((idd-if-major-mode-p . dired-mode) - (idd-if-dired-no-file-on-line-p . t)) - hm--html-idd-add-file-link-to-directory-of-buffer) - (((idd-if-major-mode-p . w3-mode) - (idd-if-url-at-point-p . t)) - hm--html-idd-add-html-link-from-w3-buffer-point) - (((idd-if-major-mode-p . w3-mode)) - hm--html-idd-add-html-link-to-w3-buffer) - (((idd-if-local-file-p . t)) - hm--html-idd-add-file-link-to-buffer))) -@end lisp - - -@node The Mouse Bindings, The Drag And Drop Mouse Pointer, Defining The Drag And Drop Actions, Drag And Drop Customization -@comment node-name, next, previous, up -@subsection The Mouse Bindings -@cindex mouse bindings -@vindex idd-global-mouse-keys -@vindex idd-global-help-mouse-keys -@vindex idd-drag-and-drop-mouse-binding-type -@findex idd-mouse-drag-and-drop -@findex idd-help-mouse-drag-and-drop - -The following three variables determine the mouse -bindings and the mouse behaviour for the internal drag and drop package: - -@itemize @bullet -@item -@code{idd-global-mouse-keys}: The mouse keys for the command -@code{idd-mouse-drag-and-drop}. The command -@code{idd-mouse-drag-and-drop} is bound during the loading of the -package @file{internal-drag-and-drop} to these keys in the @b{global -keymap}. The drag and drop action @b{must be bound global}, because the -drag and drop action must be started by a click in the source -buffer. Therefore no action will be performed if the mouse keys are not -bound to @code{idd-mouse-drag-and-drop} in the destination buffer. - -Set it to @code{nil}, if you don't want to bind this function during -loading. - -If the command is already bound in the global keymap during loading, -then this key sequence will not be bound. - -By default the mouse binding is @key{meta} @key{control} @key{button1}. - -@item -@code{idd-global-help-mouse-keys}: The mouse keys for the command -@code{idd-help-mouse-drag-and-drop}. The command -@code{idd-help-mouse-drag-and-drop} is bound during the loading of the -package @file{internal-drag-and-drop} to these keys in the @b{global -keymap}. - -Set it to @code{nil} if you don't want to bind this function during -loading. - -If the command is already bound in the global keymap during loading, -then this key sequence will not be bound. - -By default the mouse binding is @key{meta} @key{control} @key{button3}. - -@item -@code{idd-drag-and-drop-mouse-binding-type}: The type of the drag and -drop mouse binding. The value may be @code{click} or -@code{press-button-during-move}. A value of @code{click} means that -you have to click over the source, release the button and click it again -over the destination. A value of @code{press-button-during-move} means -that you have to press the button down over the source and hold it until -the mouse pointer is over the destination. - -The @emph{disadvantage} of the @code{press-button-during-move} type -compared with the @code{click} type is that you can't select a destination -region, and therefore a drag and drop action depending on a selected -region can't be started with that type of mouse binding. -@end itemize - -@node The Drag And Drop Mouse Pointer, , The Mouse Bindings, Drag And Drop Customization -@comment node-name, next, previous, up -@subsection The Drag And Drop Mouse Pointer -@cindex mouse pointer glyph -@vindex idd-mouse-pointer-image -@vindex idd-data-directory -@vindex idd-overwrite-mouse-pointers -@vindex idd-drag-and-drop-pointer-glyph -@findex idd-make-drag-and-drop-pointer-glyph - -In the XEmacs the mouse pointer glyph (shape) can be set to any -glyph. This is used during the drag and drop command to indicate, that -the command is active. There exists the following three variables to -customize this: - -@itemize @bullet -@item -@code{idd-mouse-pointer-image}: The name of the xbm file with the mouse -pointer image. By default this is the file @file{drop}. There exists -also a file called @file{dropmsk}, which contains the mask image. The -mask file is loaded automaticly. - -@item -@code{idd-data-directory}: The name fo the directory, where the file -@code{idd-mouse-pointer-image} is searched. By default this is the -subdirectory @file{idd} in the XEmacs install directory -@code{data-directory}. - -@item -@code{idd-overwrite-mouse-pointers}: A list with pointer glyph -variables, which should be overwritten by the -@code{idd-drag-and-drop-pointer-glyph}. If it is nil, the pointer wont -be changed. Currently it must be nil in the Emacs. -@end itemize - -If one of the variables @code{idd-mouse-pointer-image} or -@code{idd-data-directory} is changed, the command -@code{idd-make-drag-and-drop-pointer-glyph} must be called. This command -builds the mouse pointer glyph, which is stored in -@code{idd-drag-and-drop-pointer-glyph}. - -I don't know how to set the the mouse pointer in the Emacs to a drag and -drop image. Any hints for doing this are welcome. - - -@node The Drag And Drop Commands, , Drag And Drop Customization, Internal Drag And Drop -@comment node-name, next, previous, up -@section The Drag And Drop Commands -@cindex drag and drop commands - -There are 2 groups of commands. The first contains commands which -perform the drag and drop action and the second displays help -messages about a possible drag and drop action. - - -@menu -* Performing The Drag And Drop Action:: -* Displaying Help On Drag And Drop:: -@end menu - -@node Performing The Drag And Drop Action, Displaying Help On Drag And Drop, The Drag And Drop Commands, The Drag And Drop Commands -@comment node-name, next, previous, up -@subsection Performing The Drag And Drop Action -@cindex drag and drop commands -@cindex performing drag and drop -@findex idd-mouse-drag-and-drop -@findex idd-start-mouse-drag-and-drop -@findex idd-mouse-drag-and-drop-press-button-during-move -@findex idd-mouse-drag-and-drop-click -@findex idd-help-start-action -@vindex idd-drag-and-drop-mouse-binding-type - -The following five commands perform internal -drag and drop actions: - -@itemize @bullet -@item -@code{idd-mouse-drag-and-drop}: Performs a drag and drop action. It -calls the command @code{idd-mouse-drag-and-drop-click} or -@code{idd-mouse-drag-and-drop-press-button-during-move} depending on the -value of @code{idd-drag-and-drop-mouse-binding-type}. However you've set -this, you start a drag and drop action with this command by pressing -down its mouse button over the source. This command is bound by default -to a global mouse key sequence. @xref{The Mouse Bindings}. - -@item -@code{idd-start-mouse-drag-and-drop}: Starts a drag and drop command. -This command could be used to start a drag and drop command without a -button event. Therefore this should not be bound directly to a mouse -button. This command can be used to start a drag and drop action with a -click on a menu item or tool bar icon. After that you have to press a -mouse button over the source. The rest depends on the value of -@code{idd-drag-and-drop-mouse-binding-type}, as with the command -@code{idd-mouse-drag-and-drop}. - -@item -@code{idd-help-start-action}: It is possible to display a help buffer -with a message in it, which describes the action instead of performing -it immediately (@pxref{Displaying Help On Drag And Drop}). In this case -you can perform the action by clicking on a special extent in the help -buffer, which runs this command. - -@item -@code{idd-mouse-drag-and-drop-press-button-during-move}: Performs a drag -and drop action in a more traditional way than -@code{idd-mouse-drag-and-drop-click}. First you press the button -over the source and then move with the depressed button to the -destination, where you release the button. This must be bound to a -mouse button. The @code{SOURCE-EVENT} must be a -@code{button-press-event}. - -The disadvantage of this command compared with the command -@code{idd-mouse-drag-and-drop-click} is, that you can't select a -destination region. - -You should bind the command @code{idd-mouse-drag-and-drop} instead of -this one, because it's then possible to switch between both drag and -drop behaviours by changing only one variable. - -@item -@code{idd-mouse-drag-and-drop-click}: Performs a drag and drop action in -a more useful way than -@code{idd-mouse-drag-and-drop-press-button-during-move}. First you -click on the source and then on the destination. This must -be bound to a mouse button. The @code{SOURCE-EVENT} must be a -@code{button-press-event}. - -You should bind the command @code{idd-mouse-drag-and-drop} instead of -this one, because it's then possible to switch between both drag and -drop behaviours by changing only one variable. -@end itemize - - -@node Displaying Help On Drag And Drop, , Performing The Drag And Drop Action, The Drag And Drop Commands -@comment node-name, next, previous, up -@subsection Displaying Help On Drag And Drop -@cindex help on drag and drop -@cindex displaying help on drag and drop -@findex idd-help-mouse-drag-and-drop -@findex idd-start-help-mouse-drag-and-drop - -It's possible to display a buffer with a help message describing the -action being considered before actually performing it. To perform the -action, you then click on a special extent in the help buffer. To get -the help buffer, you do the same things as you do to perform the action -itself. Only the mouse key differs. There are two commands for this: - -@itemize @bullet -@item -@code{idd-help-mouse-drag-and-drop}: Displays help about the drag and -drop action. It works similarly to @code{idd-mouse-drag-and-drop} -(@pxref{Performing The Drag And Drop Action}). - -By default this command is globally bound to @key{meta} @key{control} -@key{button3}. This may be changed with the variable -@code{idd-global-help-mouse-keys} (@pxref{The Mouse Bindings}). - -@item -@code{idd-start-help-mouse-drag-and-drop}: Starts displaying help about -the drag and drop action. It works similarly to -@code{idd-start-mouse-drag-and-drop} (@pxref{Performing The Drag And -Drop Action}) and can be used to start the help by clicking on a menu -item or a tool bar icon. -@end itemize - - -@node Template Minor Mode, Hints For Emacs 19 Users, Internal Drag And Drop, Top -@comment node-name, next, previous, up -@chapter Template Minor Mode -@cindex templates - -There's a file called @file{tmpl-minor-mode.el} in the distribution -of the package @emph{hm---html-menus}. It provides functions to use -templates for the @code{hm--html-mode} and also for other modes. It -needs nothing from the rest of the package and therefore it can be used -independently of @code{hm--html-mode}. - - -@menu -* What Are Templates:: -* Syntax Of Templates:: -* Template Customization:: -* Template Commands:: -@end menu - -@node What Are Templates, Syntax Of Templates, Template Minor Mode, Template Minor Mode -@comment node-name, next, previous, up -@section What Are Templates -@cindex templates -@findex tmpl-insert-template-file -@findex tmpl-expand-templates-in-buffer -@findex tmpl-expand-templates-in-region - -Templates are special pieces of text, which can be expanded by -emacs. Expansion means that the template is replaced by something else, -determined by evaluating lisp forms or emacs commands. The -expansion can be done automatically after the insertion of templates -with the command @code{tmpl-insert-template-file} in a buffer or by hand -with the commands @code{tmpl-expand-templates-in-buffer} or -@code{tmpl-expand-templates-in-region}. - -Templates can be put together with normal text in a so called template -file to provide prototype files. You should name these files with the -following naming scheme: - -@example - @var{<file>}.@var{<type>}.tmpl -@end example - -where @var{<file>} is a string which describes for what the template -could be used and @var{<type>} the normal file extension, e.g. @samp{c} -for C- files or @samp{html} for HTML- files. - - -@node Syntax Of Templates, Template Customization, What Are Templates, Template Minor Mode -@comment node-name, next, previous, up -@section Syntax Of Templates -@cindex template syntax -@vindex tmpl-sign - -The templates are marked with the sign ^@@, which stands for the null -character (\000). It can be inserted in a buffer with the keys @kbd{C-q -C-SPC}. You can also use any other character or string of characters by -changing the variable @code{tmpl-sign}. - -At the moment, there are 3 major types of templates: - -@enumerate -@item -@emph{Emacs Lisp function templates}: The expansion of such a template -evals a lisp form. It is possible to use functions or variables as lisp -forms. The following is a simple example: - -@lisp -^@@LISP^@@ (insert-file "~/.emacs") ^@@END LISP^@@ -@end lisp - -inserts the contents of the file @file{~/.emacs} in the current -buffer during the expansion. - -@item -@emph{Emacs command templates}: The expansion of a command template -evals a template in the same way as an interactive command, which is -invoked with @kbd{M-x command}. For example: - -@lisp -^@@COMMAND^@@ insert-file ^@@END COMMAND^@@ -@end lisp - -runs the interactive command @code{insert-file} during the expansion. - -@item -@emph{Template comments} Nothing will be evaluated during the expansion -of a template comment. It is only a comment. For example: - -@lisp -^@@C^@@ This is a comment -@end lisp - -The end of the comment is the end of the line. Therefore it has the same -syntax as a lisp or C++ comment. -@end enumerate - -By default, a template will be deleted after its expansion, but -without the linefeed. Look at the following examples: - -Before the expansion: - -@example - Line before the template - ^@@C^@@ The Text of a comment template - Line after the template -@end example - -After the expansion: - - Line before the template - - Line after the template - - -Templates can start in any column, and only the template will be deleted -after its expansion. - - -It is also possible to put an attribute list in a template. The -attributes of the list control the deletion of the template. It -may be that this will be extended in the future with other attributes. -The attribute list must be specified as an alist (assoc list) in the start -tag of a template and after its type. Each element of the alist consists -of the name of the attribute following its value. -If no attribute list is specified or if an attribute is missing, then the -default values are used. At the moment there are the following 2 attributes: - -@enumerate -@item @emph{don't delete attribute} (@code{DONT_DELETE}): If the value -is t, then the template will not be deleted after its expansion. If the -value is nil then the template will be deleted. The default is nil. For -example: - -Before the expansion: - -@example - Line before the template - ^@@LISP ((DONT-DELETE t))^@@ (insert-file "~/.cshrc") ^@@END LISP^@@ - Line after the template -@end example - -After the expansion: - -@example - Line before the template - ^@@LISP ((DONT-DELETE t))^@@ (insert-file "~/.cshrc") ^@@END LISP^@@ - Line after the template -@end example - -It was assumed, that the file @file{~/.cshrc} was empty ! - -@item @emph{delete line attribute} (@code{DELETE-LINE}): If the value is -t, then the linefeed before or after the template will be deleted. If -the value is nil then no linefeed will be deleted. The default is -nil. For example: - -Before the expansion: - -@example - Line before the template - ^@@LISP ((DELETE-LINE t))^@@ (insert-file "~/.cshrc") ^@@END LISP^@@ - Line after the template -@end example - -After the expansion: - -@example - Line before the template - Line after the template -@end example - -It was assumed, that the file @file{~/.cshrc} was empty ! -@end enumerate - -These attributes can be combined. For example: - -@example - ^@@COMMAND ((DELETE-LINE t) (DONT-DELETE nil))^@@ - insert-file - ^@@END COMMAND^@@ -@end example - -The last examples show also that whitespace (blanks, tabs, linefeeds) -is allowed at most positions in a template. - -Look at the file @file{tmpl-minor-mode.el} for a description of the -commands to expand templates. - - -@node Template Customization, Template Commands, Syntax Of Templates, Template Minor Mode -@comment node-name, next, previous, up -@section Template Customization -@cindex customization -@cindex configuration -@vindex tmpl-template-dir-list -@vindex tmpl-automatic-expand -@vindex tmpl-filter-regexp -@vindex tmpl-sign -@vindex tmpl-minor-mode-map - -Since the XEmacs 19.15 and 20.2 a special package can be used for the -customization of lisp packages. The internal drag and drop package uses -now also this feature. Therefore you can set all user variables with the -help of the Customize submenu, which can be selected in the Option menu. -If you use it, the variables will currently be saved in a special -customization file. Please look at the @file{NEWS} file or the info -manuals of the XEmacs to find out more about the customization package. - -Templates may be used for all editing modes, not only for -@code{hm--html-mode}. Therefore their general customization isn't done -in @file{hm--html-configuration.el}. Template variables are defined in -the file @file{tmpl-minor-mode.el} instead. You can set them in your -@file{.emacs} or in one of the other emacs init files (e.g. -@file{default.el}). The following are the main variables for -customization. - -@itemize @bullet -@item -@code{tmpl-template-dir-list}: A list of directories with template -files. If it is nil, the default-directory will be used. If more than -one directory is specified, then the template filenames should differ -in all directories. - -This variable is used in the commands for inserting templates. Look at -@code{tmpl-insert-template-file-from-fixed-dirs} and at -@code{tmpl-insert-template-file}. The command -@code{tmpl-insert-template-file} uses only the car of the list (if it is -a list.) -@item -@code{tmpl-filter-regexp}: This defines a regular expression used for -filtering out non-template files in template directories. It is used in -the command @code{tmpl-insert-template-file-from-fixed-dirs} to allow -only the selection of files which match the regexp. If it is -nil, then the Filter @code{".*\\.tmpl$"} is used. Set it to -@code{\".*\"} if you want to disable the filter function or use the -command @code{tmpl-insert-template-file}. -@item -@code{tmpl-automatic-expand}: If you insert a template file with -@code{tmpl-insert-template-file-from-fixed-dirs} or with -@code{tmpl-insert-template-file}, this variable is used. The templates -in the buffer will be automatically expanded if the variable is set to -t, which is the default. -@item -@code{tmpl-sign}: Thisdetermines the sign which marks the beginning and -the end of template expressions. By default it is set to the null -character (displayed in emacs as ^@@). You can also set this to a -string. Be careful if you change it, so that the templates will not be -mixed up with other non-template text! Note: The expansion function -looks at the whole template, so that it is very unlikely that the -function will make a mistake. -@item -@code{tmpl-minor-mode-map}: The keymap for the template minor mode. -@end itemize - - -@node Template Commands, , Template Customization, Template Minor Mode -@comment node-name, next, previous, up -@section Template Commands -@cindex commands - -In this section the commands of the template package are described. - - -@menu -* Insert Of Template Files:: -* Expansion Of Templates:: -* Escaping Of Template Signs:: -* The Template Minor Mode:: -@end menu - -@node Insert Of Template Files, Expansion Of Templates, Template Commands, Template Commands -@comment node-name, next, previous, up -@subsection Insert Of Template Files -@cindex template insert -@cindex template files -@findex tmpl-insert-template-file-from-fixed-dirs -@findex tmpl-insert-template-file - -The template package provides the following two commands for inserting -template files in an emacs buffer. - -@itemize @bullet -@item -@code{tmpl-insert-template-file}: This command can be used to insert a -template file in the current buffer. It will expand the templates in the -buffer if @code{tmpl-automatic-expand} is set to @code{t}. You can set -a default directory for this command by setting the variable -@code{tmpl-template-dir-list}. @xref{Template Customization}. -@item -@code{tmpl-insert-template-file-from-fixed-dirs}: The difference from -the simpler command @code{tmpl-insert-template-file} is that this -command will build a list for filename completion from a list of -predefined directories (look at @code{tmpl-template-dir-list}). The -filename completion list will also be filtered with the regular -expression defined by @code{tmpl-filer-regexp}. @xref{Template -Customization}. You can set the directory list and/or the filter -differently in each mode where you use templates, so that you will get -in the completion list only template files which could be used for the -current mode. - -If you want to insert a template file with this command, which is not in -one of the directories from @code{tmpl-template-dir-list}, then you have -to enter the string @emph{"Change the directory"} instead of a template -file. This string is also in the completion list. -@end itemize - -Both commands can also be used as functions. In this case the template -file with is directory path must be given to them as an parameter. - -You can also use commands like @code{insert-file} to insert template -files and expand them by hand (@pxref{Expansion Of Templates}). - - -@node Expansion Of Templates, Escaping Of Template Signs, Insert Of Template Files, Template Commands -@comment node-name, next, previous, up -@subsection Expansion Of Templates -@cindex template expansion -@cindex expansion -@findex tmpl-expand-templates-in-region -@findex tmpl-expand-templates-in-buffer - -You can expand templates by hand or automatically after their -insertion. @xref{Insert Of Template Files}, for automatic -expansion. Expansion by hand can be done with one of the -following two functions: - -@itemize @bullet -@item -@code{tmpl-expand-templates-in-region}: Expands the templates in the -region. The region is established by the optional arguments @code{BEGIN} -and @code{END}. If the arguments are @code{nil}, or if the function is called -interactively, then the current region will be used. -@item -@code{tmpl-expand-templates-in-buffer}: Expands all templates in the -current buffer. -@end itemize - -Both commands are bound to keys in the @code{tmpl-minor-mode}. @xref{The -Template Minor Mode}. - - -@node Escaping Of Template Signs, The Template Minor Mode, Expansion Of Templates, Template Commands -@comment node-name, next, previous, up -@subsection Escaping Of Template Signs -@cindex template escaping -@cindex escaping -@findex tmpl-escape-tmpl-sign-in-region -@findex tmpl-escape-tmpl-sign-in-buffer - -It is possible to escape template signs in a buffer or in a -region. Templates with escaped template signs are not expanded, but they -are un-escaped by the expansion functions. Therefore it is possible to -exclude single templates from the expansion by escaping them. Note: -You can't escape a template twice. The commands which can be used for -this are: - -@itemize @bullet -@item -@code{tmpl-escape-tmpl-sign-in-region}: Escapes all @code{tmpl-sign}s -(@pxref{Template Customization}) with a @code{tmpl-sign} in a -region. The region is established by the optional arguments @code{BEGIN} -and @code{END}. If the arguments are @code{nil}, or if the function is -called interactively, then the current region will be used. -@item -@code{tmpl-escape-tmpl-sign-in-buffer}: Same as -@code{tmpl-escape-tmpl-sign-in-region}, but escapes all templates in the -whole buffer. -@end itemize - -Both commands are bound to keys in @code{tmpl-minor-mode}. @xref{The -Template Minor Mode}. - - -@node The Template Minor Mode, , Escaping Of Template Signs, Template Commands -@comment node-name, next, previous, up -@subsection The Template Minor Mode -@cindex template minor mode -@cindex minor mode -@cindex key bindings -@findex tmpl-minor-mode - -The template minor mode can be toggled with the command -@code{tmpl-minor-mode}. The purpose of this mode is only to provide -key bindings for some of the commands of the package -@file{tmpl-minor-mode}. If you don't want to use the key bindings, you -don't need this minor mode. - -Look at the key table @code{tmpl-minor-mode-map} (@pxref{Template -Customization}) for the definition of the keys. - -It may be that I'll also provide a pulldown or popup menu for the minor -mode in a future release. - - -@node Hints For Emacs 19 Users, Bug Reports, Template Minor Mode, Top -@comment node-name, next, previous, up -@chapter Hints For Emacs 19 Users -@cindex Emacs 19 -@cindex missing features in the Emacs 19 -@vindex tmpl-history-variable-name -@findex file-remote-p - -This package is tested with the GNU Emacs 19.34. The Emacs 19.34 has had -not all features of the XEmacs. Therefore also some of the features of -this package could not be implemeted in the Emacs 19. - -Please read also the Emacs 19 related file @file{README-EMACS-19}! - -The following is a list of missing features: - -@itemize @bullet -@item -The capability to start an action from the help buffer. This is only -possible in the XEmacs, because in the Emacs 19.34 one can't assign -keymaps to a text region (overlay). - -@item -The keybindings of the drag and drop commands are not displayed in -the menus, because the Emacs 19 isn't able to handle the following -menu specification: @code{:keys "\\[idd-help-mouse-drag-and-drop]"}. - -@item -The function @code{file-remote-p} couldn't be implemeted, because of the -lack of the function @code{ange-ftp-ftp-p} in the ange-ftp package of -the Emacs 19.34. - -@item -The history variable determined by @code{tmpl-history-variable-name} -isn't used, because the function @code{read-file-name} doesn't support -it in the Emacs 19. - -@item -The mouse pointer shape (glyph) wont be changed in the Emacs 19 during a -drag and drop command. For that a way is needed to set the mouse pointer -shape to an image. -@end itemize - - -@node Bug Reports, Concept Index, Hints For Emacs 19 Users, Top -@comment node-name, next, previous, up -@chapter Bug Reports -@cindex bug report -@findex hm--html-submit-bug-report - -There's no software out there without bugs. This package contains -software, therefore it has bugs. I (Heiko Münkel -<muenkel@@tnt.uni-hannover.de>) have inserted most of the bugs in this -package by myself, but I've forgotten where. So please help me out of -this disaster and send bug reports, if you've found one of these little -animals. I'll try to do my very best to fix them and to insert new ones. - -If it's possible, you should use the command - -@lisp - M-x hm--html-submit-bug-report -@end lisp - -There's also an entry in the pulldown menu for this. - -In some cases a backtrace would also be appropriate. - -If you can't send the report with this function, at -least include the package version and your @code{Emacs}/@code{XEmacs} -version. - -In the best of all worlds you would also include a patch to fix the bug. - -@emph{Note}: It's not true that I've inserted the bugs as a marketing trick, -so that you must buy the next version to get some of them fixed. This is -false, because this software is free. - - -@node Concept Index, Function Index, Bug Reports, Top -@comment node-name, next, previous, up -@unnumbered Concept Index - -@printindex cp - -@node Function Index, Variable Index, Concept Index, Top -@comment node-name, next, previous, up -@unnumbered Function Index - -@printindex fn - -@node Variable Index, , Function Index, Top -@comment node-name, next, previous, up -@unnumbered Variable Index - -@printindex vr - -@summarycontents -@contents -@bye
--- a/man/lispref/commands.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/lispref/commands.texi Mon Aug 13 10:03:52 2007 +0200 @@ -822,6 +822,12 @@ or released, button events specify the modifier keys that were held down at the time and the position of the pointer at the time. +@item dnd-drop event + Some dragged data was released. The event provides the button that was used +to drag the data, the modifier keys that were hold down, the position where +the drop took place, and a lisp object containing the type and the data +dropped (Note: until now only the OffiX protocol supports dnd-drop). + @item motion event The pointer was moved. Along with the position of the pointer, these events also specify the modifier keys that were held down at the time. @@ -897,6 +903,21 @@ The position of the pointer (in pixels) at the time of the event. @end table +@item dnd-drop event +@table @asis +@item channel +@item timestamp +@item button + What button was used to drag. Buttons are numbered starting at 1. +@item modifiers + Which modifier keys were pressed to do the drag. +@item x +@itemx y + The position of the pointer (in pixels) at the time of the event. +@item data + A lisp object containing the dropped type and data. +@end table + @item pointer-motion event @table @asis @item channel @@ -968,6 +989,8 @@ A mouse button was pressed. @item button-release A mouse button was released. +@item dnd-drop +A drop occured. @item motion The mouse moved. @item misc-user @@ -1007,6 +1030,10 @@ This is true if @var{object} is a mouse button-release event. @end defun +@defun dnd-drop-event-p object +This is true if @var{object} is a mouse dnd-drop event. +@end defun + @defun motion-event-p object This is true if @var{object} is a mouse motion event. @end defun @@ -1039,10 +1066,10 @@ @node Accessing Mouse Event Positions @subsection Accessing the Position of a Mouse Event -Unlike other events, mouse events (i.e. motion, button-press, and -button-release events) occur in a particular location on the screen. -Many primitives are provided for determining exactly where the event -occurred and what is under that location. +Unlike other events, mouse events (i.e. motion, button-press, +button-release, and dnd-drop events) occur in a particular location +on the screen. Many primitives are provided for determining exactly +where the event occurred and what is under that location. @menu * Frame-Level Event Position Info:: @@ -1061,8 +1088,8 @@ @defun event-frame event This function returns the ``channel'' or frame that the given mouse -motion, button press, or button release event occurred in. This will be -@code{nil} for non-mouse events. +motion, button press, button release, or dnd drop event occurred in. +This will be @code{nil} for non-mouse events. @end defun @defun event-x-pixel event @@ -1084,14 +1111,14 @@ a mouse event occurred. @defun event-window event -Given a mouse motion, button press, or button release event, compute and +Given a mouse motion, button press, button release, or dnd drop event, compute and return the window on which that event occurred. This may be @code{nil} if the event occurred in the border or over a toolbar. The modeline is considered to be within the window it describes. @end defun @defun event-buffer event -Given a mouse motion, button press, or button release event, compute and +Given a mouse motion, button press, button release, or dnd drop event, compute and return the buffer of the window on which that event occurred. This may be @code{nil} if the event occurred in the border or over a toolbar. The modeline is considered to be within the window it describes. This is @@ -1103,7 +1130,7 @@ This function returns the X position in pixels of the given mouse event. The value returned is relative to the window the event occurred in. This will signal an error if the event is not a mouse-motion, button-press, -or button-release event. +button-release, or dnd-drop event. @end defun @defun event-window-y-pixel event @@ -1120,33 +1147,33 @@ modeline) that a mouse event occurred over or near. @defun event-over-text-area-p event -Given a mouse-motion, button-press, or button-release event, this +Given a mouse-motion, button-press, button-release, or dnd-drop event, this function returns @code{t} if the event is over the text area of a window. Otherwise, @code{nil} is returned. The modeline is not considered to be part of the text area. @end defun @defun event-over-modeline-p event -Given a mouse-motion, button-press, or button-release event, this +Given a mouse-motion, button-press, button-release, or dnd-drop event, this function returns @code{t} if the event is over the modeline of a window. Otherwise, @code{nil} is returned. @end defun @defun event-x event This function returns the X position of the given mouse-motion, -button-press, or button-release event in characters. This is relative +button-press, button-release, or dnd-drop event in characters. This is relative to the window the event occurred over. @end defun @defun event-y event This function returns the Y position of the given mouse-motion, -button-press, or button-release event in characters. This is relative +button-press, button-release, or dnd-drop event in characters. This is relative to the window the event occurred over. @end defun @defun event-point event This function returns the character position of the given mouse-motion, -button-press, or button-release event. If the event did not occur over +button-press, button-release, or dnd-drop event. If the event did not occur over a window, or did not occur over text, then this returns @code{nil}. Otherwise, it returns an index into the buffer visible in the event's window. @@ -1154,7 +1181,7 @@ @defun event-closest-point event This function returns the character position of the given mouse-motion, -button-press, or button-release event. If the event did not occur over +button-press, button-release, or dnd-drop event. If the event did not occur over a window or over text, it returns the closest point to the location of the event. If the Y pixel position overlaps a window and the X pixel position is to the left of that window, the closest point is the @@ -1172,25 +1199,25 @@ a mouse event occurred over. @defun event-over-glyph-p event -Given a mouse-motion, button-press, or button-release event, this +Given a mouse-motion, button-press, button-release, or dnd-drop event, this function returns @code{t} if the event is over a glyph. Otherwise, @code{nil} is returned. @end defun @defun event-glyph-extent event -If the given mouse-motion, button-press, or button-release event happened +If the given mouse-motion, button-press, button-release, or dnd-drop event happened on top of a glyph, this returns its extent; else @code{nil} is returned. @end defun @defun event-glyph-x-pixel event -Given a mouse-motion, button-press, or button-release event over a +Given a mouse-motion, button-press, button-release, or dnd-drop event over a glyph, this function returns the X position of the pointer relative to the upper left of the glyph. If the event is not over a glyph, it returns @code{nil}. @end defun @defun event-glyph-y-pixel event -Given a mouse-motion, button-press, or button-release event over a +Given a mouse-motion, button-press, button-release, or dnd-drop event over a glyph, this function returns the Y position of the pointer relative to the upper left of the glyph. If the event is not over a glyph, it returns @code{nil}. @@ -1200,13 +1227,13 @@ @subsubsection Event Toolbar Position Info @defun event-over-toolbar-p event -Given a mouse-motion, button-press, or button-release event, this +Given a mouse-motion, button-press, button-release, or dnd-drop event, this function returns @code{t} if the event is over a toolbar. Otherwise, @code{nil} is returned. @end defun @defun event-toolbar-button event -If the given mouse-motion, button-press, or button-release event +If the given mouse-motion, button-press, button-release, or dnd-drop event happened on top of a toolbar button, this function returns the button. Otherwise, @code{nil} is returned. @end defun @@ -1215,7 +1242,7 @@ @subsubsection Other Event Position Info @defun event-over-border-p event -Given a mouse-motion, button-press, or button-release event, this +Given a mouse-motion, button-press, button-release, or dnd-drop event, this function returns @code{t} if the event is over an internal toolbar. Otherwise, @code{nil} is returned. @end defun @@ -1268,6 +1295,11 @@ This function returns the process of the given process event. @end defun +@defun event-drag-and-drop-data event +This function returns a list containing the type of the drop as first element +and the data of the drop as second element. +@end defun + @node Working With Events @subsection Working With Events
--- a/man/lispref/extents.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/lispref/extents.texi Mon Aug 13 10:03:52 2007 +0200 @@ -481,6 +481,11 @@ stored.) @end defun +@defun set-extent-properties extent plist +Change some properties of @var{extent}. @var{plist} is a property +list. This is useful to change many extent properties at once. +@end defun + The following table lists the properties with predefined meanings, along with their allowable values. @@ -594,6 +599,15 @@ (@code{text}, @code{whitespace}, @code{inside-margin}, or @code{outside-margin}) The layout policy for this extent's end glyph. Defaults to @code{text}. @xref{Annotations}. + +@item initial-redisplay-function +(any funcallable object) The function to be called the first time (a +part of) the extent is redisplayed. It will be called with the extent +as its argument. + +This is used by @code{lazy-shot} to implement lazy font-locking. The +functionality is still experimental, and may change without further +notice. @end table The following convenience functions are provided for accessing @@ -668,7 +682,8 @@ @defun set-extent-keymap extent keymap This function sets the @code{keymap} property of @var{extent} to -@var{keymap}. +@var{keymap}. @var{keymap} must be either a keymap object, or +@code{nil}. @end defun @defun set-extent-begin-glyph-layout extent layout @@ -693,6 +708,11 @@ respectively. (@var{layout} defaults to @code{text} if not specified.) @end defun +@defun set-extent-initial-redisplay-function extent function +This function sets the @code{initial-redisplay-function} property of the +extent to @var{function}. +@end defun + @node Detached Extents @section Detached Extents @cindex detached extent
--- a/man/mailcrypt.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1639 +0,0 @@ -\input texinfo @c -*-Texinfo-*- - -@c tighten default spacing -@c @parskip 5pt plus 1 pt -@c @secheadingskip 10pt plus 6pt minus 3pt -@c @subsecheadingskip 8pt plus 6pt minus 3pt -@c @singlespace - -@c %**start of header -@setfilename ../info/mailcrypt.info -@settitle @value{TITLE} -@setchapternewpage off -@c %**end of header - -@syncodeindex ky cp -@syncodeindex vr cp -@syncodeindex fn cp - -@set TITLE Mailcrypt -@set VERSION 3.4 -@set UPDATED October 10, 1995 - -@ifinfo - -This documentation describes Mailcrypt version @value{VERSION}. This -documentation was last updated on @value{UPDATED}. - -Copyright 1995 Patrick J. LoPresti - -The Mailcrypt program and this manual are published as free software. -You may redistribute and/or modify them 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. - -Mailcrypt 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 GNU Emacs; see the file COPYING. If not, write to the Free -Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -@end ifinfo - -@titlepage -@title Mailcrypt: An EMACS Interface to PGP -@subtitle Version @value{VERSION} -@subtitle @value{UPDATED} -@author Patrick J. LoPresti <patl@@lcs.mit.edu> - -@c Copyright page -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1995 Patrick J. LoPresti - -The Mailcrypt program and this documentation are published as free -software. You may redistribute and/or modify them 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. - -Mailcrypt 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 GNU Emacs; see the file COPYING. If not, write to the Free -Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -@end titlepage - -@ifinfo -@node Top, Introduction, (dir), (dir) -@top Mailcrypt - -Mailcrypt is an Emacs Lisp package which provides a simple but powerful -interface to cryptographic functions for mail and news. - -This documentation describes Mailcrypt version @value{VERSION}. The -documentation was last updated on @value{UPDATED}. - -@end ifinfo - -@menu -* Introduction:: Read this first. -* General Use:: Everyday cryptographic functions. -* Remailer Support:: Interface to secure anonymous remailers. -* Passphrase Cache:: Letting Mailcrypt remember your passphrase - for a while. -* Key Fetching:: Automatically retrieving public keys - via finger or HTTP. -* Miscellaneous Configuration:: Random tweakables. -* Tips:: Hints and tricks. -* Limitations:: Things Mailcrypt does not do. -* References:: Pointers to relevant information. -* Credits:: Whom to blame. -* Index:: Keys, variables, and functions. - - --- The Detailed Node Listing --- - -Introduction - -* Prerequisites:: Complicated stuff you may have to do. -* Installation:: Simple stuff you probably have to do. -* Command Overview:: A brief summary of the most common - commands. - -Installation - -* Hooking into Rmail:: -* Hooking into VM:: -* Hooking into MH-E:: -* Hooking into Gnus:: - -General Use - -* Encrypting:: Encrypting a message to one or more - recipients. -* Signing:: Clearsigning a message. -* Inserting Keys:: Extracting a key from your public key - ring and inserting it. -* Decrypting:: Decrypting a message to you. -* Verifying:: Verifying the signature on a clearsigned - message. -* Snarfing Keys:: Finding a key in the current message and - adding it to your keyring. - -Remailer Support - -* Remailer Introduction:: A little about remailers in general. -* Remailer Quick Start:: Getting started quickly. -* Remailer Chains:: Creating custom chains of your very own. -* Response Blocks:: A way to let people reply to your - anonymous messages. -* Pseudonyms:: Who do you want to be today? -* Remailing Posts:: Posting to USENET anonymously or - pseduonymously. -* Mixmaster Support:: Remailers for the truly paranoid. -* Remailer Security:: Caveats. -* Verifiable Pseudonyms:: Giving expression to the voices in your - head. -* Remailer Tips:: Free advice. - -Key Fetching - -* Keyring Fetch:: Fetching from one or more other - keyrings on the local system. -* Finger Fetch:: Fetching a key through finger. -* HTTP Fetch:: Fetching a key off of the Web. - -Miscellaneous Configuration - -* Alternate Keyring:: Specifying a different file to act - like your public keyring. -* Comment Field:: Burma - Shave -* Mode Line:: Changing that "MC-w" and "MC-r" stuff -* Key Bindings:: Which keys cause which actions. -* Nonstandard Paths:: Useful if your PGP installation is weird. - -References - -* Online Resources:: Recreational reading with a purpose. -* Key Servers:: Keepers of the Global Keyring. -* Mailing List:: Staying informed while pumping the - authors' egos. -* Politics:: Anarcho-foobarism. -@end menu - -@node Introduction, General Use, Top, Top -@chapter Introduction - -Mailcrypt is an Emacs Lisp package which provides a simple but powerful -interface to cryptographic functions for mail and news. With Mailcrypt, -encryption becomes a seamlessly integrated part of your mail and news -handling environment. - -This manual is long because it is complete. All of the information you -need to get started is contained in this Introduction alone. - -@menu -* Prerequisites:: Complicated stuff you may have to do. -* Installation:: Simple stuff you probably have to do. -* Command Overview:: A brief summary of the most common - commands. -@end menu - -@node Prerequisites, Installation, Introduction, Introduction -@section Prerequisites - -Mailcrypt requires version 19 of GNU Emacs. Mailcrypt has been tested -on a variety of systems under both FSF Emacs and XEmacs. - -Mailcrypt requires Pretty Good (tm) Privacy, usually known as PGP. This -document assumes that you have already obtained and installed PGP and -that you are familiar with its basic functions. The best way to become -familiar with these functions is to read the @cite{PGP User's Guide}, at -least Volume I. - -For more information on obtaining and installing PGP, refer to the MIT -PGP home page at @file{http://web.mit.edu/network/pgp.html}. - -Although Mailcrypt may be used to process data in arbitrary Emacs -buffers, it is most useful in conjunction with other Emacs packages for -handling mail and news. Mailcrypt has specialized support for Rmail -(@pxref{Rmail, Rmail, Reading Mail with Rmail, emacs, The GNU Emacs -Manual}), VM (@pxref{Top, VM, Introduction, vm, The VM User's Manual}), -MH-E, and Gnus (@pxref{Top, Gnus, Overview, gnus, The Gnus Manual}). -Information on the general use of these packages is beyond the scope of -this manual. - -@node Installation, Command Overview, Prerequisites, Introduction -@section Installation - -If Mailcrypt is not installed on your system, obtain the latest version -from the Mailcrypt home page at -@file{http://cag-www.lcs.mit.edu/mailcrypt/} and follow the instructions -in the file @file{INSTALL}. - -Next, teach your Emacs how and when to load the Mailcrypt functions and -install the Mailcrypt key bindings. Almost all Emacs major modes -(including mail and news handling modes) have corresponding "hook" -variables which hold functions to be run when the mode is entered. All -you have to do is add the Mailcrypt installer functions to the -appropriate hooks; then the installer functions will add the Mailcrypt -key bindings when the respective mode is entered. - -Specifically, begin by placing the following lines into your -@file{.emacs} file (or the system-wide @file{default.el} file): - -@lisp -(autoload 'mc-install-write-mode "mailcrypt" nil t) -(autoload 'mc-install-read-mode "mailcrypt" nil t) -(add-hook 'mail-mode-hook 'mc-install-write-mode) -@end lisp - -Then add additional lines for your own mail and news packages as -described below. - -@menu -* Hooking into Rmail:: -* Hooking into VM:: -* Hooking into MH-E:: -* Hooking into Gnus:: -@end menu - -@node Hooking into Rmail, Hooking into VM, Installation, Installation -@subsection Hooking into Rmail - -To hook Mailcrypt into Rmail, use the following lines: - -@lisp -(add-hook 'rmail-mode-hook 'mc-install-read-mode) -(add-hook 'rmail-summary-mode-hook 'mc-install-read-mode) -@end lisp - -@node Hooking into VM, Hooking into MH-E, Hooking into Rmail, Installation -@subsection Hooking into VM - -To hook Mailcrypt into VM, use the following lines: - -@lisp -(add-hook 'vm-mode-hook 'mc-install-read-mode) -(add-hook 'vm-summary-mode-hook 'mc-install-read-mode) -(add-hook 'vm-virtual-mode-hook 'mc-install-read-mode) -(add-hook 'vm-mail-mode-hook 'mc-install-write-mode) -@end lisp - -@node Hooking into MH-E, Hooking into Gnus, Hooking into VM, Installation -@subsection Hooking into MH-E - -To hook Mailcrypt into MH-E, use the following lines: - -@lisp -(add-hook 'mh-folder-mode-hook 'mc-install-read-mode) -(add-hook 'mh-letter-mode-hook 'mc-install-write-mode) -@end lisp - -@node Hooking into Gnus, , Hooking into MH-E, Installation -@subsection Hooking into Gnus - -To hook Mailcrypt into Gnus, use the following lines: - -@lisp -(add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) -(add-hook 'news-reply-mode-hook 'mc-install-write-mode) -@end lisp - -@node Command Overview, , Installation, Introduction -@section Command Overview - -All Mailcrypt commands are (by default) activated by three-character key -sequences which begin with @kbd{C-c /}. The four most common operations -are: - -@table @emph - -@item Encrypting a Message -@kbd{C-c / e} encrypts a message using the recipient's (or recipients') -public key(s). @xref{Encrypting, , Encrypting a Message}. - -@item Decrypting a Message -@kbd{C-c / d} decrypts a message using your secret key. -@xref{Decrypting, , Decrypting a Message}. - -@item Signing a Message -@kbd{C-c / s} clearsigns a message using your secret key. -@xref{Signing, , Signing a Message}. - -@item Verifying a Signature -@kbd{C-c / v} verifies the signature on a clearsigned message using the -sender's public key. @xref{Verifying, , Verifying a Signature}. - -@end table - -These functions and others are documented in detail in the following -chapters. - -Any time you are composing or reading mail or news, you can get a -summary of the available commands by typing @kbd{C-h m}. If you are -running Emacs under X, an even easier way to see the available commands -is to access the @code{Mailcrypt} pull-down menu. - -@node General Use, Remailer Support, Introduction, Top -@chapter General Use - -@findex mc-read-mode -@findex mc-write-mode -Mailcrypt works by providing two minor modes for interfacing with -cryptographic functions: @code{mc-read-mode} and @code{mc-write-mode}. -@code{mc-read-mode} provides key bindings for processing messages which -you have received; @code{mc-write-mode} provides key bindings for -processing messages which you are about to send. These minor modes will -indicate when they are active by placing a characteristic string in the -mode line (@pxref{Mode Line}). They will also add a @code{Mailcrypt} -pull-down menu to the menu bar. - -@findex mc-install-read-mode -@findex mc-install-write-mode -The normal installation procedure (@pxref{Installation}) will arrange -for the appropriate mode to be active when you read and compose mail and -news. But you may want to use Mailcrypt's functions at other times; to -do so, you can call @code{mc-install-read-mode} or -@code{mc-install-write-mode} directly. For example, if you were editing -a file in Text mode and wanted to digitally sign it, you would type -@kbd{M-x mc-install-write-mode}, then @kbd{C-c / s} (@pxref{Signing}). - -Once one of the Mailcrypt modes is active, you can get a summary of the -available functions by typing @kbd{C-h m} or by examining the -@code{Mailcrypt} pull-down menu. - -The description of each function below includes which of the modes has a -binding for that function. - -@menu -* Encrypting:: Encrypting a message to one or more - recipients. -* Signing:: Clearsigning a message. -* Inserting Keys:: Extracting a key from your public key - ring and inserting it. -* Decrypting:: Decrypting a message to you. -* Verifying:: Verifying the signature on a clearsigned - message. -* Snarfing Keys:: Finding a key in the current message and - adding it to your keyring. -@end menu - -@node Encrypting, Signing, General Use, General Use -@section Encrypting a Message - -@findex mc-encrypt -@kindex C-c / e -The function @code{mc-encrypt} will encrypt a message in the current -buffer. @code{mc-write-mode} binds this function to @kbd{C-c / e} by -default. - -When this function is called, Mailcrypt will prompt you for a -comma-separated list of recipients. If called from a mail composition -buffer, the recipient list will default to the Email addresses in the -@samp{To}, @samp{CC}, and @samp{BCC} lines of the message. - -@vindex mc-encrypt-for-me -If you want to be able to decrypt the message yourself, you need to add -yourself to the recipient list. If you always want to do so, set the -variable @code{mc-encrypt-for-me} to @code{t}. (Note that Mailcrypt -overrides the PGP "encrypttoself" flag; use this variable instead.) - -If you provide an empty recipient list, Mailcrypt will ASCII-armor the -message without encrypting it. - -@vindex mc-pgp-always-sign -Once you have edited the recipient list to your satisfaction, type -@kbd{@key{RET}} to accept it. You will then be asked whether you want -to sign the message; answer @kbd{y} or @kbd{n}. You can avoid this -question by setting the variable @code{mc-pgp-always-sign}: A value of -@code{t} means "yes", a value of @code{'never} means "no". - -If you elect to sign the message, Mailcrypt will prompt you for the -appropriate passphrase unless it is cached (@pxref{Passphrase Cache}). - -@vindex mc-pre-encryption-hook -@vindex mc-post-encryption-hook -Mailcrypt will then pass the message to PGP for processing. Mailcrypt -will call the functions listed in @code{mc-pre-encryption-hook} and -@code{mc-post-encryption-hook} immediately before and after processing, -respectively. The encrypted message will then replace the original -message in the buffer. You can undo the encryption with the normal -Emacs undo command @kbd{C-x u} (@pxref{Undo, Emacs Undo, Undoing -Changes, emacs, The GNU Emacs Manual}). - -If an error occurs, Mailcrypt will display an appropriate diagnostic. -If you do not have the public key for one of the specified recipients, -Mailcrypt will offer to try to fetch it for you (@pxref{Key Fetching}). - -@vindex mc-pgp-user-id -The default key for signing is the first one on the secret key ring -which matches the string @code{mc-pgp-user-id}; this defaults to -@code{(user-login-name)}. Note that this differs from PGP's normal -default, which is to use the first of @emph{all} of the secret keys. To -mimic PGP's behavior, set this variable to @code{""}. - -If you want to use a secret key other than your default for signing the -message, pass a prefix argument to @code{mc-encrypt}. (That is, type -@kbd{C-u C-c / e}.) Mailcrypt will prompt for a string and will sign with -the first key on your secret keyring which matches that string. It will -be assumed that you want to sign the message, so you will not be -prompted. - -@node Signing, Inserting Keys, Encrypting, General Use -@section Signing a Message - -@findex mc-sign -@kindex C-c / s -The function @code{mc-sign} will clearsign a message in the current -buffer. @code{mc-write-mode} binds this function to @kbd{C-c / s} by -default. - -When this function is called, Mailcrypt will prompt you for the -appropriate passphrase unless it is cached (@pxref{Passphrase Cache}). - -@vindex mc-pre-signature-hook -@vindex mc-post-signature-hook -Mailcrypt will then pass the message to PGP for processing. Mailcrypt -will call the functions listed in @code{mc-pre-signature-hook} and -@code{mc-post-signature-hook} immediately before and after processing, -respectively. The signed message will replace the original message in -the buffer. @emph{Do not} edit the message further with the signature -attached, because the signature would then be incorrect. If you -discover you need to edit a message after you have signed it, remove the -signature first with the normal Emacs undo command @kbd{C-x u} -(@pxref{Undo, Emacs Undo, Undoing Changes, emacs, The GNU Emacs -Manual}). - -The variable @code{mc-pgp-user-id} controls which secret key is used for -signing; it is described in @ref{Encrypting, , Encrypting a Message}. -To use a different secret key, pass a prefix argument to @code{mc-sign}. -(That is, type @kbd{C-u C-c / s}.) Mailcrypt will prompt for a string -and will sign with the first key on your secret keyring which matches -that string. - -@node Inserting Keys, Decrypting, Signing, General Use -@section Inserting a Public Key Block - -@findex mc-insert-public-key -@kindex C-c / x -The function @code{mc-insert-public-key} will extract a key from your -public keyring and insert it into the current buffer. -@code{mc-write-mode} binds this function to @kbd{C-c / x} by default. - -This function is useful for sending your public key to someone else or -for uploading it to the key servers (@pxref{Key Servers}). The inserted -key will be the first one on your public key ring which matches the -string @code{mc-pgp-user-id} (@pxref{Encrypting, , Encrypting a -Message}). - -You may want to insert a different public key instead; for example, you -may have signed someone's key and want to send it back to them. To do -so, pass a prefix argument to @code{mc-insert-public-key}. (That is, -type @kbd{C-u C-c / x}.) You will be prompted for a string; the first key -on your public key ring which matches that string will be inserted. - -@node Decrypting, Verifying, Inserting Keys, General Use -@section Decrypting a message - -@findex mc-decrypt -@kindex C-c / d -The function @code{mc-decrypt} will decrypt a message in the current -buffer. @code{mc-read-mode} binds this function to @kbd{C-c / d} by -default. - -When this function is called, Mailcrypt will prompt you for the -appropriate passphrase unless it is cached (@pxref{Passphrase Cache}). - -The encrypted message will then be passed to PGP for processing. If you -are not in a mail buffer, the decrypted message will replace the -encrypted form. If you are in a mail buffer, you will be prompted -whether to do the replacement. - -If you answer @kbd{n}, you will be placed in a new mail reading buffer -to view the decrypted message. This new mail reading buffer will have -no corresponding disk file; its purpose is to provide you with all of -your usual reply and citation functions without requiring you to save -the message in decrypted form. Type @kbd{q} to kill this buffer. - -@vindex mc-always-replace -You can avoid the question of whether to replace the encrypted message -by setting the variable @code{mc-always-replace}. A value of @code{t} -means "yes"; a value of @code{'never} means "no". - -If the encrypted message is also signed, PGP will attempt to verify the -signature. If the verification fails because you lack the necessary -public key, Mailcrypt will offer to fetch it for you (@pxref{Key -Fetching}). - -Look in the @code{*MailCrypt*} buffer to see the result of the signature -verification. - -@node Verifying, Snarfing Keys, Decrypting, General Use -@section Verifying a Signature - -@findex mc-verify -@kindex C-c / v -The function @code{mc-verify} will verify the cleartext signature on a -message in the current buffer. @code{mc-read-mode} binds this function -to @kbd{C-c / v} by default. - -When this function is called, Mailcrypt will pass the message to PGP for -processing and report whether or not the signature verified. - -If the signature failed to verify because you lack the necessary public -key, Mailcrypt will offer to fetch it for you (@pxref{Key Fetching}). - -@node Snarfing Keys, , Verifying, General Use -@section Snarfing a Key - -@findex mc-snarf -@kindex C-c / a -The function @code{mc-snarf} will add to your keyring any keys in the -current buffer. @code{mc-read-mode} binds this function to @kbd{C-c / a} -by default. - -This function is useful when someone sends you a public key in an Email -message. - -@node Remailer Support, Passphrase Cache, General Use, Top -@chapter Remailer Support -This is a long chapter describing an advanced feature; you -may want to skip it on first reading. - -@menu -* Remailer Introduction:: A little about remailers in general. -* Remailer Quick Start:: Getting started quickly. -* Remailer Chains:: Creating custom chains of your very own. -* Response Blocks:: A way to let people reply to your - anonymous messages. -* Pseudonyms:: Who do you want to be today? -* Remailing Posts:: Posting to USENET anonymously or - pseduonymously. -* Mixmaster Support:: Remailers for the truly paranoid. -* Remailer Security:: Caveats. -* Verifiable Pseudonyms:: Giving expression to the voices in your - head. -* Remailer Tips:: Free advice. -@end menu - -@node Remailer Introduction, Remailer Quick Start, Remailer Support, Remailer Support -@section Remailer Introduction -There are several anonymous remailer services running on the Internet. -These are programs that accept mail, strip off information that would -identify the origin of the message, and forward the mail to the -designated recipient. This simple scheme alone, however, is insecure if -the anonymous remailer becomes compromised (or if the remailer was set -up by an untrustworthy party in the first place). Whoever controls the -remailer will have access to the identities of senders and recipients. - -One solution to this is to use @emph{chains} of remailers that send -encrypted messages. For example, suppose Bill wishes to send a message -to Louis using a chain of remailers A, B, and C. He writes the message -(possibly encrypting it for Louis), then encrypts the result (including -the fact that Louis is the recipient) using a public key supplied by -remailer C. Then he encrypts this result using a public key supplied by -remailer B. Then he encrypts this result using a public key supplied by -A and sends the message to A. - -When A receives the message, it decrypts the message with its key to -produce something encrypted for B, learns that the next remailer in the -chain is B, strips off the information that the message came from Bill, -and sends the message on to B. B then decrypts, learns that the next -remailer in the chain is C, strips off the information that the message -came from A, and sends the result to C. C then decrypts, learns that -the destination is Louis, strips off the information that the message -came from B, and sends the result to Louis. With this arrangement, only -A knows that the original message came from Bill, and only C knows that -the intended recipient is Louis. In general, the sender and recipient -can both be known only to someone who has compromised all remailers in -the chain. - -If Bill wishes, he can include an encrypted "response block" in his -message to Louis, which defines a remailer chain that Louis can use to -reply to Bill. Louis can use this chain without knowing who Bill is -- -only the last remailer in the chain need know the final recipient. Bill -can also establish a @emph{pseudonym} for use in signing his anonymous -messages. - -Mailcrypt includes facilities for sending messages via remailers, for -defining chains of remailers, for generating response blocks, and for -using pseudonyms. - -@node Remailer Quick Start, Remailer Chains, Remailer Introduction, Remailer Support -@section Remailer Quick Start - -To use Mailcrypt's remailing facilities, you need to configure them -first. Begin with the following steps: - -@enumerate - -@item -Do @samp{finger remailer-list@@kiwi.cs.berkeley.edu > ~/.remailers}. -This will create a Levien-format list of remailers in the file -@file{.remailers} in your home directory. Mailcrypt will parse this the -first time you access a remailer function. - -@item -Look over the @file{.remailers} file and find the ones you want to use. - -@item -Add their PGP public keys to your keyring. You can @code{finger -pgpkeys@@kiwi.cs.berkeley.edu} for a list of remailer public keys. Note -that Mailcrypt @emph{requires} that you have the public keys of all the -remailers you want to use, and therefore that the remailers support PGP -encryption. - -@end enumerate - -@quotation -@emph{Note:} These steps need only be done once, although repeating them -from time to time is probably a good idea, since remailers come and go. -@end quotation - -Now test the remailer functions. First compose an outgoing Email -message (using @kbd{C-x m}, for example) addressed to yourself. Type -@kbd{C-c / r}. Choose a remailer; use @kbd{@key{TAB}} to get completion -on its name. The buffer will be rewritten for anonymous mailing through -that remailer. - -@node Remailer Chains, Response Blocks, Remailer Quick Start, Remailer Support -@section Remailer Chains - -@findex mc-remailer-encrypt-for-chain -@kindex C-c / r -@code{mc-write-mode} binds the function -@code{mc-remailer-encrypt-for-chain} to the key @kbd{C-c / r}. This -function rewrites the message for a remailer or chain. The resulting -buffer is just a new Email message, so it can itself be rewritten for -another remailer; this is one way to manually construct a remailer -chain. - -Mailcrypt also has powerful facilities for defining automatic chains. -We will start with an example. Suppose you have put the following into -your @file{.emacs} file: - -@vindex mc-remailer-user-chains -@lisp -(setq mc-remailer-user-chains - '(("Foo" "alumni" "robo") - ("Bar" (shuffle-vector ["replay" "flame" "spook"])) - ("Baz" "Foo" "Bar" "rahul" "Bar") - ("Quux" 4))) -@end lisp - -This code defines four chains. The first is named "Foo" and consists of -"alumni" and "robo", in that order. The second is named "Bar" and -consists of "replay", "flame", and "spook" in some random order (a -different order will be chosen each time the chain is used). The third -is named "Baz" and consists of 9 remailers: The two from "Foo", followed -by a permutation of the three from "Bar", followed by "rahul", followed -by another permutation of the three from "Bar". Finally, the fourth is -named "Quux" and consists of a random permutation of the four best -remailers as ordered in the @file{~/.remailers} file. - -Now whenever you are prompted for a "remailer or chain", the chains -"Foo", "Bar", "Baz", and "Quux" will be available, including -@kbd{@key{TAB}} completion on their names. By capitalizing their names, -you guarantee they will show up near the top of the completion list if -you type @kbd{@key{TAB}} on an empty input. - -Now for the gritty details. @code{mc-remailer-user-chains} is a list of -chain definitions. A chain definition is a list whose first element is -the name (a string) and whose remaining elements form a @dfn{remailer -list}. Each element of a remailer list is one of the following: - -@enumerate - -@item -A raw remailer structure. This is the base case, but you will probably -never want nor need to deal with these directly. - -@item -A string naming another remailer chain to be spliced in at this point. - -@item -A positive integer N representing a chain to be spliced in at this point -and consisting of a random permutation of the top N remailers as ordered -in the @file{~/.remailers} file. - -@item -An arbitrary Emacs Lisp form, which should return another remailer -list which will be spliced in at this point and recursively -evaluated. Mmmm, Lisp. - -@end enumerate -So, in the example "Bar" above, @code{shuffle-vector} is actually a Lisp -primitive which returns a random permutation of the argument vector. -(Which brings up a side note: A remailer list can be a vector instead of -a list if you like.) - -So where do the definitions for "replay" etc. come from? - -@vindex mc-remailer-internal-chains -There is another variable, @code{mc-remailer-internal-chains}, which has -the same format as @code{mc-remailer-user-chains}. In fact, the -concatenation of the two is always used internally when resolving chains -by name. The "internal chains" are normally generated automatically -from a Levien-format remailer list, which lives in @file{~/.remailers} -by default and is parsed at startup time. The parser creates several -chains, each containing a single remailer, and names each chain after -the respective remailer. - -Thus "replay" (for example) is actually the name of a @emph{chain} whose -single element is the remailer at <remailer@@replay.com>. So "replay" -is a valid name of a chain to include in the definition of another -chain, as was done above in the definition of "Bar". - -@node Response Blocks, Pseudonyms, Remailer Chains, Remailer Support -@section Response Blocks - -@kindex C-c / b -Mailcrypt can generate a response block for you. Just type @kbd{C-c / b} -in an outgoing mail buffer. That will prompt you for a chain to use, -and will insert the response block at point. Note that you can use any -chain you want for your response block; it need not be related to the -chain you (later) use to remail the message. - -If instead you type @kbd{C-u C-c / b}, you will be dropped into a -recursive edit of the innermost part of the response block. This text -is what you will see at the top of the message when the response block -is used. This text is the only way to identify the response block, -since it will be used to mail you through anonymous remailers. - -You probably won't need to use the @kbd{C-u} feature, since by default -the response block contains the date, @samp{To} field, and @samp{From} -field of the message you are composing. However, if you want your -response block to point to a USENET newsgroup instead of your Email -address, you may edit the innermost part of the response block to have a -@samp{Newsgroups} line instead of a @samp{To} line. - -Inserting a response block also updates the @samp{Reply-to} hashmark -header field. So, when your recipient replies to your message, the -reply will automatically be addressed properly. This only works if the -last remailer in the chain used to encrypt the @emph{message} supports -hashmarks (the response block chain doesn't matter). If the last -remailer does not support hashmarks, Mailcrypt will generate an error -when you try to use the chain. - -Note that you should insert your response block before you encrypt the -message for remailing. Also, see @ref{Remailer Security}. - -@node Pseudonyms, Remailing Posts, Response Blocks, Remailer Support -@section Pseudonyms - -@kindex C-c / p -Mailcrypt supports pseudonyms. Type @kbd{C-c / p} in an outgoing message -buffer and you will be prompted for a pseudonym to use. Your pseudonym -will show up in the @samp{From} line that the recipient sees. Your -pseudonym may either be a complete @samp{From} line (including an Email -address), or just a full name (with no Email address). In the latter -case, the Email address will automatically be set to <x@@x.x>, an invalid -address designed to prevent sendmail from going rewrite-happy. - -If you have one or more pseudonyms which you normally use, and you -aren't afraid of revealing them if your account is compromised, you can -set up a default list of pseudonyms with lines like the following in -your @file{.emacs} file: - -@vindex mc-remailer-pseudonyms -@lisp -(setq mc-remailer-pseudonyms - '("Elvis Presley" "Vanna White" "Charles Manson")) -@end lisp - -Then those names will be available for completion when you are -prompted for your pseudonym. - -You should insert your pseudonym before you insert a response block, so -that the response block will contain the @samp{From} line as well as the -@samp{To} line. That way you can tell who you were pretending to be -when you get a reply to your message. - -Note: Many remailers do not support pseudonyms. In addition, the Levien -format does not (yet) indicate which do and which do not, so Mailcrypt -can't warn you when your pseudonym isn't going to work. The only way to -be sure is to send yourself a test message, and to try different -remailers until you find one or more which work. On the bright side, -only the last remailer in the chain needs to provide such support; none -of the others matter. - -@node Remailing Posts, Mixmaster Support, Pseudonyms, Remailer Support -@section Remailing Posts -Mailcrypt knows how to rewrite USENET posts for anonymous or -pseudonymous remailing. Just compose your post or followup normally, -and use @kbd{C-c / r} to rewrite it for a remailer chain. You don't -even need to start your newsreader to make a post; you can just compose -a message in mail mode and replace the @samp{To} line with a -@samp{Newsgroups} line before doing @kbd{C-c / r}. - -@vindex mc-remailer-preserved-headers -Mailcrypt will generate an error if the last remailer in the chain does -not have both the @code{post} and @code{hash} (hashmarks) properties. -The hashmarks are used to preserve @samp{References} and similar -headers, so your anonymous or pseudonymous followups will thread -properly. The variable @code{mc-remailer-preserved-headers} controls -which headers are preserved when rewriting a message, but you should not -need to change it since the default value is reasonable. - -Before rewriting, you can use @kbd{C-c / p} to insert your pseudonym, -and @kbd{C-c / b} to insert your response block, just like when -composing mail. In this case, the response block will include the -@samp{From} line and the @samp{Newsgroups} line (which is the news -analogue to the @samp{To} line). - -@node Mixmaster Support, Remailer Security, Remailing Posts, Remailer Support -@section Mixmaster Support - -@dfn{Mixmaster} is a new kind of remailer which provides excellent -security against traffic analysis and replay attacks. (For more -information on these attacks and Mixmaster, see Lance Cottrell's home -page at @file{http://www.obscura.com/~loki/}. - -If you do not use Mixmaster, you may skip this section entirely; -Mailcrypt's default configuration treats Mixmaster as if it did not -exist. - -If you have the Mixmaster executable installed, you can tell Mailcrypt -to use it by placing lines like the following into your @file{.emacs} -file: - -@vindex mc-mixmaster-path -@vindex mc-mixmaster-list-path -@lisp -(setq mc-mixmaster-path "mixmaster") -(setq mc-mixmaster-list-path "/foo/bar/baz/type2.list") -@end lisp - -@code{mc-mixmaster-path} is a string representing the Mixmaster -executable. @code{mc-mixmaster-list-path} is the complete path to the -@code{type2.list} file. - -Once these variables are defined, Mailcrypt will automatically try to -use the Mixmaster executable whenever possible. Specifically, when you -rewrite a message for a chain, Mailcrypt will find maximal length -sub-chains which have the @code{mix} property and will use the Mixmaster -executable to rewrite for those sub-chains. - -This allows arbitrary intermingling of Mixmaster and normal (also called -@dfn{Type 1}) remailers, but you should note that this is @emph{not -recommended}. The recommended procedure is to have a single Mixmaster -sub-chain which is most or all of the whole chain. - -There are advantages and disadvantages to having the Mixmaster sub-chain -at the end of the whole chain. The primary advantage is that Mixmaster -remailers support multiple recipients. The primary disadvantages are -that they do not support pseudonyms nor posting. - -So here, as always, it is the last element of the chain which needs to -support the special features you want. In general, the remaining -elements do not matter, and the superior security of Mixmaster remailers -is a good argument for using them for the bulk of your chains. - -@findex mc-demix -Mixmaster remailers also have a "Type 1 compatibility mode" which you -might want to invoke to use a pseudonym or make a post. You can do this -with the function @code{mc-demix}. Here is an example of its use: - -@lisp -(setq mc-remailer-user-chains - '(("Foo" "vishnu" "spook") - ("Bar" "Foo" (mc-demix "replay")))) -@end lisp - -This makes "Bar" a chain of three remailers, and guarantees that the -last one ("replay") will be used in compatibility mode. - -Note that Mixmaster remailers cannot be used for response blocks. -Mailcrypt will ignore the @code{mix} property when generating a response -block. - -@node Remailer Security, Verifiable Pseudonyms, Mixmaster Support, Remailer Support -@section Remailer Security - -Keep in mind that there is only one person fully qualified to protect -your privacy: @emph{you}. You are responsible for obtaining a list of -remailers and their public keys; you are responsible for choosing which -of them to use and in what order. There are public lists of remailers -and keys (the Quick Start section above relies on them), but you pay for -the convenience by putting your trust in a single source. This is one -reason Mailcrypt does not access these public lists automatically; you -need to get into the habit of watching what goes on behind the scenes. -You should also try to learn something about the remailers themselves, -since you are relying on them to help protect your privacy. - -How many remailers should you include in your chain, and how should -you choose them? That depends on whom you perceive as a threat. If -the threat is your ex-spouse or your boss, even a single remailer is -probably adequate (more won't hurt, but will cost in latency). If the -threat is the Church of Scientology, you probably want to use a fair -number of remailers across multiple continents. If the threat is a -major world government, well, best of luck to you. - -Also, there is a huge difference between chains suitable for regular -messages and chains suitable for response blocks. Some remailers don't -even keep mail logs (at least, their operators claim they do not), so it -may be literally impossible to trace a message back to you after the -fact if you chain it through enough remailers. Response blocks, on the -other hand, have your identity buried in there @emph{somewhere}. In -principle, at least, it is possible to compromise the keys of all the -remailers in the chain and decrypt the response block. So you should -either use very long and strong chains for your response blocks, avoid -using response blocks at all, or only use response blocks which -themselves ultimately point to a newsgroup. - -@node Verifiable Pseudonyms, Remailer Tips, Remailer Security, Remailer Support -@section Verifiable Pseudonyms -Here is a plausible sequence of operations when using the remailer -support in Mailcrypt: - -@enumerate - -@item -You create a public/private PGP key pair. You give it a User ID which -is your pseudonym. You upload the public key to the key servers or -otherwise distribute it. (Be aware that anyone who compromises your -account can read the IDs on your secret keyring, thus discovering your -verifiable pseudonyms.) - -@item -You compose an Email message, Email reply, news post, or news followup. - -@item -You insert your pseudonym with @kbd{C-c / p}. - -@item -(Optional) You insert your response block with @kbd{C-c / b}. - -@item -You type @kbd{C-c / s} to sign the message. The @code{mc-sign} function -understands pseudonyms. - -@item -You type @kbd{C-c / r} to rewrite the message for remailing. (Or use -@kbd{C-u C-c / r} to view each step of the rewriting as it happens.) - -@item -You type @kbd{C-c C-c} to send the message. - -@end enumerate - -Now the recipient(s), reading your message through mail or news, can -verify your pseudonymous signature; thus you have started to create a -verifiable pseudonymous identity. If you use it consistently, it will -develop a reputation of its own. With Mailcrypt, using a pseudonym is -almost as easy as using your real name (and your followups in news -will even thread properly). Welcome to the new age of letters@dots{} - -@node Remailer Tips, , Verifiable Pseudonyms, Remailer Support -@section Remailer Tips - -This is a collection of tips for using Mailcrypt's remailer support. - -@itemize @bullet - -@item -@vindex mc-levien-file-name -Read and understand the @file{.remailers} file. If the service at -kiwi.cs.berkeley.edu is gone by the time you read this, track down a -comparable service elsewhere. (Ask around in -@file{news:alt.privacy.anon-server} or, as a last resort, -@file{news:alt.security.pgp}.) Check the documentation (@kbd{C-h v}) -for the variable @code{mc-levien-file-name} for a description of Levien -format. - -@item -The relevant remailer properties are @code{pgp} (required), @code{hash} -(required if you use hashmark headers), and @code{post} (required for -posting to USENET). Remailers which do not support PGP won't even show -up in the completion list. - -@item -The only remailer which needs special properties (e.g., posting, -hashmarks, pseudonym support) is the last one in a chain. Any remailer -can be used at the beginning or in the middle. So if you find a few -remailers which support the feature(s) you require, and you always use -them at the end of your chains, then you can be confident that even the -longest chains will work. - -@item -@findex mc-reread-levien-file -If you update your @file{~/.remailers} file, you can reread it with -@kbd{M-x mc-reread-levien-file}. - -@item -Remember the natural order of operations. First you compose your -message. Then you insert your pseudonym with @kbd{C-c / p}. Then you -insert your response block with @kbd{C-c / b}. Then you sign (@kbd{C-c / -s}) or sign and encrypt (@kbd{C-c / e}) the message. Then you rewrite it -for a remailer or chain (@kbd{C-c / r}). Then you send it. All but the -first and last two of these are optional. (Well, strictly speaking, -they are all optional, but you get the idea.) - -@item -Find and read some of the excellent remailer documentation available on -the Internet. For some good starting points, see @ref{References}. - -@end itemize - -@node Passphrase Cache, Key Fetching, Remailer Support, Top -@chapter Passphrase Cache - -@vindex mc-passwd-timeout -Mailcrypt can remember your passphrase so that you need not type it -repeatedly. It will also "forget" your passphrase if it has not been -used in a while, thus trading some security for some convenience. You -can tune this tradeoff with the variable @code{mc-passwd-timeout}, which -is a duration in seconds from the last time the passphrase was used -until Mailcrypt will forget it. The default value is 60 seconds. - -So, for example, to make Mailcrypt remember your passphrase for 10 -minutes after each use, you would use the following line in your -@file{.emacs} file: - -@lisp -(setq mc-passwd-timeout 600) -@end lisp - -A value of @code{nil} or 0 will disable passphrase caching completely. -This provides some increase in security, but be aware that you are -already playing a dangerous game by typing your passphrase at a Lisp -interpreter. - -Mailcrypt understands multiple secret keys with distinct passphrases. - -@findex mc-deactivate-passwd -@kindex C-c / f -To manually force Mailcrypt to forget your passphrase(s), use the -function @code{mc-deactivate-passwd}. Both @code{mc-read-mode} and -@code{mc-write-mode} bind this function to @kbd{C-c / f} by default. - -@quotation -@strong{Warning:} Although Mailcrypt takes pains to overwrite your -passphrase when "forgetting", it cannot prevent the Emacs garbage -collector from possibly leaving copies elsewhere in memory. Also, your -last 100 keystrokes can always be viewed with the function -@code{view-lossage}, normally bound to @kbd{C-h l}. So be sure to type -at least 100 characters after typing your passphrase if you plan to -leave your terminal unattended. -@end quotation - -@node Key Fetching, Miscellaneous Configuration, Passphrase Cache, Top -@chapter Key Fetching - -@findex mc-pgp-fetch-key -@kindex C-c / k -Mailcrypt knows how to fetch PGP public keys from the key servers -(@pxref{Key Servers}). The function @code{mc-pgp-fetch-key} is bound by -default to @kbd{C-c / k} in both @code{mc-read-mode} and -@code{mc-write-mode}. Additionally, @code{mc-encrypt}, -@code{mc-decrypt}, and @code{mc-verify} will offer to call this function -to automatically fetch a desired key. If you call it manually, it will -prompt you for the User ID of the key to fetch. - -@vindex mc-pgp-fetch-methods -The variable @code{mc-pgp-fetch-methods} is a list of ways to attempt to -fetch a key. (More precisely, it is a list of functions to be called, -each of which will attempt to fetch the key.) The methods will be tried -in the order listed. The default list is: - -@lisp -'(mc-pgp-fetch-from-keyrings - mc-pgp-fetch-from-finger - mc-pgp-fetch-from-http) -@end lisp - -For a description of these functions, see the following sections. - -If you are not directly on the Internet, you probably want to obtain a -copy of the global public key ring from the keyservers, install it -somewhere under the name @file{public-keys.pgp}, and do: - -@lisp -(setq mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings)) -(setq mc-pgp-fetch-keyring-list '("/blah/blah/blah/public-keys.pgp")) -@end lisp - -This will allow you to fetch keys from your local copy of the global key -ring instead of sending requests to the key servers directly -(@pxref{Keyring Fetch}). Alternately, if your organization has a proxy -HTTP server, you can configure Mailcrypt to use that. See @ref{HTTP -Fetch}. - -If the key is found, you will be shown the result of running PGP on it -locally. This allows you to inspect the signatures on the key -@emph{relative to your own keyring} before you consent to having it -added. @strong{Inspect the signatures carefully!} Key distribution is -often the Achilles' heel of public key protocols. If you blindly use -keys obtained from the key servers, you are asking for trouble. - -All of the methods use @code{mc-pgp-fetch-timeout} as a timeout in -seconds; the default value is 30. - -@menu -* Keyring Fetch:: Fetching from one or more other - keyrings on the local system. -* Finger Fetch:: Fetching a key through finger. -* HTTP Fetch:: Fetching a key off of the Web. -@end menu - -@node Keyring Fetch, Finger Fetch, Key Fetching, Key Fetching -@section Keyring Fetch - -@findex mc-pgp-fetch-from-keyrings -The function @code{mc-pgp-fetch-from-keyrings} will attempt to fetch a -key from a set of keyrings on the locally accessible filesystem. This -is useful if your organization maintains a large common public keyring -whose entire contents you do not wish to duplicate on your own ring. It -is also useful if you download a copy of the global public ring from the -key servers (@pxref{Key Servers}). - -@vindex mc-pgp-fetch-keyring-list -The variable @code{mc-pgp-fetch-keyring-list} controls this behavior. -It is a list of file names of public keyrings which this function will -search, in order, when seeking a key. The default value is @code{nil}, -meaning this search will always fail. - -@node Finger Fetch, HTTP Fetch, Keyring Fetch, Key Fetching -@section Finger Fetch - -@findex mc-pgp-fetch-from-finger -The function @code{mc-pgp-fetch-from-finger} will attempt to fetch a key -by fingering an address and parsing the output for a PGP public key -block. - -@node HTTP Fetch, , Finger Fetch, Key Fetching -@section HTTP Fetch - -@findex mc-pgp-fetch-from-http -The function @code{mc-pgp-fetch-from-http} will attempt to fetch a key -by connecting to a key server (@pxref{Key Servers}) which has a World -Wide Web interface. - -@vindex mc-pgp-keyserver-address -@vindex mc-pgp-keyserver-port -@vindex mc-pgp-keyserver-url-template -The variables @code{mc-pgp-keyserver-address}, -@code{mc-pgp-keyserver-port}, and @code{mc-pgp-keyserver-url-template} -control the fetching process. The default is to use Brian LaMacchia's -key server at MIT. If this default should stop working, or if you want -to help with network congestion and machine load, you can choose a -different server. As of this writing, any of the following sequences of -Emacs Lisp in your @file{.emacs} file will work; choose one: - -@lisp -;; Key server at MIT (Massachusetts, USA) -;; This is the default; these lines are only for reference -;(setq mc-pgp-keyserver-address "pgp.ai.mit.edu") -;(setq mc-pgp-keyserver-port 80) -;(setq mc-pgp-keyserver-url-template -; "/htbin/pks-extract-key.pl?op=get&search=%s") -@end lisp - -@lisp -;; Key server at UPC (Barcelona, Spain) -(setq mc-pgp-keyserver-address "goliat.upc.es") -(setq mc-pgp-keyserver-port 80) -(setq mc-pgp-keyserver-url-template - "/cgi-bin/pks-extract-key.pl?op=get&search=%s") -@end lisp - -@lisp -;; Key server at Cambridge University (Cambridge, England) -(setq mc-pgp-keyserver-address "www.cl.cam.ac.uk") -(setq mc-pgp-keyserver-port 80) -(setq mc-pgp-keyserver-url-template - "/cgi-bin/pks-extract-key.pl?op=get&search=%s") -@end lisp - -@lisp -;; Key server at UIT (Tromso, Norway) -(setq mc-pgp-keyserver-address "www.service.uit.no") -(setq mc-pgp-keyserver-port 80) -(setq mc-pgp-keyserver-url-template - "/cgi-bin/pks-extract-key.pl?op=get&search=%s") -@end lisp - -@lisp -;; Key server at CMU (Pennsylvania, USA) -(setq mc-pgp-keyserver-address "gs211.sp.cs.cmu.edu") -(setq mc-pgp-keyserver-port 80) -(setq mc-pgp-keyserver-url-template "/cgi-bin/pgp-key?pgpid=%s") -@end lisp - -If your organization has a firewall, you might not be able to access the -World Wide Web directly. Your organization may have a proxy HTTP server -set up, however. In that case, you should place code like the following -in your @file{.emacs} file. You can use any of the above key servers -instead of the one at MIT, of course. - -@lisp -;; Mailcrypt configuration for accessing key server through HTTP proxy -(setq mc-pgp-keyserver-address "your.proxy.com") -(setq mc-pgp-keyserver-port 13013) ; Your proxy's port -(setq mc-pgp-keyserver-url-template - "http://pgp.ai.mit.edu/htbin/pks-extract-key.pl?op=get&search=%s") -@end lisp - -Note that fetching from a key server can be somewhat slow, so be -patient. (At least it beats the tar out of the Email interface.) - -@node Miscellaneous Configuration, Tips, Key Fetching, Top -@chapter Miscellaneous Configuration - -This chapter documents some additional Mailcrypt configuration options -which could not be naturally described elsewhere. - -@menu -* Alternate Keyring:: Specifying a different file to act - like your public keyring. -* Comment Field:: Burma - Shave -* Mode Line:: Changing that "MC-w" and "MC-r" stuff -* Key Bindings:: Which keys cause which actions. -* Nonstandard Paths:: Useful if your PGP installation is weird. -@end menu - -@node Alternate Keyring, Comment Field, Miscellaneous Configuration, Miscellaneous Configuration -@section Alternate Keyring - -By default, Mailcrypt will use the same public keyring that PGP would -use if executed from the shell. - -@vindex mc-pgp-alternate-keyring -You can cause Mailcrypt to use a specific public keyring by setting the -variable @code{mc-pgp-alternate-keyring}. If this variable is set, -Mailcrypt will use that keyring for all functions which would otherwise -have used the default. This includes adding keys, extracting keys, -verifying signatures, and encrypting messages. - -This feature might be useful if you maintain multiple keyrings; you can -switch between them by setting this variable. Depending on your tastes, -you might want to configure fetching from a keyring as well -(@pxref{Keyring Fetch}). - -@node Comment Field, Mode Line, Alternate Keyring, Miscellaneous Configuration -@section Comment Field - -By default, Mailcrypt will supply a "comment" option to PGP, resulting -in output which looks something like this: - -@example ------ BEGIN PGP FOOBAR ----- -Version: 2.6.3 -Comment: Processed by Mailcrypt @value{VERSION}, an Emacs/PGP interface - -@dots{} ------ END PGP FOOBAR ----- -@end example - -@vindex mc-pgp-comment -To change the comment to one of your own, set the variable -@code{mc-pgp-comment}. Set it to @code{nil} to use PGP's default, which -is probably either no comment or something defined in @file{config.txt}. - -@node Mode Line, Key Bindings, Comment Field, Miscellaneous Configuration -@section Mode Line - -@code{mc-read-mode} and @code{mc-write-mode} will each indicate they are -active by placing the string @samp{MC-r} or @samp{MC-w} in the mode -line, respectively. - -@vindex mc-read-mode-string -@vindex mc-write-mode-string -You can change these strings by setting the variables -@code{mc-read-mode-string} and @code{mc-write-mode-string}. So, for -example, to get rid of the mode indicators entirely, you might put the -following lines into your @file{.emacs} file: - -@lisp -(setq mc-read-mode-string "") -(setq mc-write-mode-string "") -@end lisp - -@node Key Bindings, Nonstandard Paths, Mode Line, Miscellaneous Configuration -@section Key Bindings - -@vindex mc-read-mode-map -@vindex mc-write-mode-map -The Mailcrypt key bindings are defined by the keymaps -@code{mc-read-mode-map} and @code{mc-write-mode-map}. To change the key -bindings, you just need to set these variables in your @file{.emacs} -file. - -For example, if you wanted @kbd{C-c C-m} to be the Mailcrypt prefix -(instead of @kbd{C-c /}) in @code{mc-read-mode}, you would put the -following code in your @file{.emacs} file: - -@lisp -(setq mc-read-mode-map (make-sparse-keymap)) -(define-key mc-read-mode-map "\C-c\C-mf" 'mc-deactivate-passwd) -(define-key mc-read-mode-map "\C-c\C-md" 'mc-decrypt) -(define-key mc-read-mode-map "\C-c\C-mv" 'mc-verify) -(define-key mc-read-mode-map "\C-c\C-ma" 'mc-snarf) -(define-key mc-read-mode-map "\C-c\C-mk" 'mc-pgp-fetch-key) -@end lisp - -For more information on Emacs key bindings, see @ref{Key Bindings, , -Customizing Key Bindings, emacs, The GNU Emacs Manual}. - -@node Nonstandard Paths, , Key Bindings, Miscellaneous Configuration -@section Nonstandard Paths - -The information in this section should be unnecessary, but is provided -"just in case". - -@vindex mc-pgp-path -Mailcrypt will look for the PGP executable in your standard search path -under the name @file{pgp}. To use a different name (or to provide a -complete path), set the variable @code{mc-pgp-path}. - -In order to keep your identities straight, Mailcrypt needs to know where -your secret keyring resides. - -Mailcrypt figures this out heuristically by assuming that the file -@file{secring.pgp} is in the same directory as your public key ring. It -determines the location of the latter by doing a dry run of PGP with -@samp{+verbose=1} and parsing the output. - -@vindex mc-pgp-keydir -If this heuristic is failing for you, you can manually tell Mailcrypt -where your secret key ring is by setting the variable -@code{mc-pgp-keydir}, like this: - -@lisp -(setq mc-pgp-keydir "/users/patl/.pgp/") -@end lisp - -Note that the trailing slash is @emph{required}. - -If the heuristic fails, please report it as a bug (@pxref{Credits}). - -Note that if you have changed the default location of your secret -keyring, Mailcrypt will be unable to locate it. You can work around -this by either setting @code{mc-pgp-keydir}, or by making a symbolic -link to your secret keyring from @file{secring.pgp} in your default -public keyring directory. - -@node Tips, Limitations, Miscellaneous Configuration, Top -@chapter Tips - -Here are some random tips. - -@itemize @bullet - -@item -PGP provides quite good security when used correctly. You are far more -likely to use it correctly if you have read the directions. Read the -@cite{PGP User's Guide}! - -@item -60 seconds is a relatively safe but somewhat inconvenient value for -@code{mc-passwd-timeout}. If your paranoia permits, consider increasing -it to five or ten minutes (@pxref{Passphrase Cache}). - -@item -If Mailcrypt ever does something you wish it had not, @emph{DON'T -PANIC}. Just use the normal Emacs undo command, @kbd{M-x undo} or -@kbd{C-x u}, to restore your buffer (@pxref{Undo, Emacs Undo, Undoing -Changes, emacs, The GNU Emacs Manual}). Mailcrypt keeps almost no state -except what you see in your buffer, so any action can be undone this -way. - -@item -All Mailcrypt operations place PGP's output in the @code{*MailCrypt*} -buffer. Check it occasionally for status and warning messages. - -@item -Add yourself to the Mailcrypt announcements mailing list (@pxref{Mailing -List}). That way you can find out about new versions of Mailcrypt -automatically, and we can enjoy the feeling that people are actually -using our package. - -@end itemize - -@node Limitations, References, Tips, Top -@chapter Limitations - -Mailcrypt is a powerful program, but it is not a complete PGP interface. -Perhaps some future version will be; in the meantime, you will need to -use the command-line interface for some operations. Things which the -current version does not support include: - -@table @emph - -@item Complete Key Management -Mailcrypt's key management support is limited to adding and extracting -keys from keyrings. It does not support key generation, key removal, -key revocation, ID and trust parameter editing, or key signing. It also -ignores PGP's warnings when you use a key which is not fully certified. -(Of course, you can see these warnings by viewing the @code{*MailCrypt*} -buffer; see @ref{Tips}.) - -@item Encryption with Conventional Cryptography -Mailcrypt supports decryption but not encryption with "conventional" -(i.e., non-public key) cryptography. - -@item Detached Signatures -Mailcrypt does not support the creation nor the verification of detached -signatures. - -@item "For your eyes only" Decryption -Mailcrypt will be unable to decrypt a file which was encrypted with the -"for your eyes only" (@samp{-m}) option. This is actually a bug in PGP, -which provides no portable way to avoid its paging behavior. - -@end table - -@node References, Credits, Limitations, Top -@chapter References - -This chapter contains information and pointers to information about -topics related to PGP and Mailcrypt. - -@menu -* Online Resources:: Recreational reading with a purpose. -* Key Servers:: Keepers of the Global Keyring. -* Mailing List:: Staying informed while pumping the - authors' egos. -* Politics:: Anarcho-foobarism. -@end menu - -@node Online Resources, Key Servers, References, References -@section Online Resources - -@table @file - -@item http://world.std.com/~franl/crypto.html -"Cryptography, PGP, and Your Privacy", by Fran Litterio. This page is -simply excellent. It makes all the other References in this chapter -redundant, but we will include them anyway for redundancy. - -@item http://web.mit.edu/network/pgp.html -MIT is the canonical distribution site for PGP; this is the announcement -page. - -@item ftp://rtfm.mit.edu/pub/usenet/alt.security.pgp/ -This is an archive site for the @file{alt.security.pgp} FAQ lists. - -@item news:alt.security.pgp -The @file{alt.security.pgp} newsgroup is a good place to go for -discussion about PGP, as well as any topic which any fool anywhere ever -thinks is related to PGP. It is also a good last resort for getting -answers to questions, but please read the FAQ lists first. - -@item http://pgp.ai.mit.edu/~bal/pks-toplev.html -Brian LaMacchia (bal@@zurich.ai.mit.edu) has put together a World Wide -Web interface to the public key servers (@pxref{Key Servers}). -Mailcrypt uses this interface by default when attempting to fetch keys -via HTTP (@pxref{HTTP Fetch}); most people get to his interface through -this page. - -@item ftp://ftp.csua.berkeley.edu/pub/cypherpunks/Home.html -The Cypherpunks are dedicated to taking proactive measures to ensure -privacy in the digital age. They wrote the software for, and operate -many of, the anonymous remailers currently in existence. - -@item http://www.cs.berkeley.edu/~raph/ -Raph Levien actively maintains a remailer list which Mailcrypt knows how -to parse. If you are impressed by how easy it is to configure -Mailcrypt's remailer functions, Raph is the one to thank. Raph's page -also has many useful links. - -@item http://www.obscura.com/~loki/ -Lance Cottrell is the author of Mixmaster. His home page is the -canonical source for information on Mixmaster and is a good source for -PGP pointers in general. - -@end table - -@node Key Servers, Mailing List, Online Resources, References -@section Key Servers - -@dfn{Key servers} are machines with a publicly accessible interface to -an enormous global public keyring. Anyone may add keys to or query this -keyring. Each key server holds a complete copy of the global keyring, -and they arrange to keep one another informed of additions they receive. - -This means you can tell any key server to add your public key to the -global keyring, and all of the other servers will know about it within a -day or so. Then anyone will be able to query any key server to obtain -your public key. - -To add your key to the keyservers, send an Email message to -@code{pgp-public-keys@@pgp.ai.mit.edu} with a subject line of @samp{ADD} -and a body containing your public key block. With Mailcrypt installed, -you can just type @kbd{C-c / x} to insert your public key block -(@pxref{Inserting Keys}) into the body of the message. - -For help with the Email interface to the key servers, send a message -with a subject line of @samp{HELP}. For a World Wide Web interface to -the key servers, see Brian LaMacchia's home page at -@file{http://www-swiss.ai.mit.edu/~bal/}. - -Some other key servers include: - -@itemize @bullet - -@item -pgp-public-keys@@jpunix.com - -@item -pgp-public-keys@@kub.nl - -@item -pgp-public-keys@@uit.no - -@item -pgp-public-keys@@pgp.ox.ac.uk - -@end itemize - -For a complete list, consult any good online repository of PGP -information (@pxref{Online Resources}). - -It is strongly recommended that you submit your key to the key servers, -since many humans and programs (including Mailcrypt) may look for it -there. Besides, it takes mere seconds and the pain passes quickly. - -@node Mailing List, Politics, Key Servers, References -@section Mailing List -If you would like to automatically receive information about new -releases of Mailcrypt, send Email to -@samp{mc-announce-request@@cag.lcs.mit.edu} asking to be placed on the -@samp{mc-announce} mailing list. The mailing list is maintained -manually, so please be patient. - -The @samp{mc-announce} list is reserved for announcements of new -Mailcrypt versions, so it has extremely low volume. We encourage you to -add yourself so we can get a rough idea of how many people are using -our package. - -@node Politics, , Mailing List, References -@section Politics - -Cryptography in general, PGP in particular, and free software are -politically somewhat controversial topics. Heck, in the U.S. Congress, -freedom of speech is a controversial topic. Anyway, here are some -organizations you should definitely watch and preferably send lots of -money. - -@table @emph - -@item The Electronic Frontier Foundation -The EFF (@file{http://www.eff.org/}) works to protect civil liberties in -cyberspace. They also maintain an impressive collection of on-line -resources. If you like Mailcrypt so much that you wish you had paid for -it, this is the number one place we would want to see your money go. -The EFF newsgroups, @file{comp.org.eff.news} and -@file{comp.org.eff.talk}, are required reading for the well-informed. - -@item The League for Programming Freedom -The LPF (@file{http://www.lpf.org/}) works to fight software patents, -which threaten to make free software like Mailcrypt impossible. - -@item The Center for Democracy and Technology -The CDT (@file{http://www.cdt.org/}) has essentially the same goals as -the EFF, but is more of a lobbying group. - -@end table - -Mailcrypt's remailer support was inspired by the Communications Decency -Act of 1995 (see @file{http://www.cdt.org/cda.html}) and by the -International "Church" of Scientology (see -@file{http://www.mit.edu:8001/people/rnewman/scientology/}). - -@node Credits, Index, References, Top -@chapter Credits -Mailcrypt was written by Jin Choi (jin@@atype.com) and Pat LoPresti -(patl@@lcs.mit.edu). Please send us your bug reports and comments. -Also see @ref{Mailing List}. - -This documentation was mostly written by Pat LoPresti, but borrows -heavily from an earlier version by Hal Abelson (hal@@mit.edu). - -Mailcrypt would not be as robust nor as featureful if it were not for -our outstanding set of Beta testers: - -@itemize @bullet - -@item -Samuel Tardieu <sam@@inf.enst.fr> -@item -Richard Stanton <stanton@@haas.berkeley.edu> -@item -Peter Arius <arius@@immd2.informatik.uni-erlangen.de> -@item -Tomaz Borstnar <tomaz@@cmir.arnes.si> -@item -Barry Brumitt <belboz@@frc2.frc.ri.cmu.edu> -@item -Steffen Zahn <Steffen.Zahn%robinie@@sunserv.sie.siemens.co.at> -@item -Mike Campbell <mcampbel@@offenbach.sbi.com> -@item -Mark Baushke <mdb@@cisco.com> -@item -Mike Long <mike.long@@analog.com> - -@end itemize - -@node Index, , Credits, Top -@unnumbered Index - -This index has an entry for every key sequence, function, and variable -documented in this manual. - -@printindex cp - -@contents -@bye - -@c End:
--- a/man/psgml-api.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,933 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename ../info/psgml-api.info -@settitle psgml-api -@c @setchapternewpage odd -@c %**end of header -@c $Id: psgml-api.texi,v 1.1.1.1 1996/12/18 22:43:47 steve Exp $ - -@ifinfo -@format -START-INFO-DIR-ENTRY -* PSGML-API: (psgml-api). PSGML, the API documentation. -END-INFO-DIR-ENTRY -@end format -@end ifinfo - -@ifinfo -Documentation for PSGML, a major mode for SGML. - -Copyright 1994 Lennart Staflin - -Permission is granted to make and distribute verbatim -copies of this manual provided the copyright notice and -this permission notice are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX -and print the results, provided the printed document -carries a copying permission notice identical to this -one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified -versions of this manual under the conditions for -verbatim copying, and provided that the entire -resulting derived work is distributed under the terms -of a permission notice identical to this one. - -Permission is granted to copy and distribute -translations of this manual into another language, -under the above conditions for modified versions, -except that this permission notice may be stated in a -translation approved by the Free Software Foundation. - -@end ifinfo - -@titlepage - -@title Internals of PSGML -@author Lennart Staflin - -@c The following two commands -@c start the copyright page. -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1994 Lennart Staflin - -@c Published by ... - -Permission is granted to make and distribute verbatim -copies of this manual provided the copyright notice and -this permission notice are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX -and print the results, provided the printed document -carries a copying permission notice identical to this -one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified -versions of this manual under the conditions for -verbatim copying, and provided that the entire -resulting derived work is distributed under the terms -of a permission notice identical to this one. - -Permission is granted to copy and distribute -translations of this manual into another language, -under the above conditions for modified versions, -except that this permission notice may be stated in a -translation approved by the Free Software Foundation. -@end titlepage - -@node Top, Types, (dir), (dir) -@comment node-name, next, previous, up -@ifinfo -@top PSGML Internals -@end ifinfo - -@menu -* Types:: Types and operations -* Hooks:: Hooks -* Implementation:: Implementation notes -* Index:: Index - - --- The Detailed Node Listing --- - -Types and operations - -* element:: The element structure -* attribute:: Attribute Types -* parser state:: Parser state -* DTD:: DTD -* entities:: Entities -@end menu - -@node Types, Hooks, Top, Top -@comment node-name, next, previous, up -@chapter Types and operations - -NOTE: -Names of element types, attributes and entities should be treated as far -as possible as a real type. In versions prior to 1.0 names are -represented by lisp symbols but in 1.0 they are strings. - -Perhaps I should make a @file{psgml-api.el} that defines some functions -to deal with names. Then it would be possible to write code that works -in both 0.4 and 1.0. - - -@menu -* element:: The element structure -* attribute:: Attribute Types -* parser state:: Parser state -* DTD:: DTD -* entities:: Entities -@end menu - -@node element, attribute, Types, Types -@comment node-name, next, previous, up -@section The element structure - -@deftp {Data type} element -The basic data type representing the element structure is the Element (this -happens to be a node in the parse tree). -@end deftp - - -@subsection Mapping buffer positions to elements - -@defun sgml-find-context-of pos -Return the element current at buffer position @var{pos}. If @var{pos} -is in markup, @code{sgml-markup-type} will be a symbol identifying the -markup type. It will be @code{nil} if @var{pos} is outside markup. -@end defun - -@defun sgml-find-element-of pos -Return the element containing the character at buffer position @var{pos}. -@end defun - - -@subsection Functions operating on elements - -@defun sgml-element-name element -Returns the name of the element. (obsolete) -@end defun - -@defun sgml-element-gi element -Return the general identifier (string) of @var{element}. -@end defun - -@defun sgml-element-level element -Returns the level of @var{element} in the element structure. The -document element is level 1. -@end defun - -@subsubsection Structure - -@defun sgml-top-element -Return the document element. -@end defun - -@defun sgml-off-top-p element -True if @var{element} is the pseudo element above the document element. -@end defun - -These functions return other related elements, or possibly @code{nil}. - -@defun sgml-element-content element -First element in content of @var{element}, or nil. -@end defun - -@defun sgml-element-next element -Next sibling of @var{element}. To loop thru all sub elements of an -element, @code{el}, You could do like this: - -@lisp -(let ((c (sgml-element-content el))) - (while c - <<Do something with c>> - (setq c (sgml-element-next c)))) -@end lisp -@end defun - -@defun sgml-element-parent element -Parent of @var{element}. -@end defun - - -@subsubsection Tags - -@defun sgml-element-stag-optional element -Return true if the start-tag of @var{element} is omissible. -@end defun - -@defun sgml-element-etag-optional element -Return true if the end-tag of @var{element} is omissible. -@end defun - -@defun sgml-element-stag-len element -Return the length of the start-tag of @var{element}. If the start-tag -has been omitted the length is 0. -@end defun - -@defun sgml-element-etag-len element -Return the length of the end-tag of @var{element}. If the end-tag -has been omitted the length is 0. -@end defun - -@defun sgml-element-net-enabled element -Return true, if @var{element} or some parent of the element has null end -tag (NET) enabled. Return @code{t}, if it is @var{element} that has NET -enabled. -@end defun - - -@subsubsection Positions - -These functions relates an element to positions in the buffer. - -@defun sgml-element-start element -Position of start of @var{element}. -@end defun - -@defun sgml-element-end element -Position after @var{element}. -@end defun - -@defun sgml-element-stag-end element -Position after start-tag of @var{element}. -@end defun - -@defun sgml-element-etag-start element -Position before end-tag of @var{element}. -@end defun - - -@subsubsection Attributes - -@defun sgml-element-attlist element -Return the attribute declaration list for @var{element}. -@end defun - -@defun sgml-element-attribute-specification-list element -Return the attribute specification list for @var{element}. -@end defun - -@defun sgml-element-attval element attribute -Return the value of the @var{attribute} in @var{element}, string or nil. -@end defun - - -@subsubsection Misc technical - - -@defun sgml-element-data-p element -True if @var{element} can contain data characters. -@end defun - -@defun sgml-element-mixed element -True if @var{element} has mixed content. -@end defun - -@defun sgml-element-eltype element -@end defun - -@defun sgml-element-empty element -True if @var{element} is empty. -@end defun - -@defun sgml-element-excludes element -@end defun - -@defun sgml-element-includes element -@end defun - -@defun sgml-element-model element -Declared content or content model of @var{element}. -@end defun - -@defun sgml-element-context-string element -Return string describing context of @var{element}. -@end defun - -@c ---------------------------------------------------------------------- -@node attribute, parser state, element, Types -@comment node-name, next, previous, up -@section Attribute Types - -Basic types for attributes are names and values. (See note about names -in @ref{Types}.) And attribute values (attval) by lisp strings. - - -@subsection Attribute Declaration List Type - -@deftp {Data type} attlist attdecl* -This is the result of the ATTLIST declarations in the DTD. -All attribute declarations for an element is the elements -attlist. -@end deftp - -@defun sgml-lookup-attdecl name attlist -Return attribute declaration (attdecl) for attribute @var{name} in -attribute declaration list @var{attlist}. -@end defun - -@defun sgml-attribute-with-declared-value attlist declared-value -Find the first attribute in @var{attlist} that has @var{declared-value}. -@end defun - - -@subsection Attribute Declaration Type - -@deftp {Data type} attdecl name declared-value default-value -This is the representation of an individual attribute declaration -contained in an ATTLIST declaration. -@end deftp - -@defun sgml-make-attdecl name declared-value default-value -Produces an attdecl. -@end defun - -@defun sgml-attdecl-name attdecl -Returns the name of an attribute declaration. -@end defun - -@defun sgml-attdecl-declared-value attdecl -Returns the declared-value of attribute declaration @var{attdecl}. -@end defun - -@defun sgml-attdecl-default-value: attdecl -Returns the default-value of attribute declaration @var{attdecl}. -@end defun - - -@subsection Declared Value Type - -@deftp {Data type} declared-value (token-group | notation | simple) -A declared value of an SGML attribute can be of different kinds. If the -declared value is a token group there is an associated list of name -tokens. For notation there is also a list of associated names, the -allowed notation names. The other declared values are represented by the -type name as a lisp symbol. -@c token-group = nametoken+ -@c notation = nametoken+ -@c simple = symbol -@end deftp - -@defun sgml-declared-value-token-group declared-value -Return the name token group for the @var{declared-value}. -This applies to name token groups. For other declared values nil is -returned. -@end defun - -@defun sgml-declared-value-notation declared-value -Return the list of notation names for the @var{declared-value}. -This applies to notation declared value. For other declared values -nil is returned. -@end defun - - -@subsection Default Value Type - -@deftp {Data type} default-value (required | implied | conref | specified ) -@c implied, conref = constant symbol -@c specified = (fixed | normal) -@c fixed, normal = attval -There are several kinds of default values. The @var{required}, -@var{implied}, and @var{conref} has no associated information. The -@var{specified} have an associated attribute value and can be either -@code{fixed} or @code{normal}. -@end deftp - -@defun sgml-make-default-value type &optional attval -@end defun - -@defun sgml-default-value-attval default-value -Return the actual default value of the declared @var{default-value}. -The actual value is a string. Return @code{nil} if no actual value. -@end defun - -@defun sgml-default-value-type-p type default-value -Return true if @var{default-value} is of @var{type}. Where @var{type} -is a symbol, one of @code{required}, @code{implied}, @code{conref}, or -@code{fixed}. -@end defun - - -@subsection Attribute Specification Type - -@deftp {Data type} attspec name attval -This is the result of parsing an attribute specification. -@end deftp - -@defun sgml-make-attspec name attval -Create an attspec from @var{name} and @var{attval}. -Special case, if @var{attval} is @code{nil} this is an implied attribute. -@end defun - -@defun sgml-attspec-name attspec -Return the name of the attribute specified by @var{attspec}. -@end defun - -@defun sgml-attspec-attval attspec -Return the value (attval) of attribute specification @var{attspec}. -If @var{attspec} is @code{nil}, @code{nil} is returned. -@end defun - - -@subsection Attribute Specification List Type - -@deftp {Data type} asl attspec* -This is the result of parsing an attribute specification list. -@end deftp - -@defun sgml-lookup-attspec name asl -Return the attribute specification for attribute with @var{name} in the -attribute specification list @var{asl}. If the attribute is unspecified -@code{nil} is returned. -@end defun - - - -@c ------------------------------------------------------------------ -@node parser state, DTD, attribute, Types -@comment node-name, next, previous, up -@section Parser state - -The state of the parser that needs to be kept between commands are -stored in a buffer local variable. Some global variables are -initialised from this variable when parsing starts. - -@defvar sgml-buffer-parse-state -The state of the parser that is kept between commands. The value of -this variable is of type pstate. -@end defvar - -@deftp {Data type} pstate -The parser state. -@end deftp - -@defun sgml-pstate-dtd pstate -The document type information (dtd) for the parser. -@end defun - - -@c ------------------------------------------------------------------ -@node DTD, entities, parser state, Types -@comment node-name, next, previous, up -@section DTD - -@deftp {Data type} dtd -Represents what PSGML knows about the DTD. -@end deftp - -@defun sgml-dtd-doctype dtd -The document type name. -@end defun - -@defun sgml-dtd-eltypes dtd -The table of element types. -@end defun - -@defun sgml-dtd-entities dtd -The table of declared general entities (entity-table). -@end defun - -@defun sgml-dtd-parameters dtd -The table of declared parameter entities (entity-table). -@end defun - -@defun sgml-dtd-shortmaps dtd -The list of short reference maps. -@end defun - -@defun sgml-dtd-notations dtd -Not yet implemented. -@end defun - - - -@c ------------------------------------------------------------------ -@node entities, , DTD, Types -@comment node-name, next, previous, up -@section Entities - -@deftp {Data type} entity -An entity has the following properties: - -@table @var -@item name -The name of the entity (a string). This is either the name of a -declared entity (general or parameter) or the doctype name if it is the -implicit entity referred to by the doctype declaration. - -@item type -This is a symbol. It is @code{text} if it is a text entity, other -values are @code{cdata}, @code{ndata}, @code{sdata}, @code{sgml} or -@code{dtd}. - -@item text -This is the text of the entity, either a string or an external -identifier. -@end table -@end deftp - -Operations on entities - -@defun sgml-make-entity name type text -Create an entity. -@end defun - -@defun sgml-entity-name entity -The name of the entity. -@end defun - -@defun sgml-entity-type entity -The type of the entity. -@end defun - -@defun sgml-entity-text entity -The text of the entity. -@end defun - -@defun sgml-entity-insert-text entity -Insert the text of the entity into the current buffer at point. -@end defun - -@defun sgml-entity-data-p entity -True if @var{entity} is a data entity, that is not of type @code{text}. -@end defun - - -@deftp {Data type} entity-table -A table of entities that can be referenced by entity name. -@end deftp - -@defun sgml-lookup-entity name entity-table -The entity with named @var{name} in the table @var{entity-table}. If no -such entity exists, @code{nil} is returned. -@end defun - -@defun sgml-entity-declare name entity-table type text -Create an entity from @var{name}, @var{type} and @var{text}; and enter -the entity into the table @var{entity-table}. -@end defun - -@defun sgml-entity-completion-table entity-table -Make a completion table from the @var{entity-table}. -@end defun - -@defun sgml-map-entities fn entity-table &optional collect -Apply the function @var{fn} to all entities in @var{entity-table}. If -@var{collect} is @code{t}, the results of the applications are collected -in a list and returned. -@end defun - - - -@c ------------------------------------------------------------------ -@node Hooks, Implementation, Types, Top -@comment node-name, next, previous, up -@chapter Hooks - -@defvar sgml-open-element-hook -The hook run by @code{sgml-open-element}. -Theses functions are called with two arguments, the first argument is -the opened element and the second argument is the attribute specification -list. It is probably best not to refer to the content or the end-tag of -the element. -@end defvar - -@defvar sgml-close-element-hook -The hook run by @code{sgml-close-element}. These functions are invoked -with @code{sgml-current-tree} bound to the element just parsed. -@end defvar - -@defvar sgml-doctype-parsed-hook -This hook is called after the doctype has been parsed. -It can be used to load any additional information into the DTD structure. -@end defvar - -@defvar sgml-sysid-resolve-functions -This variable should contain a list of functions. -Each function should take one argument, the system identifier of an entity. -If the function can handle that identifier, it should insert the text -of the entity into the current buffer at point and return t. If the -system identifier is not handled the function should return nil. -@end defvar - -@defvar sgml-doctype-parsed-hook -This hook is caled after the doctype has been parsed. -It can be used to load any additional information into the DTD structure. -@end defvar - -@defvar sgml-close-element-hook -@c *** -The hook run by `sgml-close-element'. -These functions are invoked with `sgml-current-tree' bound to the -element just parsed. -@end defvar - -*** sgml-new-attribute-list-function -This hook is run when a new element is inserted to construct the -attribute specification list. The default function prompts for the -required attributes. - - -@c ------------------------------------------------------------------ -@node Implementation, Index, Hooks, Top -@comment node-name, next, previous, up -@chapter Implementation notes - -@section Data Types and Operations - -@subsection Element Type - -@deftp {Data type} eltype -Data type representing the information about an element type. An -@code{eltype} has information from @samp{ELEMENT} and @samp{ATTLIST} -declarations. It can also store data for the application. -@end deftp - -The element types are symbols in a special oblist. The oblist is the -table of element types. The symbols name is the GI, its value is used -to store three flags and the function definition holds the content -model. Other information about the element type is stored on the -property list. - -@defun sgml-eltype-name et -The name (a string) of the element type @var{et}. -@end defun - -@defun sgml-eltype-appdata et prop -Get application data from element type @var{et} with name @var{prop}. -@var{prop} should be a symbol, reserved names are: flags, model, attlist, -includes, excludes, conref-regexp, mixed, stag-optional, etag-optional. - -This function can be used as a place in @code{setf}, @code{push} and -other functions from the CL library. -@end defun - -@defun sgml-eltype-all-miscdata eltype -A list of all data properties for eltype except for flags, model, -includes and excludes. This function filters the property list of -@var{eltype}. Used when saving the parsed DTD. -@end defun - -@defun sgml-eltype-set-all-miscdata eltype miscdata -Append the @var{miscdata} data properties to the properties of -@var{eltype}. -@end defun - -@defun sgml-eltype-attlist et -The attribute specification list for the element type @var{et}. -@end defun - -@defun sgml-eltype-completion-table eltypes -Make a completion table from a list, @var{eltypes}, of element types. -@end defun - -@defun sgml-eltype-stag-optional et -True if the element type @var{et} has optional start-tag. -@end defun - -@defun sgml-eltype-etag-optional et -True if the element type @var{et} has optional end-tag. -@end defun - -@defun sgml-eltype-excludes et -The list of excluded element types for element type @var{et}. -@end defun - -@defun sgml-eltype-includes et -The list of included element types for element type @var{et}. -@end defun - -@defun sgml-eltype-flags et -Contains three flags as a number. The flags are stag-optional, -etag-optional and mixed. -@end defun - -@defun sgml-eltype-mixed et -True if element type @var{et} has mixed content. -@end defun - -@defun sgml-eltype-model et -The content model of element type @var{et}. The content model is either -the start state in the DFA for the content model or a symbol identifying -a declared content. -@end defun - -@defun sgml-eltype-shortmap et -The name of the shortmap associated with element type @var{et}. This -can also be the symbol @code{empty} (if declared with a @samp{<!USEMAP -gi #EMPTY>} or @code{nil} (if no associated map). -@end defun - - -@defun sgml-eltype-token et -Return a token for the element type @var{et}. -@end defun - -@defun sgml-eltypes-in-state state tree -List of element types valid in @var{state} and @var{tree}. -@end defun - - -@subsection DTD - -The DTD data type is realised as a lisp vector using @code{defstruct}. - -There are two additional fields for internal use: dependencies and -merged. - -@defun sgml-dtd-dependencies dtd -The list of files used to create this DTD. -@end defun - -@defun sgml-dtd-merged dtd -The pair (@var{file} . @var{merged-dtd}), if the DTD has had a -precompiled dtd merged into it. @var{File} is the file containing the -compiled DTD and @var{merged-dtd} is the DTD loaded from that file. -@end defun - - -@subsection Element and Tree - -@deftp {Data Type} tree -This is the data type for the nodes in the tree build by the parser. -@end deftp - -The tree nodes are represented as lisp vectors, using @code{defstruct} -to define basic operations. - -The Element data type is a view of the tree built by the parser. - - -@section Parsing model - -PSGML uses finite state machines and a stack to parse SGML. Every -element type has an associated DFA (deterministic finite automaton). -This DFA is constructed from the content model. - -SGML restricts the allowed content models in such a way that it is -easy to directly construct a DFA. - -To be able to determine when a start-tag can be omitted the DFA need to -contain some more information than the traditional DFA. In PSGML a DFA -has a set of states and two sets of edges. The edges are associated -with tokens (corresponding to SGML's primitive content tokens). I call -these moves. One set of moves, the @dfn{optional moves}, represents -optional tokens. I call the other set @dfn{required moves}. The -correspondence to SGML definitions are: if there is precisely one -required move from one state, then the associated token is required. -A state is final if there is not required move from that state. - -The SGML construct @samp{(...&...&...)} (@dfn{AND-group}) is another -problem. There is a simple translation to sequence- and or-connectors. -For example @samp{(a & b & c)} is can be translated to: - -@example -((a, b, c) | (a, c, b) | - (b, a, c) | (b, c, a) | - (c, a, b) | (c, b, a)) -@end example - -But this grows too fast to be of direct practical use. PSGML represents -an AND-group with one DFA for every (SGML) token in the group. During -parsing of an AND-group there is a pointer to a state in one of the -group's DFAs, and a list of the DFAs for the tokens not yet satisfied. -Most of this is hidden by the primitives for the state type. The parser -only sees states in a DFA and moves. - - -@section Entity manager - -@defun sgml-push-to-entity entity &optional ref-start type -Set current buffer to a buffer containing the entity @var{entity}. -@var{entity} can also be a file name. Optional argument @var{ref-start} -should be the start point of the entity reference. Optional argument -@var{type}, overrides the entity type in entity look up. -@end defun - - -@defun sgml-pop-entity -Should be called after a @code{sgml-push-to-entity} (or similar). -Restore the current buffer to the buffer that was current when the push -to this buffer was made. -@end defun - -@defun sgml-push-to-string string -Create an entity from @var{string} and push it on the top of the entity -stack. After this the current buffer will be a scratch buffer containing -the text of the new entity with point at the first character. - -Use @code{sgml-pop-entity} to exit from this buffer. -@end defun - - -@c @section Lexical - -@section Parser functions - -@defun sgml-need-dtd -This makes sure that the buffer has a DTD and set global variables -needed by parsing routines. One global variable is @code{sgml-dtd-info} -which contain the DTD (type dtd). -@end defun - - -@defun sgml-parse-to goal &optional extra-cond quiet -This is the low level interface to the parser. - -Parse until (at least) @var{goal}, a buffer position. Optional argument -@var{extra-cond} should be a function. This function is called in the -parser loop, and the loop is exited if the function returns t. If third -argument @var{quit} is non-@code{nil}, no "@samp{Parsing...}" message -will be displayed. -@end defun - - -@defun sgml-reparse-buffer shortref-fun -Reparse the buffer and let @var{shortref-fun} take care of short -references. @var{shortref-fun} is called with the entity as -argument and @code{sgml-markup-start} pointing to start of short -reference and point pointing to the end. -@end defun - - -@section Saved DTD Format -@format -File = Comment, - File version, - S-expression --dependencies--, - Parameter entites, - Document type name, - Elements, - General entities, - S-expression --shortref maps--, - S-expression --notations-- - -Elements = Counted Sequence of S-expression --element type name--, - Counted Sequence of Element type description - -File version = "(sgml-saved-dtd-version 5) -" - -Comment = (";", - (CASE - OF [0-9] - OF [11-255])*, - [10] --end of line marker--)* - -Element type description = S-expression --Misc info--, - CASE - OF [0-7] --Flags 1:stag-opt, 2:etag-opt, 4:mixed--, - Content specification, - Token list --includes--, - Token list --excludes-- - OF [128] --Flag undefined element-- - -Content specification = CASE - OF [0] --cdata-- - OF [1] --rcdata-- - OF [2] --empty-- - OF [3] --any-- - OF [4] --undefined-- - OF [128] --model follows--, - Model --nodes in the finite state automaton-- - -Model = Counted Sequence of Node - -Node = CASE - OF Normal State - OF And Node - -Normal State = Moves --moves for optional tokens--, - Moves --moves for required tokens-- - -Moves = Counted Sequence of (Token, - OCTET --state #--) - -And Node = [255] --signals an AND node--, - Number --next state (node number)--, - Counted Sequence of Model --set of models-- - -Token = Number --index in list of elements-- - -Number = CASE - OF [0-250] --Small number 0--250-- - OF [251-255] --Big number, first octet--, - OCTET --Big number, second octet-- - -Token list = Counted Sequence of Token - -Parameter entites = S-expression --internal representation of parameter entities-- - -General entities = S-expression --internal representation of general entities-- - -Document type name = S-expression --name of document type as a string-- - -S-expression = OTHER - -Counted Sequence = Number_a --length of sequence--, - (ARG_1)^a - - -@end format - - - -@c ------------------------------------------------------------------ -@node Index, , Implementation, Top -@comment node-name, next, previous, up -@chapter Index - -Types -@printindex tp - -@bye
--- a/man/psgml.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1634 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename ../info/psgml.info -@settitle psgml -@c @setchapternewpage odd -@syncodeindex fn cp -@syncodeindex vr cp -@synindex ky cp -@c %**end of header -@c $Id: psgml.texi,v 1.2 1997/04/10 05:56:17 steve Exp $ - -@ifinfo -@format -START-INFO-DIR-ENTRY -* PSGML: (psgml). PSGML, a major mode for SGML documents. -END-INFO-DIR-ENTRY -@end format -@end ifinfo - -@ifinfo -Documentation for PSGML, a major mode for SGML. - -Copyright 1994, 1996 Lennart Staflin - -Permission is granted to make and distribute verbatim -copies of this manual provided the copyright notice and -this permission notice are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX -and print the results, provided the printed document -carries a copying permission notice identical to this -one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified -versions of this manual under the conditions for -verbatim copying, and provided that the entire -resulting derived work is distributed under the terms -of a permission notice identical to this one. - -Permission is granted to copy and distribute -translations of this manual into another language, -under the above conditions for modified versions, -except that this permission notice may be stated in a -translation approved by the Free Software Foundation. - -@end ifinfo - -@titlepage - -@title Editing SGML with Emacs and PSGML -@author Lennart Staflin - -@c The following two commands -@c start the copyright page. -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1994, 1996 Lennart Staflin - -@c Published by ... - -Permission is granted to make and distribute verbatim -copies of this manual provided the copyright notice and -this permission notice are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX -and print the results, provided the printed document -carries a copying permission notice identical to this -one except for the removal of this paragraph (this -paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified -versions of this manual under the conditions for -verbatim copying, and provided that the entire -resulting derived work is distributed under the terms -of a permission notice identical to this one. - -Permission is granted to copy and distribute -translations of this manual into another language, -under the above conditions for modified versions, -except that this permission notice may be stated in a -translation approved by the Free Software Foundation. -@end titlepage - -@node Top, Introduction, (dir), (dir) -@comment node-name, next, previous, up -@ifinfo -@top PSGML - -PSGML is a major mode for editing SGML documents. This is the DRAFT -documentation for PSGML version 1.0. -@end ifinfo - -@menu -* Introduction:: Introduction -* Install:: How to install PSGML -* Invoke:: How to invoke PSGML -* Entity manager:: The Entity Manager -* Validate:: Running an external SGML parser -* SGML declaration:: Using an SGML declaration -* Managing the DTD:: Specifying what DTD to use -* Edit:: Commands for editing -* Display:: Appearance of text in the buffer -* Miscellaneous options:: -* Bugs:: Reporting bugs -* Index:: -@end menu - - -@c *** section about error recovery ?? - - -@c ------------------------------------------------------------------ - -@node Introduction, Install, Top, Top -@comment node-name, next, previous, up -@chapter Introduction -@cindex CONCUR -@cindex DATATAG -@cindex LINK -@cindex RANK -@cindex SGML Declaration - -PSGML is a major mode for editing SGML documents. It works with GNU -Emacs 19.19 and later or with Lucid Emacs 19.9 and later. PSGML -contains a simple SGML parser and can work with any DTD. Functions -provided includes menus and commands for inserting tags with only the -contextually valid tags, identification of structural errors, editing of -attribute values in a separate window with information about types and -defaults, and structure based editing. - -SGML, a language for encoding the structure of a document, is an ISO -standard: ISO 8879:1986 ``Information processing -- Text and office -systems -- Standard Generalized Markup Language (SGML)''. - -A good introduction to SGML is @cite{A Gentle Introduction to SGML} -produced by Text Encoding Initiative (this is really chapter 2 of TEI -P3). This can be found on - -@display -@file{ftp://ftp.ifi.uio.no/pub/SGML/TEI/P3SG.DOC}. -@end display - -A SGML document has three major parts, in order: - -@enumerate -@item -SGML Declaration (@samp{<!SGML "ISO 8879:1986" @dots{} >}) -@item -Document Type Declaration (@samp{<!DOCTYPE @var{name} @dots{} >}) -@item -Document Element (@samp{<@var{name}> @dots{} </@var{name}>}) -@end enumerate - -The SGML declaration contains general information about character sets, -concrete syntax, and SGML features used. PSGML does not use the SGML -Declaration, it can be left out, and if included is ignored. Many SGML -systems allow the SGML declaration to be defaulted. PSGML always use -the Concrete Reference Syntax but without limitations on -lengths. Features used has to be indicated with variables (@pxref{SGML -declaration}). - -The document type declaration specifies the valid elements and entities -and how they can be nested. A document type is usually needed, but can -reside in another file (@pxref{Managing the DTD}). - -The system declaration for PSGML: -@example -SYSTEM "ISO 8879:1986" - CHARSET - BASESET "ISO 646-1983//CHARSET - International Reference Version (IRV)//ESC 2/5 4/0" - DESCSET 0 128 0 - CAPACITY PUBLIC "ISO 8879:1986//CAPACITY Reference//EN" - FEATURES - MINIMIZE DATATAG NO OMITTAG YES RANK NO SHORTTAG YES - LINK SIMPLE NO IMPLICIT NO EXPLICIT NO - OTHER CONCUR NO SUBDOC YES 1 FORMAL YES - SCOPE DOCUMENT - SYNTAX PUBLIC "ISO 8879:1986//SYNTAX Reference//EN" -@c SYNTAX PUBLIC "ISO 8879:1986//SYNTAX Core//EN" - VALIDATE - GENERAL NO MODEL NO EXCLUDE NO CAPACITY NO - NONSGML NO SGML NO FORMAL NO - SDIF PACK NO UNPACK NO -@end example - - -@c ------------------------------------------------------------------------- -@node Install, Invoke, Introduction, Top -@comment node-name, next, previous, up -@chapter Installing PSGML - -To install PSGML you first need to uncompress and unpack the source -archive. This is done with the @code{gunzip} and @code{tar} commands. - -@example -gunzip psgml-1.0.1.tar.gz; tar xf psgml-1.0.1.tar -@end example - -This should create a subdirectory to the current directory with the -source code. This directory contains a @code{configure} command (see the -file INSTALL for more information about configure). You can use the -@code{configure} command to configure the package or you can load the -file @file{psgml-maint} and execute the @code{psgml-compile-files} -command. - -Place the @file{*.el} and the @file{*.elc} files in a directory where -Emacs can find it (i.e. one of the directories in the @code{load-path} -variable, you can add a directory to this variable in your -@file{.emacs}.) - -If you use the @code{configure} approach, compile psgml with @code{make} -and the you can run @code{make install} to install it in the system -library @file{site-lisp}. The files are installed in a subdirectory -named @file{psgml}. The location of @file{site-lisp} is figured out by -@code{configure}, but you can change it in the @file{Makefile}. You -need to make sure that this subdirectory is in Emacs @code{load-path}. - - -Put the following line in your .emacs: - -@lisp -(autoload 'sgml-mode "psgml" "Major mode to edit SGML files." t ) -@end lisp - -You may also want to set up search paths for external entities, -@xref{Entity manager}. - -The @file{psgml.info} is the documentation for PSGML in the info format. -You can read this with the Emacs command @kbd{C-u C-h i}. You can also -install the file in your systems info directory and edit the -@file{dir} file to include @file{psgml.info} in the menu. - -The info file @file{psgml.info} is created from the texinfo file -@file{psgml.texi}. The texinfo file can also be used to create a hard -copy of the documentation. To do this you need the @TeX{} program and a -copy of @file{texinfo.tex}. - - - - -@c -------------------------------------------------------------------------- -@node Invoke, Entity manager, Install, Top -@comment node-name, next, previous, up -@chapter How to invoke PSGML -@cindex invoke -@cindex start up -@cindex major mode - -@findex sgml-mode -PSGML defines a major mode called @code{sgml-mode}. Files with -extensions @file{.sgml}, @file{.sgm} or @file{.dtd} will -automatically be edited in SGML mode. To edit some other file in -sgml mode, type @kbd{M-x sgml-mode @key{RET}} after finding the -file. - -If you can modify the file you can add a @dfn{Local Variables} list -(@pxref{file variables, , Local Variables in Files, emacs, The Emacs -Editor}) to the end of the file. This can make Emacs -automatically set sgml mode and user options when the file is loaded. -The simplest Local Variables list would look like: - -@example -<!-- -Local Variables: -mode: sgml -End: ---> -@end example - -You can also put a line at the top of the file to tell emacs to use sgml -mode: - -@example -<!-- -*- sgml -*- --> -@end example - -But remember that you can't have a comment before the @emph{SGML -declaration}. - - -@c ------------------------------------------------------------------------- -@node Entity manager, Validate, Invoke, Top -@comment node-name, next, previous, up -@chapter The Entity Manager -@cindex public identifier -@cindex system identifier -@cindex external identifier -@cindex entity catalog - -@c *** sgml-sysid-resolve-functions - -SGML can refer to an external file (really entity) with an -@emph{external identifier}, this is a @emph{public identifier} or a -@emph{system identifier}, or both. - -A typical public identifier looks like - -@example -PUBLIC "ISO 8879:1986//ENTITIES Added Latin 1//EN" -@end example - -@noindent -where ``ISO 8879:1986'' is the owner, ``ENTITIES'' is the text class and -``Added Latin 1'' is the text description (and ``EN'' is language). - -A system identifier looks like - -@example -SYSTEM "htmlplus.dtd" -@end example - -@noindent where ``htmlplus.dtd'' is a system-specific identifier. - -To map external identifiers to file names, PSGML first searches entity -catalog files and then search the list of file name templates in the -variable @code{sgml-public-map}. - -The catalog format is according to SGML/Opens resolution on entity -management. The catalog consists of a series of entries and comments. A -comment is delimited by @samp{--} like in a markup declaration. -The entry types recognized are described in the following table. - -@table @samp - -@item public @var{pubid} @var{file} -The @var{file} will be used for the entity text of an entity -with the public identifier @var{pubid}. - -@item entity @var{name} @var{file} -The @var{file} will be used for the entity text of an entity -with the name @var{name}. If the @var{name} starts with a @samp{%} the -rest of the name will be matched against parameter entities. - -@item doctype @var{name} @var{file} -The @var{file} will be used for the entity text of an entity -used as external subset of a document declaration with @var{name} as -document type name. - -@item sgmldecl @var{file} -Used to specify a default SGML declaration. Recognized but not used by -PSGML other than to pass to an external validation command -(@code{sgml-validate-command}). - -@end table - -When PSGML is looking for the file containing an external entity, the -following things will be tried in order: - -@enumerate - -@vindex sgml-system-identifiers-are-preferred -@item -Try the system identifier, as a file name, if there is a system -identifier and the variable @code{sgml-system-identifiers-are-preferred} -is non-@code{nil} and there is no elements containing @samp{%s} in -@code{sgml-public-map}. If the system identifier is a relative file name -it will be relative to the directory containing the defining entity. - -@item -Look thru each catalog in @code{sgml-local-catalogs} and -@code{sgml-catalog-files} in order. For each catalog look first for -entries matching the public identifier, if any. Then look for other -matching entries in the order they appear in the catalog. - -Currently an entry will be ignored if it is matching but its file is -non-existent or unreadable. (This is under reconsideration, perhaps it -should signal error instead). - -@item -Try the system identifier, if any, as a file name. -If @code{sgml-system-identifiers-are-preferred} is @code{nil} -and there is no elements containing @samp{%s} in @code{sgml-public-map}. - -@item -Try the entries in @code{sgml-public-map}. Using the catalogs are -preferred. The @code{sgml-public-map} may disappear in a future version -of PSGML (not soon though). - -@end enumerate - -The @code{sgml-public-map} variable can contain a list of file name -templates where @samp{%P} will be substituted with the whole public -identifier, owner is substituted for @samp{%O}, public text class for -@samp{%C}, and public text description for @samp{%D}. The text class -will be converted to lower case and the owner and description will be -transliterated according to the variable -@code{sgml-public-transliterations}. The templates in the list is tried -in order until an existing file is found. The @code{sgml-public-map} is -modeled after @file{sgmls} environment variable @code{SGML_PATH} and -psgml understand the following substitution characters: %%, %N, %P, %S, -%Y, %C, %L, %O, %T, and %V. The the default value of -@code{sgml-public-map} is taken from the environment variable -@code{SGML_PATH}. - -Given the public identifier above and the file name template -@samp{/usr/local/lib/sgml/%o/%c/%d}, the resulting file name is - -@example -/usr/local/lib/sgml/ISO_8879:1986/entities/Added_Latin_1 -@end example - -Note: blanks are transliterated to @samp{_} (and also @samp{/} to -@samp{%}) and the text class is down cased. - - - -@defopt sgml-catalog-files -This is a list of catalog entry files. -The files are in the format defined in the SGML Open Draft Technical -Resolution on Entity Management. The Emacs variable is initialized from -the environment variable @code{SGML_CATALOG_FILES} or if this variable -is undefined the default is - -@lisp -("CATALOG" "/usr/local/lib/sgml/CATALOG") -@end lisp -@end defopt - -@defopt sgml-local-catalogs -A list of SGML entity catalogs to be searched first when parsing the -buffer. This is used in addition to @code{sgml-catalog-files}, and -@code{sgml-public-map}. This variable is automatically local to the -buffer. -@end defopt - -@defopt sgml-system-identifiers-are-preferred -If @code{nil}, PSGML will look up external entities by searching the -catalogs in @code{sgml-local-catalogs} and @code{sgml-catalog-files} and -only if the entity is not found in the catalogs will a given system -identifier be used. If the variable is non-nil and a system identifier is -given, the system identifier will be used for the entity. If no system -identifier is given the catalogs will searched. -@end defopt - - -@defopt sgml-public-map -This should be a list of file name templates. This variable is -initialized from the environment variable @code{SGML_PATH}. This is -the same environment variable that @file{sgmls} uses. If the -environment variable is undefined the default is - -@lisp -("%S" "/usr/local/lib/sgml/%o/%c/%d") -@end lisp -@c Mapping from public identifiers to file names. -@end defopt - -@c the colon separated list in @code{SGML_PATH} is converted to a lisp list - -@c ------------------------------------------------------------------------- -@node Validate, SGML declaration, Entity manager, Top -@comment node-name, next, previous, up -@chapter Running an external SGML parser - -@kindex C-c C-v -@findex sgml-validate -PSGML can not validate an SGML document (see below what it can -and can't do). If you have a validating SGML parser, like -@file{sgmls}, you can run the parser on your file with the -command @kbd{C-c C-v} (@code{sgml-validate}). - -Some variables control this function: - -@defopt sgml-validate-command -The shell command to validate an SGML document. - -This is a @code{format} control string that by default should contain two -@code{%s} conversion specifications: the first will be replaced by the -value of @code{sgml-declaration} (or the empty string, if nil); the -second will be replaced by the current buffer's file name (or the -empty string, if nil). - -If @code{sgml-validate-files} is non-nil, the format string should contain -one @code{%s} conversion specification for each element of its result. - -If sgml-validate-command is a list, then every element should be a -string. The strings will be tried in order and @samp{%}-sequences in the -string will be replaced according to the list below, if the string contains -@samp{%}-sequences with no replacement value the next string will be tried. - -@table @code -@item %b -means the visited file of the current buffer - -@item %s -means the SGML declaration specified in the sgml-declaration variable - -@item %d -means the file containing the DOCTYPE declaration, if not in the buffer -@end table - -The default value is @code{nsgmls -s %s %s}. -@end defopt - -@defopt sgml-validate-files -If non-nil, a function of no arguments that returns a list of -file names. These file names will serve as the arguments to the -@code{sgml-validate-command} format control string instead of -the defaults. -@end defopt - -@defopt sgml-declaration -The name of the SGML declaration file. -@end defopt - -@defopt sgml-offer-save -If non-nil, @kbd{C-c C-v} (@code{sgml-validate}) will ask about -saving modified buffers before running the validate command. -The default value is @code{t}. -@end defopt - - -@kindex C-c C-o -@findex sgml-next-trouble-spot -The built-in parser can find some markup errors. The command @kbd{C-c -C-o} (@code{sgml-next-trouble-spot}) is the best way to use the built-in -parser for this. To check the whole file go to the beginning of the -buffer and use @kbd{C-c C-o}. - -Some of the markup errors not found are: - -@itemize @bullet -@item -Errors in the SGML declaration. -@item -Errors in attribute specifications. -@item -Omitted start-tags for empty elements. -@end itemize - - -@c -------------------------------------------------------------------------- -@node SGML declaration, Managing the DTD, Validate, Top -@comment node-name, next, previous, up -@chapter SGML Declaration -@cindex SHORTTAG -@cindex OMITTAG - -PSGML does not understand the SGML declaration, it accepts one in the -file but it is ignored. If you have the SGML declaration in another -file you can make @file{sgmls} use it when you use the @kbd{C-c C-v} -(@code{sgml-validate}) command (@pxref{Validate}). - -PSGML has some options in what features it uses and what markup it -creates. You have to set these options to make PSGML's behavior -consistent with your SGML declaration and personal preferences. - -@defopt sgml-omittag -Set this to @code{t} if the SGML declaration has @samp{OMITTAG YES} and -to @code{nil} otherwise. -@end defopt - -@defopt sgml-shorttag -Set this to @code{t} if the SGML declaration has @samp{SHORTTAG YES} and -to @code{nil} otherwise. -@end defopt - -@defopt sgml-always-quote-attributes -If non-nil, quote all attribute values inserted after finishing edit -attributes. If this variable is @code{nil} and @code{sgml-shorttag} is -non-@code{nil}, attribute values that consists of only name characters -will not be quoted. -@end defopt - -@defopt sgml-minimize-attributes -Determines minimization of attributes inserted by edit-attributes. If -non-nil, omit attribute name if the attribute value is from a token -group. If @code{max}, omit attributes with default value. Minimization -will only be done if they produce legal SGML (assuming -@code{sgml-omittag} and @code{sgml-shorttag} are set correctly). -@end defopt - - -@c -------------------------------------------------------------------------- -@node Managing the DTD, Edit, SGML declaration, Top -@comment node-name, next, previous, up -@chapter Document Type Declaration -@cindex DOCTYPE -@cindex DTD - -@vindex sgml-default-doctype-name -PSGML needs to know about the DTD you are using for many of its commands. -If you do not have a @samp{DOCTYPE} declaration in your file, -PSGML will try assume that there is one of the form - -@example -<!DOCTYPE @var{name} SYSTEM> -@end example - -where @var{name} is the value of @code{sgml-default-doctype-name}, if -the value is non-@code{nil}, else the GI of the first tag will be used. - -@findex sgml-parse-prolog -@vindex sgml-auto-activate-dtd -PSGML will try to parse the document type declaration the first time -you do something that needs to parse the document or immediately if the -variable @code{sgml-auto-activate-dtd} is @code{t}. You can also -initiate the parsing of the document type declaration with the command -@code{sgml-parse-prolog}. Big DTDs take some time to parse. - -When the DTD has been parsed or loaded the name of the document element -will be displayed in the mode line inside brackets. If there was an -error parsing the DTD or there is no DTD, the mode line will display -@samp{[ANY]} (*** this is not really correct! a DTD will be established -even if there are missing entities, it may even be empty). - -@menu -* Precompiled DTD Subsets:: -* Using a Split Document:: -* Inserting a DOCTYPE:: -* Information from the DTD:: -@end menu - - -@c ------------------------------------------------------------ -@node Precompiled DTD Subsets, Using a Split Document, Managing the DTD, Managing the DTD -@comment node-name, next, previous, up -@section Precompiled DTD Subsets - -If parsing the DTD takes too long time you can arrange to have PSGML -cache an internal complied version of the DTD. Caching can be done of -DTD fragments in favourable situations. It is possible to have an -external DTD subset cached but still have an internal DTD subset as long -as the internal subset does not define parameter entities that affect -the parsing of the external subset (*** what is the exact conditions?, -probably you can't use the cached external subset if the internal subset -defines parameter entities that are also defined in the external subset -with another value). - -@vindex sgml-ecat-files -@vindex sgml-local-ecat-files -To enable caching you have to create special catalog files, hear after -called ECAT files due to (temporary) lack of imagination. These catalogs -have similar syntax to the entity catalogs and there are two variables -containing lists of catalogs to search: @code{sgml-ecat-files} and -@code{sgml-local-ecat-files}. The ECAT files can contain the following -types of entries: - -@table @samp -@item file @var{dtdfile} @var{entitydef} @var{cfile} -The @var{dtdfile} is the name of a file containing a DTD subset that -should be cached in @var{cfile}. The @var{entitydef} is optional and if -given have the following syntax: -@example -[ @var{name1} @var{literal1} @var{name2} @var{literal2} @dots{} ] -@end example -Using @var{entitydef} will modify the DTD subset by defining the -parameter entity with name @var{name1} to be @var{literal1}, @dots{}. The -cached version of the subset will be created with those entity -definitions, and when PSGML search for a matching cached subset will check -that the parameter entities in @var{entitydef} has been defined with -those values before trying to use @file{cfile}. - -@item public @var{pubid} @var{entitydef} @var{cfile} -Cache the DTD subset with public identifier @var{pubid} in file -@var{cfile}. -@end table - - -@defopt sgml-recompile-out-of-date-cdtd -If non-@code{nil}, out of date compiled DTDs will be automatically -recompiled. If the value is @code{ask}, PSGML will ask before -recompiling. A @code{nil} value will cause PSGML to silently load an out -of date compiled DTD. A DTD that refers to undefined external entities -is always out of date, thus in such case it can be useful to set this -variable to @code{nil}. -@end defopt - - -Previous versions of PSGML have had another way of speeding up DTD -parsing. This code remains in this version of PSGML, but is not actively -maintained and may disappear in the future. - -@findex sgml-save-dtd -@findex sgml-load-dtd -@vindex sgml-default-dtd-file -You can save the parsed DTD in a file using the command @kbd{M-x -sgml-save-dtd}. Next time PSGML can load that file instead of parsing -the DTD. For PSGML to find the saved DTD you must either save the DTD -using the default name or do a @kbd{M-x sgml-save-options} after saving -the DTD. To directly use an already parsed and saved DTD, load the file -containing the saved DTD with the command @kbd{M-x sgml-load-dtd}. - -@defopt sgml-default-dtd-file -This is the default file name for saved DTD. This is set by -@code{sgml-mode} to the buffer file name less extension plus the -extension @code{.ced}, if that file exists. Can be changed in the Local -variables section of the file. -@end defopt - -@c true with system-path -@c either or by creating a saved DTD and setting -@c @code{sgml-default-dtd-file} to that file. If -@c @code{sgml-default-dtd-file} contains a relative file name, the -@c directories in @code{sgml-system-path} will be searched for the file. - - -@c ------------------------------------------------------------ -@node Using a Split Document, Inserting a DOCTYPE, Precompiled DTD Subsets, Managing the DTD -@comment node-name, next, previous, up -@section Using a Split Document - -@c *** why not defopt?? -@vindex sgml-doctype -You can have the @samp{DOCTYPE} declaration in another file by setting -@code{sgml-doctype} to the other file. - -@defopt sgml-parent-document -Used when the current file is part of a bigger document. - -The variable describes how the current file's content fit into the element -hierarchy. The variable should have the form - -@lisp -(@var{parent-file} @var{context-element}* @var{top-element} (@var{has-seen-element}*)?) -@end lisp - -@table @var -@item parent-file -is a string, the name of the file containing the -document entity. - -@item context-element -is a string, that is the name of an element type. -It can occur 0 or more times and is used to set up -exceptions and short reference map. Good candidates -for these elements are the elements open when the -entity pointing to the current file is used. - -@item top-element -is a string that is the name of the element type -of the top level element in the current file. The file -should contain one instance of this element, unless -the last (lisp) element of sgml-parent-document is a -list. If it is a list, the top level of the file -should follow the content model of top-element. - -@item has-seen-element -is a string that is the name of an element type. This -element is satisfied in the content model of top-element. -@end table -@end defopt - - -@c ------------------------------------------------------------ -@node Inserting a DOCTYPE, Information from the DTD, Using a Split Document, Managing the DTD -@comment node-name, next, previous, up -@section Inserting a DOCTYPE - -@kindex C-c C-u C-d -@findex sgml-custom-dtd -*** Describe the DTD menu in general. Describe customized entries for -special DTDs. Mention @kbd{C-c C-u C-d} for inserting a DOCTYPE from -keyboard. - -If you change the doctype you must execute @code{sgml-parse-prolog}, -changes in the doctype are not automatically recognized. - -@defopt sgml-custom-dtd -Menu entries to be added to the DTD menu. The value should be a list of -entries to be added to the DTD menu. - -Every entry should be a list. The first element of the entry is a string -used as the menu entry. The second element is a string containing a -doctype declaration (this can be nil if no doctype). The rest of the -list should be a list of variables and values. For backward -compatibility a single string instead of a variable is assigned to -@code{sgml-default-dtd-file}. All variables are made buffer local and -are also added to the buffers local variables list. - -When an entry is selected from the DTD menu, the doctype declaration will -be inserted, the variables will be set to the values in the entry and a -local variables list will be created in the buffer. - -Example: - -@example - (("HTML" nil - sgml-default-dtd-file "~/sgml/html.ced" - sgml-omittag nil sgml-shorttag nil) - ("HTML+" "<!doctype htmlplus system 'htmlplus.dtd'>" - "~/sgml/htmlplus.ced" - sgml-omittag t sgml-shorttag nil) - ("DOCBOOK" "<!doctype docbook system 'docbook.dtd'>" - "~/sgml/docbook.ced" - sgml-omittag nil sgml-shorttag t))) -@end example -@end defopt - - -@c ------------------------------------------------------------ -@node Information from the DTD, , Inserting a DOCTYPE, Managing the DTD -@comment node-name, next, previous, up -@section Information from the DTD -@cindex DTD -@cindex Element - -PSGML can list various information about the current DTD. -The following commands can be used via @kbd{M-x} and -can also be found in the DTD menu. - -@table @code -@findex sgml-general-dtd-info -@item sgml-general-dtd-info -Display information about the current DTD. - -@findex sgml-describe-element-type -@item sgml-describe-element-type -Describe the properties of an element type as declared in the current DTD. - -@cindex entity -@findex sgml-describe-entity -@item sgml-describe-entity -Describe the properties of an entity as declared in the current DTD. - -@findex sgml-list-elements -@item sgml-list-elements -Will list all elements and the attributes declared for the element. - -@findex sgml-list-attributes -@item sgml-list-attributes - Will list all attributes declared and the elements that use them. - -@findex sgml-list-terminals -@item sgml-list-terminals -Will list all elements that can contain data. - -@findex sgml-list-occur-in-elements -@item sgml-list-occur-in-elements -Will list all element types and where it can occur. - -@findex sgml-list-content-elements -@item sgml-list-content-elements -Will list all element types and the element types that can occur -in its content. -@end table - - -@c --------------------------------------------------------------------------- -@node Edit, Display, Managing the DTD, Top -@comment node-name, next, previous, up -@chapter Commands for editing - -@menu -* Insert:: Inserting Markup -* Complete:: Markup completion -* Information:: Showing information -* Indent:: Indentation according to structure -* Move:: Move in the element structure -* Attributes:: Editing attributes -* Change and delete:: Changing and deleting markup -* Translating characters and entities:: -@end menu - -@c ------------------------------------------------------------------ -@node Insert, Complete, Edit, Edit -@comment node-name, next, previous, up -@section Inserting Markup - -@c erik says "inserts" ?? -The commands that insert start-tags works only if the document has an -associated DTD. - -Keyboard commands for inserting: - -@table @kbd -@kindex C-c < -@findex sgml-insert-tag -@item C-c < -Will ask, for the tag to insert, in the mini-buffer with completion on the -tags that are valid at point (@code{sgml-insert-tag}). - -If the option @code{sgml-balanced-tag-edit} is non-nil, inserting a -start-tag will also insert the corresponding end-tag. If, in addition, -@code{sgml-auto-insert-required-elements} is non-nil, tags for elements -required between the inserted tags will also be inserted. - -The list of valid tags, computed for a position in the buffer, will -contain: - -@enumerate -@item -The end-tag for the current element, if it can be ended at the position -and @code{sgml-balanced-tag-edit} is nil. Furthermore it will contain -end-tags for enclosing elements if the necessary omissible end-tag -declarations have been made in the DTD. - -@item -The start-tags of all elements that could occur after point. If -@code{sgml-omittag-transparent} is nil, the above will be limited to the -elements that can occur within the current element. -@end enumerate - - -@kindex C-c C-e -@findex sgml-insert-element -@vindex sgml-insert-end-tag-on-new-line -@item C-c C-e -Insert start and end-tags for an element -(@code{sgml-insert-element}). The name of the element is read -from the mini-buffer with completion on valid elements. If -@code{sgml-insert-end-tag-on-new-line} is non-nil or the -element has element content, the end-tag will be inserted on a -new line after the start-tag. - -@vindex sgml-omittag-transparent -If @code{sgml-omittag-transparent} is nil, the list of valid elements -will only contain the elements that can be in the content of the current -element. - -@vindex sgml-auto-insert-required-elements -@vindex sgml-insert-missing-element-comment -Required elements in the content will be automatically inserted if the -option @code{sgml-auto-insert-required-elements} is non-nil. -When the content model demands an element but there is more -than one to choose from, a comment can be inserted with the -available choices if the option -@code{sgml-insert-missing-element-comment} is non-nil. - -@kindex C-c C-r -@findex sgml-tag-region -@item C-c C-r -Makes the region into a new element (@code{sgml-tag-region}). Reads -element name from mini-buffer with completion as for @kbd{C-c C-e}. - -@kindex C-c / -@findex sgml-insert-end-tag -@item C-c / -Inserts an end-tag for the current element (@code{sgml-insert-end-tag}). - -@kindex C-c RET -@findex sgml-split-element -@item C-c RET -Split the current element at point. If repeated, the containing element -will be split before the beginning of then current element. - -Typical use is to start a new paragraph element when inside a paragraph. - -@kindex C-c + -@findex sgml-insert-attribute -@item C-c + -Read attribute name and value from mini-buffer and insert attribute -specification (@code{sgml-insert-attribute}). If point is immediately -after a start-tag, this command operates on that start-tag. Otherwise -the command will operate on the element after point. - -The attribute name will be read with completion. If the attribute has a -token list as declared value the attribute value will also be read with -completion. The prompt for attribute value will typically look like: - -@example -Value for @var{attribute} (@var{type} Default: @var{current value}): -@end example - -@kindex C-c C-u C-m -@findex sgml-custom-markup -@item C-c C-u C-m -Give keyboard access to the customized part of the Markup menu. -Emacs will prompt for the markup to insert using the menu line as -selector. (See @var{sgml-custom-markup} below.) - -@end table - -Menu bar: - -@table @samp -@item Markup -Selecting from this menu will insert markup. The menu contains -sub menus with tags and with entities, some other markup and a user -defined section. - -Sub menus: - -@item Insert element -Pops up a menu of valid elements and insert start and end-tags for -the selected element. Selections from the menu works like the @kbd{C-c -C-e} command. - -@item Insert start-tag -Pops up a menu of valid start-tags and insert the selected tag. The -menu has the same start-tags as the completion list for @kbd{C-c <}. - -@item Insert end-tag -Pops up a menu of valid end-tags and insert the selected tag. - -@item Tag region -Pops up a menu of valid elements and tag the region with the -selection. Selections from the menu works like the @kbd{C-c C-r} -command. - -@item Insert entity -Menu of all general entities defined in the DTD. - -@item Insert attribute -Pops up a menu with all the attributes of an element. The element is -either the one which start-tag is immediately before point or the -element after point. Selecting from this menu edits the attribute -specification list for the element. - -The menu has a sub menu for every attribute which declared value is a -token list. The rest of the attributes are collected in one sub menu. -For the token list attributes, selecting a value will insert that -attribute-value pair. Selecting some other attribute reads the -attribute-value from the mini-buffer and inserts the attribute value -pair. -@end table - -@kindex S-@key{mouse-1} -A menu is also available directly with a mouse button click in the -buffer. In GNU Emacs it is the first mouse button combined with shift -(@kbd{S-@key{mouse-1}}). In XEmacs it is bound to the third mouse -button. The mouse button click will pop-up a menu of valid tags or a -menu of attributes if the point is in a start-tag. The attributes menu -works as the ``Insert attribute'' menu from the menu-bar. The tags list -is the list of valid tags described above for command @kbd{C-c <}. -Selection from the tags menu works like the @kbd{C-c <} command, with -the following exception: - -You can tag a region, with start and end-tag. There are two ways to -indicate the region to mark: - -@enumerate -@item -Use the normal mouse commands to mark region. - -For this to work you must either use @dfn{transient mark mode} -(@pxref{Transient Mark, , Transient Mark Mode, emacs, The Emacs -Editor}) or set the option @code{sgml-tag-region-if-active} to non-nil -(don't set this unless you are sure that you want it). - -@item -Alternatively make a secondary selection, this is done by holding down -the meta key and using the mouse buttons. -@xref{Secondary selection, , , emacs, The Emacs Editor}. -Some window managers intercept these events, which makes it hard use the -secondary selection in Emacs. -@end enumerate - -@defopt sgml-balanced-tag-edit -If non-nil, inserting a start-tag will also insert the corresponding -end-tag. -@end defopt - -@defopt sgml-auto-insert-required-elements -If non-nil, automatically inserts required elements in the content -of an inserted element. -@end defopt - -@defopt sgml-omittag-transparent -If non-nil, will show legal tags inside elements with omissible start-tags -and legal tags beyond omissible end-tags. -@end defopt - -@defopt sgml-tag-region-if-active -If non-nil, the @samp{Insert tags} menu will tag a region if the region -is considered active by emacs. If nil, region must be active and -@code{transient-mark-mode} must be on for the region to be tagged. -@end defopt - -@defopt sgml-custom-markup -Menu entries to be added to the Markup menu. The value should be a list -of lists of two strings. The first string is the menu line and the -second string is the text inserted when the menu item is selected. The -second string can contain a @samp{\r} where the cursor should be left. -Also, if a selection is made according to the same rules as for the -@kbd{S-mouse-1} menu, the selection is replaced with the second string -and @samp{\r} is replaced with the selection. - -Example: - -@example - (("Version1" "<![%Version1[\r]]>") - ("New page" "<?NewPage>")) -@end example -@end defopt - - -@defopt sgml-insert-missing-element-comment -If non-nil, and sgml-auto-insert-required-elements also true, -@code{sgml-insert-element} will insert a comment if there is an -element required but there is more than one to choose from. -@end defopt - -@defopt sgml-insert-end-tag-on-new-line -If non-nil, @code{sgml-insert-element} will put the end-tag on -a new line after the start-tag. Useful on slow terminals if you -find the end-tag after the cursor irritating. -@end defopt - - -@c ------------------------------------------------------------------------- -@node Complete, Information, Insert, Edit -@comment node-name, next, previous, up -@section Markup completion - -@kindex M-TAB -@findex sgml-complete -If you are typing in markup directly, @kbd{M-TAB} will help you by -completing a tag name, an entity name or a markup declaration name. If -you type @kbd{M-TAB} after a plain word, @code{ispell-complete-word} -will be invoked instead. - -If you have typed (@point{} marks the position of point) - -@example -&At@point{} -@end example - -@noindent and type @kbd{M-TAB} (assuming you use the @file{ISOLat1} -entity set) you get: - -@example -Ã@point{} -@end example - - -@c --------------------------------------------------------------------------- -@node Information, Indent, Complete, Edit -@comment node-name, next, previous, up -@section Showing information - -Commands for showing information obtained by parsing the buffer. - -@table @kbd -@kindex C-c C-c -@findex sgml-show-context -@item C-c C-c -Shows in the message area: context at point, if in a tag or in mixed -content and the open elements (@code{sgml-show-context}). - -@kindex C-c C-w -@findex sgml-what-element -@item C-c C-w -Shows what element the character after point (under the cursor) belongs -to; also shows context of element (@code{sgml-what-element}). - -@kindex C-c C-t -@findex sgml-list-valid-tags -@item C-c C-t -List contextually valid tags (@code{sgml-list-valid-tags}). Displays -information about current element, all valid end-tags, valid start-tags -in current element, and start-tags valid at this point but in other -elements together with the tags omitted. -@end table - -You can make the mode-line display the name of the current open element -by setting the @code{sgml-live-element-indicator} variable. Setting -this will make all commands slower due to the work needed to keep the -mode-line up to date. - -@defopt sgml-live-element-indicator -If non-nil, indicate current element in mode line. - -NOTE: Setting this implies that every command can cause a parse. -@end defopt - - - -@c -------------------------------------------------------------------------- -@node Indent, Move, Information, Edit -@comment node-name, next, previous, up -@section Indentation according to structure - -@kindex @key{TAB} -@kindex @key{LFD} -@findex sgml-indent-or-tab -@findex newline-and-indent -You can indent a line according to the depth of element nesting at the -beginning of the line. To indent the current line use @kbd{@key{TAB}}. -You can also use @kbd{@key{LFD}} (@code{newline-and-indent}) to start a -new line with correct indentation. - -@defopt sgml-indent-step -How much to increment indent for every element level. If nil, no -indentation. - -If this is nil, @kbd{@key{TAB}} will insert a tab instead of indenting. -@end defopt - -@defopt sgml-indent-data -If non-nil, indent in data/mixed context also. -@end defopt - - - -@c --------------------------------------------------------------------------- -@node Move, Attributes, Indent, Edit -@comment node-name, next, previous, up -@section Move in the element structure - -These commands move in the element structure. The commands uses -knowledge of SGML syntax, and if available the specific DTD. - -@table @kbd -@kindex C-M-a -@findex sgml-beginning-of-element -@item C-M-a -Move to the (content) beginning of the current element -(@code{sgml-beginning-of-element}). - -@kindex C-M-e -@findex sgml-end-of-element -@item C-M-e -Move to the (content) end of the current element (@code{sgml-end-of-element}). - -@kindex C-M-f -@findex sgml-forward-element -@item C-M-f -Move forward by element (@code{sgml-forward-element}). - -@kindex C-M-b -@findex sgml-backward-element -@item C-M-b -Move backward by element (@code{sgml-backward-element}). - -@kindex C-M-u -@findex sgml-backward-up-element -@item C-M-u -Move up to before current element (@code{sgml-backward-up-element}). - -@kindex C-c C-n -@findex sgml-up-element -@item C-c C-n -Move up to after current element (@code{sgml-up-element}). - -@kindex C-M-d -@findex sgml-down-element -@item C-M-d -Move down to the (content) beginning of the next element -(@code{sgml-down-element}). - -@kindex C-c C-d -@findex sgml-next-data-field -@item C-c C-d -Move to the next place where data is allowed (@code{sgml-next-data-field}). -@end table - -You can also move to the next place where there is some structural error -with @kbd{C-c C-o} (@pxref{Validate}). - - -@c --------------------------------------------------------------------------- -@node Attributes, Change and delete, Move, Edit -@comment node-name, next, previous, up -@section Editing attributes - -@findex sgml-edit-attributes -@kindex C-c C-a -If you want to change the attributes of a start-tag you can simply edit -them directly in the buffer. Or you can place the cursor at or after -the start-tag and use the @code{sgml-edit-attributes} command, available -from the @samp{SGML}-menu or on @kbd{C-c C-a}. This will create a new -Emacs window with all possible attributes listed in the form - -@example -@var{attribute name} = @var{current value}. -@end example - -The @var{current value} may be shown as @samp{#DEFAULT} if the attribute -has not been given a value in the start-tag. The list also contains the -attributes declaration as a comment. Note also that the @var{current -value} is show without eventual quotes. - -@kindex C-c C-d -@kindex @key{TAB} -It is now possible to edit the attribute values. You can move to the -next attribute with @kbd{@key{TAB}}. If you want to let an attribute -have its default value use @kbd{C-c C-d}, this will insert a -@samp{#DEFAULT} in the value field. - -If Emacs is running in an X window, the @samp{#DEFAULT} will be -underlined to distinguish it from normal values. - -@kindex C-c C-c -Finish the editing with @kbd{C-c C-c}; this will replace the attribute -values in the main buffer with those edited. Note that values will be -quoted as needed. - -If you want to abort the editing, you can remove the window with -@kbd{C-x 0} or if you want it neat, kill the buffer and remove the -window. - -Some other keys are: -@table @kbd -@kindex C-a -@findex sgml-edit-attrib-field-start -@item C-a -Go to the beginning of the value field -(@code{sgml-edit-attrib-field-start}). - -@kindex C-e -@findex sgml-edit-attrib-field-end -@item C-e -Go to the end of the value field -(@code{sgml-edit-attrib-field-end}). - -@kindex C-c C-k -@findex sgml-edit-attrib-clear -@item C-c C-k -Clear the value field -(@code{sgml-edit-attrib-clear}). - -@kindex C-c C-d -@findex sgml-edit-attrib-default -@item C-c C-d -Set the value field to @samp{#DEFAULT} -(@code{sgml-edit-attrib-default}). This is a special value that will -make the attribute be implied. -@end table - - -@c -------------------------------------------------------------------------- -@node Change and delete, Translating characters and entities, Attributes, Edit -@comment node-name, next, previous, up -@section Changing and deleting markup - -@table @kbd -@kindex C-c = -@findex sgml-change-element-name -@item C-c = -Change the name of the current element (@code{sgml-change-element-name}). -Tries to translate attribute specifications. An attribute will be -translated to an attribute with the same name. If the new element has -no attribute with the same name, the attribute will be ignored. If -there is an attribute with the same name but different declared content, -a warning is given. - -ID attributes are handled specially, an attribute with declared value ID -will always be translated to the attribute with declared value ID. - -@kindex C-c C-k -@findex sgml-kill-markup -@item C-c C-k -Kill next tag, markup declaration or process instruction -(@code{sgml-kill-markup}). - -@kindex C-M-k -@findex sgml-kill-element -@item C-M-k -Kill the element following the cursor (@code{sgml-kill-element}). - -@kindex C-c - -@findex sgml-untag-element -@item C-c - -Remove tags from current element (@code{sgml-untag-element}). - -@kindex C-c # -@findex sgml-make-character-reference -@item C-c # -Convert character after point to a character reference -(@code{sgml-make-character-reference}). If called with a numeric -argument, convert a character reference back to a normal character. - -@kindex C-c C-q -@findex sgml-fill-element -@item C-c C-q -Fills an element as a paragraph (@code{sgml-fill-element}). This is a -substitute for the normal @code{fill-paragraph}. The command uses -heuristics to decide what should be a paragraph. - -@enumerate -@item -If point is in an element content, recursively fill the sub-elements. -@item -Find the biggest element with mixed content containing point. -@item -If the above element is mixed but contains elements with pure element -content then fill what is between the pure elements as paragraphs and -fill the pure elements recursively. -@end enumerate - -@findex sgml-expand-all-shortrefs -@item M-x sgml-expand-all-shortrefs -Short references to text entities are expanded to the replacement text -of the entity other short references are expanded into general entity -references. If argument, @var{to-entity}, is non-@code{nil}, or if -called interactive with numeric prefix argument, all short references -are replaced by generally entity references. - -@findex sgml-normalize -@item M-x sgml-normalize -Normalize the document in the buffer. This will - -@enumerate -@item -expand short references, -@item -insert missing tags, -@item -replace minimized tags with full tags, -@item -fix attribute specification lists according to options set. -@end enumerate - -There is one argument, @var{to-entity}, with the same meaning as for -@code{sgml-expand-all-shortrefs}. - -There is one option for the normalize command. With its default value, -normalize may actually change the data content of some elements. But -only by removing some white-space from the end of elements with omitted -end-tags. -@end table - -@defopt sgml-normalize-trims -If non-nil, @code{sgml-normalize} will trim off white space from end of -element when adding end-tag. - -Default: @code{t}. -@end defopt - - -@c -------------------------------------------------------------------------- -@node Translating characters and entities, , Change and delete, Edit -@comment node-name, next, previous, up -@section Translating between characters and entity references - -@c *** Need work.. - -Set the variable @code{sgml-display-char-list-filename} to a file file that -contains mappings between all characters present in the presentation -character set, and their "standard replacement text" names, e.g. "å" --> "[aring ]", e.t.c. - -The default value for this variable is `iso88591.map'. - -The use the functions (also in the Modify menu) - -@table @code -@findex sgml-charent-to-display-char -@item sgml-charent-to-display-char -@findex sgml-display-char-to-charent -@item sgml-display-char-to-charent -@end table - -to translate between entities and characters. - -@c --------------------------------------------------------------------------- -@node Display, Miscellaneous options, Edit, Top -@comment node-name, next, previous, up -@chapter Appearance of text in the buffer - -@menu -* Fold:: Folding editing -* Hiding markup:: -* Highlight:: Highlighting markup -@end menu - -@c --------------------------------------------------------------------------- -@node Fold, Hiding markup, Display, Display -@comment node-name, next, previous, up -@section Folding editing - -With these commands you can make parts of the text temporarily invisible -to make it easier to see the overall structure of your text. - -When folding a region all the lines but the first will be invisible. -The first line of the region will still be visible with an ellipsis at -the end. - -@xref{Outline Mode, , , emacs, The Emacs Editor}. - -@table @kbd -@kindex C-c C-f C-r -@findex sgml-fold-region -@item C-c C-f C-r -The region between point and mark will be folded (@code{sgml-fold-region}). - -@kindex C-c C-f C-e -@findex sgml-fold-element -@item C-c C-f C-e -The region between the start and end of the current element will be -folded (@code{sgml-fold-element}). - -This command can also fold the SGML declaration or the DOCTYPE -declaration. - -@kindex C-c C-f C-s -@findex sgml-fold-subelement -@item C-c C-f C-s -Fold all the sub elements of the current element -(@code{sgml-fold-subelement}). - -@kindex C-c C-s -@kindex C-c C-u C-l -@findex sgml-unfold-line -@item C-c C-s -@itemx C-c C-u C-l -Unfold the current line, assuming it is the first line of a folded -region (@code{sgml-unfold-line}). - -@kindex C-c C-u C-e -@findex sgml-unfold-element -@item C-c C-u C-e -Make all lines in current element visible (@code{sgml-unfold-element}). - -@kindex C-c C-u C-a -@findex sgml-unfold-all -@item C-c C-u C-a -Make all lines in current buffer visible (@code{sgml-unfold-all}). - -@kindex C-c C-f C-x -@findex sgml-expand-element -@item C-c C-f C-x -Unfold current element and then fold the subelements -(@code{sgml-expand-element}). If the current element is folded this -expands what is visible. -@end table - - -@c --------------------------------------------------------------------------- -@node Hiding markup, Highlight, Fold, Display -@comment node-name, next, previous, up -@section Hiding markup - -*** Describe hide-tags - - -@c --------------------------------------------------------------------------- -@node Highlight, , Hiding markup, Display -@comment node-name, next, previous, up -@section Highlighting markup - - -PSGML can highlight the markup giving the markup a different @dfn{face} -(@pxref{Faces, , Using Multiple Typefaces, emacs, The Emacs Editor}). -The highlighting will only be done if the variable @code{sgml-set-face} -is non-@code{nil}. The default settings make tags bold and comments -italic, but this can be modified with the variable -@code{sgml-markup-faces}. When highlighting is on PSGML will parse after -every command until the whole buffer has been parsed or user event -occurs. - -@findex sgml-clear-faces -To remove the highlighting type @kbd{M-x sgml-clear-faces}. - -@defopt sgml-set-face -If non-nil, psgml will set the face of parsed markup. -@end defopt - -@defopt sgml-markup-faces -A list of markup to face mappings. -Each element looks like @code{(@var{markup-type} . @var{face})}. -Possible values for @var{markup-type} is: - -@table @code -@item comment -comment declaration -@item doctype -doctype declaration -@item end-tag -end-tag -@item ignored -ignored marked section -@item ms-start -marked section end, if not ignored -@item ms-end -marked section start, if not ignored -@item pi -processing instruction -@item sgml -SGML declaration -@item start-tag -start-tag -@item entity -entity reference -@item shortref -short reference -@end table -@end defopt - - - -@c ------------------------------------------------------------------ -@node Miscellaneous options, Bugs, Display, Top -@comment node-name, next, previous, up -@chapter Miscellaneous options - -*** describe sgml-save-options - -@defopt sgml-ignore-undefined-elements -Start-tags for undefined elements will either be ignored, if -@code{sgml-ignore-undefined-elements} is @code{t}, or assumed to be -acceptable in the current element and defined with @code{O O ANY} -@end defopt - -@defopt sgml-range-indicator-max-length -Maximum number of characters used from the first and last entry -of a sub-menu to indicate the range of that menu. - -@vindex sgml-max-menu-size -This is used for long menus of elements, tags or entities that are split -into @code{sgml-max-menu-size} big sub-menus. -@end defopt - - - - -@c ------------------------------------------------------------------ -@node Bugs, Index, Miscellaneous options, Top -@comment node-name, next, previous, up -@chapter Bugs - - -If you encounter something that you think is a bug, please report -it. Try to include a clear description of the undesired behaviour. -A test case that exhibits the bug, would also be useful. - -You can report a bug with the command @kbd{M-x sgml-submit-bug-report}. - -When PSGML needs contextual information it parses the document up to -the point. During the parsing, it builds a parse tree. The parse -tree is used to initialize the next parse, to avoid having to parse -things already parsed. Changes to the buffer is supposed to prune -the tree of all outdated information. But if you get strange -complaints from the parser, try and back up a bit and use @kbd{C-c -C-o} (@code{sgml-next-trouble-spot}). - - - -@c ------------------------------------------------------------------ -@node Index, , Bugs, Top -@comment node-name, next, previous, up -@chapter Index - -@printindex cp - -@contents -@bye
--- a/man/umlaute.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -@catcode`@ß=@active -@catcode`@Ä=@active -@catcode`@ä=@active -@catcode`@Ö=@active -@catcode`@ö=@active -@catcode`@Ü=@active -@catcode`@ü=@active -@defß{@ss} -@defÄ{@"A} -@defä{@"a} -@defÖ{@"O} -@defö{@"o} -@defÜ{@"U} -@defü{@"u}
--- a/man/viper.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4422 +0,0 @@ -% -*-texinfo-*- - -% -\input texinfo - -@comment Using viper.info instead of viper in setfilename breaks DOS. -@comment @setfilename viper -@comment @setfilename viper.info -@setfilename ../info/viper - -@iftex -@finalout -@end iftex - -@titlepage -@title Viper Is a Package for Emacs Rebels -@subtitle a Vi emulator for GNU Emacs 20 and XEmacs 20 -@subtitle August 1997, Viper Version 3.0 (Polyglot) - -@author Michael Kifer (Viper) -@author Aamod Sane (VIP 4.4) -@author Masahiko Sato (VIP 3.5) - -@page -@vskip 0pt plus 1fill -@end titlepage - -@unnumbered Distribution - -@noindent -Copyright @copyright{} 1995, 1996, 1997 Free Software Foundation, Inc. - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through TeX and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -Permission is granted to copy and distribute modified versions of this -manual under the conditions for verbatim copying, provided that the entire -resulting derived work is distributed under the terms of a permission -notice identical to this one. - -Permission is granted to copy and distribute translations of this manual -into another language, under the same conditions as for modified versions. - -@ifinfo -@node Top, Overview,, (DIR) - -@unnumbered Viper - -We believe that one or more of the following statements are adequate -descriptions: - -@example -Viper Is a Package for Emacs Rebels; -it is a VI Plan for Emacs Rescue -and/or a venomous VI PERil. -@end example - -Technically speaking, Viper is a Vi emulation package for GNU Emacs and -XEmacs. It implements all Vi and Ex commands, occasionally improving on -them and adding many new features. It gives the user the best of both -worlds: Vi keystrokes for editing combined with the power of Emacs environment. - -Viper emulates Vi at several levels, from the one that closely follows Vi -conventions to the one that departs from many of them. It has many -customizable options, which can be used to tailor Viper to the work habits -of various users. -This manual describes Viper, concentrating on the differences from Vi and -new features of Viper. - -Viper, formerly known as VIP-19, was written by Michael Kifer. It is based -on VIP version 3.5 by Masahiko Sato and VIP version 4.4 by Aamod Sane. -Viper tries to be compatible with these packages. - -Viper is intended to be usable without reading this manual --- the defaults -are set to make Viper as close to Vi as possible. At startup, Viper will -try to set the most appropriate default environment for you, based on -your familiarity with Emacs. It will also tell you the basic GNU Emacs window -management commands to help you start immediately. - -Although this manual explains how to customize Viper, some basic -familiarity with Emacs Lisp would be a plus. - -It is recommended that you read the Overview node. The other nodes may -be visited as needed. - -Comments and bug reports are welcome. -@code{kifer@@cs.emacs.edu} is the current address for Viper bug reports. -Please use the Ex command @kbd{:submitReport} for this purpose.@refill - -@end ifinfo - -@menu -* Overview:: Must read to get started -* Improvements over Vi:: New features, Improvements -* Customization:: How to customize Viper -* Commands:: Vi and Ex Commands - -* Key Index:: Index of Vi and Ex Commands -* Function Index:: Index of Viper Functions -* Variable Index:: Index of Viper Variables -* Package Index:: Index of Packages Mentioned in this Document -* Concept Index:: Vi, Ex and Emacs concepts - -* Acknowledgments:: -@end menu -@iftex -@unnumbered Introduction - -We believe that one or more of the following statements are adequate -descriptions: - -@example -Viper Is a Package for Emacs Rebels; -it is a VI Plan for Emacs Rescue -and/or a venomous VI PERil. -@end example - -Viper is a Vi emulation package for GNU Emacs 20 and XEmacs 20. Viper -contains virtually all of Vi and Ex functionality and much more. It -gives you the best of both worlds: Vi keystrokes for editing combined -with the GNU Emacs environment. Viper also fixes some common complaints -with Vi commands. This manual describes Viper, concentrating on the -differences from Vi and on the new features of Viper. - -Viper was written by Michael Kifer. It is based on VIP version 3.5 by -Masahiko Sato and VIP version 4.4 by Aamod Sane. Viper tries to be -compatible with these packages. - -Viper is intended to be usable out of the box, without reading this manual ---- the defaults are set to make Viper as close to Vi as possible. At -startup, Viper will attempt to set the most appropriate default environment -for you, based on your familiarity with Emacs. It will also tell you the -basic GNU Emacs window management commands to help you start immediately. - -Although this manual explains how to customize Viper, some basic -familiarity with Emacs Lisp would be a plus. - -It is recommended that you read the chapter Overview. The other chapters -will be useful for customization and advanced usage. - -You should also learn to use the Info on-line hypertext manual system that -comes with Emacs. This manual can be read as an Info file. Try the command -@kbd{@key{ESC} x info} with vanilla Emacs sometime. - -Comments and bug reports are welcome. -@code{kifer@@cs.sunysb.edu} is the current address for Viper bug reports. -Please use the Ex command @kbd{:submitReport} for this purpose.@refill - -@end iftex - -@node Overview,Improvements over Vi,Top,Top -@chapter Overview of Viper - -Viper is a Vi emulation on top of Emacs. At the same time, Viper provides a -virtually unrestricted access to Emacs facilities. Perfect compatibility -with Vi is possible but not desirable. This chapter tells you about the -Emacs ideas that you should know about, how to use Viper within Emacs and -some incompatibilities. - -Viper was formerly known as VIP-19, which was -a descendant of VIP 3.5 by Masahiko Sato and VIP 4.4 by Aamod Sane. - -@menu -* Emacs Preliminaries:: Basic concepts in Emacs. -* Loading Viper:: Loading and Preliminary Configuration. -* States in Viper:: Viper has four states orthogonal to - modes in Emacs. -* The Minibuffer:: Command line in Emacs. -* Multiple Files in Viper:: True multiple file handling. -* Unimplemented Features:: That are unlikely to be implemented. -@end menu - -@node Emacs Preliminaries, Loading Viper, Overview, Overview -@section Emacs Preliminaries - -@cindex buffer -@cindex point -@cindex mark -@cindex text -@cindex looking at -@cindex end (of buffer) -@cindex end (of line) -@cindex region - -Emacs can edit several files at once. A file in Emacs is placed in a -@dfn{buffer} that usually has the same name as the file. Buffers are also used -for other purposes, such as shell interfaces, directory editing, etc. -@xref{Dired,,Directory Editor,emacs,The -Gnu Emacs Manual}, for an example.@refill - -A buffer has a distinguished position called the @dfn{point}. -A @dfn{point} is always between 2 characters, and is @dfn{looking at} -the right hand character. The cursor is positioned on the right hand -character. Thus, when the @dfn{point} is looking at the end-of-line, -the cursor is on the end-of-line character, i.e. beyond the last -character on the line. This is the default Emacs behavior.@refill - -The default settings of Viper try to mimic the behavior of Vi, -preventing the cursor from going beyond the last character on the line. -By using Emacs commands directly (such as those bound to arrow keys), it is -possible -to get the cursor beyond the end-of-line. However, this won't (or shouldn't) -happen if you restrict yourself to standard Vi keys, unless you modify the -default editing style. @xref{Customization}.@refill - -In addition to the @dfn{point}, there is another distinguished buffer -position called the @dfn{mark}. @xref{Mark,,Mark,emacs,The GNU Emacs -manual}, for more info on the mark. The text between the @dfn{point} and the -@dfn{mark} is called the @dfn{region} of the buffer. For the Viper user, -this simply means that in addition to the Vi textmarkers a--z, there is -another marker called @dfn{mark}. This is similar to the unnamed Vi marker -used by the jump commands (`` and ''), which move the cursor to the -position of the last absolute jump. -Viper provides access to the region in most -text manipulation commands as @kbd{r} and @kbd{R} suffix to commands -that operate on text regions, e.g., @kbd{dr} to delete region, etc. -@xref{Basics}, for more info.@refill - -@cindex window -@cindex mode line -@cindex buffer information -@cindex Minibuffer -@cindex command line -@cindex buffer (modified) - -Emacs divides the screen into tiled @dfn{windows}. You can see the -contents of a buffer through the window associated with the buffer. The -cursor of the screen is positioned on the character after @dfn{point}. -Every window has a @dfn{mode line} that displays information about the buffer. -You can change the format of the mode -line, but normally if you see @samp{**} at the beginning of a mode line it -means that the buffer is @dfn{modified}. If you write out the contents of -a buffer to a file, then the buffer will become not modified. Also if -you see @samp{%%} at the beginning of the mode line, it means that the file -associated with the buffer is write protected. The mode line will also -show the buffer name and current major and minor modes (see below). -A special buffer called @dfn{Minibuffer} is displayed as the last line -in a Minibuffer window. The Minibuffer window is used for command input -output. Viper uses Minibuffer window for @kbd{/} and @kbd{:} -commands.@refill - -@cindex mode -@cindex keymap -@cindex local keymap -@cindex global keymap -@cindex major mode -@cindex minor mode - -An Emacs buffer can have a @dfn{major mode} that customizes Emacs for -editing text of a particular sort by changing the functionality of the keys. -Keys are defined using a @dfn{keymap} that records the bindings between -keystrokes and -functions. The @dfn{global keymap} is common to all the -buffers. Additionally, each buffer has its @dfn{local keymap} that determines the -@dfn{mode} of the buffer. If a function is bound to some key in the local -keymap then that function will be executed when you type the key. -If no function is bound to a key in the -local map, however, the function bound to the key in the global map -will be executed. @xref{Major Modes,Major Modes,Major Modes,emacs,The -GNU Emacs Manual}, for more information.@refill - -A buffer can also have a @dfn{minor mode}. Minor modes are options that -you can use or not. A buffer in @code{text-mode} can have -@code{auto-fill-mode} as minor mode, which can be turned off or on at -any time. In Emacs, a minor mode may have it own keymap, -which overrides the local keymap when the minor mode is turned on. For -more information, @pxref{Minor Modes,Minor Modes,Minor Modes,emacs,The -GNU Emacs Manual} @refill - -@cindex Viper as minor mode -@cindex Control keys -@cindex Meta key - -Viper is implemented as a collection of minor modes. Different minor modes -are involved when Viper emulates Vi command mode, Vi insert mode, etc. -You can also turn Viper on and off at any time while in Vi command mode. -@xref{States in Viper}, for -more information.@refill - -Emacs uses Control and Meta modifiers. These are denoted as C and M, -e.g. @kbd{^Z} as @kbd{C-z} and @kbd{Meta-x} as @kbd{M-x}. The Meta key is -usually located on each side of the Space bar; it is used in a manner -similar to the Control key, e.g., @kbd{M-x} means typing @kbd{x} while -holding the Meta key down. For keyboards that do not have a Meta key, -@key{ESC} is used as Meta. Thus @kbd{M-x} is typed as @kbd{@key{ESC} -x}. Viper uses @key{ESC} to switch from Insert state to Vi state. Therefore -Viper defines @kbd{C-\} as its Meta key in Vi state. @xref{Vi State}, for -more info.@refill - -Emacs is structured as a lisp interpreter around a C core. Emacs keys -cause lisp functions to be called. It is possible to call these -functions directly, by typing @kbd{M-x function-name}. - -@node Loading Viper, States in Viper, Emacs Preliminaries, Overview -@section Loading Viper - -The most common way to load it automatically is to include the following -lines (in the given order!): - -@lisp -(setq viper-mode t) -(require 'viper) -@end lisp - -@noindent -in your @file{~/.emacs} file. The @file{.emacs} file is placed in your -home directory and it is be executed every time you invoke Emacs. This is -the place where all general Emacs customization takes place. Beginning with -version 20.0, Emacsen have an interactive interface, which simplifies the -job of customization significantly. - -Viper also uses the file @file{~/.viper} for Viper-specific customization. -If you wish to be in Vi command state whenever this is deemed appropriate -by the author, you can include the following line in your @file{.viper}: -@lisp -(setq viper-always t) -@end lisp -@noindent -(@xref{Vi State}, for the explanation of Vi command state.) - -The location of Viper customization file can be changed by setting the -variable @code{viper-custom-file-name} in @file{.emacs} @emph{prior} to loading -Viper. - -Once invoked, Viper will arrange to bring up Emacs buffers in Vi state -whenever this makes sense. -@xref{Packages that Change Keymaps}, to find out when forcing Vi command state -on a buffer may be counter-productive. - -Even if your @file{.emacs} and @file{.viper} files do not contain any of the -above lines, you can still load Viper and enter Vi command state by typing the -following from within Emacs: - -@lisp -M-x viper-mode -@end lisp - -When Emacs first comes up, if you have not specified a file on the -command line, it will show the @samp{*scratch*} buffer, in the -@samp{Lisp Interaction} mode. After you invoke Viper, you can start -editing files by using @kbd{:e}, @kbd{:vi}, or @kbd{v} commands. -(@xref{File and Buffer Handling}, for more information on @kbd{v} and other -new commands that, in many cases, are more convenient than @kbd{:e}, -@kbd{:vi}, and similar old-style Vi commands.)@refill - -Finally, if at some point you would want to get de-Viperize your running -copy of Emacs after Viper has been loaded, the command @kbd{M-x -viper-go-away} will do it for you. The function @code{toggle-viper-mode} -toggles Viperization of Emacs on and off. - -@node States in Viper, The Minibuffer, Loading Viper,Overview -@section States in Viper - -@kindex @kbd{C-z} -@kindex @key{ESC} -@kindex @kbd{i} -@cindex Emacs state -@cindex Vi state -@cindex Insert state -@cindex Replace state -@cindex Ex commands -@findex @code{viper-go-away} -@findex @code{toggle-viper-mode} - -Viper has four states, Emacs, Vi, Insert, and Replace. - -@table @samp -@item Emacs state -This is the state plain vanilla Emacs is normally in. After you have loaded -Viper, @kbd{C-z} will normally take you to Vi command state. Another -@kbd{C-z} will take you back to Emacs state. This toggle key can be -changed, @pxref{Customization} You can also type @kbd{M-x viper-mode} to -change to Vi state.@refill - - -For users who chose to set their user level to 1 at Viper setup time, -switching to Emacs state is deliberately made harder in order to not -confuse the novice user. In this case, @kbd{C-z} will either iconify Emacs -(if Emacs runs as an application under X Windows) or it will stop Emacs (if -Emacs runs on a dumb terminal or in an Xterm window). - -@item Vi state -This is the Vi command mode. Any of the Vi commands, such as @kbd{i, o, a}, -@dots{}, will take you to Insert state. All Vi commands may -be used in this mode. Most Ex commands can also be used. -For a full list of Ex commands supported by Viper, type -@kbd{:} and then @key{TAB}. To get help on any issue, including the Ex -commands, type @kbd{:help}. This will invoke Viper Info -(if it is installed). Then typing @kbd{i} will prompt you for a topic to -search in the index. Note, to search for Ex commands in the index, you -should start them with a ``@kbd{:}'', e.g., @kbd{:WW}. - -@item Insert state -Insert state is the Vi insertion mode. @key{ESC} will take you back to -Vi state. Insert state editing can be done, including auto-indentation. By -default, Viper disables Emacs keybindings in Insert state. - -@item Replace state -Commands like @kbd{cw} invoke the Replace state. When you cross the -boundary of a replacement region (usually designated via a @samp{$} sign), -it will automatically change to Insert state. You do not have to worry -about it. The key bindings remain practically the same as in Insert -state. If you type @key{ESC}, Viper will switch to Vi command mode, terminating the -replacement state. @refill -@end table - -@cindex mode line - -The modes are indicated on the @dfn{mode line} as <E>, <I>, <V>, and <R>, -so that the multiple modes do not confuse you. Most of your editing can be -done in Vi and Insert states. Viper will try to make all new buffers be in Vi -state, but sometimes they may come up in Emacs state. @kbd{C-z} -will take you to Vi state in such a case. In some major modes, like Dired, -Info, Gnus, etc., you should not switch to Vi state (and Viper will not -attempt to do so) because these modes are not intended for text editing and -many of the Vi keys have special meaning there. If you plan to read news, -browse directories, read mail, etc., from Emacs (which you should start -doing soon!), you should learn about the meaning of the various keys in -those special modes (typing @kbd{C-h m} in a buffer provides -help with key bindings for the major mode of that buffer). - -If you switch to Vi in Dired or similar modes---no harm is done. It is just -that the special keybindings provided by those modes will be temporarily -overshadowed by Viper's bindings. Switching back to Viper's Emacs state -will revive the environment provided by the current major mode. - -States in Viper are orthogonal to Emacs major modes, such as C mode or Dired -mode. You can turn Viper on and off for any Emacs state. When Viper is turned -on, Vi state can be used to move around. In Insert state, the bindings for -these modes can be accessed. For beginners (users at Viper levels 1 and 2), -these bindings are suppressed in Insert state, so that new users are not -confused by the Emacs states. Note that unless you allow Emacs bindings in -Insert state, you cannot do many interesting things, like language -sensitive editing. For the novice user (at Viper level 1), all major mode -bindings are turned off in Vi state as well. This includes the bindings for -key sequences that start with @kbd{C-c}, which practically means that all -major mode bindings are supported. @xref{Customization}, to find out how -to allow Emacs keys in Insert state. - -@menu -* Emacs State:: This is the state you should learn more about when - you get up to speed with Viper. -* Vi State:: Vi commands are executed in this state. -* Insert State:: You can enter text, and also can do sophisticated - editing if you know enough Emacs commands. -* Replace State:: Like Insert mode, but it is invoked via the - replacement commands, such as cw, C, R, etc. -@end menu - -@node Emacs State, Vi State, States in Viper, States in Viper -@subsection Emacs State - -@kindex @kbd{C-z} -@cindex Emacs state - - -You will be in this mode only by accident (hopefully). This is the state -Emacs is normally in (imagine!!). Now leave it as soon as possible by -typing @kbd{C-z}. Then you will be in Vi state (sigh of relief) :-). - -Emacs state is actually a Viperism to denote all the major and minor modes -(@xref{Emacs Preliminaries}) other than Viper that Emacs can be in. Emacs -can have several modes, such as C mode for editing C programs, LaTeX mode -for editing LaTeX documents, Dired for directory editing, etc. These are -major modes, each with a different set of key-bindings. Viper states are -orthogonal to these Emacs major modes. The presence of these language -sensitive and other modes is a major win over Vi. @xref{Improvements over -Vi}, for more.@refill - -The bindings for these modes can be made available in the Viper Insert state -as well as in Emacs state. Unless you specify your user level as 1 (a -novice), all major mode key sequences that start with @kbd{C-x} and -@kbd{C-c} are also available in Vi state. This is important because major -modes designed for editing files, such as cc-mode or latex-mode, use key -sequences that begin with @kbd{C-x} and @kbd{C-c}. - -There is also a key that lets you temporarily escape to Vi command state -from Emacs or Insert states: typing @kbd{C-c \} will let you execute a -single Vi command while staying in Viper's Emacs or Insert state. -In Insert state, the same can also be achieved by typing @kbd{C-z}. - - -@node Vi State, Insert State, Emacs State, States in Viper -@subsection Vi State - -@cindex Vi state - -This is the Vi command mode. When Viper is in Vi state, you will see the sign -<V> in the mode line. Most keys will work as in Vi. The notable -exceptions are: - -@table @kbd -@item C-x -@kindex @kbd{C-x} -@kbd{C-x} is used to invoke Emacs commands, mainly those that do window -management. @kbd{C-x 2} will split a window, @kbd{C-x 0} will close a -window. @kbd{C-x 1} will close all other windows. @kbd{C-xb} is used to -switch buffers in a window, and @kbd{C-xo} to move through windows. -These are about the only necessary keystrokes. -For the rest, see the GNU Emacs Manual. - -@item C-c -@kindex @kbd{C-c} -For user levels 2 and higher, this key serves as a prefix key for the key -sequences used by various major modes. For users at Viper level 1, @kbd{C-c} -simply beeps. - -@item C-g and C-] -@kindex @kbd{C-g} -@kindex @kbd{C-]} - -These are the Emacs @samp{quit} keys. -There will be cases where you will have to -use @kbd{C-g} to quit. Similarly, @kbd{C-]} is used to exit -@samp{Recursive Edits} in Emacs for which there is no comparable Vi -functionality and no key-binding. Recursive edits are indicated by -@samp{[]} brackets framing the modes on the mode line. -@xref{Recursive Edit,Recursive -Edit,Recursive Edit,emacs,The GNU Emacs Manual}. -At user level 1, @kbd{C-g} is bound to @code{viper-info-on-file} -function instead. -@refill -@item C-\ -@kindex @kbd{C-\} -@cindex Meta key - -Viper uses @key{ESC} as a switch between Insert and Vi states. Emacs uses -@key{ESC} for Meta. The Meta key is very important in Emacs since many -finctions are accessible only via that key as @kbd{M-x function-name}. -Therefore, we need to simulate it somehow. In Viper's Vi, Insert, and -Replace states, the meta key is set to be @kbd{C-\}. Thus, to get -@kbd{M-x}, you should type @kbd{C-\ x} (if the keyboard has no Meta key). -This works both in the Vi command state and in the Insert and Replace -states. In Vi command state, you can also use @kbd{\ @key{ESC}} as the -meta key. - -Note: Emacs binds @kbd{C-\} to a function that offers to change the -keyboard input method in the multilingual environment. Viper overrides this -binding. However, it is still possible to switch the input method by typing -@kbd{\ C-\} in the Vi command state and @kbd{C-z \ C-\} in the Insert state. -Or you can use the MULE menu in the menubar. -@end table -@noindent -Other differences are mostly improvements. The ones you should know -about are: - -@table @samp -@item Undo -@kindex @kbd{u} -@kbd{u} will undo. Undo can be repeated by the @kbd{.} key. Undo itself -can be undone. Another @kbd{u} will change the direction. The presence -of repeatable undo means that @kbd{U}, undoing lines, is not very -important. Therefore, @kbd{U} also calls @code{viper-undo}. -@cindex multiple undo -@cindex undo - - -@item Counts -Most commands, @kbd{~}, @kbd{[[}, @kbd{p}, @kbd{/}, @dots{}, etc., take counts. - -@comment ]] Just to balance parens -@item Regexps -Viper uses Emacs Regular Expressions for searches. These are a superset of -Vi regular -expressions, excepting the change-of-case escapes @samp{\u}, @samp{\L}, -@dots{}, etc. @xref{Regular Expressions,,Regular Expressions,emacs,The -GNU Emacs Manual}, for details. -Files specified to @kbd{:e} use @code{csh} regular expressions -(globbing, wildcards, what have you). -However, the function @code{viper-toggle-search-style}, bound to @kbd{C-c /}, -lets the user switch from search with regular expressions to plain vanilla -search and vice versa. It also lets one switch from case-sensitive search -to case-insensitive and back. -@xref{Viper Specials}, for more details. -@cindex regular expressions -@cindex vanilla search -@cindex case-sensitive search -@cindex case-insensitive search -@kindex @kbd{C-c /} - -@item Ex commands -@cindex Ex commands -The current working directory of a buffer is automatically inserted in the -minibuffer if you -type @kbd{:e} then space. -Absolute filenames are required less often in Viper. -For path names, -Emacs uses a convention that is slightly different from that of Unix. -It is designed to minimize the need for deleting path names that Emacs -provides in its prompts. (This is usually convenient, but occasionally -the prompt may suggest a wrong path name for you.) If you see a prompt -@kbd{/usr/foo/} and you wish to edit the file @kbd{~/.viper}, you don't -have to erase the prompt. Instead, simply continue typing what you -need. Emacs will interpret @kbd{/usr/foo/~/.viper} correctly. Similarly, -if the prompt is @kbd{~/foo/} and you need to get to @kbd{/bar/file}, keep -typing. Emacs interprets @kbd{~/foo//bar/} as @kbd{/bar/file}, since when it -sees @samp{//}, it understands that @kbd{~/foo/} is to be discarded. - -The command @kbd{:cd} will change the default directory for the -current buffer. The command @kbd{:e} will interpret the -filename argument in @code{csh}. @xref{Customization}, if you -want to change the default shell. -The command @kbd{:next} takes counts from -@kbd{:args}, so that @kbd{:rew} is obsolete. Also, @kbd{:args} will show only -the invisible files (i.e., those that are not currently seen in Emacs -windows). - -When applicable, Ex commands support file completion and history. This -means that by typing a partial file name and then @key{TAB}, Emacs will try -to complete the name or it will offer a menu of possible completions. -This works similarly to Tcsh and extends the behavior of Csh. While Emacs -is waiting for a file name, you can type @kbd{M-p} to get the previous file -name you typed. Repeatedly typing @kbd{M-p} and @kbd{M-n} will let you -browse through the file history. - -Like file names, partially typed Ex commands can be completed by typing -@key{TAB}, and Viper keeps the history of Ex commands. After typing -@kbd{:}, you can browse through the previously entered Ex commands by -typing @kbd{M-p} and @kbd{M-n}. Viper tries to rationalize when it puts Ex -commands on the history list. For instance, if you typed @kbd{:w! foo}, -only @kbd{:w!} will be placed on the history list. This is because the -last history element is the default that can be invoked simply by typing -@kbd{: @key{RET}}. If @kbd{:w! foo} were placed on the list, it would be all to -easy to override valuable data in another file. Reconstructing the full -command, @kbd{:w! foo}, from the history is still not that hard, since Viper -has a separate history for file names. By typing @kbd{: M-p}, you will get -@kbd{:w!} in the Minibuffer. Then, repeated @kbd{M-p} will get you through -the file history, inserting one file name after another. - -In contrast to @kbd{:w! foo}, if the command were @kbd{:r foo}, the entire -command will appear in the history list. This is because having @kbd{:r} -alone as a default is meaningless, since this command requires a file -argument. -@refill -@end table -@noindent -As Vi, Viper's destructive commands can be re-executed by typing `@kbd{.}'. -However, in addition, Viper keeps track of the history of such commands. This -history can be perused by typing @kbd{C-c M-p} and @kbd{C-c M-n}. -Having found the appropriate command, it can be then executed by typing -`@kbd{.}'. -@xref{Improvements over Vi}, for more information. - -@node Insert State, Replace State, Vi State, States in Viper -@subsection Insert State - -@cindex Insert state - -To avoid confusing the beginner (at Viper level 1 and 2), Viper makes only the -standard Vi keys available in Insert state. The implication is that -Emacs major modes cannot be used Insert state. -It is strongly recommended that as soon as you are comfortable, make the -Emacs state bindings visible (by changing your user level to 3 or higher). -@xref{Customization}, -to see how to do this.@refill - -Once this is done, it is possible to do quite a bit of editing in -Insert state. For instance, Emacs has a @dfn{yank} command, @kbd{C-y}, -which is similar to Vi's @kbd{p}. However, unlike @kbd{p}, @kbd{C-y} can be -used in Insert state of Viper. Emacs also has a kill ring where it keeps -pieces of text you deleted while editing buffers. The command @kbd{M-y} is -used to delete the text previously put back by Emacs' @kbd{C-y} or by Vi's -@kbd{p} command and reinsert text that was placed on the kill-ring earlier. - -This works both in Vi and Insert states. -In Vi state, @kbd{M-y} is a much better alternative to the usual Vi's way -of recovering the 10 previously deleted chunks of text. In Insert state, -you can -use this as follows. Suppose you deleted a piece of text and now you need -to re-insert it while editing in Insert mode. The key @kbd{C-y} will put -back the most recently deleted chunk. If this is not what you want, type -@kbd{M-y} repeatedly and, hopefully, you will find the chunk you want. - -Finally, in Insert and Replace states, Viper provides the history of -pieces of text inserted in previous insert or replace commands. These -strings of text can be recovered by repeatedly typing @kbd{C-c M-p} or -@kbd{C-c M-n} while in Insert or Replace state. (This feature is disabled -in the minibuffer: the above keys are usually bound to other histories, -which are more appropriate in the minibuffer.) - - -@cindex Meta key - -You can call Meta functions from Insert state. As in Vi state, the Meta key -is @kbd{C-\}. Thus @kbd{M-x} is typed as @kbd{C-\ x}. - -Other Emacs commands that are useful in Insert state are @kbd{C-e} -and @kbd{C-a}, which move the cursor to the end and the beginning of the -current line, respectively. You can also use @kbd{M-f} and @kbd{M-b}, -which move the cursor forward (or backward) one word. -If your display has a Meta key, these functions are invoked by holding the -Meta key and then typing @kbd{f} and @kbd{b}, respectively. On displays -without the Meta key, these functions are invoked by typing -@kbd{C-\ f} and @kbd{C-\ b} (@kbd{C-\} simulates the Meta key in Insert -state, as explained above). - -The key @kbd{C-z} is sometimes also useful in Insert state: it allows you -to execute a single command in Vi state without leaving the Insert state! -For instance, @kbd{C-z d2w} will delete the next two words without leaving -the Insert state. - -When Viper is in Insert state, you will see <I> in the mode line. - -@node Replace State,, Insert State, States in Viper -@subsection Replace State - -@cindex Replace state - -This state is entered through Vi replacement commands, such as @kbd{C}, -@kbd{cw}, etc., or by typing @kbd{R}. In Replace state, Viper puts <R> in -the mode line to let you know which state is in effect. If Replace state is -entered through @kbd{R}, Viper stays in that state until the user hits -@key{ESC}. If this state is entered via the other replacement commands, -then Replace state is in effect until you hit @key{ESC} or until you cross -the rightmost boundary of the replacement region. In the latter case, Viper -changes its state from Replace to Insert (which you will notice by the -change in the mode line). - -Since Viper runs under Emacs, it is possible to switch between buffers -while in Replace state. You can also move the cursor using the arrow keys -(even on dumb terminals!) and the mouse. Because of this freedom (which is -unattainable in regular Vi), it is possible to take the cursor outside the -replacement region. (This may be necessary for several reasons, including -the need to enable text selection and region-setting with the mouse.) - -The issue then arises as to what to do when the user -hits the @key{ESC} key. In Vi, this would cause the text between cursor and -the end of the replacement region to be deleted. But what if, as is -possible in Viper, the cursor is not inside the replacement region? - -To solve the problem, Viper keeps track of the last cursor position while it -was still inside the replacement region. So, in the above situation, Viper -would delete text between this position and the end of the replacement -region. - -@node The Minibuffer,Multiple Files in Viper, States in Viper, Overview -@section The Minibuffer - -@cindex Minibuffer - -The Minibuffer is where commands are entered in. Editing can be done -by commands from Insert state, namely: - -@table @kbd -@item C-h -Backspace -@item C-w -Delete Word -@item C-u -Erase line -@item C-v -Quote the following character -@item @key{RET} -Execute command -@item C-g and C-] -Emacs quit and abort keys. These may be necessary. @xref{Vi State}, for an -explanation. -@item M-p and M-n -These keys are bound to functions that peruse minibuffer history. The -precise history to be perused depends on the context. It may be the history -of search strings, Ex commands, file names, etc. -@end table - -Most of the Emacs keys are functional in the Minibuffer. While in the -Minibuffer, Viper tries to make editing resemble Vi's behavior when the -latter is waiting for the user to type an Ex command. In particular, you -can use the regular Vi commands to edit the Minibuffer. You can switch -between the Vi state and Insert state at will, and even use the replace mode. -Initially, the Minibuffer comes up in Insert state. - -Some users prefer plain Emacs bindings in the Minibuffer. To this end, set -@code{viper-vi-style-in-minibuffer} to @code{nil} in @file{.viper}. -@xref{Customization}, to learn how to do this. - -When the Minibuffer changes Viper states, you will notice that the appearance -of the text there changes as well. This is useful because the Minibuffer -has no mode line to tell which Vi state it is in. -The appearance of the text in the Minibuffer can be changed. -@xref{Viper Specials}, for more details. - -@node Multiple Files in Viper,Unimplemented Features,The Minibuffer,Overview -@section Multiple Files in Viper - -@cindex multiple files -@cindex managing multiple files - -Viper can edit multiple files. This means, for example that you never need -to suffer through @code{No write since last change} errors. -Some Viper elements are common over all the files. - -@table @samp -@item Textmarkers -@cindex markers -@cindex textmarkers -Textmarkers remember @emph{files and positions}. -If you set marker @samp{a} in -file @file{foo}, start editing file @file{bar} and type @kbd{'a}, then -@emph{YOU WILL SWITCH TO FILE @file{foo}}. You can see the contents of a -textmarker using the Viper command @kbd{[<a-z>} where <a-z> are the -textmarkers, e.g., @kbd{[a} to view marker @samp{a} .@refill -@item Repeated Commands -Command repetitions are common over files. Typing @kbd{!!} will repeat the -last @kbd{!} command whichever file it was issued from. -Typing @kbd{.} will repeat the last command from any file, and -searches will repeat the last search. Ex commands can be repeated by typing -@kbd{: @key{RET}}.@refill -Note: in some rare cases, that @kbd{: @key{RET}} may do something dangerous. -However, usually its effect can be undone by typing @kbd{u}. -@item Registers -@cindex registers -Registers are common to files. Also, text yanked with @kbd{y} can be -put back (@kbd{p}) into any file. The Viper command @kbd{]<a-z>}, where <a-z> are -the registers, can be used to look at the contents of a register, e.g., -type @kbd{]a} to view register @samp{a}. - -There is one difference in text deletion that you should be -aware of. This difference comes from Emacs and was adopted in Viper -because we find it very useful. In Vi, if you delete a line, say, and then -another line, these two deletions are separated and are put back -separately if you use the @samp{p} command. In Emacs (and Viper), successive -series of deletions that are @emph{not interrupted} by other commands are -lumped together, so the deleted text gets accumulated and can be put back -as one chunk. If you want to break a sequence of deletions so that the -newly deleted text could be put back separately from the previously deleted -text, you should perform a non-deleting action, e.g., move the cursor one -character in any direction. -@item Absolute Filenames -@cindex absolute paths -The current directory name for a file is automatically prepended to the -file name in any -@kbd{:e}, @kbd{:r}, @kbd{:w}, etc., command (in Emacs, each buffer has a -current directory). -This directory is inserted in the Minibuffer once you type space after -@kbd{:e, r}, etc. Viper also supports completion of file names and Ex -commands (@key{TAB}), and it keeps track of -command and file history (@kbd{M-p}, @kbd{M-n}). -Absolute filenames are required less -often in Viper. - -You should be aware that Emacs interprets @kbd{/foo/bar//bla} as -@kbd{/bla} and @kbd{/foo/~/bar} as @kbd{~/bar}. This is designed to -minimize the need for erasing path names that Emacs suggests in its -prompts, if a suggested path name is not what you wanted. - -The command @kbd{:cd} will change the default directory for the -current Emacs buffer. The Ex command @kbd{:e} will interpret the -filename argument in @samp{csh}, by default. @xref{Customization}, if you -want to change this. -@end table - -@noindent -Currently undisplayed files can be listed using the @kbd{:ar} command. The -command @kbd{:n} can be given counts from the @kbd{:ar} list to switch to -other files. - -@node Unimplemented Features,,Multiple Files in Viper,Overview -@section Unimplemented Features - -Unimplemented features include: - -@itemize @bullet -@item -@kbd{:ab} and @kbd{:una} are not implemented. -Both @kbd{:map} and @kbd{:ab} are considered obsolete, since Emacs has much -more powerful facilities for defining keyboard macros and abbreviations. -@item -@kbd{:set option?} is not implemented. The current -@kbd{:set} can also be used to set Emacs variables. -@item -@kbd{:se list} requires modification of the display code for Emacs, so -it is not implemented. -A useful alternative is @code{cat -t -e file}. Unfortunately, it cannot -be used directly inside Emacs, since Emacs will obdurately change @samp{^I} -back to normal tabs.@refill -@end itemize - -@comment node-name, next, previous, up -@node Improvements over Vi, Customization, Overview, Top -@chapter Improvements over Vi - -Some common problems with Vi and Ex have been solved in Viper. This -includes better implementation of existing commands, new commands, and -the facilities provided by Emacs. - -@menu -* Basics:: Basic Viper differences, Multi-file effects. -* Undo and Backups:: Multiple undo, auto-save, backups and changes -* History:: History for Ex and Vi commands. -* Macros and Registers:: Keyboard Macros (extended ".") @@reg execution. -* Completion:: Filename and Command Completion for Ex. -* Improved Search:: Incremental Search and Buffer Content Search. -* Abbreviation Facilities:: Normal Abbrevs, Templates, and Dynamic Abbrevs. -* Movement and Markers:: Screen Editor movements, viewing textmarkers. -* New Commands:: Commands that do not exist in Vi. -* Useful Packages:: A Sampling of some Emacs packages, and things - you should know about. -@end menu - -@node Basics, Undo and Backups, Improvements over Vi, Improvements over Vi -@section Basics - -The Vi command set is based on the idea of combining motion commands -with other commands. The motion command is used as a text region -specifier for other commands. -We classify motion commands into @dfn{point commands} and -@dfn{line commands}.@refill - -@cindex point commands - -The point commands are: - -@quotation -@kbd{h}, @kbd{l}, @kbd{0}, @kbd{$}, @kbd{w}, @kbd{W}, @kbd{b}, @kbd{B}, -@kbd{e}, @kbd{E}, @kbd{(}, @kbd{)}, @kbd{/}, @kbd{?}, @kbd{`}, @kbd{f}, -@kbd{F}, @kbd{t}, @kbd{T}, @kbd{%}, @kbd{;}, @kbd{,}, @kbd{^} -@end quotation - -@cindex line commands - -The line commands are: - -@quotation -@kbd{j}, @kbd{k}, @kbd{+}, @kbd{-}, @kbd{H}, @kbd{M}, @kbd{L}, @kbd{@{}, -@kbd{@}}, @kbd{G}, @kbd{'}, @kbd{[[}, @kbd{]]}, @kbd{[]} -@end quotation - -@cindex region -@cindex region specification -@cindex expanding (region) -@cindex describing regions -@cindex movement commands - -@noindent -If a point command is given as an argument to a modifying command, the -region determined by the point command will be affected by the modifying -command. On the other hand, if a line command is given as an argument to a -modifying command, the region determined by the line command will be -enlarged so that it will become the smallest region properly containing the -region and consisting of whole lines (we call this process @dfn{expanding -the region}), and then the enlarged region will be affected by the modifying -command. -Text Deletion Commands (@xref{Deleting Text}), Change commands -(@xref{Changing Text}), even Shell Commands (@xref{Shell Commands}) -use these commands to describe a region of text to operate on. -Thus, type @kbd{dw} to delete a word, @kbd{>@}} to shift a paragraph, or -@kbd{!'afmt} to format a region from @samp{point} to textmarker -@samp{a}. - -@cindex r and R region specifiers - -Viper adds the region specifiers @samp{r} and @samp{R}. Emacs has a -special marker called @dfn{mark}. The text-area between the current cursor -position @dfn{point} and the @dfn{mark} is called the @dfn{region}. -@samp{r} specifies the raw region and @samp{R} is the expanded region -(i.e., the minimal contiguous chunk of full lines that contains the raw -region). -@kbd{dr} will now delete the region, @kbd{>r} will shift it, etc. -@kbd{r,R} are not motion commands, however. The special mark is set by -@kbd{m.} and other commands. @xref{Marking}, for more info. - -Viper also adds counts to most commands for which it would make sense. - -In the Overview chapter, some Multiple File issues were discussed -(@xref{Multiple Files in Viper}). In addition to the files, Emacs has -buffers. These can be seen in the @kbd{:args} list and switched using -@kbd{:next} if you type @kbd{:set ex-cycle-through-non-files t}, or -specify @code{(setq ex-cycle-through-non-files t)} in your @file{.viper} -file. @xref{Customization}, for details. - -@node Undo and Backups, History, Basics, Improvements over Vi -@section Undo and Backups - -@cindex undo - -Viper provides multiple undo. The number of undo's and the size is limited -by the machine. The Viper command @kbd{u} does an undo. Undo can be -repeated by typing @kbd{.} (a period). Another @kbd{u} will undo the undo, -and further -@kbd{.} will repeat it. Typing @kbd{u} does the first undo, and changes the -direction. - -@cindex backup files -@cindex auto save - -Since the undo size is limited, Viper can create backup files and -auto-save files. It will normally do this automatically. It is possible -to have numbered backups, etc. For details, @pxref{Backup,,Backup and -Auto-Save,emacs,The GNU Emacs Manual} @refill - -@comment [ balance parens -@cindex viewing registers and markers -@cindex registers -@cindex markers -@cindex textmarkers - -The results of the 9 previous changes are available in the 9 numeric -registers, as in Vi. The extra goody is the ability to @emph{view} these -registers, in addition to being able to access them through @kbd{p} and -@kbd{M-y} (@xref{Insert State}, for details.) -The Viper command @kbd{] register} will display the contents of any -register, numeric or alphabetical. The related command @kbd{[ textmarker} -will show the text around the textmarker. @samp{register} and @samp{textmarker} -can be any letters from a through z. -@comment ] balance parens - -@node History, Macros and Registers, Undo and Backups,Improvements over Vi -@section History - -@cindex history -@cindex Minibuffer - -History is provided for Ex commands, Vi searches, file names, pieces of -text inserted in earlier commands that use Insert or Replace state, and for -destructive commands in Vi state. These are -useful for fixing those small typos that screw up searches and @kbd{:s}, -and for eliminating routine associated with repeated typing of file names -or pieces of text that need to be inserted frequently. -At the @kbd{:} or @kbd{/} prompts in the Minibuffer, you can do the following: - -@table @kbd -@item M-p and M-n -To move to previous and next history items. This causes the history -items to appear on the command line, where you can edit them, or -simply type Return to execute. -@item M-r and M-s -To search backward and forward through the history. -@item @key{RET} -Type @key{RET} to accept a default (which is displayed in the prompt). -@end table - -The history of insertions can be perused by -typing @kbd{C-c M-p} and @kbd{C-c M-n} while in Insert or Replace state. -The history of destructive Vi commands can be perused via the same keys -when Viper is in Vi state. @xref{Viper Specials}, for details. - -All Ex commands have a file history. For instance, typing @kbd{:e}, space -and then @kbd{M-p} will bring up the name of the previously typed file -name. Repeatedly typing @kbd{M-p}, @kbd{M-n}, etc., will let you browse -through the file history. - -Similarly, commands that have to do with switching buffers -have a buffer history, and commands that expect strings or regular -expressions keep a history on those items. - -@node Macros and Registers,Completion,History,Improvements over Vi -@section Macros and Registers - -@cindex keyboard macros -@cindex macros -@cindex registers -@cindex register execution - -Viper facilitates the use of Emacs-style keyboard macros. @kbd{@@#} will -start a macro definition. As you type, the commands will be executed, and -remembered (This is called ``learn mode'' in some editors.) -@kbd{@@register} will complete the macro, putting it into @samp{register}, -where @samp{register} is any character from @samp{a} through @samp{z}. Then -you can execute this macro using @kbd{@@register}. It is, of course, -possible to yank some text into a register and execute it using -@kbd{@@register}. Typing @kbd{@@@@}, @kbd{@@RET}, or @kbd{@@C-j} will -execute the last macro that was executed using @kbd{@@register}.@refill - -Viper will automatically lowercase the register, so that pressing the -@kbd{SHIFT} key for @kbd{@@} will not create problems. This is for -@kbd{@@} macros and @kbd{"p} @emph{only}. In the case of @kbd{y}, -@kbd{"Ayy} will append to @emph{register a}. For @kbd{[,],',`}, it -is an error to use a Uppercase register name. - -@comment [ balance parens -@cindex viewing registers and markers - -The contents of a register can be seen by @kbd{]register}. (@kbd{[textmarker} -will show the contents of a textmarker). -@comment ] balance parens - -@cindex last keyboard macro - -The last keyboard macro can also be executed using -@kbd{*}, and it can be yanked into a register using @kbd{@@!register}. -This is useful for Emacs style keyboard macros defined using @kbd{C-x(} -and @kbd{C-x)}. Emacs keyboard macros have more capabilities. -@xref{Keyboard Macros,,Keyboard Macros,emacs, The GNU Emacs Manual}, for -details.@refill - -Keyboard Macros allow an interesting form of Query-Replace: -@kbd{/pattern} or @kbd{n} to go to the next pattern (the query), followed by a -Keyboard Macro execution @kbd{@@@@} (the replace). - -Viper also provides Vi-style macros. @xref{Vi Macros}, for details. - - -@node Completion, Improved Search, Macros and Registers, Improvements over Vi -@section Completion - -@cindex completion - -Completion is done when you type @key{TAB}. The Emacs completer does not -grok wildcards in filenames. Once you type a wildcard, the completer will -no longer work for that path. Remember that Emacs interprets a file name -of the form @kbd{/foo//bar} as @kbd{/bar} and @kbd{/foo/~/bar} as -@kbd{~/bar}. - -@node Improved Search, Abbreviation Facilities, Completion, Improvements over Vi -@section Improved Search - -@cindex buffer search -@cindex word search - -Viper provides buffer search, the ability to search the buffer for a region -under the cursor. You have to turn this on in @file{.viper} either by calling - -@example -(viper-buffer-search-enable) -@end example - -@noindent -or by setting @code{viper-buffer-search-char} to, say, @kbd{f3}: -@example -(setq viper-buffer-search-char [f3]) -@end example - -@noindent -If the user calls @code{viper-buffer-search-enable} explicitly (the first -method), then @code{viper-buffer-search-char} will be set to @kbd{g}. -Regardless of how this feature is enabled, the key -@code{viper-buffer-search-char} will take movement commands, like -@kbd{w,/,e}, to find a region and then search for the contents of that -region. This command is very useful for searching for variable names, etc., -in a program. The search can be repeated by @kbd{n} or reversed by @kbd{N}. - -@cindex incremental search - -Emacs provides incremental search. As you type the string in, the -cursor will move to the next match. You can snarf words from the buffer -as you go along. Incremental Search is normally bound to @kbd{C-s} and -@kbd{C-r}. @xref{Customization}, to find out how to change the bindings -of @kbd{C-r or C-s}. -For details, @pxref{Incremental Search,,Incremental -Search,emacs,The GNU Emacs Manual} @refill - -@cindex query replace - -Viper also provides a query replace function that prompts through the -Minibuffer. It is invoked by the @kbd{Q} key in Vi state. - -@cindex mouse search - -On a window display, Viper supports mouse search, i.e., you can search for a -word by clicking on it. @xref{Viper Specials}, for details. - -Finally, on a window display, Viper highlights search patterns as it finds -them. This is done through what is known as @emph{faces} in Emacs. The -variable that controls how search patterns are highlighted is -@code{viper-search-face}. If you don't want any highlighting at all, put -@example -(copy-face 'default 'viper-search-face) -@end example -@vindex @code{viper-search-face} -@noindent -in @file{~/.viper}. If you want to change how patterns are highlighted, you -will have to change @code{viper-search-face} to your liking. The easiest -way to do this is to use Emacs customization widget, which is accessible -from the menubar. Viper customization group is located under the -@emph{Emulations} customization group, which in turn is under the -@emph{Editing} group. All Viper faces are grouped together under Viper's -@emph{Highlighting} group. - -Try it: it is really simple! - -@node Abbreviation Facilities,Movement and Markers,Improved Search,Improvements over Vi -@section Abbreviation Facilities - -@cindex abbrevs - -It is possible in Emacs to define abbrevs based on the contents of the -buffer. -Sophisticated templates can be defined using the Emacs abbreviation -facilities. @xref{Abbrevs,,Abbreviations,emacs,The GNU Emacs Manual}, for -details. - -@cindex dynamic abbrevs - -Emacs also provides Dynamic Abbreviations. Given a partial word, Emacs -will search the buffer to find an extension for this word. For instance, -one can type @samp{Abbreviations} by typing @samp{A}, followed by a keystroke -that completed the @samp{A} to @samp{Abbreviations}. Repeated typing -will search further back in the buffer, so that one could get -@samp{Abbrevs} by repeating the -keystroke, which appears earlier in the text. Emacs binds this to -@kbd{@key{ESC} /}, so you will have to find a key and bind the function -@code{dabbrev-expand} to that key. -Facilities like this make Vi's @kbd{:ab} command obsolete. - -@node Movement and Markers, New Commands, Abbreviation Facilities, Improvements over Vi -@section Movement and Markers - -@cindex Ex style motion -@cindex line editor motion - -Viper can be set free from the line--limited movements in Vi, such as @kbd{l} -refusing to move beyond the line, @key{ESC} moving one character back, -etc. These derive from Ex, which is a line editor. If your @file{.viper} -contains - -@example -@code{(setq viper-ex-style-motion nil)} -@end example - -@noindent -the motion will be a true screen editor motion. One thing you must then -watch out for is that it is possible to be on the end-of-line character. -The keys @kbd{x} and @kbd{%} will still work correctly, i.e., as if they -were on the last character. - -@vindex @code{viper-syntax-preference} -@cindex syntax table - -The word-movement commands @kbd{w}, @kbd{e}, etc., and the associated -deletion/yanking commands, @kbd{dw}, @kbd{yw}, etc., can be made to -understand Emacs syntax tables. If the variable -@code{viper-syntax-preference} is set to @code{strict-vi} then -the meaning of @emph{word} is the same as in -Vi. However, if the value is @code{reformed-vi} (the default) then the -alphanumeric symbols will be those specified by the current Emacs syntax -table (which may be different for different major modes) plus the -underscore symbol @kbd{_}, minus some non-word symbols, like '.;,|, etc. -Both @code{strict-vi} and @code{reformed-vi} work close to Vi in -traditional cases, but @code{reformed-vi} does a better job when editing -text in non-Latin alphabets. - -The user can also specify the value @code{emacs}, which would -make Viper use exactly the Emacs notion of word. In particular, the -underscore may not be part of a word. Finally, if -@code{viper-syntax-preference} is set to @code{extended}, Viper words would -consist of characters that are classified as alphanumeric @emph{or} as -parts of symbols. This is convenient for writing programs and in many other -situations. - -@code{viper-syntax-preference} is a local variable, so it can have different -values for different major modes. For instance, in programming modes it can -have the value @code{extended}. In text modes where words contain special -characters, such as European (non-English) letters, Cyrillic letters, etc., -the value can be @code{reformed-vi} or @code{emacs}. - -Changes to @code{viper-syntax-preference} should be done in the hooks to -various major modes by executing @code{viper-set-syntax-preference} as in -the following example: - -@example -(viper-set-syntax-preference nil "emacs") -@end example - -@findex @code{viper-set-syntax-preference} - -The above discussion of the meaning of Viper's words concerns only Viper's -movement commands. In regular expressions, words remain the same as in -Emacs. That is, the expressions @code{\w}, @code{\>}, @code{\<}, etc., use -Emacs' idea of what is a word, and they don't look into the value of -variable @code{viper-syntax-preference}. This is because Viper doesn't change -syntax tables in fear of upsetting the various major modes that set these -tables. - -@cindex textmarkers - -Textmarkers in Viper remember the file and the position, so that you can -switch files by simply doing @kbd{'a}. If you set up a regimen for using -Textmarkers, this is very useful. Contents of textmarkers can be viewed -by @kbd{[marker}. (Contents of registers can be viewed by @kbd{]register}). - -@node New Commands, Useful Packages, Movement and Markers, Improvements over Vi -@section New Commands - -These commands have no Vi analogs. - -@table @kbd -@item C-x, C-c -@kindex @kbd{C-x} -@kindex @kbd{C-c} -These two keys invoke many important Emacs functions. For example, if you -hit @kbd{C-x} followed by @kbd{2}, then the current window will be split -into 2. Except for novice users, @kbd{C-c} is also set to execute an Emacs -command from the current major mode. @key{ESC} will do the same, if you -configure @key{ESC} as Meta by setting @code{viper-no-multiple-ESC} to nil -in @file{.viper}. @xref{Customization}. @kbd{C-\} in Insert, Replace, or Vi -states will make Emacs think @kbd{Meta} has been hit.@refill -@item \ -@kindex @kbd{\} -Escape to Emacs to execute a single Emacs command. For instance, -@kbd{\ @key{ESC}} will act like a Meta key. -@item Q -@kindex @kbd{Q} -@cindex query replace -@kbd{Q} is for query replace. By default, -each string to be replaced is treated as a regular expression. You can use -@code{(setq viper-re-query-replace nil)} in your @file{.emacs} file to -turn this off. (For normal searches, @kbd{:se nomagic} will work. Note -that @kbd{:se nomagic} turns Regexps off completely, unlike Vi). -@item v -@itemx V -@itemx C-v -@kindex @kbd{v} -@kindex @kbd{V} -@kindex @kbd{C-v} -These keys are used to visit files. @kbd{v} will switch to a buffer -visiting file whose name can be entered in the Minibuffer. @kbd{V} is -similar, but will use a window different from the current window. -@kbd{C-v} is like @kbd{V}, except that a new frame (X window) will be used -instead of a new Emacs window. -@item # -@kindex @kbd{#} -If followed by a certain character @var{ch}, it becomes an operator whose -argument is the region determined by the motion command that follows -(indicated as <move>). -Currently, @var{ch} can be one of @kbd{c}, @kbd{C}, @kbd{g}, @kbd{q}, and -@kbd{s}. For instance, @kbd{#qr} will prompt you for a string and then -prepend this string to each line in the buffer.@refill -@item # c -@kindex @kbd{#c<move>} -@cindex changing case -Change upper-case characters in the region to lower-case -(@code{downcase-region}). -Emacs command @kbd{M-l} does the same for words. -@item # C -@kindex @kbd{#C<move>} -Change lower-case characters in the region to upper-case. For instance, -@kbd{# C 3 w} will capitalize 3 words from the current point -(@code{upcase-region}). -Emacs command @kbd{M-u} does the same for words. -@item # g -@kindex @kbd{#g<move>} -Execute last keyboard macro for each line in the region -(@code{viper-global-execute}).@refill -@item # q -@kindex @kbd{#q<move>} -Insert specified string at the beginning of each line in the region -(@code{viper-quote-region}). -@item # s -@kindex @kbd{#s<move>} -Check spelling of words in the region (@code{spell-region}). -The function used for spelling is determined from the variable -@code{viper-spell-function}. -@vindex @code{viper-spell-function} -@item * -@kindex @kbd{*} -Call last keyboard macro. -@item m . -Set mark at point and push old mark off the ring -@item m< -@item m> -Set mark at beginning and end of buffer, respectively. -@item m, -Jump to mark and pop mark off the ring. @xref{Mark,,Mark,emacs,The GNU -Emacs Manual}, for more info. -@item ] register -@kindex @kbd{]<a-z>} -View contents of register -@item [ textmarker -@kindex @kbd{[<a-z>} -View filename and position of textmarker -@item @@# -@item @@register -@item @@! -@kindex @kbd{@@#} -@kindex @kbd{@@<a-z>} -@kindex @kbd{@@!} -@cindex keyboard macros -@cindex register execution - -Begin/end keyboard macro. @@register has a different meaning when used after -a @kbd{@@#}. @xref{Macros and Registers}, for details -@item [] -@kindex @kbd{[]} -Go to end of heading. -@item g <@emph{movement command}> -Search buffer for text delimited by movement command. The canonical -example is @kbd{gw} to search for the word under the cursor. -@xref{Improved Search}, for details.@refill -@item C-g and C-] -@kindex @kbd{C-g} -@kindex @kbd{C-]} -Quit and Abort Recursive edit. These may be necessary on occasion. -@xref{Vi State}, for a reason. -@item C-c g -@kindex @kbd{C-c g} -Hitting @kbd{C-c} followed by @kbd{g} will display the information on the -current buffer. This is the same as hitting @kbd{C-g} in Vi, but, as -explained above, @kbd{C-g} is needed for other purposes in Emacs. -@item C-c / -@kindex @kbd{C-c /} -Without a prefix argument, this command toggles -case-sensitive/case-insensitive search modes and plain vanilla/regular -expression search. With the prefix argument 1, i.e., -@kbd{1 C-c /}, this toggles case-sensitivity; with the prefix argument 2, -toggles plain vanilla search and search using -regular expressions. @xref{Viper Specials}, for alternative ways to invoke -this function. -@cindex vanilla search -@cindex case-sensitive search -@cindex case-insensitive search - -@item M-p and M-n -@kindex @kbd{M-p} -@kindex @kbd{M-n} -In the Minibuffer, these commands navigate through the minibuffer -histories, such as the history of search strings, Ex commands, etc. - -@item C-c M-p and C-c M-n -@kindex @kbd{C-c M-p} -@kindex @kbd{C-c M-n} -@cindex Insertion history -@cindex Insertion ring -@cindex Command history -@cindex Command ring - -In Insert or Replace state, these commands let the user -peruse the history of insertion strings used in previous insert or replace -commands. Try to hit @kbd{C-c M-p} or @kbd{C-c M-n} repeatedly and see what -happens. @xref{Viper Specials}, for more. - -In Vi state, these commands let the user peruse the history of Vi-style -destructive commands, such as @kbd{dw}, @kbd{J}, @kbd{a}, etc. -By repeatedly typing @kbd{C-c M-p} or @kbd{C-c M-n} you will cycle Viper -through the recent history of Vi commands, displaying the commands one by -one. Once -an appropriate command is found, it can be executed by typing `@kbd{.}'. - -Since typing @kbd{C-c M-p} is tedious, it is more convenient to bind an -appropriate function to a function key on the keyboard and use that key. -@xref{Viper Specials}, for details. - -@item Ex commands -@findex @kbd{:args} -@findex @kbd{:n} -@findex @kbd{:pwd} -@findex @kbd{:pre} -The commands @kbd{:args}, @kbd{:next}, @kbd{:pre} behave -differently. @kbd{:pwd} exists to get current directory. -The commands @kbd{:b} and @kbd{:B} switch buffers around. @xref{File and -Buffer Handling}, for details. -There are also the new commands @kbd{:RelatedFile} and -@kbd{PreviousRelatedFile} (which abbreviate to @kbd{R} and @kbd{P}, -respectively. @xref{Viper Specials}, for details. -@findex @kbd{:RelatedFile} -@findex @kbd{:PreviousRelatedFile} -@end table - -Apart from the new commands, many old commands have been enhanced. Most -notably, Vi style macros are much more powerful in Viper than in Vi. @xref{Vi -Macros}, for details. - -@node Useful Packages, ,New Commands, Improvements over Vi -@section Useful Packages - -Some Emacs packages are mentioned here as an aid to the new Viper user, to -indicate what Viper is capable of. -A vast number comes with the standard Emacs distribution, and many more exist -on the net and on the archives. - -This manual also mentions some Emacs features a new user -should know about. The details of these are found in the GNU Emacs -Manual. - -The features first. For details, look up the Emacs Manual. - -@table @samp -@item Make -@cindex make -@cindex compiling - -Makes and Compiles can be done from the editor. Error messages will be -parsed and you can move to the error lines. -@item Shell -@cindex shell -@cindex interactive shell -You can talk to Shells from inside the editor. Your entire shell session -can be treated as a file. -@item Mail -@cindex email -@cindex mail -Mail can be read from and sent within the editor. Several sophisticated -packages exist. -@item Language Sensitive Editing -Editing modes are written for most computer languages in existence. By -controlling indentation, they catch punctuation errors. -@end table - -The packages, below, represents a drop in the sea of special-purpose -packages that come with standard distribution of Emacs. - -@table @samp -@item Transparent FTP -@cindex transparent ftp -@pindex ange-ftp.el -@code{ange-ftp.el} can ftp from the editor to files on other machines -transparent to the user. -@item RCS Interfaces -@cindex version maintenance -@cindex RCS -@pindex vc.el -@code{vc.el} for doing RCS commands from inside the editor -@item Directory Editor -@cindex dired -@pindex dired.el -@code{dired.el} for editing contents of directories and for navigating in -the file system. -@item Syntactic Highlighting -@cindex font-lock -@pindex font-lock.el -@code{font-lock.el} for automatic highlighting various parts of a buffer -using different fonts and colors. -@item Saving Emacs Configuration -@cindex desktop -@pindex desktop.el -@code{desktop.el} for saving/restoring configuration on Emacs exit/startup. -@item Spell Checker -@cindex ispell -@pindex ispell.el -@code{ispell.el} for spell checking the buffer, words, regions, etc. -@item File and Buffer Comparison -@cindex ediff -@pindex ediff.el -@code{ediff.el} for finding differences between files and for applying -patches. -@end table - -@noindent -Emacs Lisp archives exist on -@samp{archive.cis.ohio-state.edu} -and @samp{wuarchive.wustl.edu}@refill - - -@node Customization,Commands,Improvements over Vi,Top -@chapter Customization - -@cindex customization - -Customization can be done in 2 ways. - -@itemize @bullet -@item -@cindex initialization -@cindex .viper -Elisp code in a @file{.viper} file in your home directory. Viper -loads @file{.viper} just before it does the binding for mode -hooks. This is the recommended method. -@item -@cindex .emacs -Elisp code in your @file{.emacs} file before and after the @code{(require -'viper)} line. This method is not recommended, unless you know what you are -doing. Only two variables, @code{viper-mode} and -@code{viper-custom-file-name} are supposed to be customized in @file{.emacs}, -prior to loading Viper.@refill -@end itemize - -@noindent -Most of Viper's behavior can be customized via the interactive Emacs user -interface. Choose "Customize" from the menubar, click on "Editing", then on -"Emulations". The customization widget is self-explanatory. Once you are -satisfied with your changes, save them into a file and then include the -contents of that file in the Viper customization repository, @file{.viper} -(except for @code{viper-mode} and @code{viper-custom-file-name}, which are -supposed to go into @code{.emacs}). - -Some advanced customization cannot be accomplished this way, however, and -has to be done in Emacs Lisp. For the common cases, examples are provided -that you can use directly. - -@menu -* Rudimentary Changes:: Simple constant definitions. -* Keybindings:: Enabling Emacs Keys, Rebinding keys, etc. -* Packages that Change Keymaps:: How to deal with such beasts. -* Viper Specials:: Special Viper commands. -* Vi Macros:: How to do Vi style macros. -@end menu - -@node Rudimentary Changes,Keybindings,Customization,Customization -@section Rudimentary Changes - -@cindex setting variables -@cindex variables for customization -@findex @kbd{:set} - -An easy way to customize Viper is to change the values of constants used in -Viper. Here is the list of the constants used in Viper and their default -values. The corresponding :se command is also indicated. (The symbols -@code{t} and @code{nil} represent ``true'' and ``false'' in Lisp). - -Viper supports both the abbreviated Vi variable names and their full -names. Variable completion is done on full names only. @key{TAB} and -@key{SPC} complete -variable names. Typing `=' will complete the name and then will prompt for -a value, if applicable. For instance, @kbd{:se au @key{SPC}} will complete the -command to @kbd{:set autoindent}; @kbd{:se ta @key{SPC}} will complete the command -and prompt further like this: @kbd{:set tabstop = }. -However, typing @kbd{:se ts @key{SPC}} will produce a ``No match'' message -because @kbd{ts} is an abbreviation for @kbd{tabstop} and Viper supports -completion on full names only. However, you can still hit @key{RET} -or @kbd{=}, which will complete the command like this: @kbd{:set ts = } and -Viper will be waiting for you to type a value for the tabstop variable. -To get the full list of Vi variables, type @kbd{:se @key{SPC} @key{TAB}}. - -@table @code -@item viper-auto-indent nil -@itemx :se ai (:se autoindent) -@itemx :se ai-g (:se autoindent-global) -If @code{t}, enable auto indentation. -by @key{RET}, @kbd{o} or @kbd{O} command. - -@code{viper-auto-indent} is a local variable. To change the value globally, use -@code{setq-default}. It may be useful for certain major modes to have their -own values of @code{viper-auto-indent}. This can be achieved by using -@code{setq} to change the local value of this variable in the hooks to the -appropriate major modes. - -@kbd{:se ai} changes the value of @code{viper-auto-indent} in the current -buffer only; @kbd{:se ai-g} does the same globally. -@item viper-electric-mode t -If not @code{nil}, auto-indentation becomes electric, which means that -@key{RET}, @kbd{O}, and @kbd{o} indent cursor according to the current -major mode. In the future, this variable may control additional electric -features. - -This is a local variable: @code{setq} changes the value of this variable -in the current buffer only. Use @code{setq-default} to change the value in -all buffers. -@item viper-case-fold-search nil -@itemx :se ic (:se ignorecase) -If not @code{nil}, search ignores cases. -This can also be toggled by quickly hitting @kbd{/} twice. -@item viper-re-search nil -@itemx :se magic -If not @code{nil}, search will use regular expressions; if @code{nil} then -use vanilla search. -This behavior can also be toggled by quickly hitting @kbd{/} trice. -@item buffer-read-only -@itemx :se ro (:se readonly) -Set current buffer to read only. To change globally put -@code{(setq-default buffer-read-only t)} in your @file{.emacs} file. -@item blink-matching-paren t -@itemx :se sm (:se showmatch) -Show matching parens by blinking cursor. -@item tab-width t (default setting via @code{setq-default}) -@itemx :se ts=value (:se tabstop=value) -@itemx :se ts-g=value (:se tabstop-global=value) -@code{tab-width} is a local variable that controls the width of the tab stops. -To change the value globally, use @code{setq-default}; for local settings, -use @code{setq}. - -The command @kbd{:se ts} -sets the tab width in the current -buffer only; it has no effect on other buffers. - -The command @kbd{:se ts-g} sets tab width globally, -for all buffers where the tab is not yet set locally, -including the new buffers. - -Note that typing @key{TAB} normally -doesn't insert the tab, since this key is usually bound to -a text-formatting function, @code{indent-for-tab-command} (which facilitates -programming and document writing). Instead, the tab is inserted via the -command @code{viper-insert-tab}, which is bound to @kbd{S-tab} (shift + tab). - -On some non-windowing terminals, Shift doesn't modify the @key{TAB} key, so -@kbd{S-tab} behaves as if it were @key{TAB}. In such a case, you will have -to bind @code{viper-insert-tab} to some other convenient key. - -@item viper-shift-width 8 -@itemx :se sw=value (:se shiftwidth=value) -The number of columns shifted by @kbd{>} and @kbd{<} commands. -@item viper-search-wrap-around t -@itemx :se ws (:se wrapscan) -If not @code{nil}, search wraps around the end/beginning of buffer. -@item viper-search-scroll-threshold 2 -If search lands within this many lines of the window top or bottom, the -window will be scrolled up or down by about 1/7-th of its size, to reveal -the context. If the value is negative---don't scroll. -@item viper-tags-file-name "TAGS" -The name of the file used as the tag table. -@item viper-re-query-replace nil -If not @code{nil}, use reg-exp replace in query replace. -@item viper-want-ctl-h-help nil -If not @code{nil}, @kbd{C-h} is bound to @code{help-command}; -otherwise, @kbd{C-h} is bound as usual in Vi. -@item viper-vi-style-in-minibuffer t -If not @code{nil}, Viper provides a high degree of compatibility with Vi -insert mode when you type text in the Minibuffer; if @code{nil}, typing in -the Minibuffer feels like plain Emacs. -@item viper-no-multiple-ESC t -If you set this to @code{nil}, you can use @key{ESC} as Meta in Vi state. -Normally, this is not necessary, since graphical displays have separate -Meta keys (usually on each side of the space bar). On a dumb terminal, Viper -sets this variable to @code{twice}, which is almost like @code{nil}, except -that double @key{ESC} beeps. This, too, lets @key{ESC} to be used as a Meta. -@item viper-ESC-keyseq-timeout 200 on tty, 0 on windowing display -Escape key sequences separated by this much delay (in miliseconds) are -interpreted as command, ignoring the special meaning of @key{ESC} in -VI. The default is suitable for most terminals. However, if your terminal -is extremely slow, you might want to increase this slightly. You will know -if your terminal is slow if the @key{ESC} key sequences emitted by the -arrow keys are interpreted as separately typed characters (and thus the -arrow keys won't work). Making this value too large will slow you down, so -exercise restraint. -@item viper-fast-keyseq-timeout 200 -Key sequences separated by this many miliseconds are treated as Vi-style -keyboard macros. If the key sequence is defined as such a macro, it will be -executed. Otherwise, it is processed as an ordinary sequence of typed keys. - -Setting this variable too high may slow down your typing. Setting it too -low may make it hard to type macros quickly enough. -@item viper-ex-style-motion t -Set this to @code{nil}, if you want @kbd{l,h} to cross -lines, etc. @xref{Movement and Markers}, for more info. -@item viper-ex-style-editing t -Set this to to @code{nil}, if you want -@kbd{C-h} and @key{DEL} to not stop -at the beginning of a line in Insert state, @key{X} and @key{x} to delete -characters across lines in Vi command state, etc. -@item viper-ESC-moves-cursor-back t -It t, cursor moves back 1 character when switching from insert state to vi -state. If nil, the cursor stays where it was before the switch. -@item viper-always t -@code{t} means: leave it to Viper to decide when a buffer must be brought -up in Vi state, -Insert state, or Emacs state. This heuristics works well in virtually all -cases. @code{nil} means you either has to invoke @code{viper-mode} manually -for each buffer (or you can add @code{viper-mode} to the appropriate major mode -hooks using @code{viper-load-hook}). - -This option must be set in the file @file{~/.viper}. -@item viper-custom-file-name "~/.viper" -File used for Viper-specific customization. -Change this setting, if you want. Must be set in @file{.emacs} (not @file{.viper}!) -before Viper is loaded. Note that you -have to set it as a string inside double quotes. -@item viper-spell-function 'ispell-region -Function used by the command @kbd{#c<move>} to spell. -@item ex-nontrivial-find-file-function -The value of this variable is the function used to find all files that -match a wildcard. This is usually done when the user types @kbd{:e} and -specifies a wildcard in the file name (or if the file name contains unusual -symbols (e.g., a space). Viper provides two functions for this: one for -Unix-like systems (@code{viper-ex-nontrivial-find-file-unix}) and one for -DOS, W95, and NT (@code{viper-ex-nontrivial-find-file-ms}). If the default -function doesn't quite do what you expect or if you prefer to use ``fancy'' -shells, you may have to write your own version of this function and make it -into the value of @code{ex-nontrivial-find-file-function}. Use -@code{viper-ex-nontrivial-find-file-unix} and -@code{viper-ex-nontrivial-find-file-ms} as examples. -@vindex @code{ex-nontrivial-find-file-function}. -@findex @code{viper-ex-nontrivial-find-file-ms} -@findex @code{viper-ex-nontrivial-find-file-unix} -@item ex-cycle-other-window t -If not @code{nil}, @kbd{:n} and @kbd{:b} will cycle through files in another -window, if one exists. -@item ex-cycle-through-non-files nil -@kbd{:n} does not normally cycle through buffers. Set this to get -buffers also. -@item viper-want-emacs-keys-in-insert -This is set to @code{nil} for user levels 1 and 2 and to @code{t} for user -levels 3 and 4. Users who specify level 5 are allowed to set this variable -as they please (the default for this level is @code{t}). If set to -@code{nil}, complete Vi compatibility is provided in Insert state. This is -really not recommended, as this precludes you from using language-specific -features provided by the major modes. -@item viper-want-emacs-keys-in-vi -This is set to @code{nil} for user -level 1 and to @code{t} for user levels 2--4. -At level 5, users are allowed to set this variable as they please (the -default for this level is @code{t}). -If set to @code{nil}, complete Vi compatibility is provided -in Vi command state. Setting this to @code{nil} is really a bad idea, -unless you are a novice, as this precludes the use -of language-specific features provided by the major modes. -@item viper-keep-point-on-repeat t -If not @code{nil}, point is not moved when the user repeats the previous -command by typing `.' This is very useful for doing repeated changes with -the @kbd{.} key. -@item viper-repeat-from-history-key 'f12 -Prefix key used to invoke the macros @kbd{f12 1} and @kbd{f12 2} that repeat -the second-last and the third-last destructive command. -Both these macros are bound (as Viper macros) to -@code{viper-repeat-from-history}, -which checks the second key by which it is invoked to see which of the -previous commands to invoke. Viper binds @kbd{f12 1} and @kbd{f12 2} only, -but the user can bind more in @file{~/.viper}. @xref{Vi Macros}, for how to do -this. -@item viper-keep-point-on-undo nil -If not @code{nil}, Viper tries to not move point when undoing commands. -Instead, it will briefly move the cursor to the place where change has -taken place. However, if the undone piece of text is not seen in window, -then point will be moved to the place where the change took place. -Set it to @code{t} and see if you like it better. -@item viper-delete-backwards-in-replace nil -If not @code{nil}, @key{DEL} key will delete characters while moving the cursor -backwards. If @code{nil}, the cursor will move backwards without deleting -anything. -@item viper-replace-overlay-face 'viper-replace-overlay-face -On a graphical display, Viper highlights replacement regions instead of -putting a @samp{$} at the end. This variable controls the so called -@dfn{face} used to highlight the region. - -By default, @code{viper-replace-overlay-face} underlines the replacement on -monochrome displays and also lays a stipple over them. On color displays, -replacement regions are highlighted with color. - -If you know something about Emacs faces and don't like how Viper highlights -replacement regions, you can change @code{viper-replace-overlay-face} by -specifying a new face. (Emacs faces are described in the Emacs Lisp -reference.) On a color display, the following customization method is -usually most effective: -@example -(set-face-foreground viper-replace-overlay-face "DarkSlateBlue") -(set-face-background viper-replace-overlay-face "yellow") -@end example -For a complete list of colors available to you, evaluate the expression -@code{(x-defined-colors)}. (Type it in the buffer @code{*scratch*} and then -hit the @kbd{C-j} key. - -@item viper-replace-overlay-cursor-color "Red" -@vindex @code{viper-replace-overlay-cursor-color} -Cursor color when it is inside the replacement region. -This has effect only on color displays and only when Emacs runs as an X -application. -@item viper-insert-state-cursor-color nil -@vindex @code{viper-insert-state-cursor-color} -If set to a valid color, this will be the cursor color when Viper is in -insert state. -@item viper-replace-region-end-delimiter "$" -A string used to mark the end of replacement regions. It is used only on -TTYs or if @code{viper-use-replace-region-delimiters} is non-nil. -@item viper-replace-region-start-delimiter "" -A string used to mark the beginning of replacement regions. It is used -only on TTYs or if @code{viper-use-replace-region-delimiters} is non-nil. -@item viper-use-replace-region-delimiters -If non-nil, Viper will always use @code{viper-replace-region-end-delimiter} and -@code{viper-replace-region-start-delimiter} to delimit replacement regions, -even on color displays (where this is unnecessary). By default, this -variable is non-nil only on TTYs or monochrome displays. -@item viper-allow-multiline-replace-regions t -If non-nil, multi-line text replacement regions, such as those produced by -commands @kbd{c55w}, @kbd{3C}, etc., will stay around until the user exits -the replacement mode. In this variable is set to @code{nil}, Viper will -emulate the standard Vi behavior, which supports only intra-line -replacement regions (and multi-line replacement regions are deleted). -@item viper-toggle-key "\C-z" -Specifies the key used to switch from Emacs to Vi and back. -Must be set in @file{.viper}. This variable can't be -changed interactively after Viper is loaded. - -In Insert state, this key acts as a temporary escape to Vi state, i.e., it -will set Viper up so that the very next command will be executed as if it -were typed in Vi state. -@item viper-ESC-key "\e" -Specifies the key used to escape from Insert/Replace states to Vi. -Must be set in @file{.viper}. This variable cannot be -changed interactively after Viper is loaded. -@item viper-buffer-search-char nil -Key used for buffer search. @xref{Viper Specials}, for details. -@item viper-surrounding-word-function 'viper-surrounding-word -The value of this variable is a function name that is used to determine -what constitutes a word clicked upon by the mouse. This is used by mouse -search and insert. -@item viper-search-face 'viper-search-face -Variable that controls how search patterns are highlighted when they are -found. -@item viper-vi-state-hook nil -List of parameterless functions to be run just after entering the Vi -command state. -@item viper-insert-state-hook nil -Same for Insert state. This hook is also run after entering Replace state. -@item viper-replace-state-hook nil -List of (parameterless) functions called just after entering Replace state -(and after all @code{viper-insert-state-hook}). -@item viper-emacs-state-hook nil -List of (parameterless) functions called just after switching from Vi state -to Emacs state. -@item viper-load-hook nil -List of (parameterless) functions called just after loading Viper. This is -the last chance to do customization before Viper is up and running. -@end table -@noindent -You can reset some of these constants in Viper with the Ex command @kbd{:set} -(when so indicated in the table). Or you -can include a line like this in your @file{.viper} file: -@example -(setq viper-case-fold-search t) -@end example -@vindex @code{viper-auto-indent} -@vindex @code{viper-electric-mode} -@vindex @code{viper-case-fold-search} -@vindex @code{viper-re-search} -@vindex @code{viper-shift-width} -@vindex @code{buffer-read-only} -@vindex @code{viper-search-wrap-around} -@vindex @code{viper-search-scroll-threshold} -@vindex @code{viper-search-face} -@vindex @code{viper-tags-file-name} -@vindex @code{viper-re-query-replace} -@vindex @code{viper-want-ctl-h-help} -@vindex @code{viper-vi-style-in-minibuffer} -@vindex @code{viper-no-multiple-ESC} -@vindex @code{viper-always} -@vindex @code{viper-ESC-keyseq-timeout} -@vindex @code{viper-fast-keyseq-timeout} -@vindex @code{viper-ex-style-motion} -@vindex @code{viper-ex-style-editing} -@vindex @code{viper-ESC-moves-cursor-back} -@vindex @code{viper-custom-file-name} -@vindex @code{viper-spell-function} -@vindex @code{ex-cycle-other-window} -@vindex @code{ex-cycle-through-non-files} -@vindex @code{viper-want-emacs-keys-in-insert} -@vindex @code{viper-want-emacs-keys-in-vi} -@vindex @code{viper-keep-point-on-repeat} -@vindex @code{viper-keep-point-on-undo} -@vindex @code{viper-delete-backwards-in-replace} -@vindex @code{viper-replace-overlay-face} -@vindex @code{viper-replace-region-end-symbol} -@vindex @code{viper-replace-region-start-symbol} -@vindex @code{viper-allow-multiline-replace-regions} -@vindex @code{viper-toggle-key} -@vindex @code{viper-ESC-key} -@vindex @code{viper-buffer-search-char} -@vindex @code{viper-surrounding-word-function} -@vindex @code{viper-vi-state-hook} -@vindex @code{viper-insert-state-hook} -@vindex @code{viper-replace-state-hook} -@vindex @code{viper-emacs-state-hook} - -@node Keybindings, Packages that Change Keymaps, Rudimentary Changes,Customization -@section Keybindings - -@cindex keybindings -@cindex keymaps - -Viper lets you define hot keys, i.e., you can associate keyboard keys -such as F1, Help, PgDn, etc., with Emacs Lisp functions (that may already -exist or that you will write). Each key has a "preferred form" in -Emacs. For instance, the Up key's preferred form is [up], the Help key's -preferred form is [help], and the Undo key has the preferred form [f14]. -You can find out the preferred form of a key by typing @kbd{M-x -describe-key-briefly} and then typing the key you want to know about. - -Under X Windows, every keyboard key emits its preferred form, so you can -just type - -@lisp -(global-set-key [f11] 'calendar) ; L1, Stop -(global-set-key [f14] 'undo) ; L4, Undo -@end lisp - -@noindent -to bind L1 so it will invoke the Emacs Calendar and to bind L4 so it will -undo changes. -However, on a dumb terminal or in an Xterm window, even the standard arrow -keys may -not emit the right signals for Emacs to understand. To let Emacs know about -those keys, you will have to find out which key sequences they emit -by typing @kbd{C-q} and then the key (you should switch to Emacs state -first). Then you can bind those sequences to their preferred forms using -@code{function-key-map} as follows: - -@lisp -(cond ((string= (getenv "TERM") "xterm") -(define-key function-key-map "\e[192z" [f11]) ; L1 -(define-key function-key-map "\e[195z" [f14]) ; L4, Undo -@end lisp - -The above illustrates how to do this for Xterm. On VT100, you would have to -replace "xterm" with "vt100" and also change the key sequences (the same -key may emit different sequences on different types of terminals). - -The above keys are global, so they are overwritten by the local maps -defined by the major modes and by Viper itself. Therefore, if you wish to -change a binding set by a major mode or by Viper, read this. - -Viper users who wish to specify their own key bindings should be concerned -only with the following three keymaps: -@code{viper-vi-global-user-map} for Vi state commands, -@code{viper-insert-global-user-map} for Insert state commands, -and @code{viper-emacs-global-user-map} for Emacs state commands (note: -customized bindings for Emacs state made to @code{viper-emacs-global-user-map} -are @emph{not} inherited by Insert state). - -For more information on Viper keymaps, see the header of the file -@file{viper.el}. -If you wish to change a Viper binding, you can use the -@code{define-key} command, to modify @code{viper-vi-global-user-map}, -@code{viper-insert-global-user-map}, and @code{viper-emacs-global-user-map}, as -explained below. Each of these key maps affects the corresponding Viper state. -The keymap @code{viper-vi-global-user-map} also affects Viper's Replace state. - -@noindent -If you want to -bind a key, say @kbd{C-v}, to the function that scrolls -page down and to make @kbd{0} display information on the current buffer, -putting this in @file{.viper} will do the trick in Vi state: -@example -(define-key viper-vi-global-user-map "\C-v" 'scroll-down) -@end example -@noindent -To set a key globally, -@example -(define-key viper-emacs-global-user-map "\C-c m" 'smail) -(define-key viper-vi-global-user-map "0" 'viper-info-on-file) -@end example -@noindent -Note, however, that this binding may be overwritten by other keymaps, since -the global keymap has the lowest priority. -To make sure that nothing will override a binding in Emacs state, you -can write this: -@example -(define-key viper-emacs-global-user-map "\C-c m" 'smail) -@end example -@noindent -To customize the binding for @kbd{C-h} in Insert state: -@example -(define-key viper-insert-global-user-map "\C-h" 'my-del-backwards-function) -@end example -@noindent - -Each Emacs command key calls some lisp function. If you have enabled the -Help, (@xref{Rudimentary Changes}) @kbd{C-h k} will show you the function -for each specific key; @kbd{C-h b} will show all bindings, and @kbd{C-h m} -will provide information on the major mode in effect. If Help is not -enabled, you can still get help in Vi state by prefixing the above commands -with @kbd{\}, e.g., @kbd{\ C-h k} (or you can use the Help menu in the -menu bar, if Emacs runs under X Windows). - -Viper users can also change bindings on a per major mode basis. As with -global bindings, this can be done separately for each of the three main Viper -states. To this end, Viper provides the function -@code{viper-modify-major-mode}. -@findex @code{viper-modify-major-mode} - -To modify keys in Emacs state for @code{my-favorite-major-mode}, the user -needs to create a sparse keymap, say, @code{my-fancy-map}, bind whatever -keys necessary in that keymap, and put - -@example -(viper-modify-major-mode 'dired-mode 'emacs-state my-fancy-map) -@end example - -@noindent -in @file{~/.viper}. To do the same in Vi and Insert states, one should use -@code{vi-state} and @code{insert-state}. Changes in Insert state are also -in effect in Replace state. For instance, suppose that the user wants to -use @kbd{dd} in Vi state under Dired mode to delete files, @kbd{u} to unmark -files, etc. The following code in @file{~/.viper} will then do the job: - -@example -(setq my-dired-modifier-map (make-sparse-keymap)) -(define-key my-dired-modifier-map "dd" 'dired-flag-file-deletion) -(define-key my-dired-modifier-map "u" 'dired-unmark) -(viper-modify-major-mode 'dired-mode 'vi-state my-dired-modifier-map) -@end example - -A Vi purist may want to modify Emacs state under Dired mode so that -@kbd{k}, @kbd{l}, etc., will move around in directory buffers, as in -Vi. Although this is not recommended, as these keys are bound to useful -Dired functions, the trick can be accomplished via the following code: - -@example -(setq my-dired-vi-purist-map (make-sparse-keymap)) -(define-key my-dired-vi-purist-map "k" 'viper-previous-line) -(define-key my-dired-vi-purist-map "l" 'viper-forward-char) -(viper-modify-major-mode 'dired-mode 'emacs-state my-dired-vi-purist-map) -@end example - -Similar effect can be achieved by defining Vi keyboard macros using the -Ex commands @kbd{:map} and @kbd{:map!}. The difference is that multi-key -Vi macros do not override the keys they are bound to, unless these keys are -typed in quick succession. So, with macros, one can use the normal keys -alongside with the macros. If per-mode modifications are needed, the user -can try both ways and see which one is more convenient. -@findex @kbd{:map} -@xref{Vi Macros}, for details. - -Note: in major modes that come up in @emph{Emacs state} by default, the -aforesaid modifications may not take place immediately (but only after the -buffer switches to some other Viper state and then back to Emacs state). To -avoid this, one should add @code{viper-change-state-to-emacs} to an -appropriate hook of that major mode. (Check the function -@code{viper-set-hooks} in @file{viper.el} for examples.) However, if you -have set @code{viper-always} to @code{t}, chances are that you won't need to -perform the above procedure, because Viper will take care of most useful -defaults. - - -Finally, Viper has a facility that lets the user define per-buffer -bindings, i.e., bindings that are in effect in some specific buffers -only. Unlike per-mode bindings described above, per-buffer bindings can be -defined based on considerations other than the major mode. This is done -via the function @code{viper-add-local-keys}, which lets one specify bindings -that should be in effect in the current buffer only and for a specific Viper -state. For instance, -@lisp -(viper-add-local-keys 'vi-state '(("ZZ" . TeX-command-master) - ("ZQ" . viper-save-kill-buffer))) -@end lisp -@noindent -redefines @kbd{ZZ} to invoke @code{TeX-command-master} in @code{vi-state} -and @kbd{ZQ} to save-then-kill the current buffer. These bindings take -effect only in the buffer where this command is executed. The typical use -of this function is to execute the above expression from within a function -that is included in a hook to some major mode. For instance, the above -expression -could be called from a function, @code{my-tex-init}, which may be added to -@code{tex-mode-hook} as follows: -@lisp -(add-hook 'tex-mode-hook 'my-tex-init) -@end lisp -@noindent -When TeX mode starts, the hook is executed and the above Lisp expression is -evaluated. Then, the bindings for @kbd{ZZ} and @kbd{ZQ} are changed in Vi -command mode for all buffers in TeX mode. - -Another useful application is to bind @kbd{ZZ} to @code{send-mail} -in the Mail mode buffers (the specifics of this depend on which mail -package you are using, @code{rmail}, @code{mh-e}, @code{vm}, etc. -For instance, here is how to do this for @code{mh-e}, the Emacs interface -to MH: -@lisp -(defun mh-add-vi-keys () - "Set up ZZ for MH-e and XMH." - (viper-add-local-keys 'vi-state '(("ZZ" . mh-send-letter)))) -(add-hook 'mh-letter-mode-hook 'mh-add-vi-keys) -@end lisp - -You can also use @code{viper-add-local-keys} to set per buffer -bindings in Insert state and Emacs state by passing as a parameter the -symbols @code{insert-state} and @code{emacs-state}, respectively. -As with global bindings, customized local bindings done to Emacs state -are not inherited by Insert state. - -On rare occasions, local keys may be added by mistake. Usually this is done -indirectly, by invoking a major mode that adds local keys (e.g., -@code{shell-mode} redefines @key{RET}). In such a case, exiting the wrong -major mode won't rid you from unwanted local keys, since these keys are -local to Viper state and the current buffer, not to the major mode. -In such situations, the remedy is to type @kbd{M-x viper-zap-local-keys}. - -So much about Viper-specific bindings. -@xref{Customization,,Customization,emacs,The GNU Emacs -Manual}, and the Emacs quick reference card for the general info on key -bindings in Emacs. - -@vindex @code{function-key-map} -@vindex @code{viper-vi-global-user-map} -@vindex @code{viper-insert-global-user-map} -@vindex @code{viper-emacs-global-user-map} -@findex @code{viper-add-local-keys} -@findex @code{viper-zap-local-keys} - -@node Packages that Change Keymaps,Viper Specials,Keybindings,Customization -@subsection Packages that Change Keymaps -@cindex C-c and Viper -@cindex Viper and C-c - -Viper is designed to coexist with all major and minor modes of Emacs. This -means that bindings set by those modes are generally available with Viper -(unless you explicitly prohibit them by setting -@code{viper-want-emacs-keys-in-vi} and @code{viper-want-emacs-keys-in-insert} to -@code{nil}). -If @code{viper-always} is set to @code{t}, Viper will try to bring each buffer -in the Viper state that is most appropriate for that buffer. -Usually, this would be the Vi state, but sometimes it could be the Insert -state or the Emacs state. - -Some major mode bindings will necessarily be overwritten by Viper. Indeed, in -Vi state, most of the 1-character keys are used for Vi-style editing. This -usually causes no problems because most packages designed for editing files -typically do not bind such keys. Instead, they use key sequences that start -with @kbd{C-x} and @kbd{C-c}. This is why it was so important for us to -free up @kbd{C-x} and @kbd{C-c}. -It is common for language-specific major modes to bind @key{TAB} and -@kbd{C-j} (the line feed) keys to various formatting functions. This is -extremely useful, but may require some getting used to for a Vi user. If you -decide that this feature is not for you, you can re-bind these keys as -explained earlier (@xref{Customization}). - -Binding for @key{TAB} is one of the most unusual aspects of Viper for many -novice users. In Emacs, @key{TAB} is used to format text and programs, and -is extremely useful. For instance, hitting @key{TAB} causes the current -line to be re-indented in accordance with the context. In programming, -this is very important, since improper automatic indentation would -immediately alert the programmer to a possible error. For instance, if a -@kbd{)} or a @kbd{"} is missing somewhere above the current -line, @key{TAB} is likely to mis-indent the line. - -For this reason, Viper doesn't change the standard Emacs binding of -@key{TAB}, thereby sacrificing Vi compatibility -(except for users at level 1). Instead, in Viper, the key -@kbd{S-tab} (shift+ tab) is chosen to emulate Vi's @key{TAB}. - -We should note that on some non-windowing terminals, Shift doesn't modify -the @key{TAB} key, so @kbd{S-tab} behaves as if it were @key{TAB}. In such -a case, you will have to bind @code{viper-insert-tab} to some other -convenient key. - -Some packages, notably Dired, Gnus, Info, etc., attach special meaning to -common keys like @key{SPC}, @kbd{x}, @kbd{d}, @kbd{v}, and others. This -means that Vi command state is inappropriate for working with these -packages. Fortunately, these modes operate on read-only buffers and are -designed not for editing files, but for special-purpose browsing, reading -news, mail, etc., and Vi commands are meaningless in these situations. For -this reason, Viper doesn't force Vi state on such major modes. Rather, it -brings them in Emacs state. You can switch to Vi state by typing @kbd{C-z} -if, for instance, you want to do Vi-style search in a buffer (although, -usually, incremental search, which is bound to @kbd{C-s}, is sufficient in -these situations). But you should then switch back to Emacs state if you -plan to continue using these major modes productively. You can also switch -to Vi temporarily, to execute just one command. This is done by typing -@kbd{C-c \}. (In some of these modes, @kbd{/} and @kbd{:} are bound -Vi-style, unless these keys perform essential duties.) - -If you would like certain major modes to come up in Emacs state rather than -Vi state (but Viper thinks otherwise), you should put these major modes -on the @code{viper-non-vi-major-modes} list and also add -@code{viper-change-state-to-emacs} to these modes' hooks. -@vindex @code{viper-non-vi-major-modes} - -It is also possible to harness some major modes, even though they may bind -common keys to specialized commands. Harnessing can make sense for modes -that bind only a small number of common keys. For instance, if -@code{viper-always} is set to @code{t} in your @file{~/.viper} file, Viper will -harness Shell mode by changing the bindings for @kbd{C-m} and @kbd{C-d} -using @code{viper-add-local-keys} described in section on customization -(@xref{Customization}). In general, there is no single recipe for -harnessing modes. It can be as simple as adding the function -@code{viper-mode} to a hook associated with the mode, or it can be more -complex, as in the case of Shell mode and Emerge. Take a look at -@code{viper-set-hooks} function for some examples. - -Conversely, it may be the case that most of the major modes harnessed -by @code{viper-set-hooks} function fit your working style, except one or two -cases. In this case, you may still be able to set @code{viper-always} to -@code{t} and then remove a hook that forces Vi command state. For instance, -to unharness @code{lisp-interaction-mode}, you can execute the following line -in @code{viper-load-hook}: -@lisp -(remove-hook 'lisp-interaction-mode-hook 'viper-mode) -@end lisp -Note: this type of customization cannot be done in @code{.viper}! - -In some rare cases, some minor modes may override certain essential -bindings in Vi command state. This is not really catastrophic because this -may happen only in the beginning, when the minor mode kicks in. Typing -@code{M-x viper-mode} will correct the situation. Viper knows about -several such minor modes and takes care of them, so that the above trick -is usually not necessary. If you find that some minor mode, e.g., -@code{nasty-mode.el} interferes with Viper, putting the following in -@file{.viper} should fix the problem: -@lisp -(viper-harness-minor-mode "nasty-mode") -@end lisp -@noindent -The argument to @code{viper-harness-minor-mode} is the name of the file for the -offending minor mode with the suffixes @file{.el} and @file{.elc} removed. - -It may be tricky, however, to find out which minor mode is at fault. The -only guidance here is to look into the file that defines the minor mode you -are suspecting, say @code{nasty-mode.el}, and see if it has a variable -called @code{nasty-mode-map}. Then check if there is a statement of the form -@lisp -(define-key nasty-mode-map key function) -@end lisp -@noindent -that binds the misbehaving -keys. If so, use the above line to harness @code{nasty-mode}. If your -suspicion is wrong, no harm is done if you harness a minor mode that -doesn't need to be harnessed. - -@vindex @code{viper-want-emacs-keys-in-vi} -@vindex @code{viper-want-emacs-keys-in-insert} -@vindex @code{viper-always} -@findex @code{viper-set-hooks} -@findex @code{viper-mode} -@findex @code{viper-harness-minor-mode} -@findex @code{remove-hook} -@findex @code{add-hook} - -@node Viper Specials,Vi Macros,Packages that Change Keymaps,Customization -@section Viper Specials - -Viper extends Vi with a number of useful features. This includes various -search functions, histories of search strings, Ex commands, insertions, and -Vi's destructive commands. In addition, Viper supports file name completion -and history, completion of Ex commands and variables, and many other -features. Some of these features are explained in detail elsewhere in this -document. Other features are explained here. - -@table @code -@item (viper-buffer-search-enable) -@item viper-buffer-search-char nil -Enable buffer search. Explicit call to @code{viper-buffer-search-enable} -sets @code{viper-buffer-search-char} to @kbd{g}. Alternatively, the user can -set @code{viper-buffer-search-char} in @file{.viper} to a key sequence -to be used for buffer search. There is no need to call -@code{viper-buffer-search-enable} in that case. -@findex @code{viper-buffer-search-enable} -@vindex @code{viper-buffer-search-char} -@item viper-toggle-search-style -This function, bound to @kbd{C-c /}, lets one toggle case-sensitive and -case-insensitive search, and also switch between plain vanilla search and -search via regular expressions. Without the prefix argument, the user is -asked which mode to toggle. With prefix argument 1, this toggles -case-sensitivity. With prefix argument 2, regular expression/vanilla search -will be toggled. - -However, we found that the most convenient way to toggle -these options is to bind a Vi macro to -bind @kbd{//} to toggles case sensitivity and to @kbd{///} to toggles -vanilla search. Thus, quickly hitting @kbd{/} twice will switch Viper from -case sensitive search to case-insensitive. Repeating this once again will -restore the original state. Likewise, quickly hitting @kbd{/} three times -will switch you from vanilla-style search to search via regular expressions. -If you hit something other than @kbd{/} after the first @kbd{/} or if the -second @kbd{/} doesn't follow quickly enough, then Viper will issue the -usual prompt @kbd{/} and will wait for input, as usual in Vi. -If you don't like this behavior, you can ``unrecord'' these macros in your -@file{~/.viper} file. For instance, if you don't like the above feature, put -this in @file{~/.viper}: -@example -(viper-set-searchstyle-toggling-macros 'undefine) -@end example -@findex @code{viper-set-searchstyle-toggling-macros} - -@item Vi-isms in Emacs state -Some people find it useful to use the Vi-style search key, `/', to invoke -search in modes which Viper leaves in emacs-state. These modes are: -@code{dired-mode}, @code{mh-folder-mode}, @code{gnus-group-mode}, -@code{gnus-summary-mode}, @code{Info-mode}, and @code{Buffer-menu-mode} -(more may be added in the future). So, in the above modes, Viper binds `/' -so that it will behave Vi-style. Furthermore, in those major modes, Viper -binds `:' to invoke ex-style commands, like in vi-state. And, as described -above, `//' and `///' get bound to Vi-style macros that toggle -case-insensitivity and regexp-search. - -If you don't like these features---which I don't really understand---you -can unbind `/' and `:' in @code{viper-dired-modifier-map} (for Dired) or in -@code{viper-slash-and-colon-map}, for other modes. -@vindex @code{viper-slash-and-colon-map} -@vindex @code{viper-dired-modifier-map} - -To unbind the macros `//' and `///' for a major mode where you feel they -are undesirable, execute @code{viper-set-emacs-state-searchstyle-macros} with a -non-nil argument. This can be done either interactively, by supplying a -prefix argument, or by placing -@example -(viper-set-emacs-state-searchstyle-macros 'undefine) -@end example -@findex @code{viper-set-emacs-state-searchstyle-macros} -in the hook to the major mode (e.g., @code{dired-mode-hook}). -@xref{Vi Macros}, for more information on Vi macros. - -@item viper-heading-start -@item viper-heading-end -@cindex headings -@cindex sections -@cindex paragraphs -@cindex sentences -Regular Expressions for @kbd{[[} and @kbd{]]}. Note that Emacs defines -Regexps for paragraphs and sentences. @xref{Paragraphs,,Paragraphs and -Sentences,emacs,The GNU Emacs Manual}, for details. -@item M-x viper-set-expert-level -@findex @code{viper-set-expert-level} -Change your user level interactively. -@item viper-smart-suffix-list '("" "tex" "c" "cc" "el" "p") -@vindex @code{viper-smart-suffix-list} -Viper supports Emacs-style file completion when it prompts the user for a -file name. However, in many cases, the same directory may contain files -with identical prefix but different suffixes, e.g., prog.c, prog.o, -paper.tex, paper.dvi. In such cases, completion will stop at the `.'. -If the above variable is a list of strings representing suffixes, Viper will -try these suffixes -in the order listed and will check if the corresponding file exists. - -For instance, if completion stopped at `paper.' and the user typed -@key{RET}, -then Viper will check if the files `paper.', `paper.tex', `paper.c', etc., exist. -It will take the first such file. If no file exists, Viper will give a chance -to complete the file name by typing the appropriate suffix. If `paper.' was -the intended file name, hitting return will accept it. - -To turn this feature off, set the above variable to @code{nil}. - -@item viper-insertion-ring-size 14 -@vindex @code{viper-insertion-ring-size} -@cindex Insertion ring -Viper remembers what was previously inserted in Insert and Replace states. -Several such recent insertions are kept in a special ring of strings of size -@code{viper-insertion-ring-size}. -If you enter Insert or Replace state you can reinsert strings from this -ring by typing @kbd{C-c M-p} or @kbd{C-c M-n}. The former will search the -ring in -the direction of older insertions, and the latter will search in -the direction of newer insertions. Hitting @kbd{C-c M-p} or @kbd{C-c M-n} -in succession -will undo the previous insertion from the ring and insert the next item on -the ring. If a larger ring size is needed, change the value of the above -variable in the @file{~/.viper} file. - -Since typing these sequences of keys may be tedious, it is suggested that the -user should bind a function key, such as @kbd{f31}, as follows: -@example -(define-key viper-insert-global-user-map [f31] - 'viper-insert-prev-from-insertion-ring) -@end example -This binds @kbd{f31} (which is usually @kbd{R11} on a Sun workstation) -to the function that inserts the previous string in the insertion history. -To rotate the history in the opposite -direction, you can either bind an unused key to -@code{viper-insert-next-from-insertion-ring} or hit any digit (1 to 9) then -@kbd{f31}. - -One should not bind the above functions to @kbd{M-p} or @kbd{M-n}, since -this will interfere with the Minibuffer histories and, possibly, other -major modes. - -@item viper-command-ring-size 14 -@vindex @code{viper-command-ring-size} -@cindex Destructive command ring -@cindex Destructive command history -Viper keeps track of the recent history of destructive -commands, such as @kbd{dw}, @kbd{i}, etc. -In Vi state, -the most recent command can be re-executed by hitting `@kbd{.}', as in Vi. -However, repeated typing @kbd{C-c M-p} will cause Viper to show the -previous destructive commands in the minibuffer. Subsequent hitting `@kbd{.}' -will execute the command that was displayed last. -The key @kbd{C-c M-n} will cycle through the command history in the -opposite direction. -Since typing @kbd{C-c M-p} may be tedious, it is more convenient to bind an -appropriate function to an unused function key on the keyboard and use that -key. For instance, the following -@example -(define-key viper-vi-global-user-map [f31] - 'viper-prev-destructive-command) -@end example -binds the key @kbd{f31} (which is usually @kbd{R11} on a Sun workstation) -to the function that searches the command history in the direction of older -commands. To search in the opposite -direction, you can either bind an unused key to -@code{viper-next-destructive-command} or hit any digit (1 to 9) then @kbd{f31}. - -One should not bind the above functions to @kbd{M-p} or @kbd{M-n}, since -this will interfere with the Minibuffer histories and, possibly, other -major modes. - -@item viper-minibuffer-vi-face 'viper-minibuffer-vi-face -@item viper-minibuffer-insert-face 'viper-minibuffer-insert-face -@item viper-minibuffer-emacs-face 'viper-minibuffer-emacs-face -These faces control the appearance of the minibuffer text in the -corresponding Viper states. You can change the appearance of these faces -through Emacs' customization widget, which is accessible through the -menubar. - -Viper is located in this widget under the @emph{Emulations} customization -subgroup of the @emph{Editing} group. All Viper faces are grouped together -in Viper's @emph{Highlighting} customization subgroup. - -Note that only the text you type in is affected by the above faces. -Prompts and Minibuffer messages are not affected. - -Purists who do not like adornments in the minibuffer can always zap them by -putting -@example -(copy-face 'default 'viper-minibuffer-vi-face) -(copy-face 'default 'viper-minibuffer-insert-face) -(copy-face 'default 'viper-minibuffer-emacs-face) -@end example -in the @file{~/.viper} file or through the customization widget, as -described above. However, in that case, the user will not have any -indication of the current Viper state in the minibuffer. (This is important -if the user accidentally switches to another Viper state by typing @key{ESC} or -@kbd{C-z}). -@item M-x viper-go-away -@findex @code{viper-go-away} -Make Viper disappear from the face of your running Emacs instance. If your -fingers start aching again, @kbd{M-x viper-mode} might save your day. -@item M-x toggle-viper-mode -@findex @code{toggle-viper-mode} -Toggle Viperization of Emacs on and off. -@end table - -@cindex Multifile documents and programs - -Viper provides some support for multi-file documents and programs. -If a document consists of several files we can designate one of them as a -master and put the following at the end of that file: -@lisp -;;; Local Variables: -;;; eval: (viper-setup-master-buffer "file1" "file2" "file3" "file5" "file5") -;;; End: -@end lisp -@noindent -where @code{file1} to @code{file5} are names of files related to the master -file. Next time, when the master file is visited, the command -@code{viper-setup-master-buffer} will be evaluated and the above files will -be associated with the master file. Then, the new Ex command -@kbd{:RelatedFile} (abbr. @kbd{:R}) will display files 1 to 5 one after -another, so you can edit them. If a file is not in any Emacs buffer, it -will be visited. The command @kbd{PreviousRelatedFile} (abbr., @kbd{:P}) -goes through the file list in the opposite direction. -@findex @kbd{:RelatedFile} -@findex @kbd{:PreviousRelatedFile} - -These commands are akin to @kbd{:n} and @kbd{:N}, but they allow the user to -focus on relevant files only. - -Note that only the master file needs to have the aforementioned block of -commands. Also, ";;;" above can be replaced by some other -markers. Semicolon is good for Lisp programs, since it is considered a -comment designator there. For LaTeX, this could be "%%%", and for C the -above block should be commented out. - -Even though these commands are sometimes useful, they are no substitute for -the powerful @emph{tag table} facility of Emacs. Viper's @kbd{:tag} command -in a primitive interface to Emacs tags. @xref{Tags,Tags,Tags,emacs, -The Gnu Emacs Manual}, for more information on tags. - -The following two commands are normally bound to a mouse click and are part -of Viper. They work only if Emacs runs as an application under X -Windows (or under some other window system for which a port of GNU Emacs 20 -is available). Clicking the mouse when Emacs is invoked in an Xterm window -(using @code{emacs -nw}) will do no good. - -@table @code -@cindex mouse -@cindex mouse-search -@item viper-mouse-search-key (meta shift 1) -@vindex @code{viper-mouse-insert-key} -This variable controls the @emph{mouse-search} feature of Viper. The -default value -states that holding Meta and Shift keys while clicking mouse button 1 -should initiate search for a region under the mouse pointer (defined -below). This command can take a prefix argument, which indicates the -occurrence of the pattern to search for. - -Note: while loading initially, Viper binds this mouse action only if it is -not already bound to something else. If you want to use the mouse-seatch -feature and the Meta-Shift-button-1 mouse action is already bound to -something else you can rebind the mouse-search feature by setting -@code{viper-mouse-search-key} to something else in your @code{~/.viper} -file: -@lisp -(setq viper-mouse-search-key '(meta 1)) -@end lisp -This would bind mouse search to the action invoked by pressing the -Meta key and clicking mouse button 1. The allowed values of -@code{viper-mouse-search-key} are lists that contain a mouse-button number -(1,2, or 3) and any combination of the words `control', `meta', and -`shift'. - -If the requested mouse action (e.g., (meta 1)) is already taken for other -purposes then you have to confirm your intention by placing the following -command in @code{~/.viper} after setting @code{viper-mouse-search-key}: -@lisp -(viper-bind-mouse-search-key 'force) -@end lisp - -You can also change this setting interactively, through the customization -widget of Emacs (choose option "Customize.Customize Group" from the -menubar). - -The region that is chosen as a pattern to search for is determined as -follows. If search is invoked via a single click, Viper chooses the region -that lies between the beginning of the ``word'' under the pointer (``word'' -is understood in Vi sense) and the end of that word. The only difference -with Vi's words is that in Lisp major modes `-' is considered an -alphanumeric symbol. This is done for the convenience of working with Lisp -symbols, which often have an `-' in them. Also, if you click on a -non-alphanumeric character that is not a word separator (in Vi sense) then -this character will also be considered alphanumeric, provided that it is -adjacent (from either side) to an alphanumeric character. This useful -feature gives added control over the patterns selected by the mouse click. - -On a double-click, the region is determined by the beginning of the current -Vi's ``Word'' (i.e., the largest non-separator chunk of text) and the End -of that ``Word'' (as determined by the @kbd{E} command). - -On a triple-click, the region consists of the entire line where the click -occurred with all leading and trailing spaces and tabs removed. - -@cindex mouse-insert -@item viper-mouse-insert-key (meta shift 2) -@vindex @code{viper-mouse-insert-key} -This variable controls the @emph{mouse-insert} feature of Viper. -The above default value states that -holding Meta and Shift keys while clicking mouse button 2 -should insert the region surrounding the -mouse pointer. The rules defining this region are the same as for -mouse-search. This command takes an optional prefix argument, which -indicates how many such regions to snarf from the buffer and insert. (In -case of a triple-click, the prefix argument is ignored.) - -Note: while loading initially, Viper binds this mouse action only if it not -already bound to something else. If you want to use this feature and the -default mouse action is already bound, you can rebind mouse-insert by -placing this command in @code{~/.viper}: -@lisp -(setq viper-mouse-insert-key '(meta 2)) -@end lisp -If you want to bind mouse-insert to an action even if this action is -already taked for other purposes in Emacs, then you should add this command -to @code{~/.viper}, after setting @code{viper-mouse-insert-key}: -@lisp -(viper-bind-mouse-insert-key 'force) -@end lisp - -This value can also be changed via the Emacs customization widget at the -menubar. - -@item viper-multiclick-timeout -This variable controls the rate at which double-clicking must occur for the -purpose of mouse search and mouse insert. By default, this is set to -@code{double-click-time} in Emacs and to -@code{mouse-track-multi-click-time} milliseconds in XEmacs. -@end table -@kindex @kbd{S-mouse-1} -@kindex @kbd{S-mouse-2} -@kindex @kbd{meta shift button1up} -@kindex @kbd{meta shift button2up} -@vindex @code{viper-multiclick-timeout} -@findex @code{viper-mouse-click-insert-word} -@findex @code{viper-mouse-click-search-word} - -Note: The above functions search and insert in the selected window of -the latest active frame. This means that you can click in another window or -another frame and have search or insertion done in the frame and window you -just left. This lets one use these functions in a multi-frame -configuration. However, this may require some getting used to. For -instance, if you are typing in a frame, A, and then move the mouse to frame -B and click to invoke mouse search, search (or insertion) will be performed -in frame A. To perform search/insertion in frame B, you will first have to -shift focus there, which doesn't happen until you type a character or -perform some other action in frame B---mouse search doesn't shift focus (in -XEmacs, to shift focus to frame B, you will have to select this frame with -a mouse, by clicking. - -If you decide that you don't like the above feature and always want -search/insertion be performed in the frame where the click occurs, don't -bind (and unbind, if necessary) @code{viper-mouse-catch-frame-switch} from -the mouse event it is bound to. - -Mouse search is integrated with Vi-style search, so you can -repeat it with @kbd{n} and @kbd{N}. It should be also noted that, while -case-sensitivity of search in Viper is controlled by the variable -@code{viper-case-fold-search}, the case of mouse search is -controlled by the Emacs variable @code{case-fold-search}, which may be set -differently from @code{viper-case-fold-search}. Therefore, case-sensitivity -of mouse search may be different from that of the usual Vi-style search. - -Finally, if the way Viper determines the word to be searched for or to be -inserted is not what you want, there is a variable, -@code{viper-surrounding-word-function}, which can be changed to indicate -another function for snarfing words out of the buffer. The catch is that -you will then have to write such a function and make it known to your -Emacs. The function @code{viper-surrounding-word} in @file{viper.el} can be -used as a guiding example. - -@node Vi Macros, ,Viper Specials,Customization -@section Vi Macros - -@cindex Vi macros - -Viper supports much enhanced Vi-style macros and also facilitates the use -of Emacs-style macros. To define a temporary macro, it is generally more -convenient to use Emacs keyboard macro facility. Emacs keyboard macros are -usually defined anonymously, and the latest macro can be executed by typing -@kbd{C-x e} (or @kbd{*}, if Viper is in Vi state). If you need to use several -temporary macros, Viper lets you save them to a -register (a lowercase letter); such macros can then be executed by typing -@kbd{@@a} in Vi state (if a macro was previously saved in register -@kbd{a}). -@xref{Macros and Registers}, for details. - -If, however, you need to use a macro regularly, it must be given a -permanent name and saved. Emacs manual explains how to do this, but -invocation of named Emacs macros is quite different from Vi's. First, -invocation of permanent Emacs macros takes time because of the extra keys. -Second, binding such macros to function keys, for -fast access, hogs valuable real estate on the keyboard. - -Vi-style macros are better in that respect, since Vi lets the user overload -the meaning of key sequences: keys typed in fast succession are treated -specially, if this key sequence is bound to a macro. - -Viper provides keyboard macros through the usual Ex commands, @kbd{:map} and -@kbd{:map!}. Vi-style macros are much more powerful in Viper than -they are in the original Vi and in other emulators. This is because Viper -implements an enhanced vi-style -interface to the powerful Emacs keyboard macro facility. - -First, any Emacs -command can be executed while defining a macro, not just the Vi -commands. In particular, the user can invoke Emacs commands via @kbd{M-x -command-name} or by pressing various function keys on the keyboard. One -can even use the mouse, although this is usually not useful and is not -recommended (and macros defined with the use of the mouse cannot be saved in -command history and in the startup file, for future use). - -Macros defined by mixing Vi and Emacs commands are represented as -vectors. So, don't be confused when you see one (usually through the -history of Ex commands). For instance, if @kbd{gg} is defined by typing -@kbd{l}, the up-arrow key and @kbd{M-x next-line}, its definition will look -as follows in Emacs (in XEmacs, it looks slightly different, see below): - -@example -[l up (meta x) n e x t - l i n e return] -@end example - -Second, Viper macros are defined in a WYSIWYG style. This means that -commands are executed as you type them, so you can see precisely what is -being defined. Third, macros can be bound to arbitrary sequences of keys, -not just to printable keys. For instance, one can define a macro that will -be invoked by hitting @kbd{f3} then @kbd{f2} function keys. (The keys -@kbd{delete} and @kbd{backspace} are excluded; also, a macro invocation -sequence can't start with @key{ESC}. Some other keys, such as @kbd{f1} and -@kbd{help}, can't be bound to macros under Emacs (not XEmacs), since they -are bound in @code{key-translation-map}, which overrides any other binding -the user gives to keys. In general, keys that have a binding in -@code{key-translation-map} can't be bound to a macro.) - -Fourth, in Viper, one can define macros that are specific to a given -buffer, a given major mode, or macros that are defined for all buffers. In -fact, the same macro name can have several different definitions: one -global, several definitions for various major modes, and -definitions for various specific buffers. Buffer-specific definitions -override mode-specific definitions, which, in turn, override global -definitions. - -As if all that is not enough, Viper (through its interface to Emacs -macros) lets the user define keyboard macros that ask for confirmation or -even prompt the user for input and then continue. To do this, one should -type @kbd{C-x q} (for confirmation) or @kbd{C-u C-x q} (for prompt). -For details, @pxref{Kbd Macro Query,,Customization,emacs,The GNU Emacs -Manual} @refill - -When the user finishes defining a macro (which is done by typing @kbd{C-x)} --- -a departure from Vi), you will be asked whether you want this -macro to be global, mode-specific, or buffer-specific. You will also be -given a chance to save the macro in your @file{~/.viper} file. -This is the easiest way to save a macro and make -it permanently available. If you work your startup files with bare hands, -here is how Viper saves the above macro so that it will be -available in Viper's Insert state (and Replace state) in buffer @code{my-buf} -only: - -@example -(viper-record-kbd-macro "gg" 'insert-state - [l up (meta x) n e x t - l i n e return] - "my-buf") -@end example - -@noindent -To do the same for Vi state and all buffers with the major mode -@code{cc-mode}, use: - -@example -(viper-record-kbd-macro "gg" 'vi-state - [l up (meta x) n e x t - l i n e return] - 'cc-mode) -@end example - -@noindent -Both macro names and macro definitions are vectors of symbols that denote -keys on the keyboard. Some keys, like @kbd{\}, @kbd{ }, or digit-keys must -be escaped with a backslash. Modified keys are represented as lists. For -instance, holding Meta and Control and pressing @kbd{f4} is represented as -@kbd{(control meta f4)}. -If all members of a vectors are printable characters (or sequences, such as -@kbd{\e}, @kbd{\t}, for @key{ESC} and @key{TAB}), then they can also be represented as -strings: - -@example -(viper-record-kbd-macro "aa" 'vi-state "aaa\e" "my-buffer") -@end example - -@noindent -Thus, typing @kbd{aa} fast in Vi state will switch Viper to Insert state -(due to the first @kbd{a}), insert @kbd{aa}, and then it will switch back to Vi -state. All this will take effect only in the buffer named @code{my-buffer}. - -Note that the last argument to @code{viper-record-kbd-macro} must be either a -string (a buffer name), a symbol representing a major mode, or @code{t}; -the latter says that the macro is to be defined for all buffers -(which is how macros are defined in original Vi). - -For convenience, Viper also lets you define Vi-style macros in its Emacs -state. There is no Ex command, like @kbd{:map} and @kbd{:map!} for doing -this, but the user can include such a macro in the @file{~/.viper} file. The -only thing is that the @code{viper-record-kbd-macro} command should specify -@code{emacs-state} instead of @code{vi-state} or @code{insert-state}. - -The user can get rid of a macro either by using the Ex commands @kbd{:unmap} -and @kbd{:unmap!} or by issuing a call to @code{viper-unrecord-kbd-macro}. -The latter is more powerful, since it can delete macros even in -@code{emacs-state}. However, @code{viper-unrecord-kbd-macro} is usually -needed only when the user needs to get rid of the macros that are already -predefined in Viper. -The syntax is: -@findex @code{viper-unrecord-kbd-macro} -@example -(viper-unrecord-kbd-macro macro state) -@end example -@noindent -The second argument must be @code{vi-state}, @code{insert-state}, or -@code{emacs-state}. The first argument is a name of a macro. To avoid -mistakes in specifying names of existing macros, type @kbd{M-x -viper-describe-kbd-macros} and use a name from the list displayed by this -command. - -If an error occurs during macro definition, Emacs -aborts the process, and it must be repeated. This is analogous to Vi, -except that in Vi the user doesn't know there is an error until the macro is -actually run. All that means that in order for a definition to be -successful, the user must do some simple planning of the process in -advance, to avoid errors. For instance, if you want to map @kbd{gg} to -@kbd{llll} in Vi state, you must make sure that there is enough room on the -current line. Since @kbd{l} moves the cursor forward, it may signal an -error on reaching the end of line, which will abort the definition. - -These precautions are necessary only when defining macros; they will help -avoid the need to redo the job. When macros are actually run, an error -during the execution will simply terminate the current execution -(but the macro will remain mapped). - -A macro name can be a string of characters or a vector of keys. -The latter makes it possible to define macros bound to, say, double-hits -on a function key, such as @kbd{up} or @kbd{f13}. -This is very useful if you run out of function keys on your keyboard; it -makes Viper macro facility a @emph{keyboard doubler}, so to speak. - -Elsewhere (@xref{Keybindings}, for details), we review -the standard Emacs mechanism for binding function keys to commands. -For instance, - -@example -(global-set-key [f13] 'repeat-complex-command) -@end example - -@noindent -binds the key f13 to the Emacs function that repeats the last minibuffer -command. Under Viper, however, you may still use this key for additional -purposes, if you bind, say, a double-hitting action for that key to some -other function. Emacs doesn't allow the user to do that, but Viper does -this through its keyboard macro facility. To do this, type @kbd{:map } -first. When you are asked to enter a macro name, hit f13 twice, followed by -@key{RET} or @key{SPC}. - -Emacs will now start the mapping process by actually executing -Vi and Emacs commands, so that you could see what will happen each time the -macro is executed. Suppose now we wanted to bind the key sequence -@kbd{f13 f13} to the command @code{eval-last-sexp}. To accomplish this, we -can type @kbd{M-x eval-last-sexp} followed by @kbd{C-x )}. -If you answer positively to Viper's offer to save this macro in @file{~/.viper} -for future uses, the following will be inserted in that file: - -@example -(viper-record-kbd-macro [f16 f16] 'vi-state - [(meta x) e v a l - l a s t - s e x p] - 'lisp-interaction-mode) -@end example - -To illustrate the above point, Viper provides two canned macros, which, by -default, are bound to @kbd{[f12 \1]} and @kbd{[f12 \2]} (invoked by typing -@kbd{f12} then @kbd{1} and @kbd{2}, respectively). These macros are useful -shortcuts to Viper's command ring history. The first macro will execute the -second-last destructive command (the last one is executed by @kbd{.}, as -usual). The second macro executes the third-last command. - -If you need to go deeper into the command history, you will have to use -other commands, as described earlier in this section; or you can bind, -say, @kbd{f12 \3} like this: - -@example -(viper-record-kbd-macro [f12 \3] 'vi-state - [(meta x) r e p e a t - f r o m - h i s t o r y] - t) -@end example - - -Note that even though the macro uses the function key @kbd{f12}, the key is -actually free and can still be bound to some Emacs function via -@code{define-key} or @code{global-set-key}. - - -Viper allows the user to define macro names that are prefixes of other macros. -For instance, one can define @kbd{[[} and @kbd{[[[[} to be macros. -If you type the exact sequence of such keys and then pause, Viper will -execute the right macro. However, if you don't pause and, say, type -@kbd{[[[[text} then the conflict is resolved as follows. If only one of the -key sequences, @kbd{[[} or @kbd{[[[[} has a definition applicable to the -current buffer, then, in fact, there is no conflict and the right macro -will be chosen. If both have applicable definitions, then the first one -found will be executed. Usually this is the macro with a shorter name. So, -in our case, @kbd{[[[[text} will cause the macro @kbd{[[} to be executed -twice and then the remaining keys, @kbd{t e x t}, will be processed. - -When defining macros using @kbd{:map} or @kbd{:map!}, the user enters the -actually keys to be used to invoke the macro. For instance, you should hit -the actual key @kbd{f6} if it is to be part of a macro name; you do -@emph{not} write `f 6'. When entering keys, Viper displays them as strings or -vectors (e.g., "abc" or [f6 f7 a]). The same holds for unmapping. Hitting -@key{TAB} while typing a macro name in the @kbd{:unmap} or @kbd{:unmap!} command -will cause name completion. Completions are displayed as strings or vectors. -However, as before, you don't actually type ``"'', ``['', or ``]'' that -appear in the completions. These are meta-symbols that indicate whether -the corresponding macro name is a vector or a string. - -One last difference from Vi: Vi-style keyboard macros cannot be defined in -terms of other Vi-style keyboard macros (but named Emacs macros are OK). -More precisely, while defining or executing a macro, the special meaning -of key sequences (as Vi macros) is ignored. -This is because it is all too easy to create an infinite loop in this way. -Since Viper macros are much more powerful than Vi's it is impossible to -detect such loops. In practice, this is not really a limitation but, -rather, a feature. - -We should also note that Vi macros are disabled in the Minibuffer, which -helps keep some potential troubles away. - -The rate at which the user must type keys in order for them to be -recognized as a timeout macro is controlled by the variable -@code{viper-fast-keyseq-timeout}, which defaults to 200 milliseconds. - -For the most part, Viper macros defined in @file{~/.viper} can be shared -between Emacs, XEmacs, and X and TTY modes. However, macros defined via -function keys may need separate definitions when XEmacs and Emacs have -different names for the same keyboard key. For instance, the `Page Up' key -may be known in Emacs as @kbd{prior} and in XEmacs as @kbd{pgup}. -The problem with TTY may be that the function keys there generate sequences -of events instead of a single event (as under a window system). -Both Emacs and XEmacs mape some of these sequences back to the logical keys -(e.g., the sequences generated by the arrow keys are mapped to @kbd{up}, -@kbd{left}, etc.). However, not all function keys are mapped in this way. -Macros that are bound to key sequences that contain such unmapped function -keys have to be redefined for TTY's (and possibly for every type of TTY you -may be using). To do this, start Emacs on an appropriate TTY device and -define the macro using @kbd{:map}, as usual. - -@findex @code{viper-describe-kbd-macros} -Finally, Viper provides a function that conveniently displays all macros -currently defined. To see all macros along with their definitions, type -@kbd{M-x viper-describe-kbd-macros}. - -@node Commands,,Customization,Top,Top -@chapter Commands - -This section is a semi-automatically bowdlerized version of the Vi -reference created by @* @samp{maart@@cs.vu.nl} and others. It can be -found on the Vi archives. This reference has been adapted for Viper.@refill - -@menu -* Groundwork:: Textual Conventions and Viper basics -* Text Handling:: Moving, Editing, Undoing. -* Display:: Scrolling. -* File and Buffer Handling:: Editing, Writing and Quitting. -* Mapping:: Mapping Keys, Keyboard Macros -* Shell Commands:: Accessing Shell Commands, Processing Text -* Options:: Ex options, the @kbd{:set} commands -* Emacs Related Commands:: Meta Keys, Windows -* Mouse-bound Commands:: Search and insertion of text -@end menu - -@node Groundwork, Text Handling, Commands, Commands -@comment node-name, next, previous, up -@section Groundwork - -The VI command set is based on the idea of combining motion commands -with other commands. The motion command is used as a text region -specifier for other commands. -We classify motion commands into @dfn{point commands} and -@dfn{line commands}.@refill - -@cindex point commands - -The point commands are: - -@quotation -@kbd{h}, @kbd{l}, @kbd{0}, @kbd{$}, @kbd{w}, @kbd{W}, @kbd{b}, @kbd{B}, -@kbd{e}, @kbd{E}, @kbd{(}, @kbd{)}, @kbd{/}, @kbd{?}, @kbd{`}, @kbd{f}, -@kbd{F}, @kbd{t}, @kbd{T}, @kbd{%}, @kbd{;}, @kbd{,}, @kbd{^} -@end quotation - -@cindex line commands - -The line commands are: - -@quotation -@kbd{j}, @kbd{k}, @kbd{+}, @kbd{-}, @kbd{H}, @kbd{M}, @kbd{L}, @kbd{@{}, -@kbd{@}}, @kbd{G}, @kbd{'}, @kbd{[[}, @kbd{]]}, @kbd{[]} -@end quotation -@noindent - -Text Deletion Commands (@xref{Deleting Text}), Change commands -(@xref{Changing Text}), even Shell Commands (@xref{Shell Commands}) -use these commands to describe a region of text to operate on. - -@cindex r and R region specifiers - -Viper adds two region descriptors, @kbd{r} and @kbd{R}. These describe -the Emacs regions (@xref{Basics}), but they are not movement commands. - -The command description uses angle brackets @samp{<>} to indicate -metasyntactic variables, since the normal conventions of using simple -text can be confusing with Viper where the commands themselves are -characters. Watch out where @kbd{<} shift commands and @kbd{<count>} are -mentioned together!!! - -@kindex <move> -@kindex <a-z> -@kindex <address> -@cindex <move> -@cindex <a-z> -@cindex <address> -@cindex movements - -@samp{<move>} refers to the above movement commands, and @samp{<a-z>} -refers to registers or textmarkers from @samp{a} to @samp{z}. Note -that the @samp{<move>} is described by full move commands, that is to -say they will take counts, and otherwise behave like normal move commands. -@cindex Ex addresses -@samp{<address>} refers to Ex line addresses, which include - -@table @kbd -@item . <No address> -Current line -@item .+n .-n -Add or subtract for current line -@item number -Actual line number, use @kbd{.=} to get the line number -@item '<a-z> -Textmarker -@item $ -Last line -@item x,y -Where x and y are one of the above -@item % -@cindex % (Ex address) -For the whole file, same as (1,$). -@item /pat/ -@item ?pat? -Next or previous line with pattern pat -@end table - -@cindex % (Current file) -Note that @samp{%} is used in Ex commands to mean current file. If you -want a @samp{%} in your command, it must be escaped as @samp{\%}. -@cindex # (Previous file) -Similarly, @samp{#} expands to the previous file. The previous file is -the first file in @kbd{:args} listing. This defaults to previous window -in the VI sense if you have one window only. - -@kindex <args> -@kindex <cmd> -@cindex <args> -@cindex <cmd> -@noindent -Others like @samp{<args> -- arguments}, @samp{<cmd> -- command} etc. -should be fairly obvious. - -@noindent -Common characters referred to include: - -@table @kbd -@item <sp> -Space -@item <ht> -Tab -@item <lf> -Linefeed -@item <esc> -Escape -@item <cr> -Return, Enter -@end table -@cindex <cr> -@cindex <esc> -@cindex <lf> -@cindex <ht> -@cindex <sp> - -@cindex words -@cindex WORDS -@cindex char -@cindex CHAR - -We also use @samp{word} for alphanumeric/non-alphanumeric words, and -@samp{WORD} for whitespace delimited words. @samp{char} refers to any -ASCII character, @samp{CHAR} to non-whitespace character. -Brackets @samp{[]} indicate optional parameters; @samp{<count>} also -optional, usually defaulting to 1. Brackets are elided for -@samp{<count>} to eschew obfuscation. - -Viper's idea of Vi's words is slightly different from Vi. First, Viper -words understand Emacs symbol tables. Therefore, all symbols declared to be -alphanumeric in a symbol table can automatically be made part of the Viper -word. This is useful when, for instance, editing text containing European, -Cyrillic, Japanese, etc., texts. - -Second, Viper lets you depart from Vi's idea of a word by changing the a -syntax preference via the customization widget (the variable -@code{viper-syntax-preference}) or by executing -@code{viper-set-syntax-preference} interactively. - -By default, Viper syntax preference is @code{reformed-vi}, which means that -Viper considers only those symbols to be part of a word that are specified -as word-symbols by the current Emacs syntax table (which may be different -for different major modes) plus the underscore symbol @kbd{_}, minus the -symbols that are not considered words in Vi (e.g., `,',;, etc.), but may be -considered as word-symbols by various Emacs major modes. Reformed-Vi works -very close to Vi, and it also recognizes words in other -alphabets. Therefore, this is the most appropriate mode for editing text -and is likely to fit all your needs. - -You can also set Viper syntax preference to @code{strict-vi}, which would -cause Viper to view all non-English letters as non-word-symbols. - -You can also specify @code{emacs} as your preference, which would -make Viper use exactly the same notion of a word as Emacs does. In -particular, the underscore may not be part of a word in some major modes. - -Finally, if @code{viper-syntax-preference} is set to @code{extended}, Viper -words would consist of characters that are classified as alphanumeric -@emph{or} as parts of symbols. This is convenient for editing programs. - -@code{viper-syntax-preference} is a local variable, so it can have different -values for different major modes. For instance, in programming modes it can -have the value @code{extended}. In text modes where words contain special -characters, such as European (non-English) letters, Cyrillic letters, etc., -the value can be @code{reformed-vi} or @code{emacs}. -If you consider using different syntactic preferences for different major -modes, you should execute, for example, - -@example -(viper-set-syntax-preference nil "extended") -@end example - -in the appropriate major mode hooks. - -@vindex @code{viper-syntax-preference} -@findex @code{viper-set-syntax-preference} -@cindex syntax table - - - -The above discussion concerns only the movement commands. In regular -expressions, words remain the same as in Emacs. That is, the expressions -@code{\w}, @code{\>}, @code{\<}, etc., use Emacs' idea of what is a word, -and they don't look into the value of variable -@code{viper-syntax-preference}. This is because Viper doesn't change syntax -tables in order to not thwart the various major modes that set these -tables. - -The usual Emacs convention is used to indicate Control Characters, i.e -C-h for Control-h. @emph{Do not confuse this to mean the separate -characters C - h!!!} The @kbd{^} is itself, never used to indicate a -Control character. - -@node Text Handling, Display, Groundwork, Commands -@section Text Handling - -@menu -* Move Commands:: Moving, Searching -* Marking:: Textmarkers in Viper and the Emacs Mark. -* Appending Text:: Text insertion, Shifting, Putting -* Editing in Insert State:: Autoindent, Quoting etc. -* Deleting Text:: Deleting -* Changing Text:: Changing, Replacement, Joining -* Search and Replace:: Searches, Query Replace, Pattern Commands -* Yanking:: Yanking, Viewing Registers -* Undoing:: Multiple Undo, Backups -@end menu - -@node Move Commands,Marking,,Text Handling -@subsection Move Commands - -@cindex movement commands -@cindex searching -@cindex textmarkers -@cindex markers -@cindex column movement -@cindex paragraphs -@cindex headings -@cindex sections -@cindex sentences -@cindex matching parens -@cindex paren matching - -@table @kbd -@item <count> h C-h -<count> chars to the left. -@item <count> j <lf> C-n -<count> lines downward. -@item <count> l <sp> -<count> chars to the right. -@item <count> k C-p -<count> lines upward. -@item <count> $ -To the end of line <count> from the cursor. -@item <count> ^ -To the first CHAR <count> - 1 lines lower. -@item <count> - -To the first CHAR <count> lines higher. -@item <count> + <cr> -To the first CHAR <count> lines lower. -@item 0 -To the first char of the line. -@item <count> | -To column <count> -@item <count> f<char> -<count> <char>s to the right (find). -@item <count> t<char> -Till before <count> <char>s to the right. -@item <count> F<char> -<count> <char>s to the left. -@item <count> T<char> -Till after <count> <char>s to the left. -@item <count> ; -Repeat latest @kbd{f t F T} <count> times. -@item <count> , -Repeat latest @kbd{f t F T} -<count> times in opposite direction. -@item <count> w -<count> words forward. -@item <count> W -<count> WORDS forward. -@item <count> b -<count> words backward. -@item <count> B -<count> WORDS backward. -@item <count> e -To the end of word <count> forward. -@item <count> E -To the end of WORD <count> forward. -@item <count> G -Go to line <count> (default end-of-file). -@item <count> H -To line <count> from top of the screen (home). -@item <count> L -To line <count> from bottom of the screen (last). -@item M -To the middle line of the screen. -@item <count> ) -<count> sentences forward. -@item <count> ( -<count> sentences backward. -@item <count> @} -<count> paragraphs forward. -@item <count> @{ -<count> paragraphs backward. -@item <count> ]] -To the <count>th heading. -@item <count> [[ -To the <count>th previous heading. -@item <count> [] -To the end of <count>th heading. -@item m<a-z> -Mark the cursor position with a letter. -@item `<a-z> -To the mark. -@item '<a-z> -To the first CHAR of the line with the mark. -@item [<a-z> -Show contents of textmarker. -@item ]<a-z> -Show contents of register. -@item `` -To the cursor position before the latest absolute -jump (of which are examples @kbd{/} and @kbd{G}). -@item '' -To the first CHAR of the line on which the cursor -was placed before the latest absolute jump. -@item <count> /<string> -To the <count>th occurrence of <string>. -@item <count> /<cr> -To the <count>th occurrence of <string> from previous @kbd{/ or ?}. -@item <count> ?<string> -To the <count>th previous occurrence of <string>. -@item <count> ?<cr> -To the <count>th previous occurrence of <string> from previous @kbd{? or /}. -@item n -Repeat latest @kbd{/} @kbd{?} (next). -@item N -Repeat latest search in opposite direction. -@item C-c / -Without a prefix argument, this command toggles -case-sensitive/case-insensitive search modes and plain vanilla/regular -expression search. With the prefix argument 1, i.e., -@kbd{1 C-c /}, this toggles case-sensitivity; with the prefix argument 2, -toggles plain vanilla search and search using -regular expressions. @xref{Viper Specials}, for alternative ways to invoke -this function. -@cindex vanilla search -@cindex case-sensitive search -@cindex case-insensitive search -@item % -Find the next bracket/parenthesis/brace and go to its match. -By default, Viper ignores brackets/parentheses/braces that occur inside -parentheses. You can change this by setting -@code{viper-parse-sexp-ignore-comments} to nil in your @file{.viper} fipe. -This option can also be toggled interactively if you quickly hit @kbd{%%%}. - -This latter feature is implemented as a vi-style keyboard macro. If you -don't want this macro, put - -@example -(viper-set-parsing-style-toggling-macro 'undefine) -@end example -@findex @code{viper-set-parsing-style-toggling-macro} - -in your @file{~/.viper} file. - -@end table -@kindex @kbd{%} -@kindex @kbd{C-c /} -@kindex @kbd{N} -@kindex @kbd{n} -@kindex @kbd{?<cr>} -@kindex @kbd{/<cr>} -@kindex @kbd{?<string>} -@kindex @kbd{/<string>} -@kindex @kbd{''} -@kindex @kbd{``} -@kindex @kbd{]<a-z>} -@kindex @kbd{[<a-z>} -@kindex @kbd{'<a-z>} -@kindex @kbd{`<a-z>} -@kindex @kbd{m<a-z>} -@kindex @kbd{[]} -@kindex @kbd{[[} -@kindex @kbd{]]} -@kindex @kbd{@{} -@kindex @kbd{@}} -@kindex @kbd{(} -@kindex @kbd{)} -@kindex @kbd{M} -@kindex @kbd{L} -@kindex @kbd{H} -@kindex @kbd{G} -@kindex @kbd{E} -@kindex @kbd{e} -@kindex @kbd{B} -@kindex @kbd{b} -@kindex @kbd{W} -@kindex @kbd{w} -@kindex @kbd{,} -@kindex @kbd{;} -@kindex @kbd{T<char>} -@kindex @kbd{F<char>} -@kindex @kbd{t<char>} -@kindex @kbd{f<char>} -@kindex @kbd{|} -@kindex @kbd{0} -@kindex @kbd{<cr>} -@kindex @kbd{+} -@kindex @kbd{-} -@kindex @kbd{^} -@kindex @kbd{$} -@kindex @kbd{C-p} -@kindex @kbd{<lf>} -@kindex @kbd{<sp>} -@kindex @kbd{C-n} -@kindex @kbd{C-h} -@kindex @kbd{h} -@kindex @kbd{j} -@kindex @kbd{k} -@kindex @kbd{l} -@vindex @code{viper-parse-sexp-ignore-comments} - -@node Marking,Appending Text,Move Commands,Text Handling -@subsection Marking - -Emacs mark is referred to in the region specifiers @kbd{r} and @kbd{R}. -@xref{Emacs Preliminaries} and @pxref{Basics} for explanation. Also -see @ref{Mark,,Mark,emacs,The GNU Emacs manual}, for an explanation of -the Emacs mark ring. - -@cindex marking - -@table @kbd -@item m<a-z> -Mark the current file and position with the specified letter. -@item m . -Set the Emacs mark (@xref{Emacs Preliminaries}) at point. -@item m < -Set the Emacs mark at beginning of buffer. -@item m > -Set the Emacs mark at end of buffer. -@item m , -Jump to the Emacs mark. -@item :mark <char> -Mark position with text marker named <char>. This is an Ex command. -@item :k <char> -Same as @kbd{:mark}. -@item `` -Exchange point and mark. -@item '' -Exchange point and mark and go to the first CHAR on line. -@item '<a-z> -Go to specified Viper mark. -@item -Go to specified Viper mark and go to the first CHAR on line. -@end table -@kindex @kbd{m<a-z>} -@kindex @kbd{m.} -@kindex @kbd{m>} -@kindex @kbd{m<} -@kindex @kbd{m,} -@findex @kbd{:mark} -@findex @kbd{:k} -@kindex @kbd{''} -@kindex @kbd{``} -@kindex @kbd{`<a-z>} -@kindex @kbd{'<a-z>} - -@node Appending Text, Editing in Insert State, Marking,Text Handling -@subsection Appending Text - -@xref{Options} to see how to change tab and shiftwidth size. See the GNU -Emacs manual, or try @kbd{C-ha tabs} (If you have turned Emacs help on). -Check out the variable @code{indent-tabs-mode} to put in just spaces. -Also see options for word-wrap. - -@cindex inserting -@cindex appending -@cindex paste -@cindex put - -@table @kbd -@item <count> a -<count> times after the cursor. -@item <count> A -<count> times at the end of line. -@item <count> i -<count> times before the cursor (insert). -@item <count> I -<count> times before the first CHAR of the line -@item <count> o -On a new line below the current (open). -The count is only useful on a slow terminal. -@item <count> O -On a new line above the current. -The count is only useful on a slow terminal. -@item <count> ><move> -Shift the lines described by <count><move> one -shiftwidth to the right (layout!). -@item <count> >> -Shift <count> lines one shiftwidth to the right. -@item <count> ["<a-z1-9>]p -Put the contents of the (default undo) buffer -<count> times after the cursor. The register will -be automatically downcased. -@item <count> ["<a-z1-9>]P -Put the contents of the (default undo) buffer -<count> times before the cursor. The register will -@item [<a-z> -Show contents of textmarker. -@item ]<a-z> -Show contents of register. -@item <count> . -Repeat previous command <count> times. For destructive -commands as well as undo. -@item f1 1 and f1 2 -While @kbd{.} repeats the last destructive command, -these two macros repeat the second-last and the third-last destructive -commands. @xref{Vi Macros}, for more information on Vi macros. -@item C-c M-p and C-c M-n -In Vi state, -these commands help peruse the history of Vi's destructive commands. -Successive typing of @kbd{C-c M-p} causes Viper to search the history in -the direction -of older commands, while hitting @kbd{C-c M-n} does so in reverse -order. Each command in the history is displayed in the Minibuffer. The -displayed command can -then be executed by typing `@kbd{.}'. - -Since typing the above sequences of keys may be tedious, the -functions doing the perusing can be bound to unused keyboard keys in the -@file{~/.viper} file. @xref{Viper Specials}, for details. -@end table -@kindex @kbd{C-c M-p} -@kindex @kbd{C-c M-n} -@kindex @kbd{.} -@kindex @kbd{]<a-z>} -@kindex @kbd{[<a-z>} -@kindex @kbd{P} -@kindex @kbd{p} -@kindex @kbd{"<a-z1-9>p} -@kindex @kbd{"<a-z1-9>P} -@kindex @kbd{>>} -@kindex @kbd{><move>} -@kindex @kbd{O} -@kindex @kbd{o} -@kindex @kbd{i} -@kindex @kbd{A} -@kindex @kbd{a} - -@node Editing in Insert State, Deleting Text, Appending Text,Text Handling -@subsection Editing in Insert State - -Minibuffer can be edited similarly to Insert state, and you can switch -between Insert/Replace/Vi states at will. -Some users prefer plain Emacs feel in the Minibuffer. To this end, set -@var{viper-vi-style-in-minibuffer} to @code{nil}. - -@cindex Insert state - -@table @kbd -@item C-v -Deprive the next char of its special meaning (quoting). -@item C-h -One char back. -@item C-w -One word back. -@item C-u -Back to the begin of the change on the -current line. - -@end table -@kindex @kbd{C-u} -@kindex @kbd{C-w} -@kindex @kbd{C-v} - -@node Deleting Text, Changing Text, Editing in Insert State, Text Handling -@subsection Deleting Text - - -There is one difference in text deletion that you should be -aware of. This difference comes from Emacs and was adopted in Viper -because we find it very useful. In Vi, if you delete a line, say, and then -another line, these two deletions are separated and are put back -separately if you use the @samp{p} command. In Emacs (and Viper), successive -series of deletions that are @emph{not interrupted} by other commands are -lumped together, so the deleted text gets accumulated and can be put back -as one chunk. If you want to break a sequence of deletions so that the -newly deleted text could be put back separately from the previously deleted -text, you should perform a non-deleting action, e.g., move the cursor one -character in any direction. - -@cindex shifting text - -@table @kbd -@item <count> x -Delete <count> chars under and after the cursor. -@item <count> X -Delete <count> chars before the cursor. -@item <count> d<move> -Delete from point to endpoint of <count><move>. -@item <count> dd -Delete <count> lines. -@item D -The rest of the line. -@item <count> <<move> -Shift the lines described by <count><move> one -shiftwidth to the left (layout!). -@item <count> << -Shift <count> lines one shiftwidth to the left. -@end table -@kindex @kbd{<<} -@kindex @kbd{<<move>} -@kindex @kbd{D} -@kindex @kbd{dd} -@kindex @kbd{d<move>} -@kindex @kbd{X} -@kindex @kbd{x} - -@node Changing Text, Search and Replace, Deleting Text,Text Handling -@subsection Changing Text - -@cindex joining lines -@cindex changing case -@cindex quoting regions -@cindex substitution - -@table @kbd -@item <count> r<char> -Replace <count> chars by <char> - no <esc>. -@item <count> R -Overwrite the rest of the line, -appending change @var{count - 1} times. -@item <count> s -Substitute <count> chars. -@item <count> S -Change <count> lines. -@item <count> c<move> -Change from begin to endpoint of <count><move>. -@item <count> cc -Change <count> lines. -@item <count> C -The rest of the line and <count> - 1 next lines. -@item <count> =<move> -Reindent the region described by move. -@item <count> ~ -Switch lower and upper cases. -@item <count> J -Join <count> lines (default 2). -@item :[x,y]s/<p>/<r>/<f> -Substitute (on lines x through y) the pattern -<p> (default the last pattern) with <r>. Useful -flags <f> are @samp{g} for @samp{global} (i.e. change every -non-overlapping occurrence of <p>) and @samp{c} for -@samp{confirm} (type @samp{y} to confirm a particular -substitution, else @samp{n} ). Instead of @kbd{/} any -punctuation CHAR unequal to <space> <tab> and <lf> can be used as -delimiter. - -In Emacs, @samp{\&} stands for the last matched expression, so -@kbd{s/[ab]+/\&\&/} will double the string matched by @kbd{[ab]}. -Viper doesn't treat @samp{&} specially, unlike Vi: use @samp{\&} instead. -@item :[x,y]copy [z] -Copy text between @kbd{x} and @kbd{y} to the position after @kbd{z}. -@item :[x,y]t [z] -Same as @kbd{:copy}. -@item :[x,y]move [z] -Move text between @kbd{x} and @kbd{y} to the position after @kbd{z}. -@item & -Repeat latest Ex substitute command, e.g. -@kbd{:s/wrong/right}. -@item C-c / -Toggle case-sensitive search. With prefix argument, toggle vanilla/regular -expression search. -@item #c<move> -Change upper-case characters in the region to lower-case. -@item #C<move> -Change lower-case characters in the region to upper-case. -@item #q<move> -Insert specified string at the beginning of each line in the region -@item C-c M-p and C-c M-n -In Insert and Replace states, these keys are bound to commands that peruse -the history of the text -previously inserted in other insert or replace commands. By repeatedly typing -@kbd{C-c M-p} or @kbd{C-c M-n}, you will cause Viper to -insert these previously used strings one by one. -When a new string is inserted, the previous one is deleted. - -In Vi state, these keys are bound to functions that peruse the history of -destructive Vi commands. -@xref{Viper Specials}, for details. -@end table -@kindex @kbd{C-c M-p} -@kindex @kbd{C-c M-n} -@kindex @kbd{#q<move> } -@kindex @kbd{#C<move>} -@kindex @kbd{#c<move>} -@kindex @kbd{&} -@kindex @kbd{\&} -@findex @kbd{:substitute/<p>/<r>/<f>} -@findex @kbd{:s/<p>/<r>/<f>} -@findex @kbd{:copy [z]} -@findex @kbd{:t [z]} -@findex @kbd{:move [z]} -@kindex @kbd{J} -@kindex @kbd{~} -@kindex @kbd{=<move>} -@kindex @kbd{C} -@kindex @kbd{cc} -@kindex @kbd{c<move>} -@kindex @kbd{S} -@kindex @kbd{s} -@kindex @kbd{R} -@kindex @kbd{r<char>} - -@node Search and Replace, Yanking, Changing Text,Text Handling -@subsection Search and Replace - -@xref{Groundwork}, for Ex address syntax. @xref{Options} to see how to -get literal (non-regular-expression) search and how to stop search from -wrapping around. - -@table @kbd -@item <count> /<string> -To the <count>th occurrence of <string>. -@item <count> ?<string> -To the <count>th previous occurrence of <string>. -@item <count> g<move> -Search for the text described by move. (off by default) -@item n -Repeat latest @kbd{/} @kbd{?} (next). -@item N -Idem in opposite direction. -@item % -Find the next bracket and go to its match -@item :[x,y]g/<string>/<cmd> -@cindex text processing -Search globally [from line x to y] for <string> -and execute the Ex <cmd> on each occurrence. -@item :[x,y]v/<string>/<cmd> -Execute <cmd> on the lines that don't match. -@item #g<move> -Execute the last keyboard macro for each line in the region. -@xref{Macros and Registers}, for more info. -@item Q -Query Replace. -@item :ta <name> -Search in the tags file where <name> is defined (file, line), and go to it. -@item :[x,y]s/<p>/<r>/<f> -Substitute (on lines x through y) the pattern <p> (default the last -pattern) with <r>. Useful -flags <f> are @samp{g} for @samp{global} (i.e. change every -non-overlapping occurrence of <p>) and @samp{c} for -@samp{confirm} (type @samp{y} to confirm a particular -substitution, else @samp{n}). Instead of @kbd{/} any -punctuation character other than <space> <tab> and <lf> can be used as -delimiter. -@item & -Repeat latest Ex substitute command, e.g. @kbd{:s/wrong/right}. -@item :global /<pattern>/<ex-command> -@itemx :g /<pattern>/<ex-command> -Execute <ex-command> on all lines that match <pattern>. -@item :vglobal /<pattern>/<ex-command> -@itemx :v /<pattern>/<ex-command> -Execute <ex-command> on all lines that do not match <pattern>. -@end table -@kindex @kbd{&} -@findex @kbd{:substitute/<p>/<r>/<f>} -@kindex @kbd{Q} -@kindex @kbd{#g<move>} -@findex @kbd{:v} -@findex @kbd{:g} -@findex @kbd{:global} -@findex @kbd{:vglobal} -@findex @kbd{:tag <name>} -@kindex @kbd{%} -@kindex @kbd{N} -@kindex @kbd{n} -@kindex @kbd{g<move>} -@kindex @kbd{?<string>} -@kindex @kbd{/<string>} - -@node Yanking,Undoing,Search and Replace,Text Handling -@subsection Yanking - -@cindex cut and paste -@cindex paste - -@table @kbd -@item <count> y<move> -Yank from begin to endpoint of <count><move>. -@item <count> "<a-z>y<move> -Yank from begin to endpoint of <count><move> to register. -@item <count> "<A-Z>y<move> -Yank from begin to endpoint of <count><move> and append -to register. -@item <count> yy -<count> lines. -@item <count> Y -Idem (should be equivalent to @kbd{y$} though). -@item m<a-z> -Mark the cursor position with a letter. -@item [<a-z> -Show contents of textmarker. -@item ]<a-z> -Show contents of register. -@item <count> ["<a-z1-9>]p -Put the contents of the (default undo) buffer -<count> times after the cursor. The register will -be automatically downcased. -@item <count> ["<a-z1-9>]P -Put the contents of the (default undo) buffer -<count> times before the cursor. The register will -@end table -@kindex @kbd{P} -@kindex @kbd{p} -@kindex @kbd{"<a-z1-9>p} -@kindex @kbd{"<a-z1-9>P} -@kindex @kbd{]<a-z>} -@kindex @kbd{[<a-z>} -@kindex @kbd{m<a-z>} -@kindex @kbd{Y} -@kindex @kbd{yy} -@kindex @kbd{"<A-Z>y<move>} -@kindex @kbd{"<a-z>y<move>} -@kindex @kbd{y<move>} -@kindex @kbd{yank} -@findex @kbd{:yank} - -@node Undoing,, Yanking,Text Handling -@subsection Undoing - -@cindex undo -@cindex backup files - -@table @kbd -@item u U -Undo the latest change. -@item . -Repeat undo. -@item :q! -Quit Vi without writing. -@item :e! -Re-edit a messed-up file. -@item :rec -Recover file from autosave. Viper also creates backup files -that have a @samp{~} appended to them. -@end table -@findex @kbd{:rec} -@findex @kbd{:e!} -@findex @kbd{:q!} -@kindex @kbd{.} -@kindex @kbd{U} -@kindex @kbd{u} - -@node Display, File and Buffer Handling, Text Handling, Commands -@section Display - -@cindex scrolling - -@table @kbd -@item C-g -At user level 1, -give file name, status, current line number -and relative position. @* -At user levels 2 and higher, abort the current command. -@item C-c g -Give file name, status, current line number and relative position -- all -user levels. -@item C-l -Refresh the screen. -@item <count> C-e -Expose <count> more lines at bottom, cursor stays put (if possible). -@item <count> C-y -Expose <count> more lines at top, cursor stays put (if possible). -@item <count> C-d -Scroll <count> lines downward (default the number of the previous scroll; -initialization: half a page). -@item <count> C-u -Scroll <count> lines upward (default the number of the previous scroll; -initialization: half a page). -@item <count> C-f -<count> pages forward. -@item <count> C-b -<count> pages backward (in older versions @kbd{C-b} only works without count). -@item <count> z<cr> -@item zH -Put line <count> at the top of the window (default the current line). -@item <count> z- -@item zL -Put line <count> at the bottom of the window -(default the current line). -@item <count> z. -@item zM -Put line <count> in the center of the window -(default the current line). -@end table -@kindex @kbd{zM} -@kindex @kbd{zL} -@kindex @kbd{zH} -@kindex @kbd{z<cr>} -@kindex @kbd{z.} -@kindex @kbd{z-} -@kindex @kbd{z<cr>} -@kindex @kbd{C-b} -@kindex @kbd{C-f} -@kindex @kbd{C-u} -@kindex @kbd{C-d} -@kindex @kbd{C-y} -@kindex @kbd{C-e} -@kindex @kbd{C-l} -@kindex @kbd{C-g} - - -@node File and Buffer Handling, Mapping, Display,Commands -@section File and Buffer Handling - -@cindex multiple files - -In all file handling commands, space should be typed before entering the file -name. If you need to type a modifier, such as @kbd{>>} or @kbd{!}, don't -put any space between the command and the modifier. - -@table @kbd -@item :q -Quit buffer except if modified. -@item :q! -Quit buffer without checking. In Viper, these two commands -are identical. Confirmation is required if exiting modified buffers that -visit files. -@item :suspend -@item :stop -Suspend Viper -@item :[x,y] w -Write the file. Viper nakes sure that a final newline is always added to -any file where this newline is missing. This is done by setting Emacs -variable @code{require-final-newline} to @code{t}. If you don't like this -feature, use @code{setq-default} to set @code{require-final-newline} to -@code{nil}. This must be done in @file{.viper} file. -@item :[x,y] w <name> -Write to the file <name>. -@item :[x,y] w>> <name> -Append the buffer to the file <name>. There should be no space between -@kbd{w} and @kbd{>>}. Type space after the @kbd{>>} and see what happens. -@item :w! <name> -Overwrite the file <name>. In Viper, @kbd{:w} and @kbd{:w!} are identical. -Confirmation is required for writing to an existing file (if this is not -the file the buffer is visiting) or to a read-only file. -@item :x,y w <name> -Write lines x through y to the file <name>. -@item :wq -Write the file and kill buffer. -@item :r <file> [<file> ...] -Read file into a buffer, inserting its contents after the current line. -@item :xit -Same as @kbd{:wq}. -@item :Write -@itemx :W -Save all unsaved buffers, asking for confirmation. -@item :WWrite -@itemx :WW -Like @kbd{W}, but without asking for confirmation. -@item ZZ -Save current buffer and kill it. If user level is 1, then save all files -and kill Emacs. Killing Emacs is the wrong way to use it, so you should -switch to higher user levels as soon as possible. -@item :x [<file>] -Save and kill buffer. -@item :x! [<file>] -@kbd{:w![<file>]} and @kbd{:q}. -@item :pre -Preserve the file -- autosave buffers. -@item :rec -Recover file from autosave. -@item :f -Print file name and lines. -@item :cd [<dir>] -Set the working directory to <dir> (default home directory). -@item :pwd -Print present working directory. -@item :e [+<cmd>] <files> -Edit files. If no filename is given, edit the file visited by the current -buffer. If buffer was modified or the file changed on disk, ask for -confirmation. Unlike Vi, Viper allows @kbd{:e} to take multiple arguments. -The first file is edited the same way as in Vi. The rest are visited -in the usual Emacs way. -@item :e! [+<cmd>] <files> -Re-edit file. If no filename, reedit current file. -In Viper, unlike Vi, @kbd{e!} is identical to @kbd{:e}. In both cases, the -user is asked to confirm if there is a danger of discarding changes to a -buffer. -@item :q! -Quit Vi without writing. -@item C-^ -Edit the alternate (normally the previous) file. -@item :rew -Obsolete -@item :args -List files not shown anywhere with counts for next -@item :n [count] [+<cmd>] [<files>] -Edit <count> file, or edit files. The count comes from :args. -@item :N [count] [+<cmd>] [<files>] -Like @kbd{:n}, but the meaning of the variable -@var{ex-cycle-other-window} is reversed. -@item :b -Switch to another buffer. If @var{ex-cycle-other-window} is @code{t}, -switch in another window. Buffer completion is supported. -@item :B -Like @kbd{:b}, but the meaning of @var{ex-cycle-other-window} is reversed. -@item :<address>r <name> -Read the file <name> into the buffer after the line <address>. -@item v, V, C-v -Edit a file in current or another window, or in another frame. File name -is typed in Minibuffer. File completion and history are supported. -@end table -@kindex @kbd{v} -@kindex @kbd{V} -@findex @kbd{:args} -@findex @kbd{:rew} -@kindex @kbd{C-^} -@findex @kbd{:e! [<files>]} -@findex @kbd{:e [<files>]} -@findex @kbd{:edit [<files>]} -@findex @kbd{:edit! [<files>]} -@findex @kbd{:q!} -@findex @kbd{:q} -@findex @kbd{:quit} -@findex @kbd{:quit!} -@findex @kbd{:f} -@findex @kbd{:rec} -@findex @kbd{:r} -@findex @kbd{:read} -@findex @kbd{:pre} -@kindex @kbd{ZZ} -@findex @kbd{:wq} -@findex @kbd{:w <file>} -@findex @kbd{:w! <file>} -@findex @kbd{:w >> <file>} -@findex @kbd{:write <file>} -@findex @kbd{:write! <file>} -@findex @kbd{:write >> <file>} -@findex @kbd{:W} -@findex @kbd{:WW} -@findex @kbd{:Write} -@findex @kbd{:WWrite} -@findex @kbd{:WWrite} -@findex @kbd{:x} -@findex @kbd{:x!} -@findex @kbd{:suspend} -@findex @kbd{:stop} -@findex @kbd{:n [<count> | <file>]} -@findex @kbd{:cd [<dir>]} -@findex @kbd{:pwd} - -@node Mapping, Shell Commands, File and Buffer Handling, Commands -@section Mapping - -@cindex keybindings -@cindex keymapping - -@table @kbd -@item :map <string> -Start defining a Vi-style keyboard macro. -For instance, typing -@kbd{:map www} followed by @kbd{:!wc %} and then typing @kbd{C-x )} -will cause @kbd{www} to run wc on -current file (Vi replaces @samp{%} with the current file name). -@item C-x ) -Finish defining a keyboard macro. -In Viper, this command completes the process of defining all keyboard -macros, whether they are Emacs-style or Vi-style. -This is a departure from Vi, needed to allow WYSIWYG mapping of -keyboard macros and to permit the use of function keys and arbitrary Emacs -functions in the macros. -@item :unmap <string> -Deprive <string> of its mappings in Vi state. -@item :map! <string> -Map a macro for Insert state. -@item :unmap! <string> -Deprive <string> of its mapping in Insert state (see @kbd{:unmap}). -@item @@<a-z> -In Vi state, -execute the contents of register as a command. -@item @@@@ -In Vi state, -repeat last register command. -@item @@# -In Vi state, -begin keyboard macro. End with @@<a-z>. This will -put the macro in the proper register. Register will -be automatically downcased. -@xref{Macros and Registers}, for more info. -@item @@!<a-z> -In Vi state, -yank anonymous macro to register -@item * -In Vi state, -execute anonymous macro (defined by C-x( and C-x )). -@item C-x e -Like @kbd{*}, but works in all Viper states. -@item #g<move> -Execute the last keyboard macro for each line in the region. -@xref{Macros and Registers}, for more info. -@item [<a-z> -Show contents of textmarker. -@item ]<a-z> -Show contents of register. -@end table -@kindex @kbd{]<a-z>} -@kindex @kbd{[<a-z>} -@kindex @kbd{#g<move>} -@kindex @kbd{*} -@kindex @kbd{@@!<a-z>} -@kindex @kbd{@@#} -@kindex @kbd{@@@@} -@kindex @kbd{@@<a-z>} -@findex @kbd{:unmap <char>} -@findex @kbd{:map <char> <seq>} -@findex @kbd{:unmap! <char>} -@findex @kbd{:map! <char> <seq>} - -@node Shell Commands, Options, Mapping, Commands -@section Shell Commands - -@cindex % (Current file) - -Note that % is used in Ex commands to mean current file. If you want a % -in your command, it must be escaped as @samp{\%}. -@cindex % (Ex address) -However if % is the -first character, it stands as the address for the whole file. -@cindex # (Previous file) -Similarly, @samp{#} expands to the previous file. The previous file is -the first file in @kbd{:args} listing. This defaults -to the previous file in the VI sense if you have one window.@refill - -@cindex shell commands - -@table @kbd -@item :sh -Execute a subshell in another window -@item :[x,y]!<cmd> -Execute a shell <cmd> [on lines x through y; -% is replace by current file, \% is changed to % -@item :[x,y]!! [<args>] -Repeat last shell command [and append <args>]. -@item :!<cmd> -Just execute command and display result in a buffer. -@item :!! <args> -Repeat last shell command and append <args> -@item <count> !<move><cmd> -The shell executes <cmd>, with standard -input the lines described by <count><move>, -next the standard output replaces those lines -(think of @samp{cb}, @samp{sort}, @samp{nroff}, etc.). -@item <count> !!<cmd> -Give <count> lines as standard input to the -shell <cmd>, next let the standard output -replace those lines. -@item :[x,y] w !<cmd> -Let lines x to y be standard input for <cmd> -(notice the <sp> between @kbd{w} and @kbd{!}). -@item :<address>r !<cmd> -Put the output of <cmd> after the line <address> (default current). -@item :<address>r <name> -Read the file <name> into the buffer after the line <address> (default -current). -@end table -@findex @kbd{:<address>r <name>} -@findex @kbd{:<address>r !<cmd>} -@findex @kbd{!<cmd>} -@findex @kbd{!!<cmd>} -@findex @kbd{!<move><cmd>} -@findex @kbd{:w !<cmd>} -@findex @kbd{:x,y w !<cmd>} -@findex @kbd{:!! <args>} -@findex @kbd{:!<cmd>} -@findex @kbd{:sh} - -@node Options,Emacs Related Commands,Shell Commands,Commands -@section Options - -@cindex Vi options - -@table @kbd -@item autoindent -@itemx ai -@cindex autoindent -autoindent -- In append mode after a <cr> the -cursor will move directly below the first -character on the previous line. -This setting affects the current buffer only. -@item autoindent-global -@itemx ai-global -Same as `autoindent', but affects all buffers. -@item noautoindent -@itemx noai -Cancel autoindent. -@item noautoindent-global -@itemx noai-g -Cancel autoindent-global. -@item ignorecase -@itemx ic -@cindex case and searching -ignorecase -- No distinction between upper and lower cases when searching. -@item noignorecase -@itemx noic -Cancel ignorecase. -@item magic -@itemx ma -@cindex literal searching -Regular expressions used in searches; nomagic means no regexps. -@item nomagic -@item noma -Cancel magic. -@item readonly -@itemx ro -@cindex readonly files -readonly -- The file is not to be changed. -If the user attempts to write to this file, confirmation will be requested. -@item noreadonly -@itemx noro -Cancel readonly. -@item shell=<string> -@itemx sh=<string> -@cindex shell -shell -- The program to be used for shell escapes -(default @samp{$SHELL} (default @file{/bin/sh})). -@item shiftwidth=<count> -@itemx sw=<count> -@cindex layout -@cindex shifting text -shiftwidth -- Gives the shiftwidth (default 8 positions). -@item showmatch -@itemx sm -@cindex paren matching -@cindex matching parens -showmatch -- Whenever you append a @kbd{)}, Vi shows -its match if it's on the same page; also with -@kbd{@{} and @kbd{@}}. If there's no match, Vi will beep. -@item noshowmatch -@itemx nosm -Cancel showmatch. -@item tabstop=<count> -@itemx ts=<count> -@cindex changing tab width -@cindex tabbing -tabstop -- The length of a <ht>; warning: this is -only IN the editor, outside of it <ht>s have -their normal length (default 8 positions). -This setting affects the current buffer only. -@item tabstop-global -@itemx ts-g -Same as `tabstop', but affects all buffers. -@item wrapmargin=<count> -@itemx wm=<count> -@cindex auto fill -@cindex word wrap -wrapmargin -- In append mode Vi automatically -puts a <lf> whenever there is a <sp> or <ht> -within <wm> columns from the right margin. -@item wrapscan -@itemx ws -@cindex searching -wrapscan -- When searching, the end is -considered @samp{stuck} to the begin of the file. -@item nowrapscan -@itemx nows -Cancel wrapscan. -@item :set <option> -Turn <option> on. -@item :set no<option> -Turn <option> off. -@item :set <option>=<value> -Set <option> to <value>. -@end table -@findex @kbd{:set <option>=<value>} -@findex @kbd{:set no<option>} -@findex @kbd{:set <option>} -@findex @kbd{:set ws} -@findex @kbd{:set wrapscan} -@findex @kbd{:set wm=<count>} -@findex @kbd{:set wrapmargin=<count>} -@findex @kbd{:set ts=<count>} -@findex @kbd{:set tabstop=<count>} -@findex @kbd{:set tab-stop-local=<count>} -@findex @kbd{:set sm} -@findex @kbd{:set showmatch} -@findex @kbd{:set sw=<count>} -@findex @kbd{:set shiftwidth=<count>} -@findex @kbd{:set sh=<string>} -@findex @kbd{:set shell=<string>} -@findex @kbd{:set ro} -@findex @kbd{:set readonly} -@findex @kbd{:set magic} -@findex @kbd{:set ic} -@findex @kbd{:set ignorecase} -@findex @kbd{:set ai} -@findex @kbd{:set autoindent} - -@node Emacs Related Commands,,Options,Commands -@section Emacs Related Commands - -@table @kbd -@item C-\ -Begin Meta command in Vi or Insert states. Most often used as C-\ x (M-x). - -Note: Emacs binds @kbd{C-\} to a function that offers to change the -keyboard input method in the multilingual environment. Viper overrides this -binding. However, it is still possible to switch the input method by typing -@kbd{\ C-\} in the Vi command state and @kbd{C-z \ C-\} in the Insert state. -Or you can use the MULE menu on the menubar. -@item C-z -In Insert and Replace states, prepare Viper to accept the next command and -execute it as if Viper was in Vi state. Then return to Insert state. - -In Vi state, switch to Emacs state; in Emacs state, switch to Vi state. -@item C-c \ -Switches to Vi state for the duration of a single command. Then goes back -to the original Viper state. Works from Vi, Insert, Replace, and Emacs states. -@item C-x0 -Close Window -@item C-x1 -Close Other Windows -@item C-x2 -Split Window -@item C-xo -Move among windows -@item C-xC-f -Emacs find-file, useful in Insert state -@item C-y -Put back the last killed text. Similar to Vi's @kbd{p}, but also works in -Insert and Replace state. This command doesn't work in Vi command state, -since this binding is taken for something else. -@item M-y -Undoes the last @kbd{C-y} and puts another kill from the kill ring. -Using this command, you can try may different kills until you find the one -you need. -@end table -@kindex @kbd{M-y} -@kindex @kbd{C-y} -@kindex @kbd{C-xC-f} -@kindex @kbd{C-xo} -@kindex @kbd{C-x2} -@kindex @kbd{C-x1} -@kindex @kbd{C-x0} -@kindex @kbd{C-z} -@kindex @kbd{C-\} -@kindex @kbd{C-c\} - -@node Mouse-bound Commands,,,Commands -@section Mouse-bound Commands - -The following two mouse actions are normally bound to to special search and -insert commands in of Viper: - -@table @kbd -@item S-mouse-1 (Emacs) -@item meta button1up (XEmacs) -Holding Shift (or Meta, if XEmacs) and clicking mouse button 1 will -initiate search for -a region under the mouse pointer. -This command can take a prefix argument. Note: Viper sets this -binding only if this mouse action is not -already bound to something else. -@xref{Viper Specials}, for more information.@refill - -@item S-mouse-2 (Emacs) -@item meta button2up (XEmacs) -Holding Shift (or Meta, if XEmacs) and clicking button 2 of the mouse will -insert a region surrounding the mouse pointer. -This command can also take a prefix argument. -Note: Viper sets this binding only if this mouse action is not -already bound to something else. -@xref{Viper Specials}, for more details.@refill -@end table -@kindex @kbd{S-mouse-1} -@kindex @kbd{S-mouse-2} -@kindex @kbd{meta button1up} -@kindex @kbd{meta button2up} - -@node Acknowledgments,,,Top -@comment node-name, next, previous, up -@unnumbered Acknowledgments - -Viper, formerly known as VIP-19, was written by Michael Kifer. Viper is -based on the original VIP package by Masahiko Sato and on its enhancement, -VIP 4.4, by Aamod Sane. This manual is an adaptation of the manual for VIP -4.4, which, in turn, was based on Sato's manual for VIP 3.5. - -Many contributors on the net pointed out bugs and suggested a number of -useful features. Here is a (hopefully) complete list of contributors: - -@example -jjm@@hplb.hpl.hp.com (Jean-Jacques Moreau), jl@@cse.ogi.edu (John -Launchbury), rxga@@ulysses.att.com, jamesm@@bga.com (D.J. Miller II), -ascott@@fws214.intel.com (Andy Scott), toma@@convex.convex.com, -dave@@hellgate.utah.edu, cook@@biostat.wisc.edu -(Tom Cook), lindstro@@biostat.wisc.edu (Mary Lindstrom), -edmonds@@edmonds.home.cs.ubc.ca (Brian Edmonds), mveiga@@dit.upm.es -(Marcelino Veiga Tuimil), dwight@@toolucky.llnl.gov (Dwight Shih), -phil_brooks@@MENTORG.COM (Phil Brooks), kin@@isi.com (Kin Cho), -ahg@@panix.com (Al Gelders), dwallach@@cs.princeton.edu (Dan Wallach), -hpz@@ibmhpz.aug.ipp-garching.mpg.de (Hans-Peter Zehrfeld), -simonb@@prl.philips.co.uk (Simon Blanchard), Mark.Bordas@@East.Sun.COM -(Mark Bordas), gviswana@@cs.wisc.edu (Guhan Viswanathan), -meyering@@comco.com (Jim Meyering), pfister@@cs.sunysb.edu (Hanspeter -Pfister), amade@@diagram.fr (Paul-Bernard Amade), -jackr@@dblues.engr.sgi.com (Jack Repenning), -pogrell@@informatik.hu-berlin.de (Lutz Pogrell), -csdayton@@midway.uchicago.edu (Soren Dayton), -pradyut@@cs.uchicago.edu (Pradyut Shah), -vrenjak@@sun1.racal.com (Milan Vrenjak), -gvr@@halcyon.com (George V. Reilly), -whicken@@dragon.parasoft.com (Wendell Hicken), -terra@@diku.dk (Morten Welinder), -kanze@@gabi-soft.fr (James Kanze), -hatazaki@@bach.convex.com (Takao Hatazaki), -sawdey@@lcse.umn.edu (Aaron Sawdey), -jobrien@@hchp.org (John O'Brien), -mrb@@Eng.Sun.COM (Martin Buchholz), -kwzh@@gnu.ai.mit.edu (Karl Heuer), -sudish@@MindSpring.COM (Sudish Joseph), -paulk@@summit.esg.apertus.com (Paul Keusemann), -roderick@@argon.org (Roderick Schertler), -johnw@@borland.com (John Wiegley), -zapman@@cc.gatech.edu (Jason Zapman II), -schwab@@issan.informatik.uni-dortmund.de (Andreas Schwab) -@end example - - -@node Key Index,Function Index,,Top -@comment node-name, next, previous, up -@unnumbered Key Index - -@printindex ky - -@node Function Index,Variable Index,Key Index,Top -@comment node-name, next, previous, up -@unnumbered Function Index - -@printindex fn - -@node Variable Index,Package Index,Function Index,Top -@comment node-name, next, previous, up -@unnumbered Variable Index - -@printindex vr - -@node Package Index,Concept Index,Variable Index,Top -@comment node-name, next, previous, up -@unnumbered Package Index - -@printindex pg - -@node Concept Index,,Package Index,Top -@comment node-name, next, previous, up -@unnumbered Concept Index - -@printindex cp - -@contents -@bye
--- a/man/vm.texi Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1398 +0,0 @@ -\input texinfo @comment -*-Texinfo-*- -@setfilename vm.info -@settitle VM User's Manual -@iftex -@finalout -@end iftex -@c @setchapternewpage odd % For book style double sided manual. -@c @smallbook -@tex -\overfullrule=0pt -%\global\baselineskip 30pt % For printing in double spaces -@end tex -@ifinfo -This file documents the VM mail reader. - -Copyright (C) 1989, 1991 Kyle E. Jones - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@ignore -Permission is granted to process this file through Tex and print the -results, provided the printed document carries copying permission -notice identical to this one except for the removal of this paragraph -(this paragraph not being relevant to the printed manual). - -@end ignore -@end ifinfo -@c -@titlepage -@sp 6 -@center @titlefont{VM User's Manual} -@sp 4 -@center Second Edition, VM Version 5 -@sp 1 -@center June 1991 -@sp 5 -@center Kyle E. Jones -@center @t{kyle@@uunet.uu.net} -@page -@vskip 0pt plus 1filll -Copyright @copyright{} 1989, 1991 Kyle E. Jones - -Permission is granted to make and distribute verbatim copies of -this manual provided the copyright notice and this permission notice -are preserved on all copies. - -@end titlepage -@page -@ifinfo -@node Top, Introduction,, (DIR) - -This manual documents the VM mail reader, a Lisp program which runs as a -subsystem under Emacs. The manual is divided into the following -chapters. - -@menu -* Introduction:: Overview of the VM interface. -* Starting Up:: What happens when your start VM. -* Selecting Messages:: How to select messages for reading. -* Reading Messages:: Previewing and paging through a message. -* Sending Messages:: How to send messages from within VM. -* Saving Messages:: How to save messages. -* Deleting Messages:: How to delete, undelete and expunge messages -* Editing Messages:: How to alter the text and headers of a message. -* Message Marks:: Running VM commands on arbitrary subsets of messages. -* Undoing:: How to undo changes to message attributes. -* Grouping Messages:: How to make VM present similar message together. -* Reading Digests:: How to read digests under VM. -* Summaries:: How to view and customize the summary of a folder. -* Miscellaneous:: Various customization variables undescribed elsewhere. - -Indices: - -* Key Index:: Menus of command keys and their references. -* Command Index:: Menus of commands and their references. -* Variable Index:: Menus of variables and their references. -@end menu -@end ifinfo - -@node License, Introduction, Variable Index, Top -@unnumbered License - -@unnumbered GNU GENERAL PUBLIC LICENSE -@center Version 1, February 1989 -@cindex license to copy Emacs -@cindex General Public License - -@display -Copyright @copyright{} 1989 Free Software Foundation, Inc. -675 Mass Ave, Cambridge, MA 02139, USA - -Everyone is permitted to copy and distribute verbatim copies -of this license document, but changing it is not allowed. -@end display - -@unnumberedsec Preamble - - The license agreements of most software companies try to keep users -at the mercy of those companies. By contrast, our General Public -License is intended to guarantee your freedom to share and change free -software---to make sure the software is free for all its users. The -General Public License applies to the Free Software Foundation's -software and to any other program whose authors commit to using it. -You can use it for your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Specifically, the General Public License is designed to make -sure that you have the freedom to give away or sell copies of free -software, that you receive source code or can get it if you want it, -that you can change the software or use pieces of it in new free -programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of a such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must tell them their rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - The precise terms and conditions for copying, distribution and -modification follow. - -@iftex -@unnumberedsec TERMS AND CONDITIONS -@end iftex -@ifinfo -@center TERMS AND CONDITIONS -@end ifinfo - -@enumerate -@item -This License Agreement applies to any program or other work which -contains a notice placed by the copyright holder saying it may be -distributed under the terms of this General Public License. The -``Program'', below, refers to any such program or work, and a ``work based -on the Program'' means either the Program or any work containing the -Program or a portion of it, either verbatim or with modifications. Each -licensee is addressed as ``you''. - -@item -@cindex Distribution -You may copy and distribute verbatim copies of the Program's source -code as you receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice and -disclaimer of warranty; keep intact all the notices that refer to this -General Public License and to the absence of any warranty; and give any -other recipients of the Program a copy of this General Public License -along with the Program. You may charge a fee for the physical act of -transferring a copy. - -@item -You may modify your copy or copies of the Program or any portion of -it, and copy and distribute such modifications under the terms of Paragraph -1 above, provided that you also do the following: - -@itemize @bullet -@item -cause the modified files to carry prominent notices stating that -you changed the files and the date of any change; and - -@item -cause the whole of any work that you distribute or publish, that -in whole or in part contains the Program or any part thereof, either -with or without modifications, to be licensed at no charge to all -third parties under the terms of this General Public License (except -that you may choose to grant warranty protection to some or all -third parties, at your option). - -@item -If the modified program normally reads commands interactively when -run, you must cause it, when started running for such interactive use -in the simplest and most usual way, to print or display an -announcement including an appropriate copyright notice and a notice -that there is no warranty (or else, saying that you provide a -warranty) and that users may redistribute the program under these -conditions, and telling the user how to view a copy of this General -Public License. - -@item -You may charge a fee for the physical act of transferring a -copy, and you may at your option offer warranty protection in -exchange for a fee. -@end itemize - -Mere aggregation of another independent work with the Program (or its -derivative) on a volume of a storage or distribution medium does not bring -the other work under the scope of these terms. - -@item -You may copy and distribute the Program (or a portion or derivative of -it, under Paragraph 2) in object code or executable form under the terms of -Paragraphs 1 and 2 above provided that you also do one of the following: - -@itemize @bullet -@item -accompany it with the complete corresponding machine-readable -source code, which must be distributed under the terms of -Paragraphs 1 and 2 above; or, - -@item -accompany it with a written offer, valid for at least three -years, to give any third party free (except for a nominal charge -for the cost of distribution) a complete machine-readable copy of the -corresponding source code, to be distributed under the terms of -Paragraphs 1 and 2 above; or, - -@item -accompany it with the information you received as to where the -corresponding source code may be obtained. (This alternative is -allowed only for noncommercial distribution and only if you -received the program in object code or executable form alone.) -@end itemize - -Source code for a work means the preferred form of the work for making -modifications to it. For an executable file, complete source code means -all the source code for all modules it contains; but, as a special -exception, it need not include source code for modules which are standard -libraries that accompany the operating system on which the executable -file runs, or for standard header files or definitions files that -accompany that operating system. - -@item -You may not copy, modify, sublicense, distribute or transfer the -Program except as expressly provided under this General Public License. -Any attempt otherwise to copy, modify, sublicense, distribute or transfer -the Program is void, and will automatically terminate your rights to use -the Program under this License. However, parties who have received -copies, or rights to use copies, from you under this General Public -License will not have their licenses terminated so long as such parties -remain in full compliance. - -@item -By copying, distributing or modifying the Program (or any work based -on the Program) you indicate your acceptance of this license to do so, -and all its terms and conditions. - -@item -Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the original -licensor to copy, distribute or modify the Program subject to these -terms and conditions. You may not impose any further restrictions on the -recipients' exercise of the rights granted herein. - -@item -The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of the license which applies to it and ``any -later version'', you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -the license, you may choose any version ever published by the Free Software -Foundation. - -@item -If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - -@iftex -@heading NO WARRANTY -@end iftex -@ifinfo -@center NO WARRANTY -@end ifinfo - -@item -BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM ``AS IS'' WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - -@item -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL -ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES -ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT -LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES -SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE -WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN -ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -@end enumerate - -@iftex -@heading END OF TERMS AND CONDITIONS -@end iftex -@ifinfo -@center END OF TERMS AND CONDITIONS -@end ifinfo - -@page -@unnumberedsec Appendix: How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to humanity, the best way to achieve this is to make it -free software which everyone can redistribute and change under these -terms. - - To do so, attach the following notices to the program. It is safest to -attach them to the start of each source file to most effectively convey -the exclusion of warranty; and each file should have at least the -``copyright'' line and a pointer to where the full notice is found. - -@smallexample -@var{one line to give the program's name and a brief idea of what it does.} -Copyright (C) 19@var{yy} @var{name of author} - -This program 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 1, or (at your option) -any later version. - -This program 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 this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -@end smallexample - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - -@smallexample -Gnomovision version 69, Copyright (C) 19@var{yy} @var{name of author} -Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. -This is free software, and you are welcome to redistribute it -under certain conditions; type `show c' for details. -@end smallexample - -The hypothetical commands `show w' and `show c' should show the -appropriate parts of the General Public License. Of course, the -commands you use may be called something other than `show w' and `show -c'; they could even be mouse-clicks or menu items---whatever suits your -program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a ``copyright disclaimer'' for the program, if -necessary. Here a sample; alter the names: - -@example -Yoyodyne, Inc., hereby disclaims all copyright interest in the -program `Gnomovision' (a program to direct compilers to make passes -at assemblers) written by James Hacker. - -@var{signature of Ty Coon}, 1 April 1989 -Ty Coon, President of Vice -@end example - -That's all there is to it! - -@node Introduction, Starting Up, License, Top -@unnumbered Introduction - -VM (View Mail) is an Emacs subsystem that allows UNIX mail to be read -and disposed of within Emacs. Commands exist to do the normal things -expected of a mail user agent, such as generating replies, saving -messages to folders, deleting messages and so on. There are other more -advanced commands that do tasks like bursting and creating digests, -message forwarding, and organizing message presentation according to -various criteria. - -To invoke VM simply type @kbd{M-x vm}. VM gathers any mail that has -arrived in your system mailbox and appends it to a file known as your -@dfn{primary inbox}, and visits that file for reading. @xref{Starting Up}. -A file visited for reading by VM is called the @dfn{current folder}.@refill - -@findex vm-scroll-forward -@findex vm-scroll-backward -@kindex SPC -@kindex b -@kindex DEL -If there are any messages in the primary inbox, VM selects the first new -or unread message, and previews it. @dfn{Previewing} is VM's way of -showing you part of message and allowing you to decide whether you want -to read it. @xref{Previewing}. By default VM shows you the message's -sender, recipient, subject and date headers. Typing @key{SPC} -(@code{vm-scroll-forward}) exposes the body of the message and flags the -message as read. Subsequent @key{SPC}'s scroll forward through the -message, @kbd{b} or @key{DEL} scrolls backward. When you reach the end -of a message, typing @key{SPC} or @kbd{n} moves you forward to preview -the next message. @xref{Paging}.@refill - -If you do not want to read a message that's being previewed, just type -@kbd{n} and VM will move on to the next message (if there is one). -@xref{Selecting Messages}.@refill - -To save a message to a mail folder use @kbd{s} (@code{vm-save-message}). -VM will prompt you for the folder name in the minibuffer. -@xref{Saving Messages}.@refill - -Messages are deleted by typing @kbd{d} (@code{vm-delete-message}) while -previewing or reading them. The message is not deleted right away; it -is simply flagged for deletion. If you change your mind about deleting a -message just select it and type @kbd{u} (@code{vm-undelete-message}), -and the message will be undeleted. @xref{Deleting Messages}. The -actual removal of deleted messages from the current folder is called -@dfn{expunging} and it is accomplished by typing @kbd{#} -(@code{vm-expunge-folder}). The message is still present in the on-disk -version of the folder until the folder is saved.@refill - -Typing @kbd{h} (@code{vm-summarize}) causes VM to pop up a window -containing a summary of the contents of the current folder. The summary is -presented one line per message, by message number, listing each message's -author, date sent, line and byte count, and subject. Also, various -letters appear beside the message number to indicate that a message is -new, unread, flagged for deletion, etc. An arrow @samp{->} appears to -the left of the line summarizing the current message. The summary -format is user configurable, @pxref{Summaries}.@refill - -@findex vm-save-folder -@kindex S -When you are finished reading mail the current folder must be saved, so -that the next time the folder is visited VM will know which messages have -been already read, replied to and so on. Typing @kbd{S} -(@code{vm-save-folder}) expunges all deleted messages and saves the -folder. @kbd{C-x C-s} saves the folder without expunging deleted -messages but the messages are still flagged deleted. The next time the -folder is visited these messages will still be flagged for deletion.@refill - -@findex vm-quit -@findex vm-quit-no-change -@kindex q -@kindex x -To quit VM you can type @kbd{q} (@code{vm-quit}) or @kbd{x} -(@code{vm-quit-no-change}). Typing @kbd{q} expunges and saves the -current folder before quitting. Also, any messages flagged new are -changed to be flagged unread, before saving. The @kbd{x} command quits -VM without expunging, saving or otherwise modifying the current folder. -Quitting is not required; you can simply switch to another Emacs buffer -when you've finished reading mail.@refill - -@findex vm-get-new-mail -@kindex g -At any time while reading mail in the primary inbox you can type @kbd{g} -(@code{vm-get-new-mail}) to check to see if new mail has arrived. If new -mail has arrived it will be moved from the system spool area and merged into -the primary inbox. If you are not in the middle of another message, VM -will also jump to the first new message. - -If @code{vm-get-new-mail} is given a prefix argument, it will prompt for -another file from which to gather messages instead of the usual spool -files. In this case the source folder is copied but not deleted. - -@node Starting Up, Selecting Messages, Introduction, Top -@chapter Starting Up - -@findex vm-load-rc -@kindex L -There are three ways to start VM: @kbd{M-x vm}, @kbd{M-x vm-visit-folder} -and @code{vm-mode}. The first time VM is started in an Emacs session (by -any of these methods), it attempts to load the file @file{~/.vm}. If -present this file should contain Lisp code, much like the @file{.emacs} -file. Since VM has in excess of forty configuration variables, use of -the @file{~/.vm} can considerably reduce clutter in the @file{.emacs} -file. You can force the reloading of this file on demand by typing -@kbd{L} (@code{vm-load-init-file}) from within VM.@refill - -@findex vm -@vindex vm-primary-inbox -@kbd{M-x vm} causes VM to gather any mail present in your system mailbox -and append it to a file known as your @dfn{primary inbox}, creating -this file if necessary. The default name of this file is -@file{~/INBOX}, but VM will use whatever file is named by the variable -@code{vm-primary-inbox}.@refill - -@vindex vm-crash-box -VM transfers the mail from the system mailbox to the primary inbox via a -temporary file known as the @dfn{crash box}. The variable -@code{vm-crash-box} names the crash box file. VM first copies the mail -to the crash box, deletes the system mailbox, merges the crash box -contents into the primary inbox, and then deletes the crash box. If the -system or Emacs should crash in the midst of this transfer, any message -not present in the primary inbox will be either in the system mailbox or -the crash box. Some messages may be duplicated but no mail will be -lost.@refill - -If the file named by @code{vm-crash-box} already exists when VM is -started up, VM will merge that with the primary inbox before getting any -new messages from the system mailbox.@refill - -@vindex vm-spool-files -By default, the location of the system mailbox is determined -heuristically based on what type of system you're using. VM can -be told explicitly where the system mailbox is through the variable -@code{vm-spool-files}. The value of this variable should be a list of -strings naming files VM should try when searching for newly arrived -mail. Multiple mailboxes can be specified if you receive mail in -more than one place. The value of @code{vm-spool-files} will be inherited -from the shell environmental variables MAILPATH or MAIL if either of -these variables are defined.@refill - -@findex vm-visit-folder -@kindex v -@kbd{M-x vm-visit-folder} (@kbd{v} from within VM) allows you to visit -some other mail folder than the primary inbox. The folder name will be -prompted for in the minibuffer.@refill - -Once VM has read the folder, the first new or unread message will be -selected. If there is no such message, the first message in the folder -is selected. - -@findex vm-mode -@kbd{M-x vm-mode} can be used on a buffer already loaded into Emacs to put -it into the VM major mode so that VM commands can be executed from within -it. This command is suitable for use in Lisp programs, and for inclusion in -@code{auto-mode-alist} to automatically start VM on a file based on a -particular filename suffix. @code{vm-mode} foregoes some of VM's startup -procedures (e.g. starting up a summary) to facilitate noninteractive use. - -@vindex vm-startup-with-summary -The variable @code{vm-startup-with-summary} controls whether VM -automatically displays a summary of the folder's contents at startup. A -value of @code{nil} gives no summary; a value of @code{t} gives a full -frame summary. A value that is neither @code{t} nor @code{nil} splits -the frame between the summary and the folder display. The latter only -works if the variable @code{pop-up-windows}'s value is non-@code{nil}, -and the value of @code{vm-mutable-windows} is non-@code{nil}. The -default value of @code{vm-startup-with-summary} is @code{nil}.@refill - -@vindex vm-mail-window-percentage -The variable @code{vm-mail-window-percentage} tells VM what percentage of -the frame should be given to the folder display when both it and the -folder summary are being displayed. Note that Emacs enforces a minimum -window size limit, so a very high or very low value for this variable -may squeeze out one of the displays entirely. This variable's default -value is 75, which works with Emacs' default minimum window size limit, -on a 24 line terminal. Note that the value of @code{vm-mutable-windows} -must be @code{t} or VM will not do window resizing regardless of the -value of @code{vm-mail-window-percentage}.@refill - -@vindex vm-inhibit-startup-message -A non-@code{nil} value for the variable @code{vm-inhibit-startup-message} -disables the display of the VM's copyright, copying and warranty -disclaimer. If you must, set this variable in your own @file{.emacs} file; -don't set it globally for everyone. Users should be told their rights. -The startup messages abort at the first keystroke after startup, so they do not -impede mail reading.@refill - -@node Selecting Messages, Reading Messages, Starting Up, Top -@chapter Selecting Messages - -@findex vm-next-message -@findex vm-previous-message -@kindex n -@kindex p -@vindex vm-skip-deleted-messages -@vindex vm-skip-read-messages -The primary commands for selecting messages in VM are @kbd{n} -(@code{vm-next-message}) and @kbd{p} (@code{vm-previous-message}). -These commands move forward and backward through the current folder. -When they go beyond the end or beginning of the folder they wrap to the -beginning and end respectively. By default, these commands skip messages -flagged for deletion. This behavior can be disabled by setting the value -of the variable @code{vm-skip-deleted-messages} to @code{nil}. These -commands can also be made to skip messages that have been read; set -@code{vm-skip-read-messages} to @code{t} to do this. - -The commands @kbd{n} and @kbd{p} also take prefix arguments that specify -the number of messages to move forward or backward. If the magnitude of -the prefix argument is greater than 1, no message skipping will be done -regardless of the settings of the previously mentioned skip control -variables.@refill - -@vindex vm-circular-folders -The variable @code{vm-circular-folders} determines whether VM folders -will be considered circular by various commands. @dfn{Circular} means VM -will wrap from the end of the folder to the start and vice versa when -moving the message pointer, deleting, undeleting or saving messages -before or after the current message.@refill - -A value of @code{t} causes all VM commands to consider folders circular. -A value of @code{nil} causes all of VM commands to signal an error if -the start or end of the folder would have to be passed to complete the -command. For movement commands, this occurs after the message pointer -has been moved as far it can go. For other commands the error occurs -before any part of the command has been executed, i.e. no deletions, saves, -etc. will be done unless they can be done in their entirety. A value -other than @code{nil} or @code{t} causes only VM's movement -commands to consider folders circular. Saves, deletes and undeletes -will behave as if the value is @code{nil}. The default value of -@code{vm-circular-folders} is @code{0}.@refill - -Other commands to select messages: - -@table @kbd -@findex vm-goto-message -@kindex RET -@item RET (@code{vm-goto-message}) -Go to message number @var{n}. @var{n} is the prefix argument, if -provided, otherwise it is prompted for in the minibuffer. -@findex vm-goto-message -@kindex TAB -@item TAB (@code{vm-goto-message-last-seen}) -Go to message last previewed or read. -@findex vm-Next-message -@findex vm-Previous-message -@kindex N -@kindex P -@item N (@code{vm-Next-message}) -@itemx P (@code{vm-Previous-message}) -Go to the next (previous) message, ignoring the settings of the skip -control variables. -@findex vm-next-unread-message -@findex vm-previous-unread-message -@kindex M-n -@kindex M-p -@item M-n (@code{vm-next-unread-message}) -@itemx M-p (@code{vm-previous-unread-message}) -Move forward (backward) to the nearest new or unread message. If no -such message exists then these commands work like @kbd{n} and @kbd{p}. -@findex vm-isearch-forward -@findex vm-isearch-backward -@kindex M-s -@comment @kindex M-r -@vindex vm-search-using-regexps -@item M-s (@code{vm-isearch-forward}) -@itemx M-x vm-isearch-backward -These work just like Emacs' normal forward and backward incremental -search commands, except that when the search ends, VM selects the -message containing point. If the value of the variable -@code{vm-search-using-regexps} is non-@code{nil}, a regular expression -may be used instead of a fixed string for the search pattern; VM -defaults to the fixed string search. If a prefix argument is given, -the value of @code{vm-search-using-regexps} is temporarily toggled for -the search. -@xref{Incremental Search,,,emacs, the GNU Emacs Manual}.@refill -@end table - -@node Reading Messages, Sending Messages, Selecting Messages, Top -@chapter Reading Messages - -Once a message has been selected, VM will present it to you. By default, -presentation is done in two stages: @dfn{previewing} and @dfn{paging}. - -@menu -* Previewing:: Customizing message previews. -* Paging:: Scrolling and paging through the current message. -@end menu - -@node Previewing, Paging, Reading Messages, Reading Messages -@section Previewing - -@dfn{Previewing} is VM's way of showing you a small portion of a message -and allowing you to decide whether you want to read it. Typing -@key{SPC} exposes the body of the message, and from there you can -repeatedly type @key{SPC} to page through the message. - -By default, the sender, recipient, subject and date headers are shown -when previewing; the rest of the message is hidden. This behavior may -be altered by changing the settings of three variables: -@code{vm-visible-headers}, @code{vm-invisible-header-regexp} and -@code{vm-preview-lines}.@refill - -@vindex vm-preview-lines -The value of @code{vm-preview-lines} should be a number that tells VM -how many lines of the text of the message should be visible. The default -value of this variable is 0. If @code{vm-preview-lines} is @code{nil}, -then previewing is not done at all; when a message is first presented it -is immediately exposed in its entirety and is flagged as read.@refill - -@vindex vm-visible-headers -The value of @code{vm-visible-headers} should be a list of regular -expressions matching the beginnings of headers that should be made -visible when a message is presented. The regexps should be listed in -the preferred presentation order of the headers they match.@refill - -@vindex vm-invisible-header-regexp -If non-@code{nil}, the variable @code{vm-invisible-header-regexp} -specifies what headers should @emph{not} be displayed. Its value should -be a string containing a regular expression that matches all headers you -do not want to see. Setting this variable non-@code{nil} implies that -you want to see all headers not matched by it; therefore the value of -@code{vm-visible-headers} is only used to determine the order of the -visible headers in this case. Headers not matched by -@code{vm-invisible-header-regexp} or @code{vm-visible-headers} are -displayed last.@refill - -If you change the value of either @code{vm-visible-headers} or -@code{vm-invisible-header-regexp} in the middle of a VM session the -effects will not be immediate. You will need to use the command -@code{vm-discard-cached-data} on each message (bound to @kbd{j} by -default) to force VM rearrange the message headers. A good way to do -this is to mark all the messages in the folder and apply -@code{vm-discard-cached-data} to the marked messages. @xref{Message -Marks}.@refill - -@vindex vm-highlighted-header-regexp -Another variable of interest is @code{vm-highlighted-header-regexp}. The -value of this variable should be a single regular expression that -matches the beginnings of any header that should be presented in inverse -video when previewing. For example, a value of @samp{"^From\\|^Subject"} -causes the From and Subject headers to be highlighted.@refill - -@vindex vm-preview-read-messages -By default, VM previews all messages, even if they have already been read. -To have VM preview only those messages that have not been read, set the -value of @code{vm-preview-read-messages} to @code{nil}. - -@findex vm-expose-hidden-headers -Typing @kbd{t} (@code{vm-expose-hidden-headers}) makes VM toggle -between exposing and hiding headers that would ordinarily be hidden.@refill - -@node Paging,, Previewing, Reading Messages -@section Paging - -@vindex vm-auto-next-message -Typing @key{SPC} during a message preview exposes the body of the -message. If the message was new or previously unread, it will be flagged -``read''. At this point you can use @key{SPC} to scroll forward, and -@kbd{b} or @key{DEL} to scroll backward a windowful of text at a time. -Typing space at the end of a message moves you to the next message. If -the value of @code{vm-auto-next-message} is @code{nil}, @key{SPC} will -not move to the next message; you must type @kbd{n} explicitly. - -If the value of @code{vm-honor-page-delimiters} is non-@code{nil}, VM -will recognize and honor page delimiters. This means that when you -scroll through a document, VM will display text only up to the next page -delimiter. Text after the delimiter will be hidden until you type -another @key{SPC}, at which point the text preceding the delimiter will -become hidden. The Emacs variable @code{page-delimiter} determines what -VM will consider to be a page delimiter. - -You can ``unread'' a message (so to speak) by typing @kbd{U} -(@code{vm-unread-message}). The current message will be flagged unread. - -@node Sending Messages, Saving Messages, Reading Messages, Top -@chapter Sending Messages - -When sending messages from within VM, you will be using the standard -Mail major mode provided with GNU Emacs. @xref{Mail Mode,,,emacs, the -GNU Emacs Manual}. -However, @samp{*mail*} buffers created by VM have extra command keys: - -@table @kbd -@findex vm-yank-message -@kindex C-c C-y -@item C-c C-y (@code{vm-yank-message}) -Copies a message from the current folder into the @samp{*mail*} buffer. -The message number is read from the minibuffer. By default, each line of -the copy is prepended with the value of the variable -@code{vm-included-text-prefix}. All message headers are yanked along -with the text. Point is left before the inserted text, the mark after. -Any hook functions bound to mail-yank-hooks are run, after inserting -the text and setting point and mark. If a prefix argument is given, -this tells VM to ignore mail-yank-hooks, don't set the mark, don't prepend the -value of vm-included-text-prefix to every yanked line, and don't yank -any headers other than those specified in -vm-visible-headers/vm-invisible-headers.@refill -@kindex C-c y -@findex vm-yank-message-other-folder -@item C-c y (@code{vm-yank-message-other-folder}) -Work like @code{vm-yank-message}, but it first prompts for the name of a -folder from which to yank the message.@refill -@kindex C-c C-v -@item C-c C-v <Any VM command key> -All VM commands may be accessed in the @samp{*mail*} buffer by prefixing them -with C-c C-v. -@end table - -@findex vm-mail -@kindex m -The simplest command is @kbd{m} (@code{vm-mail}) which sends a mail -message much as @kbd{M-x mail} does but allows the added commands -described above. - -@code{vm-mail} can be invoked outside of VM by typing @kbd{M-x vm-mail}. -However, of the above commands, only @kbd{C-c y} -(@code{vm-yank-message-other-folder}) will work; all the other commands -require a parent folder.@refill - -If you send a message and it is returned by the mail system because it -was undeliverable, you can easily resend the message by typing @kbd{M-r} -(@code{vm-resend-bounced-message}). VM will extract the old message and -its pertinent headers from the returned message, and place you in a -@samp{*mail*} buffer. You can then change the recipient addresses or do -whatever is necessary to correct the original problem and resend the -message.@refill - -@menu -* Replying:: Describes the various ways to reply to a message. -* Forwarding Messages:: How to forward a message to a third party. -@end menu - -@node Replying, Forwarding Messages, Sending Messages, Sending Messages -@section Replying - -@vindex vm-reply-subject-prefix -VM has special commands that make it easy to reply to a message. When a -reply command is invoked, VM fills in the subject and recipient headers -for you, since it is apparent to whom the message should be sent and -what the subject should be. There is an old convention of prepending -the string @samp{"Re: "} to the subject of replies if the string isn't -present already. VM supports this indirectly by providing the variable -@code{vm-reply-subject-prefix}. Its value should be a string to prepend -to the subject of replies, if the said string isn't present already. A -@code{nil} value means don't prepend anything to the subject (this is -the default). In any case you can edit any of the message headers -manually, if you wish.@refill - -@vindex vm-included-text-prefix -VM also helps you quote material from a message to which you are -replying by providing @dfn{included text} as a feature of some of the -commands. @dfn{Included text} is a copy of the message being replied to with -some fixed string prepended to each line so that included text can be -distinguished from the text of the reply. The variable -@code{vm-included-text-prefix} specifies what the prepended string will -be.@refill - -@vindex vm-included-text-attribution-format -The variable @code{vm-included-text-attribution-format} specifies the -format for the attribution of included text. This attribution is a line -of text that tells who wrote the text that is to be included; it will be -inserted before the included text. If non-@code{nil}, the value of -@code{vm-included-text-attribution-format} should be a string format -specification similar to @code{vm-summary-format}. @xref{Summaries}. A -@code{nil} value causes the attribution to be omitted.@refill - -@vindex vm-in-reply-to-format -The variable @code{vm-in-reply-to-format} specifies the format of the -In-Reply-To header that is inserted into header section of the reply -buffer. Like @code{vm-included-text-attribution-format}, -@code{vm-in-reply-to-format} should be a string similar to that of -@code{vm-summary-format}. A @code{nil} value causes the In-Reply-To -header to be omitted.@refill - -@vindex vm-strip-reply-headers -The recipient headers generated for reply messages are created by -simply copying the appropriate headers for the message to which you are -replying. This includes any full name information, comments, etc. in -these headers. If the variable @code{vm-strip-reply-headers} is -non-@code{nil}, the reply headers will stripped of all information but -the actual addresses. - -The reply commands are: - -@table @kbd -@findex vm-reply -@kindex r -@item r (@code{vm-reply}) -Replies to the author of the current message. -@findex vm-reply-include-text -@kindex R -@item R (@code{vm-reply-include-text}) -Replies to the author of the current message and provides included text. -@findex vm-followup -@kindex f -@item f (@code{vm-followup}) -Replies to the all recipients of the current message. -@findex vm-followup-include-text -@kindex F -@item F (@code{vm-followup-include-text}) -Replies to the all recipients of the current message and provides -included text. -@end table - -These commands all accept a numeric prefix argument @var{n}, which if -present, causes VM to reply to the next (or previous if the argument is -negative) @var{n-1} message as well as the current message. Also all -the reply commands set the ``replied'' attribute of the messages to -which you are responding, but only when the reply is actually sent. The -reply commands can also be applied to marked messages, -@pxref{Message Marks}.@refill - -@vindex vm-reply-ignored-addresses -If you are one of multiple recipients of a message and you use @kbd{f} -and @kbd{F}, your address will be included in the recipients of the -reply. You can avoid this by judicious use of the variable -@code{vm-reply-ignored-addresses}. Its value should be a list of -regular expressions that match addresses that VM should automatically -remove from the recipient headers of replies. - -@node Forwarding Messages,, Replying, Sending Messages -@section Forwarding Messages - -VM has two commands to forward messages: @kbd{z} -(@code{vm-forward-message}) and @key{@@} (@code{vm-send-digest}).@refill - -@findex vm-forward-message -@kindex z -@vindex vm-rfc934-forwarding -@vindex vm-forwarding-subject-format -Typing @kbd{z} puts you into a @samp{*mail*} buffer just like @kbd{m}, -except the current message appears as the body of the message in the -@samp{*mail*} buffer. The forwarded message is surrounded by RFC 934 -compliant message delimiters. If the variable -@code{vm-rfc934-forwarding} is non-@code{nil}, "^-" to "- -" character -stuffing is done to the forwarded message (this is the default). This -behavior is required if the recipient of the forwarded message wants to -use a RFC 934 standard bursting agent to access the message. If the -variable @code{vm-forwarding-subject-format} is non-@code{nil} it should -specify the format of the Subject header of the forwarded message. This -subject will be used as the contents of the Subject header automatically -inserted into the @samp{*mail*} buffer. A @code{nil} value causes the -Subject header to be left blank. The forwarded message is flagged -``forwarded''.@refill -@findex vm-send-digest -@vindex vm-digest-preamble-format -@vindex vm-digest-center-preamble -@kindex @@ -The command @key{@@} (@code{vm-send-digest}) works like @kbd{z} except -that a digest of all the messages in the current folder is made and -inserted into the @samp{*mail*} buffer. Also, @code{vm-send-digest} can -be applied to marked messages. @xref{Message Marks}. When applied to -marked messages, @code{vm-send-digest} will only bundle marked messages, -as opposed to the usual bundling of all messages in the current folder. -If you give @code{vm-send-digest} a prefix argument, VM will insert a -list of preamble lines at the beginning of the digest, one line per -digestified message. The variable @code{vm-digest-preamble-format} -determines the format of the preamble lines. If the value of -@code{vm-digest-center-preamble} is non-@code{nil}, the preamble lines -will be centered.@refill - -@node Saving Messages, Deleting Messages, Sending Messages, Top -@chapter Saving Messages - -Mail messages are normally saved to files that contain only mail -messages. Such files are called @dfn{folders}. - -@findex vm-save-message -@kindex s -The VM command to save a message to a folder is @kbd{s} -(@code{vm-save-message}); invoking this command causes the current -message to be saved to a folder whose name you specify in the -minibuffer. If @code{vm-save-message} is given a prefix argument -@var{n}, the current message plus the next @var{n-1} message are saved. -If @var{n} is negative, the current message and the previous @var{n-1} -messages are saved. Messages saved with @code{vm-save-message} are -flagged ``filed''.@refill - -@vindex vm-confirm-new-folders -If the value of the variable @code{vm-confirm-new-folders} is -non-@code{nil}, VM will ask for confirmation before creating a new -folder on interactive saves.@refill - -@vindex vm-folder-directory -If you have a directory where you keep all your mail folders, you should -set the variable @code{vm-folder-directory} to point to it. If this -variable is set, @code{vm-save-message} will insert this directory name -into the minibuffer before prompting you for a folder name; this will save -you some typing.@refill - -@vindex vm-auto-folder-alist -Another aid to selecting folders in which to save mail is the variable -@code{vm-auto-folder-alist}. The value of this variable should be a -list of the form,@refill - -@display -((@var{header-name} - (@var{regexp} . @var{folder-name}) ...) - ...) -@end display - -where @var{header-name} and @var{regexp} are strings, and -@var{folder-name} is a string or an s-expression that evaluates to a -string.@refill - -If any part of the contents of the message header named by -@var{header-name} is matched by the regular expression @var{regexp}, VM -will evaluate the corresponding @var{folder-name} and use the result as -the default when prompting for a folder to save the message in. If -the resulting folder name is a relative pathname it resolves to the directory -named by @code{vm-folder-directory}, or the @code{default-directory} of -the currently visited folder if @code{vm-folder-directory} is @code{nil}.@refill - -When @var{folder-name} is evaluated, the current buffer will contain only -the contents of the header named by @var{header-name}. It is safe to -modify this buffer. You can use the match data from any @samp{\( @dots{} -\)} grouping constructs in @var{regexp} along with the function -@code{buffer-substring} to build a folder name based on the header information. -If the result of evaluating @var{folder-name} is a list, then the list will -be treated as another auto-folder-alist and will be descended -recursively.@refill - -@vindex vm-auto-folder-case-fold-search -Whether matching is case sensitive depends on the value of the variable -@code{vm-auto-folder-case-fold-search}. A non-@code{nil} value makes -matching case insensitive. The default value is @code{t}, which means -matching is case sensitive. Note that the matching of header names is -always case insensitive because RFC 822 specifies that header names are -case indistinct. - -@vindex vm-visit-when-saving -VM can save messages to a folder in two distinct ways. The message can be -appended directly to the folder on disk, or the folder can be visited as -Emacs would visit any other file and the message be appended to that -buffer. In the latter method you must save the buffer yourself to change -the on-disk copy of the folder. The variable @code{vm-visit-when-saving} -controls which method is used. A value of @code{t} causes VM to always -visit a folder before saving message to it. A @code{nil} value causes VM -to always append directly to the folder file. In this case VM will not -save messages to the disk copy of a folder that is being visited. This -restriction is necessary to insure that the buffer and on-disk copies of -the folder are consistent. If the value of @var{vm-visit-when-saving} is -not @code{nil} and not @code{t} (e.g. 0, the default), VM will append to -the folder's buffer if the buffer is currently being visited, otherwise VM -will append to the file itself.@refill - -@vindex vm-delete-after-saving -After a message is saved to a folder, the usual thing to do next is to -delete it. If the variable @code{vm-delete-after-saving} is -non-@code{nil}, VM will flag messages for deletion automatically after -saving them. This applies only to saves to folders, not for the @kbd{w} -command (see below).@refill - -Other commands: - -@table @kbd -@findex vm-save-message-sans-headers -@kindex w -@item w (@code{vm-save-message-sans-headers}) -Saves a message or messages to a file without their headers. This -command responds to a prefix argument exactly as @code{vm-save-message} -does. Messages saved this way are flagged ``written''. -@findex vm-auto-archive-messages -@kindex A -@item A (@code{vm-auto-archive-messages}) -Save all unfiled messages that auto-match a folder via -@code{vm-auto-folder-alist} to their appropriate folders. Messages that -are flagged for deletion are not saved by this command. If invoked with a -prefix argument, confirmation will be requested for each save. -@findex vm-pipe-message-to-command -@kindex | -@item | (@code{vm-pipe-message-to-command}) -Runs a shell command with some or all of the current message as input. -By default, the entire message is used.@* -@* -If invoked with one @t{C-u} the text portion of the message is used.@* -If invoked with two @t{C-u}'s the header portion of the message is used.@* -@* -If the shell command generates any output, it is displayed in a -@samp{*Shell Command Output*} buffer. The message itself is not altered. -@end table - -@node Deleting Messages, Editing Messages, Saving Messages, Top -@chapter Deleting Messages - -In VM, messages are flagged for deletion, and then are subsequently -@dfn{expunged} or removed from the folder. The messages are not removed -from the on-disk copy of the folder until the folder is saved. - -@table @kbd -@findex vm-delete-message -@kindex d -@item d (@code{vm-delete-message}) -Flags the current message for deletion. A prefix argument @var{n} -causes the current message and the next @var{n-1} messages to be flagged. -A negative @var{n} causes the current message and the previous @var{n-1} -messages to be flagged. -@findex vm-undelete-message -@kindex u -@item u (@code{vm-undelete-message}) -Removes the deletion flag from the current message. A prefix argument @var{n} -causes the current message and the next @var{n-1} messages to be undeleted. -A negative @var{n} causes the current message and the previous @var{n-1} -messages to be undeleted. -@findex vm-kill-subject -@kindex k -@item k (@code{vm-kill-subject}) -Flags all messages with the same subject as the current message (ignoring -``Re:'') for deletion. -@findex vm-expunge-folder -@kindex # -@item # (@code{vm-expunge-folder}) -Does the actual removal of messages flagged for deletion in the current -folder. -@end table - -@vindex vm-move-after-deleting -@vindex vm-move-after-undeleting -Setting the variable @code{vm-move-after-deleting} non-@code{nil} causes -VM to move past the messages after flagging them for deletion. Setting -@code{vm-move-after-undeleting} non-@code{nil} causes similar movement after undeletes.@refill - -@node Editing Messages, Message Marks, Deleting Messages, Top -@chapter Editing Messages - -To edit a message, type @kbd{e} (@code{vm-edit-message}). The current -message is copied into a temporary buffer, and this buffer is selected -for editing. The major mode of this buffer is controlled by the -variable @code{vm-edit-message-mode}. The default is Text mode.@refill - -Use @kbd{C-c ESC} (@code{vm-edit-message-end}) when you have finished -editing the message. The message will be inserted into its folder, -replacing the old version of the message. If you want to quit the edit -without your edited version replacing the original, use @kbd{C-c C-]} -(@code{vm-edit-message-abort}), or you can just kill the edit buffer -with @kbd{C-x k} (@code{kill-buffer}).@refill - -If you give a prefix argument to @code{vm-edit-message}, then the -current message will be flagged unedited.@refill - -As with VM @samp{*mail*} buffers, all VM commands can be accessed from -the edit buffer through the command prefix @kbd{C-c C-v}.@refill - -@node Message Marks, Undoing, Editing Messages, Top -@chapter Message Marks - -VM provides general purpose @dfn{marks} that may be applied to any and -all messages within a given folder. Certain VM commands can be -subsequently invoked only on those message that are marked. - -To mark the current message, type @kbd{C-c C-@@} -(@code{vm-mark-message}). If you give a numeric prefix argument -@var{n}, the next @var{n-1} messages will be marked as well. A negative -prefix argument means mark the previous @var{n-1}. An asterisk -(@samp{*}) will appear to the right of the message numbers of all marked -messages in the summary window.@refill - -To remove a mark from the current message, use @kbd{C-c SPC} -(@code{vm-unmark-message}). Prefix arguments work as with -@code{vm-mark-message}.@refill - -Use @kbd{C-c C-a} to mark all messages in the current folder; @kbd{C-c a} -removes marks from all messages. - -To apply a VM command to all marked message you must prefix it with the -key sequence @kbd{C-c RET} (@code{vm-next-command-uses-marks}). The -next VM command will apply to all marked messages, provided the -command can be applied to such messages in a meaningful and useful way. -The current commands that can be applied to marked messages are: -@code{vm-delete-message}, @code{vm-discard-cached-data}, -@code{vm-followup}, @code{vm-followup-include-text}, @code{vm-reply}, -@code{vm-reply-include-text}, @code{vm-save-message}, -@code{vm-save-message-sans-headers}, @code{vm-send-digest}, -@code{vm-undelete-message}, and @code{vm-unread-message}.@refill - -@node Undoing, Grouping Messages, Message Marks, Top -@chapter Undoing - -VM provides a special form of undo which allows changes to message attributes -to be undone. - -@findex vm-undo -@kindex C-x u -@kindex C-_ -Typing @kbd{C-x u} or @key{C-_} (@code{vm-undo}) undoes the last -attribute change. Consecutive @code{vm-undo}'s undo further and further -back. Any intervening command breaks the undo chain, after which the -undos themselves become undoable by subsequent invocations of -@code{vm-undo}.@refill - -Note that expunges, saves and message edits are @emph{not} undoable. - -@node Grouping Messages, Reading Digests, Undoing, Top -@chapter Grouping Messages - -@findex vm-group-messages -@kindex G -In order to make numerous related messages easier to cope with, VM -provides the command @kbd{G} (@code{vm-group-messages}), which groups -all messages in a folder according to some criterion. @dfn{Grouping} -causes messages that are related in some way to be presented -consecutively. The actual order of the folder is not altered; -the messages are simply numbered and presented differently. Grouping -should not be confused with sorting; grouping only moves messages that -occur later in the folder backward to ``clump'' with other related -messages.@refill - -The grouping criteria currently supported are: -@table @samp -@item subject -Messages with the same subject (ignoring ``Re:'' prefixes) are grouped -together. -@item author -Messages with the same author are grouped together. -@item recipient -Message with the same recipients are grouped together. -@item date-sent -Messages sent on the same day are grouped together. -@item physical-order -Message presentation reverts to physical message order of the folder (the -default). -@end table - -@vindex vm-group-by -If the variable @code{vm-group-by} has a non-@code{nil} value it -specifies the default grouping that will be used for all folders. So if -you like having your mail presented to you grouped by subject, then put -@code{(setq vm-group-by "subject")} in your @file{.vm} or @file{.emacs} -file to get this behavior.@refill - -@node Reading Digests, Summaries, Grouping Messages, Top -@chapter Reading Digests - -A @dfn{digest} is one or more mail messages encapsulated in a single message. - -VM supports digests by providing a command to ``burst'' them into their -individual messages. These messages can then be handled like any other -messages under VM. - -@findex vm-burst-digest -@kindex * -The command @kbd{*} (@code{vm-burst-digest}) bursts a digest into its -individual messages and appends them to the current folder. These -messages are then assimilated into the current folder using the default -grouping. @xref{Grouping Messages}. The original digest message is not -altered, and the messages extracted from it are not part of the on-disk copy -of the folder until a save is done.@refill - -If you give a prefix argument to @code{vm-burst-digest}, it will attempt -to cope with non-RFC 934 compliant digests. If @code{vm-burst-digest} -seems to be breaking digests at inappropriate places, most likely the -digest is not compliant with the standard. In this case try using the -prefix arg. - -@node Summaries, Miscellaneous, Reading Digests, Top -@chapter Summaries - -@findex vm-summarize -@vindex vm-auto-center-summary -@kindex h -Typing @kbd{h} (@code{vm-summarize}) causes VM to display a summary of -contents of the current folder. The information in the summary is -automatically updated as changes are made to the current folder. An -arrow @samp{->} appears to the left of the line summarizing the current -message. The variable @code{vm-auto-center-summary} controls whether VM -will keep the summary arrow vertically centered within the summary -window. A value of @code{t} causes VM to always keep the arrow -centered. A value of @code{nil} (the default) means VM will never -bother centering the arrow. A value that is not @code{nil} and not -@code{t} causes VM to center the arrow only if the summary window is not -the only existing window.@refill - -@vindex vm-summary-format -The variable @code{vm-summary-format} controls the format of each -message's summary. Its value should be a string. This string should -contain printf-like ``%'' conversion specifiers which substitute -information about the message into the final summary. - -Recognized specifiers are: -@display - a - attribute indicators (always four characters wide) - The first char is `D', `N', `U' or ` ' for deleted, new, unread - and read messages respectively. - The second char is `F', `W' or ` ' for filed (saved) or written - messages. - The third char is `R', `Z' or ` ' for messages replied to, - and forwarded messages. - The fourth char is `E' if the message has been edited, - ` ' otherwise. - A - longer version of attributes indicators (six characters wide) - The first char is `D', `N', `U' or ` ' for deleted, new, unread - and read messages respectively. - The second is `r' or ` ', for message replied to. - The third is `z' or ` ', for messages forwarded. - The fourth is `f' or ` ', for messages filed. - The fifth is `w' or ` ', for messages written. - The sixth is `e' or ` ', for messages that have been edited. - c - number of characters in message (ignoring headers) - d - numeric day of month message sent - f - author's address - F - author's full name (same as f if full name not found) - h - hour message sent - i - message ID - l - number of lines in message (ignoring headers) - m - month message sent - M - numeric month message sent (January = 1) - n - message number - s - message subject - t - addresses of the recipients of the message, in a comma-separated list - T - full names of the recipients of the message, in a comma-separated list - If a full name cannot be found, the corresponding address is used - instead. - w - day of the week message sent - y - year message sent - z - timezone of date when the message was sent - * - `*' if the current message is marked, ` ' otherwise -@end display - -Use ``%%'' to get a single ``%''. - -A numeric field width may be specified between the ``%'' and the -specifier; this causes right justification of the substituted string. A -negative field width causes left justification. The field width may be -followed by a ``.'' and a number specifying the maximum allowed length -of the substituted string. If the string is longer than this value, it -is truncated. - -The summary format need not be one line per message but it must end with -a newline, otherwise the message pointer will not be displayed correctly -in the summary window. - -You can have a summary generated automatically at startup, -@pxref{Starting Up}.@refill - -@vindex vm-follow-summary-cursor -All VM commands are available in the summary buffer just as they are in -the folder buffer itself. If you set @code{vm-follow-summary-cursor} -non-@code{nil}, VM will select the message under the cursor in the -summary window before executing commands that operate on the current -message. Note that this occurs @emph{only} when executing a command -from the summary buffer window.@refill - -@node Miscellaneous,, Summaries, Top -@chapter Miscellaneous - -Here are some VM customization variables that don't really fit into the -other chapters. - -@table @code -@vindex vm-confirm-quit -@item vm-confirm-quit -A value of @code{t} causes VM to always ask for confirmation before -ending a VM visit of a folder. A @code{nil} value means VM will ask -only when messages will be lost unwittingly by quitting, i.e. not -removed by intentional delete and expunge. A value that is neither -@code{nil} nor @code{t} causes VM to ask only when there are unsaved -changes to message attributes or message will be lost. -@vindex vm-berkeley-mail-compatibility -@item vm-berkeley-mail-compatibility -A non-@code{nil} value means to read and write BSD @i{Mail(1)} style Status: -headers. This makes sense if you plan to use VM to read mail archives -created by @i{Mail}. -@vindex vm-gargle-uucp -@item vm-gargle-uucp -A non-@code{nil} value means to use a crufty regular expression that -does surprisingly well at beautifying UUCP addresses that are substituted -for %f and %t as part of summary and attribution formats. -@vindex vm-mode-hooks -@item vm-mode-hooks -A non-@code{nil} value should be a list of hook functions to run when a -buffer enters vm-mode. These hook functions should generally be used to -set key bindings and local variables. Mucking about in the folder -buffer is certainly possible, but it is not encouraged. -@vindex vm-delete-empty-folders -@item vm-delete-empty-folders -A non-@code{nil} value for this variable causes VM to remove empty (zero -length) folder files after saving them. -@vindex vm-mutable-windows -@item vm-mutable-windows -This variable's value controls VM's window usage. A value of @code{t} gives VM -free run of the Emacs display; it will commandeer the entire frame for -its purposes. A value of @code{nil} restricts VM's window usage to the window -from which it was invoked. VM will not create, delete, or use any other -windows, nor will it resize its own window. A value that is neither @code{t} -nor @code{nil} allows VM to use other windows, but it will not create new ones, -or resize or delete the current ones.@refill -@vindex mail-yank-hooks -@item mail-yank-hooks -Value should be a list of functions to be called after a message is -yanked into a @samp{*mail*} buffer via @code{vm-yank-message}. When -each hook function is called, point will be at the beginning of the -yanked text and mark at the end. - -This is not a VM specific variable, but rather an external variable that -VM honors so that citation packages such as @i{SUPERCITE} can be -used with VM. -@end table - -@node Key Index, Command Index, Top, Top -@unnumbered Key Index -@printindex ky - -@node Command Index, Variable Index, Key Index, Top -@unnumbered Command Index -@printindex fn - -@node Variable Index, Introduction, Command Index, Top -@unnumbered Variable Index -@printindex vr - -@summarycontents -@contents -@bye
--- a/man/vmcard.tex Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,381 +0,0 @@ -% Quick Reference Card for VM 4 under GNU Emacs version 18 on Unix systems -%**start of header -\newcount\columnsperpage - -% This file can be printed with 1, 2, or 3 columns per page (see below). -% Specify how many you want here. Nothing else needs to be changed. - -\columnsperpage=2 - -% Copyright (c) 1989 Free Software Foundation, Inc. - -% This file is part of GNU Emacs. - -% This file is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY. No author or distributor -% accepts responsibility to anyone for the consequences of using it -% or for whether it serves any particular purpose or describes -% any piece of software unless they say so in writing. Refer to the -% GNU Emacs General Public License for full details. -% -% Permission is granted to copy, modify and redistribute this source -% file provided the copyright notice and permission notices are -% preserved on all copies. -% -% Permission is granted to process this file through TeX and print the -% results, provided the printed document carries copyright and -% permission notices identical to the ones below. - -% This file is intended to be processed by plain TeX (TeX82). -% -% The final reference card has six columns, three on each side. -% This file can be used to produce it in any of three ways: -% 1 column per page -% produces six separate pages, each of which needs to be reduced to 80%. -% This gives the best resolution. -% 2 columns per page -% produces three already-reduced pages. -% You will still need to cut and paste. -% 3 columns per page -% produces two pages which must be printed sideways to make a -% ready-to-use 8.5 x 11 inch reference card. -% For this you need a dvi device driver that can print sideways. -% Which mode to use is controlled by setting \columnsperpage above. -% -% VMREFCARD 1.0 - October 9, 1989 - jgraf@mipos3.intel.com -% Hacked up vipcard.tex by msato which was hacked from refcard.tex -% by sgildea. No doubt a tradition for years to come. -% -% Author: -% Masahiko Sato -% Internet: ms@sail.stanford.edu -% Junet: masahiko@sato.riec.tohoku.junet -% -% The original TeX code for formatting the reference card was written by: -% Stephen Gildea -% UUCP: mit-erl!gildea -% Internet: gildea@erl.mit.edu - - -\def\versionnumber{1.0} -\def\year{1989} -\def\version{September \year\ v\versionnumber} - -\def\shortcopyrightnotice{\vskip 1ex plus 2 fill - \centerline{\small \copyright\ \year\ Kyle Jones - Permissions on back. v\versionnumber}} - -\def\copyrightnotice{ -%\vskip 1ex plus 2 fill\begingroup\small -\vskip 1ex \begingroup\small -\centerline{Copyright \copyright\ \year\ Kyle Jones} -\centerline{refcard redesigned by jgraf, \version} -\centerline{for VM 4 under GNU Emacs version 18 on Unix systems} - -Permission is granted to make and distribute copies of -this card provided the copyright notice and this permission notice -are preserved on all copies. - -\endgroup} - -% make \bye not \outer so that the \def\bye in the \else clause below -% can be scanned without complaint. -\def\bye{\par\vfill\supereject\end} - -\newdimen\intercolumnskip -\newbox\columna -\newbox\columnb - -\def\ncolumns{\the\columnsperpage} - -\message{[\ncolumns\space - column\if 1\ncolumns\else s\fi\space per page]} - -\def\scaledmag#1{ scaled \magstep #1} - -% This multi-way format was designed by Stephen Gildea -% October 1986. -% Slightly modified by Masahiko Sato, September 1987. -\if 1\ncolumns - \hsize 4in - \vsize 10in - %\voffset -.7in - \voffset -.57in - \font\titlefont=\fontname\tenbf \scaledmag3 - \font\headingfont=\fontname\tenbf \scaledmag2 - \font\miniheadingfont=\fontname\tenbf \scaledmag1 % masahiko - \font\smallfont=\fontname\sevenrm - \font\smallsy=\fontname\sevensy - - \footline{\hss\folio} - \def\makefootline{\baselineskip10pt\hsize6.5in\line{\the\footline}} -\else - %\hsize 3.2in - %\vsize 7.95in - \hsize 3.41in % masahiko - \vsize 8in % masahiko - \hoffset -.75in - \voffset -.745in - \font\titlefont=cmbx10 \scaledmag2 - \font\headingfont=cmbx10 \scaledmag1 - \font\miniheadingfont=cmbx10 % masahiko - \font\smallfont=cmr6 - \font\smallsy=cmsy6 - \font\eightrm=cmr8 - \font\eightbf=cmbx8 - \font\eightit=cmti8 - \font\eightsl=cmsl8 - \font\eighttt=cmtt8 - \font\eightsy=cmsy8 - \textfont0=\eightrm - \textfont2=\eightsy - \def\rm{\eightrm} - \def\bf{\eightbf} - \def\it{\eightit} - \def\sl{\eightsl} % masahiko - \def\tt{\eighttt} - \normalbaselineskip=.8\normalbaselineskip - \normallineskip=.8\normallineskip - \normallineskiplimit=.8\normallineskiplimit - \normalbaselines\rm %make definitions take effect - - \if 2\ncolumns - \let\maxcolumn=b - \footline{\hss\rm\folio\hss} - \def\makefootline{\vskip 2in \hsize=6.86in\line{\the\footline}} - \else \if 3\ncolumns - \let\maxcolumn=c - \nopagenumbers - \else - \errhelp{You must set \columnsperpage equal to 1, 2, or 3.} - \errmessage{Illegal number of columns per page} - \fi\fi - - %\intercolumnskip=.46in - \intercolumnskip=.19in % masahiko .19x4 + 3.41x3 = 10.99 - \def\abc{a} - \output={% - % This next line is useful when designing the layout. - %\immediate\write16{Column \folio\abc\space starts with \firstmark} - \if \maxcolumn\abc \multicolumnformat \global\def\abc{a} - \else\if a\abc - \global\setbox\columna\columnbox \global\def\abc{b} - %% in case we never use \columnb (two-column mode) - \global\setbox\columnb\hbox to -\intercolumnskip{} - \else - \global\setbox\columnb\columnbox \global\def\abc{c}\fi\fi} - \def\multicolumnformat{\shipout\vbox{\makeheadline - \hbox{\box\columna\hskip\intercolumnskip - \box\columnb\hskip\intercolumnskip\columnbox} - \makefootline}\advancepageno} - \def\columnbox{\leftline{\pagebody}} - - \def\bye{\par\vfill\supereject - \if a\abc \else\null\vfill\eject\fi - \if a\abc \else\null\vfill\eject\fi - \end} -\fi - -% we won't be using math mode much, so redefine some of the characters -% we might want to talk about -\catcode`\^=12 -\catcode`\_=12 - -\chardef\\=`\\ -\chardef\{=`\{ -\chardef\}=`\} - -\hyphenation{mini-buf-fer} - -\parindent 0pt -\parskip 1ex plus .5ex minus .5ex - -\def\small{\smallfont\textfont2=\smallsy\baselineskip=.8\baselineskip} - -\outer\def\newcolumn{\vfill\eject} - -\outer\def\title#1{{\titlefont\centerline{#1}}\vskip 1ex plus .5ex} - -\outer\def\section#1{\par\filbreak - \vskip 3ex plus 2ex minus 2ex {\headingfont #1}\mark{#1}% - \vskip 2ex plus 1ex minus 1.5ex} - -% masahiko -\outer\def\subsection#1{\par\filbreak - \vskip 2ex plus 2ex minus 2ex {\miniheadingfont #1}\mark{#1}% - \vskip 1ex plus 1ex minus 1.5ex} - -\newdimen\keyindent - -\def\beginindentedkeys{\keyindent=1em} -\def\endindentedkeys{\keyindent=0em} -\endindentedkeys - -\def\paralign{\vskip\parskip\halign} - -\def\<#1>{$\langle${\rm #1}$\rangle$} - -\def\kbd#1{{\tt#1}\null} %\null so not an abbrev even if period follows - -\def\beginexample{\par\leavevmode\begingroup - \obeylines\obeyspaces\parskip0pt\tt} -{\obeyspaces\global\let =\ } -\def\endexample{\endgroup} - -\def\key#1#2{\leavevmode\hbox to \hsize{\vtop - {\hsize=.75\hsize\rightskip=1em - \hskip\keyindent\relax#1}\kbd{#2}\hfil}} - -\newbox\metaxbox -\setbox\metaxbox\hbox{\kbd{M-x }} -\newdimen\metaxwidth -\metaxwidth=\wd\metaxbox - -\def\metax#1#2{\leavevmode\hbox to \hsize{\hbox to .75\hsize - {\hskip\keyindent\relax#1\hfil}% - \hskip -\metaxwidth minus 1fil - \kbd{#2}\hfil}} - -\def\fivecol#1#2#3#4#5{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad&\kbd{#4}\quad&\kbd{#5}\cr} - -\def\fourcol#1#2#3#4{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad&\kbd{#4}\quad\cr} - -\def\threecol#1#2#3{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad - &\kbd{#3}\quad\cr} - -\def\twocol#1#2{\hskip\keyindent\relax\kbd{#1}\hfil&\kbd{#2}\quad\cr} - -\def\twocolkey#1#2#3#4{\hskip\keyindent\relax#1\hfil&\kbd{#2}\quad&\relax#3\hfil&\kbd{#4}\quad\cr} - -%**end of header - -\beginindentedkeys - -\title{VM (View Mail) Reference Card} - -\centerline{(for version 4 under GNU Emacs version 18)} - -%\copyrightnotice - -\section{VM Major Mode} - -To invoke VM type {\bf M-x vm} - -\subsection{Selecting and Previewing Mail} - -\key{go to next message}{n} -\key{go to previous message}{p} -\key{like {\bf n} but ignore skip-variable setting}{N} -\key{like {\bf p} but ignore skip-variable setting}{P} -\key{go to next unread message}{M-n} -\key{go to previous unread message}{M-p} -\key{go to numbered message (uses prefix arg)}{RET} -\key{go to last message seen}{TAB} -\key{incremental search through folder}{M-s} - -\key{display hidden headers}{t} -\key{scroll forward a page (or display next msg)}{SPC} -\key{scroll back a page}{b {\rm or} DEL} -\key{go to start of current message}{<} -\key{go to end of current message}{>} - -\subsection{Deleting mail} -\key{delete current message (mark)}{d} -\key{undelete (mark)}{u} -\key{delete all msgs with same subj as current msg}{k} - -\subsection{Sending mail from within VM} - -\key{originate a piece of mail}{m} -\key{reply (only to sender of message)}{r} -\key{reply with included text from current msg}{R} -\key{followup (reply to all recipients of msg)}{f} -\key{followup with included text}{F} -\key{forward the current message}{z} - -\subsection{Folders} - -\key{digestify and mail folder contents}{@} -\key{burst a digest}{*} - -\key{group msgs according to criteria}{G} - -\key{get any new mail from system mailbox}{g} -\key{visit another mail folder}{v} - -\key{save current msg to folder (append if exist)}{s} -\key{write msg to file sans headers (append if exist)}{w} -\key{expunge and save mail folder}{S} -\key{expunge deleted msgs (don't save folder)}{\#} -\key{save unfiled msgs via vm-auto-folder-alist}{A} -\key{quit VM, expunge and save folder}{q} -\key{exit VM with no change to folder}{x} - -\shortcopyrightnotice - -\subsection {VM Miscellaneous Commands} - -\key{special undo for msg attributes only}{C-_} -\key{help}{?} -\key{run a shell command}{!} -\key{run a shell cmd with cur. msg as input}{|} - -\hskip 5ex -If the *mail* buffer was entered via the VM command {\bf m}, then the -following commands are valid within the *mail* buffer: - -\hskip 5ex - -\key{copy msg from folder to *mail*}{C-C C-y} -\key{execute VM cmd in *mail* buffer}{C-C C-v} - -\section{EMACS Mail Mode} - -\key{originate a piece of mail}{C-x m} -\key{same as C-x m but use other window}{C-x 4 m} - -\subsection{Sending Mail} - -\key{send message, leave *mail* selected}{C-c C-s} -\key{send message, select some other buffer}{C-c C-c} - -\subsection{Mail Mode Commands} - -\key{insert file \~/.signature at end of message}{C-c C-w} -\key{yank selected message from Rmail/VM}{C-c C-y} -\key{fill paragraphs of yanked messages}{C-c C-q} - -\subsection{Mail Header Fields} - -\hskip 5ex -Fields that have commands associated with them will move to the -appropriate field creating one if needed. - -\paralign to \hsize{#\tabskip=10pt plus 1 fil&#\tabskip=0pt&#\cr - -\threecol{{\bf Field}}{{\bf Purpose}}{{\bf Command}} -\threecol{To:} {mail to address(es)}{C-c C-f C-t} -\threecol{Subject:} {topic of mail message}{C-c C-f C-s} -\threecol{CC:} {copy to(appears in header)}{C-c C-f C-c} -\threecol{BCC:} {copy to (not in header)}{C-c C-f C-b} -\threecol{FCC:} {save file to after send}{NA} -\threecol{From:} {who sent the mail}{NA} -\threecol{Reply-To:} {send replies to address}{NA} -\threecol{In-Reply-To}{subject of reply}{NA} -} - -\hskip 5ex -The `To', `CC', `BCC' and `FCC' fields can appear any number of times and -`To', `CC' and `BCC' fields can have continuation lines. - -\hskip 5ex - -\copyrightnotice - -\bye - -% Local variables: -% compile-command: "tex refcard" -% End:
--- a/man/xemacs-faq.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/xemacs-faq.texi Mon Aug 13 10:03:52 2007 +0200 @@ -44,6 +44,292 @@ * Subsystems:: Major Subsystems. * Miscellaneous:: The Miscellaneous Stuff. * Current Events:: What the Future Holds. + +@detailmenu + + --- The Detailed Node Listing --- + +Introduction, Policy, Credits + +* Q1.0.1:: What is XEmacs? +* Q1.0.2:: What is the current version of XEmacs? +* Q1.0.3:: Where can I find it? +* Q1.0.4:: Why Another Version of Emacs? +* Q1.0.5:: Why Haven't XEmacs and GNU Emacs Merged? +* Q1.0.6:: Where can I get help? +* Q1.0.7:: Where is the mailing list archived? +* Q1.0.8:: How do you pronounce XEmacs? +* Q1.0.9:: What does XEmacs look like? +* Q1.0.10:: Is there a port of XEmacs to Microsoft ('95 or NT)? +* Q1.0.11:: Is there a port of XEmacs to the Macintosh? +* Q1.0.12:: Is there a port of XEmacs to NextStep? +* Q1.0.13:: Is there a port of XEmacs to OS/2? +* Q1.0.14:: Where can I get a printed copy of the XEmacs users manual? + +Policies: +* Q1.1.1:: What is the FAQ editorial policy? +* Q1.1.2:: How do I become a Beta Tester? +* Q1.1.3:: How do I contribute to XEmacs itself? + +Credits: +* Q1.2.1:: Who wrote XEmacs? +* Q1.2.2:: Who contributed to this version of the FAQ? +* Q1.2.3:: Who contributed to the FAQ in the past? + +Internationalization: +* Q1.3.1:: What is the status of XEmacs v20? +* Q1.3.2:: What is the status of Asian-language support, aka @var{mule}? +* Q1.3.3:: How do I type non-ASCII characters? +* Q1.3.4:: Can XEmacs messages come out in a different language? +* Q1.3.5:: Please explain the various input methods in MULE/XEmacs 20.0 +* Q1.3.6:: How do I portably code for MULE/XEmacs 20.0? +* Q1.3.7:: How about Cyrillic Modes? + +Getting Started: +* Q1.4.1:: What is a @file{.emacs} and is there a sample one? +* Q1.4.2:: Can I use the same @file{.emacs} with the other Emacs? +* Q1.4.3:: Any good XEmacs tutorials around? +* Q1.4.4:: May I see an example of a useful XEmacs Lisp function? +* Q1.4.5:: And how do I bind it to a key? +* Q1.4.6:: What's the difference between a macro and a function? +* Q1.4.7:: Why options saved with 19.13 don't work with 19.14 or later? + +Installation and Trouble Shooting + +* Q2.0.1:: Running XEmacs without installing. +* Q2.0.2:: XEmacs is too big. +* Q2.0.3:: Compiling XEmacs with Netaudio. +* Q2.0.4:: Problems with Linux and ncurses. +* Q2.0.5:: Do I need X11 to run XEmacs? +* Q2.0.6:: I'm having strange crashes. What do I do? +* Q2.0.7:: Libraries in non-standard locations. +* Q2.0.8:: can't resolve symbol _h_errno +* Q2.0.9:: Where do I find external libraries? +* Q2.0.10:: After I run configure I find a coredump, is something wrong? +* Q2.0.11:: XEmacs can't resolve host names. +* Q2.0.12:: Why can't I strip XEmacs? +* Q2.0.13:: Can't link XEmacs on Solaris with Gcc. +* Q2.0.14:: Make on HP/UX 9 fails after linking temacs + +Trouble Shooting: +* Q2.1.1:: XEmacs just crashed on me! +* Q2.1.2:: Cryptic Minibuffer messages. +* Q2.1.3:: Translation Table Syntax messages at Startup. +* Q2.1.4:: Startup warnings about deducing proper fonts? +* Q2.1.5:: XEmacs cannot connect to my X Terminal. +* Q2.1.6:: XEmacs just locked up my Linux X server. +* Q2.1.7:: HP Alt key as Meta. +* Q2.1.8:: got (wrong-type-argument color-instance-p nil)! +* Q2.1.9:: XEmacs causes my OpenWindows 3.0 server to crash. +* Q2.1.10:: Warnings from incorrect key modifiers. +* Q2.1.11:: [This question intentionally left blank] +* Q2.1.12:: Regular Expression Problems on DEC OSF1. +* Q2.1.13:: HP/UX 10.10 and @code{create_process} failure +* Q2.1.14:: @kbd{C-g} doesn't work for me. Is it broken? +* Q2.1.15:: How to debug an XEmacs problem with a debugger. +* Q2.1.16:: XEmacs crashes in @code{strcat} on HP/UX 10. +* Q2.1.17:: @samp{Marker does not point anywhere}. +* Q2.1.18:: 19.14 hangs on HP/UX 10.10. +* Q2.1.19:: XEmacs does not follow the local timezone. +* Q2.1.20:: @samp{Symbol's function definition is void: hkey-help-show.} +* Q2.1.21:: Every so often the XEmacs frame freezes. +* Q2.1.22:: XEmacs seems to take a really long time to do some things. +* Q2.1.23:: Movemail on Linux does not work for XEmacs 19.15 and later. + +Customization and Options + +* Q3.0.1:: What version of Emacs am I running? +* Q3.0.2:: How do I evaluate Elisp expressions? +* Q3.0.3:: @code{(setq tab-width 6)} behaves oddly. +* Q3.0.4:: How can I add directories to the @code{load-path}? +* Q3.0.5:: How to check if a lisp function is defined? +* Q3.0.6:: Can I force the output of @code{(face-list)} to a buffer? +* Q3.0.7:: Font selections don't get saved after @code{Save Options}. +* Q3.0.8:: How do I make a single minibuffer frame? + +X Window System & Resources: +* Q3.1.1:: Where is a list of X resources? +* Q3.1.2:: How can I detect a color display? +* Q3.1.3:: @code{(set-screen-width)} worked in 19.6, but not in 19.13? +* Q3.1.4:: Specifiying @code{Emacs*EmacsScreen.geometry} in @file{.emacs} does not work in 19.15? +* Q3.1.5:: How can I get the icon to just say @samp{XEmacs}? +* Q3.1.6:: How can I have the window title area display the full path? +* Q3.1.7:: @samp{xemacs -name junk} doesn't work? +* Q3.1.8:: @samp{-iconic} it doesn't work. + +Textual Fonts & Colors: +* Q3.2.1:: How can I set color options from @file{.emacs}? +* Q3.2.2:: How do I set the text, menu and modeline fonts? +* Q3.2.3:: How can I set the colors when highlighting a region? +* Q3.2.4:: How can I limit color map usage? +* Q3.2.5:: My tty supports color, but XEmacs doesn't use them. + +The Modeline: +* Q3.3.1:: How can I make the modeline go away? +* Q3.3.2:: How do you have XEmacs display the line number in the modeline? +* Q3.3.3:: How do I get XEmacs to put the time of day on the modeline? +* Q3.3.4:: How do I turn off current chapter from AUC TeX modeline? +* Q3.3.5:: How can one change the modeline color based on the mode used? + +3.4 Multiple Device Support: +* Q3.4.1:: How do I open a frame on another screen of my multi-headed display? +* Q3.4.2:: Can I really connect to a running XEmacs after calling up over a modem? How? + +3.5 The Keyboard: +* Q3.5.1:: How can I bind complex functions (or macros) to keys? +* Q3.5.2:: How can I stop down-arrow from adding empty lines to the bottom of my buffers? +* Q3.5.3:: How do I bind C-. and C-; to scroll one line up and down? +* Q3.5.4:: Globally binding @kbd{Delete}? +* Q3.5.5:: Scrolling one line at a time. +* Q3.5.6:: How to map @kbd{Help} key alone on Sun type4 keyboard? +* Q3.5.7:: How can you type in special characters in XEmacs? +* Q3.5.8:: Why does @code{(global-set-key [delete-forward] 'delete-char)} complain? +* Q3.5.9:: How do I make the Delete key delete forward? +* Q3.5.10:: Can I turn on @dfn{sticky} modifier keys? + +The Cursor: +* Q3.6.1:: Is there a way to make the bar cursor thicker? +* Q3.6.2:: Is there a way to get back the old block cursor where the cursor covers the character in front of the point? +* Q3.6.3:: Can I make the cursor blink? + +The Mouse and Highlighting: +* Q3.7.1:: How can I turn off Mouse pasting? +* Q3.7.2:: How do I set control/meta/etc modifiers on mouse buttons? +* Q3.7.3:: Clicking the left button does not do anything in buffer list. +* Q3.7.4:: How can I get a list of buffers when I hit mouse button 3? +* Q3.7.5:: Why does cut-and-paste not work between XEmacs and a cmdtool? +* Q3.7.6:: How I can set XEmacs up so that it pastes where the text cursor is? +* Q3.7.7:: How do I select a rectangular region? +* Q3.7.8:: Why does @kbd{M-w} take so long? + +The Menubar and Toolbar: +* Q3.8.1:: How do I get rid of the menu (or menubar)? +* Q3.8.2:: Can I customize the basic menubar? +* Q3.8.3:: How do I control how many buffers are listed in the menu @code{Buffers} list? +* Q3.8.4:: Resources like @code{Emacs*menubar*font} are not working? +* Q3.8.5:: How can I bind a key to a function to toggle the toolbar? + +Scrollbars: +* Q3.9.1:: How can I disable the scrollbar? +* Q3.9.2:: How can one use resources to change scrollbar colors? +* Q3.9.3:: Moving the scrollbar can move the point; can I disable this? +* Q3.9.4:: How can I get automatic horizontal scrolling? + +Text Selections: +* Q3.10.1:: How can I turn off or change highlighted selections? +* Q3.10.2:: How do I get that typing on an active region removes it? +* Q3.10.3:: Can I turn off the highlight during isearch? +* Q3.10.4:: How do I turn off highlighting after @kbd{C-x C-p} (mark-page)? +* Q3.10.5:: The region disappears when I hit the end of buffer while scrolling. + +Major Subsystems + +* Q4.0.1:: How do I set up VM to retrieve remote mail using POP? +* Q4.0.2:: How do I get VM to filter mail for me? +* Q4.0.3:: How can I get VM to automatically check for new mail? +* Q4.0.4:: [This question intentionally left blank] +* Q4.0.5:: How do I get my outgoing mail archived? +* Q4.0.6:: I have various addresses at which I receive mail. How can I tell VM to ignore them when doing a "reply-all"? +* Q4.0.7:: Is there a mailing list or FAQ for VM? +* Q4.0.8:: Remote Mailreading with VM. +* Q4.0.9:: rmail or VM gets an error incorporating new mail. +* Q4.0.10:: How do I make VM stay in a single frame? +* Q4.0.11:: How do I make VM or mh-e display graphical smilies? +* Q4.0.12:: Customization of VM not covered in the manual or here. + +Web browsing with W3: +* Q4.1.1:: What is W3? +* Q4.1.2:: How do I run W3 from behind a firewall? +* Q4.1.3:: Is it true that W3 supports style sheets and tables? + +Reading Netnews and Mail with Gnus: +* Q4.2.1:: GNUS, (ding) Gnus, Gnus 5, September Gnus, Red Gnus,argh! +* Q4.2.2:: [This question intentionally left blank] +* Q4.2.3:: How do I make Gnus stay within a single frame? +* Q4.2.4:: How do I customize the From: line? + +Other Mail & News: +* Q4.3.1:: How can I read and/or compose MIME messages? +* Q4.3.2:: What is TM and where do I get it? +* Q4.3.3:: Why isn't this @code{movemail} program working? +* Q4.3.4:: Movemail is also distributed by Netscape? Can that cause problems? +* Q4.3.5:: Where do I find pstogif (required by tm)? + +Sparcworks, EOS, and WorkShop: +* Q4.4.1:: What is SPARCworks, EOS, and WorkShop + +Energize: +* Q4.5.1:: What is/was Energize? + +Infodock: +* Q4.6.1:: What is Infodock? + +Other Unbundled Packages: +* Q4.7.1:: What is AUC TeX? Where do you get it? +* Q4.7.2:: Are there any Emacs Lisp Spreadsheets? +* Q4.7.3:: Byte compiling AUC TeX on XEmacs 19.14 +* Q4.7.4:: Problems installing AUC TeX +* Q4.7.5:: Is there a reason for an Emacs package not to be included in XEmacs? + +The Miscellaneous Stuff + +* Q5.0.1:: How can I do source code highlighting using font-lock? +* Q5.0.2:: I do not like cc-mode. How do I use the old c-mode? +* Q5.0.3:: How do I get @samp{More} Syntax Highlighting on by default? +* Q5.0.4:: How can I enable auto-indent? +* Q5.0.5:: How can I get XEmacs to come up in text/auto-fill mode by default? +* Q5.0.6:: How do I start up a second shell buffer? +* Q5.0.7:: Telnet from shell filters too much. +* Q5.0.8:: Why does edt emulation not work? +* Q5.0.9:: How can I emulate VI and use it as my default mode? +* Q5.0.10:: [This question intentionally left blank] +* Q5.0.11:: Filladapt doesn't work in 19.15? +* Q5.0.12:: How do I disable gnuserv from opening a new frame? +* Q5.0.13:: How do I start gnuserv so that each subsequent XEmacs is a client? +* Q5.0.14:: Strange things are happening in Shell Mode. +* Q5.0.15:: Where do I get the latest CC Mode? +* Q5.0.16:: I find auto-show-mode disconcerting. How do I turn it off? +* Q5.0.17:: How can I get two instances of info? +* Q5.0.18:: I upgraded to XEmacs 19.14 and gnuserv stopped working +* Q5.0.19:: Is there something better than LaTeX mode? + +Emacs Lisp Programming Techniques: +* Q5.1.1:: The difference in key sequences between XEmacs and GNU Emacs? +* Q5.1.2:: Can I generate "fake" keyboard events? +* Q5.1.3:: Could you explain @code{read-kbd-macro} in more detail? +* Q5.1.4:: What is the performance hit of @code{let}? +* Q5.1.5:: What is the recommended use of @code{setq}? +* Q5.1.6:: What is the typical misuse of @code{setq} ? +* Q5.1.7:: I like the the @code{do} form of cl, does it slow things down? +* Q5.1.8:: I like recursion, does it slow things down? +* Q5.1.9:: How do I put a glyph as annotation in a buffer? + +Sound: +* Q5.2.1:: How do I turn off the sound? +* Q5.2.2:: How do I get funky sounds instead of a boring beep? +* Q5.2.3:: What's NAS, how do I get it? +* Q5.2.4:: Sunsite sounds don't play. + +Miscellaneous: +* Q5.3.1:: How do you make XEmacs indent CL if-clauses correctly? +* Q5.3.2:: Fontifying hangs when editing a postscript file. +* Q5.3.3:: How can I print WYSIWYG a font-locked buffer? +* Q5.3.4:: Getting @kbd{M-x lpr} to work with postscript printer. +* Q5.3.5:: How do I specify the paths that XEmacs uses for finding files? +* Q5.3.6:: [This question intentionally left blank] +* Q5.3.7:: Can I have the end of the buffer delimited in some way? +* Q5.3.8:: How do I insert today's date into a buffer? +* Q5.3.9:: Are only certain syntactic character classes available for abbrevs? +* Q5.3.10:: How can I get those oh-so-neat X-Face lines? +* Q5.3.11:: How do I add new Info directories? +* Q5.3.12:: What do I need to change to make printing work? + +What the Future Holds + +* Q6.0.1:: What is new in 20.2? +* Q6.0.2:: What is new in 20.3? +* Q6.0.3:: Procedural changes in XEmacs development. +@end detailmenu @end menu @node Introduction, Installation, Top, Top @@ -239,6 +525,11 @@ and the XEmacs development team which provide little hope for a merge to take place in the short-term future. +If you have a comment to add regarding the merge, it is a good idea to +avoid posting to the newsgroups, because of the very heated flamewars +that often result. Mail your questions to <xemacs-beta@@xemacs.org> and +<bug-gnu-emacs@@prep.ai.mit.edu>. + @node Q1.0.6, Q1.0.7, Q1.0.5, Introduction @section Where can I get help? @@ -268,11 +559,14 @@ @node Q1.0.7, Q1.0.8, Q1.0.6, Introduction @section Where is the mailing list archived? -The mailing list is archived in the directory +The mailing list was archived in the directory @example <URL:ftp://ftp.xemacs.org:/pub/mlists/>. @end example +However, this archive is out of date. The current mailing list server +supports an @code{archive} feature, which may be utilized. + @node Q1.0.8, Q1.0.9, Q1.0.7, Introduction @section How do you pronounce XEmacs? @@ -339,7 +633,8 @@ InfoDock Associates, a firm specializing in Emacs-related support and development, will be maintaining the XEmacs user manual. The firm plans -to begin publishing printed copies of the manual in March 1997. +to begin publishing printed copies of the manual soon. +@c This used to say `March 1997'! @example Web: http://www.xemacs.com @@ -418,7 +713,7 @@ @section Who wrote XEmacs? XEmacs is the result of the time and effort of many people. The -developers responsible for the 19.15/20.0 release are: +developers responsible for the 19.15/20.x releases are: @itemize @bullet @item Martin Buchholz <mrb@@eng.sun.com> @@ -519,9 +814,13 @@ The MULE support works OK but still needs a fair amount of work before it's really solid. We could definitely use some help here, esp. people who speak Japanese and will use XEmacs/MULE to work with Japanese and -have some experience with E-Lisp. Martin Buchholz -<Martin.Buchholz@@sun.com> is working full-time on this currently. If -you can help out here, @xref{Q1.1.2}. +have some experience with E-Lisp. + +As the fundings on Mule have stopped, Mule part of XEmacs is currently +looking for a full-time maintainer. If you can provide help here, or +are willing to fund the work, please mail to <xemacs-beta@@xemacs.org>. + +@xref{Q1.1.2}. @node Q1.3.3, Q1.3.4, Q1.3.2, Introduction @section How do I type non-ASCII characters? @@ -754,12 +1053,6 @@ Or interactively, @kbd{M-x global-set-key} and follow the prompts. -You can also view Jari Aalto's <jaalto@@tre.ntc.nokia.com> file: - -@example -<URL:ftp://cs.uta.fi/pub/ssjaaa/ema-keys.html> -@end example - @node Q1.4.6, Q1.4.7, Q1.4.5, Introduction @section What's the difference between a macro and a function? @@ -884,6 +1177,9 @@ @node Q2.0.2, Q2.0.3, Q2.0.1, Installation @section XEmacs is too big +Although this entry has been written for XEmacs 19.13, most of it still +stands true. + Steve Baur <steve@@altair.xemacs.org> writes: @quotation @@ -1189,6 +1485,8 @@ All external libraries used by XEmacs can be found at the XEmacs FTP site <URL:ftp://ftp.xemacs.org/pub/aux/>. +@c This list is a pain in the you-know-what to keep in synch with the +@c world. The canonical locations (at the time of this writing) are as follows: @table @asis @@ -5266,18 +5564,10 @@ @node Q6.0.2, Q6.0.3, Q6.0.1, Current Events @section What is new in 20.3? -XEmacs release 20.3 is planned for autumn 1997. It will likely contain -a much smaller amount of code for basic functionality, with all the -popular Lisp packages being available in the form of easy-to-install -add-ons. - -Other input methods (such as skk) will be made available for Mule, as -well as more user-level documentation. - -Many new features are planned, such as multiple TTY frames, support for -Autoconf 2, synches with Emacs 20.1, and more; much of this is already -running in various beta versions. Ask at -@code{<xemacs-beta-request@@xemacs.org>} for more details. +XEmacs release 20.3 is planned for november 1997. It will contain many +bugfixes, and a number of new features, including Autoconf 2 based +configuration, multiple TTY frames, further customizations, synches with +GNU Emacs 20, advanced Perl-like regexp features, and more. @node Q6.0.3, , Q6.0.2, Current Events @section Procedural changes in XEmacs development. @@ -5296,9 +5586,8 @@ decided that intermediate versions will be made available in source only form for the truly interested. -No further XEmacs 19 feature releases are planned. XEmacs 19.16 will -consist of 19.15 plus the collected bugfixes, and will probably be the -final version of XEmacs 19. +XEmacs 19.16 will be the last 19 release, basically consisting of 19.15 +plus the collected bugfixes. @item As of December 1996, Steve Baur <steve@@altair.xemacs.org> has become
--- a/man/xemacs/custom.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/xemacs/custom.texi Mon Aug 13 10:03:52 2007 +0200 @@ -212,10 +212,10 @@ Customization of the One True Editor. See also [Manual]. -Editing group: [Go to Group] + [Open] Editing group Basic text editing facilities. -External group: [Go to Group] + [Open] External group Interfacing to external utilities. @var{more second-level groups} @@ -240,11 +240,10 @@ when you @dfn{invoke} it. To invoke an active field, either click on it with @kbd{Mouse-1}, or move point to it and type @key{RET}. - For example, the phrase @samp{[Go to Group]} that appears in a -second-level group is an active field. Invoking the @samp{[Go to -Group]} field for a group creates a new customization buffer, which -shows that group and its contents. This field is a kind of hypertext -link to another group. + For example, the phrase @samp{[Open]} that appears in a second-level +group is an active field. Invoking the @samp{[Open]} field for a group +opens up a new customization buffer, which shows that group and its +contents. This field is a kind of hypertext link to another group. The @code{Emacs} group does not include any user options itself, but other groups do. By examining various groups, you will eventually find @@ -392,11 +391,11 @@ operation. You can also restore the option to its standard value by invoking -@samp{[State]} and selecting the @samp{Reset to Standard Settings} -operation. There are actually three reset operations: +@samp{[State]} and selecting the @samp{Reset} operation. There are +actually three reset operations: @table @samp -@item Reset +@item Reset to Current If you have made some modifications and not yet set the option, this restores the text in the customization buffer to match the actual value. @@ -421,7 +420,7 @@ containing several active fields: @smallexample - [Set] [Save] [Reset] [Reset to Saved] [Reset to Standard] [Done] + [Set] [Save] [Reset] [Done] @end smallexample @noindent @@ -445,13 +444,17 @@ Custom Changed Face: (sample) [State]: this face is unchanged from its standard setting. Face used when the customize item has been changed. -Attributes: [ ] Bold: [toggle] off - [X] Italic: [toggle] on - [ ] Underline: [toggle] off - [ ] Inverse-Video: [toggle] on - [ ] Foreground: black (sample) - [ ] Background: white (sample) - [ ] Stipple: +Parent groups: [Custom Magic Faces] +Attributes: [ ] Bold: [Toggle] off (nil) + [ ] Italic: [Toggle] off (nil) + [ ] Underline: [Toggle] off (nil) + [ ] Foreground: white (sample) + [ ] Background: blue (sample) + [ ] Inverse: [Toggle] off (nil) + [ ] Stipple: + [ ] Font Family: + [ ] Size: + [ ] Strikethru: off @end smallexample Each face attribute has its own line. The @samp{[@var{x}]} field @@ -460,11 +463,12 @@ attribute by invoking that field. When the attribute is enabled, you can change the attribute value in the usual ways. - On a black-and-white display, the colors you can use for the -background are @samp{black}, @samp{white}, @samp{gray}, @samp{gray1}, -and @samp{gray3}. Emacs supports these shades of gray by using -background stipple patterns instead of a color. - +@c Is this true for XEmacs? +@c On a black-and-white display, the colors you can use for the +@c background are @samp{black}, @samp{white}, @samp{gray}, @samp{gray1}, +@c and @samp{gray3}. Emacs supports these shades of gray by using +@c background stipple patterns instead of a color. +@c Setting, saving and resetting a face work like the same operations for options (@pxref{Changing an Option}). @@ -474,13 +478,14 @@ appearances for a face, select @samp{Show Display Types} in the menu you get from invoking @samp{[State]}. -@findex modify-face - Another more basic way to set the attributes of a specific face is -with @kbd{M-x modify-face}. This command reads the name of a face, then -reads the attributes one by one. For the color and stipple attributes, -the attribute's current value is the default---type just @key{RET} if -you don't want to change that attribute. Type @samp{none} if you want -to clear out the attribute. +@c It would be cool to implement this +@c @findex modify-face +@c Another more basic way to set the attributes of a specific face is +@c with @kbd{M-x modify-face}. This command reads the name of a face, then +@c reads the attributes one by one. For the color and stipple attributes, +@c the attribute's current value is the default---type just @key{RET} if +@c you don't want to change that attribute. Type @samp{none} if you want +@c to clear out the attribute. @node Specific Customization @subsubsection Customizing Specific Items
--- a/man/xemacs/major.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/xemacs/major.texi Mon Aug 13 10:03:52 2007 +0200 @@ -1,5 +1,5 @@ -@node Major Modes, Indentation, Windows, Top +@node Major Modes, Indentation, Mule, Top @chapter Major Modes @cindex major modes @kindex TAB
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/man/xemacs/mule.texi Mon Aug 13 10:03:52 2007 +0200 @@ -0,0 +1,528 @@ +@c This is part of the Emacs manual. +@c Copyright (C) 1997 Free Software Foundation, Inc. +@c See file emacs.texi for copying conditions. +@node Mule, Major Modes, Windows, Top +@chapter World Scripts Support +@cindex MULE +@cindex international scripts +@cindex multibyte characters +@cindex encoding of characters + +@cindex Chinese +@cindex Devanagari +@cindex Hindi +@cindex Marathi +@cindex Ethiopian +@cindex Greek +@cindex IPA +@cindex Japanese +@cindex Korean +@cindex Lao +@cindex Russian +@cindex Thai +@cindex Tibetan +@cindex Vietnamese + If you compile XEmacs with mule option, it supports a wide variety of +world scripts, including Latin alphabet (for some European languages and +Vietnamese), as well as Arabic, Simplified Chinese (for mainland of +China), Traditional Chinese (for Taiwan and Hong-Kong), Greek, Hebrew, +IPA, Japanese (Hiragana, Katakana and Kanji), Korean (Hangul and Hanja) +and Cyrillic (Beylorussian, Bulgarian, Russian, Serbian and Ukrainian) +scripts. These features have been merged from the modified version of +Emacs known as MULE (for ``MULti-lingual Enhancement to GNU Emacs''). + +@menu +* Mule Intro:: Basic concepts of Mule. +* Language Environments:: Setting things up for the language you use. +* Input Methods:: Entering text characters not on your keyboard. +* Select Input Method:: Specifying your choice of input methods. +* Coding Systems:: Character set conversion when you read and + write files, and so on. +* Recognize Coding:: How XEmacs figures out which conversion to use. +* Specify Coding:: Various ways to choose which conversion to use. +@end menu + +@node Mule Intro, Language Environments, Mule, Mule +@section Introduction to world scripts + + The users of these scripts have established many more-or-less standard +coding systems for storing files. +@c XEmacs internally uses a single multibyte character encoding, so that it +@c can intermix characters from all these scripts in a single buffer or +@c string. This encoding represents each non-ASCII character as a sequence +@c of bytes in the range 0200 through 0377. +XEmacs translates between the internal character encoding and various +other coding systems when reading and writing files, when exchanging +data with subprocesses, and (in some cases) in the @kbd{C-q} command +(see below). + +@kindex C-h h +@findex view-hello-file + The command @kbd{C-h h} (@code{view-hello-file}) displays the file +@file{etc/HELLO}, which shows how to say ``hello'' in many languages. +This illustrates various scripts. + + Keyboards, even in the countries where these character sets are used, +generally don't have keys for all the characters in them. So XEmacs +supports various @dfn{input methods}, typically one for each script or +language, to make it convenient to type them. + +@kindex C-x RET + The prefix key @kbd{C-x @key{RET}} is used for commands that pertain +to world scripts, coding systems, and input methods. + + +@node Language Environments, Input Methods, Mule Intro, Mule +@section Language Environments +@cindex language environments + + All supported character sets are supported in XEmacs buffers if it is +compile with mule; there is no need to select a particular language in +order to display its characters in an XEmacs buffer. However, it is +important to select a @dfn{language environment} in order to set various +defaults. The language environment really represents a choice of +preferred script (more or less) rather that a choice of language. + + The language environment controls which coding systems to recognize +when reading text (@pxref{Recognize Coding}). This applies to files, +incoming mail, netnews, and any other text you read into XEmacs. It may +also specify the default coding system to use when you create a file. +Each language environment also specifies a default input method. + +@findex set-language-environment + The command to select a language environment is @kbd{M-x +set-language-environment}. It makes no difference which buffer is +current when you use this command, because the effects apply globally to +the XEmacs session. The supported language environments include: + +@quotation +Chinese-BIG5, Chinese-CNS, Chinese-GB, Cyrillic-ISO, English, Ethiopic, +Greek, Japanese, Korean, Latin-1, Latin-2, Latin-3, Latin-4, Latin-5. +@end quotation + + Some operating systems let you specify the language you are using by +setting locale environment variables. XEmacs handles one common special +case of this: if your locale name for character types contains the +string @samp{8859-@var{n}}, XEmacs automatically selects the +corresponding language environment. + +@kindex C-h L +@findex describe-language-environment + To display information about the effects of a certain language +environment @var{lang-env}, use the command @kbd{C-h L @var{lang-env} +@key{RET}} (@code{describe-language-environment}). This tells you which +languages this language environment is useful for, and lists the +character sets, coding systems, and input methods that go with it. It +also shows some sample text to illustrate scripts used in this language +environment. By default, this command describes the chosen language +environment. + +@node Input Methods, Select Input Method, Language Environments, Mule +@section Input Methods + +@cindex input methods + An @dfn{input method} is a kind of character conversion designed +specifically for interactive input. In XEmacs, typically each language +has its own input method; sometimes several languages which use the same +characters can share one input method. A few languages support several +input methods. + + The simplest kind of input method works by mapping ASCII letters into +another alphabet. This is how the Greek and Russian input methods work. + + A more powerful technique is composition: converting sequences of +characters into one letter. Many European input methods use composition +to produce a single non-ASCII letter from a sequence that consists of a +letter followed by accent characters. For example, some methods convert +the sequence @kbd{'a} into a single accented letter. + + The input methods for syllabic scripts typically use mapping followed +by composition. The input methods for Thai and Korean work this way. +First, letters are mapped into symbols for particular sounds or tone +marks; then, sequences of these which make up a whole syllable are +mapped into one syllable sign. + + Chinese and Japanese require more complex methods. In Chinese input +methods, first you enter the phonetic spelling of a Chinese word (in +input method @code{chinese-py}, among others), or a sequence of portions +of the character (input methods @code{chinese-4corner} and +@code{chinese-sw}, and others). Since one phonetic spelling typically +corresponds to many different Chinese characters, you must select one of +the alternatives using special XEmacs commands. Keys such as @kbd{C-f}, +@kbd{C-b}, @kbd{C-n}, @kbd{C-p}, and digits have special definitions in +this situation, used for selecting among the alternatives. @key{TAB} +displays a buffer showing all the possibilities. + + In Japanese input methods, first you input a whole word using +phonetic spelling; then, after the word is in the buffer, XEmacs +converts it into one or more characters using a large dictionary. One +phonetic spelling corresponds to many differently written Japanese +words, so you must select one of them; use @kbd{C-n} and @kbd{C-p} to +cycle through the alternatives. + + Sometimes it is useful to cut off input method processing so that the +characters you have just entered will not combine with subsequent +characters. For example, in input method @code{latin-1-postfix}, the +sequence @kbd{e '} combines to form an @samp{e} with an accent. What if +you want to enter them as separate characters? + + One way is to type the accent twice; that is a special feature for +entering the separate letter and accent. For example, @kbd{e ' '} gives +you the two characters @samp{e'}. Another way is to type another letter +after the @kbd{e}---something that won't combine with that---and +immediately delete it. For example, you could type @kbd{e e @key{DEL} +'} to get separate @samp{e} and @samp{'}. + + Another method, more general but not quite as easy to type, is to use +@kbd{C-\ C-\} between two characters to stop them from combining. This +is the command @kbd{C-\} (@code{toggle-input-method}) used twice. +@ifinfo +@xref{Select Input Method}. +@end ifinfo + + @kbd{C-\ C-\} is especially useful inside an incremental search, +because stops waiting for more characters to combine, and starts +searching for what you have already entered. + +@vindex input-method-verbose-flag +@vindex input-method-highlight-flag + The variables @code{input-method-highlight-flag} and +@code{input-method-verbose-flag} control how input methods explain what +is happening. If @code{input-method-highlight-flag} is non-@code{nil}, +the partial sequence is highlighted in the buffer. If +@code{input-method-verbose-flag} is non-@code{nil}, the list of possible +characters to type next is displayed in the echo area (but not when you +are in the minibuffer). + +@node Select Input Method, Coding Systems, Input Methods, Mule +@section Selecting an Input Method + +@table @kbd +@item C-\ +Enable or disable use of the selected input method. + +@item C-x @key{RET} C-\ @var{method} @key{RET} +Select a new input method for the current buffer. + +@item C-h I @var{method} @key{RET} +@itemx C-h C-\ @var{method} @key{RET} +@findex describe-input-method +@kindex C-h I +@kindex C-h C-\ +Describe the input method @var{method} (@code{describe-input-method}). +By default, it describes the current input method (if any). + +@item M-x list-input-methods +Display a list of all the supported input methods. +@end table + +@findex select-input-method +@vindex current-input-method +@kindex C-x RET C-\ + To choose an input method for the current buffer, use @kbd{C-x +@key{RET} C-\} (@code{select-input-method}). This command reads the +input method name with the minibuffer; the name normally starts with the +language environment that it is meant to be used with. The variable +@code{current-input-method} records which input method is selected. + +@findex toggle-input-method +@kindex C-\ + Input methods use various sequences of ASCII characters to stand for +non-ASCII characters. Sometimes it is useful to turn off the input +method temporarily. To do this, type @kbd{C-\} +(@code{toggle-input-method}). To reenable the input method, type +@kbd{C-\} again. + + If you type @kbd{C-\} and you have not yet selected an input method, +it prompts for you to specify one. This has the same effect as using +@kbd{C-x @key{RET} C-\} to specify an input method. + +@vindex default-input-method + Selecting a language environment specifies a default input method for +use in various buffers. When you have a default input method, you can +select it in the current buffer by typing @kbd{C-\}. The variable +@code{default-input-method} specifies the default input method +(@code{nil} means there is none). + +@findex quail-set-keyboard-layout + Some input methods for alphabetic scripts work by (in effect) +remapping the keyboard to emulate various keyboard layouts commonly used +for those scripts. How to do this remapping properly depends on your +actual keyboard layout. To specify which layout your keyboard has, use +the command @kbd{M-x quail-set-keyboard-layout}. + +@findex list-input-methods + To display a list of all the supported input methods, type @kbd{M-x +list-input-methods}. The list gives information about each input +method, including the string that stands for it in the mode line. + +@node Coding Systems, Recognize Coding, Select Input Method, Mule +@section Coding Systems +@cindex coding systems + + Users of various languages have established many more-or-less standard +coding systems for representing them. XEmacs does not use these coding +systems internally; instead, it converts from various coding systems to +its own system when reading data, and converts the internal coding +system to other coding systems when writing data. Conversion is +possible in reading or writing files, in sending or receiving from the +terminal, and in exchanging data with subprocesses. + + XEmacs assigns a name to each coding system. Most coding systems are +used for one language, and the name of the coding system starts with the +language name. Some coding systems are used for several languages; +their names usually start with @samp{iso}. There are also special +coding systems @code{binary} and @code{no-conversion} which do not +convert printing characters at all. + + In addition to converting various representations of non-ASCII +characters, a coding system can perform end-of-line conversion. XEmacs +handles three different conventions for how to separate lines in a file: +newline, carriage-return linefeed, and just carriage-return. + +@table @kbd +@item C-h C @var{coding} @key{RET} +Describe coding system @var{coding}. + +@item C-h C @key{RET} +Describe the coding systems currently in use. + +@item M-x list-coding-systems +Display a list of all the supported coding systems. +@end table + +@kindex C-h C +@findex describe-coding-system + The command @kbd{C-h C} (@code{describe-coding-system}) displays +information about particular coding systems. You can specify a coding +system name as argument; alternatively, with an empty argument, it +describes the coding systems currently selected for various purposes, +both in the current buffer and as the defaults, and the priority list +for recognizing coding systems (@pxref{Recognize Coding}). + +@findex list-coding-systems + To display a list of all the supported coding systems, type @kbd{M-x +list-coding-systems}. The list gives information about each coding +system, including the letter that stands for it in the mode line +(@pxref{Mode Line}). + + Each of the coding systems that appear in this list---except for +@code{binary}, which means no conversion of any kind---specifies how and +whether to convert printing characters, but leaves the choice of +end-of-line conversion to be decided based on the contents of each file. +For example, if the file appears to use carriage-return linefeed between +lines, that end-of-line conversion will be used. + + Each of the listed coding systems has three variants which specify +exactly what to do for end-of-line conversion: + +@table @code +@item @dots{}-unix +Don't do any end-of-line conversion; assume the file uses +newline to separate lines. (This is the convention normally used +on Unix and GNU systems.) + +@item @dots{}-dos +Assume the file uses carriage-return linefeed to separate lines, +and do the appropriate conversion. (This is the convention normally used +on Microsoft systems.) + +@item @dots{}-mac +Assume the file uses carriage-return to separate lines, and do the +appropriate conversion. (This is the convention normally used on the +Macintosh system.) +@end table + + These variant coding systems are omitted from the +@code{list-coding-systems} display for brevity, since they are entirely +predictable. For example, the coding system @code{iso-8859-1} has +variants @code{iso-8859-1-unix}, @code{iso-8859-1-dos} and +@code{iso-8859-1-mac}. + + In contrast, the coding system @code{binary} specifies no character +code conversion at all---none for non-Latin-1 byte values and none for +end of line. This is useful for reading or writing binary files, tar +files, and other files that must be examined verbatim. + + The easiest way to edit a file with no conversion of any kind is with +the @kbd{M-x find-file-literally} command. This uses @code{binary}, and +also suppresses other XEmacs features that might convert the file +contents before you see them. @xref{Visiting}. + + The coding system @code{no-conversion} means that the file contains +non-Latin-1 characters stored with the internal XEmacs encoding. It +handles end-of-line conversion based on the data encountered, and has +the usual three variants to specify the kind of end-of-line conversion. + + +@node Recognize Coding, Specify Coding, Coding Systems, Mule +@section Recognizing Coding Systems + + Most of the time, XEmacs can recognize which coding system to use for +any given file--once you have specified your preferences. + + Some coding systems can be recognized or distinguished by which byte +sequences appear in the data. However, there are coding systems that +cannot be distinguished, not even potentially. For example, there is no +way to distinguish between Latin-1 and Latin-2; they use the same byte +values with different meanings. + + XEmacs handles this situation by means of a priority list of coding +systems. Whenever XEmacs reads a file, if you do not specify the coding +system to use, XEmacs checks the data against each coding system, +starting with the first in priority and working down the list, until it +finds a coding system that fits the data. Then it converts the file +contents assuming that they are represented in this coding system. + + The priority list of coding systems depends on the selected language +environment (@pxref{Language Environments}). For example, if you use +French, you probably want XEmacs to prefer Latin-1 to Latin-2; if you +use Czech, you probably want Latin-2 to be preferred. This is one of +the reasons to specify a language environment. + +@findex prefer-coding-system + However, you can alter the priority list in detail with the command +@kbd{M-x prefer-coding-system}. This command reads the name of a coding +system from the minibuffer, and adds it to the front of the priority +list, so that it is preferred to all others. If you use this command +several times, each use adds one element to the front of the priority +list. + +@vindex file-coding-system-alist + Sometimes a file name indicates which coding system to use for the +file. The variable @code{file-coding-system-alist} specifies this +correspondence. There is a special function +@code{modify-coding-system-alist} for adding elements to this list. For +example, to read and write all @samp{.txt} using the coding system +@code{china-iso-8bit}, you can execute this Lisp expression: + +@smallexample +(modify-coding-system-alist 'file "\\.txt\\'" 'china-iso-8bit) +@end smallexample + +@noindent +The first argument should be @code{file}, the second argument should be +a regular expression that determines which files this applies to, and +the third argument says which coding system to use for these files. + +@vindex coding + You can specify the coding system for a particular file using the +@samp{-*-@dots{}-*-} construct at the beginning of a file, or a local +variables list at the end (@pxref{File Variables}). You do this by +defining a value for the ``variable'' named @code{coding}. XEmacs does +not really have a variable @code{coding}; instead of setting a variable, +it uses the specified coding system for the file. For example, +@samp{-*-mode: C; coding: iso-8859-1;-*-} specifies use of the +iso-8859-1 coding system, as well as C mode. + +@vindex buffer-file-coding-system + Once XEmacs has chosen a coding system for a buffer, it stores that +coding system in @code{buffer-file-coding-system} and uses that coding +system, by default, for operations that write from this buffer into a +file. This includes the commands @code{save-buffer} and +@code{write-region}. If you want to write files from this buffer using +a different coding system, you can specify a different coding system for +the buffer using @code{set-buffer-file-coding-system} (@pxref{Specify +Coding}). + + +@node Specify Coding, , Recognize Coding, Mule +@section Specifying a Coding System + + In cases where XEmacs does not automatically choose the right coding +system, you can use these commands to specify one: + +@table @kbd +@item C-x @key{RET} f @var{coding} @key{RET} +Use coding system @var{coding} for the visited file +in the current buffer. + +@item C-x @key{RET} k @var{coding} @key{RET} +Use coding system @var{coding} for keyboard input. + +@item C-x @key{RET} t @var{coding} @key{RET} +Use coding system @var{coding} for terminal output. + +@item C-x @key{RET} p @var{coding} @key{RET} +Use coding system @var{coding} for subprocess input and output +in the current buffer. +@end table + +@kindex C-x RET f +@findex set-buffer-file-coding-system + The command @kbd{C-x RET f} (@code{set-buffer-file-coding-system}) +specifies the file coding system for the current buffer---in other +words, which coding system to use when saving or rereading the visited +file. You specify which coding system using the minibuffer. Since this +command applies to a file you have already visited, it affects only the +way the file is saved. + + Another way to specify the coding system for a file is when you visit +the file. If you run some file input commands with the precedent +@kbd{C-u}, you can specify coding system to read from minibuffer. + + So if the immediately following command is @kbd{C-x C-f}, for example, +it reads the file using that coding system (and records the coding +system for when the file is saved). Other file commands affected by a +specified coding system include @kbd{C-x C-i} and @kbd{C-x C-v}, as well +as the other-window variants of @kbd{C-x C-f}. + +@vindex default-buffer-file-coding-system + The variable @code{default-buffer-file-coding-system} specifies the +choice of coding system to use when you create a new file. It applies +when you find a new file, and when you create a buffer and then save it +in a file. Selecting a language environment typically sets this +variable to a good choice of default coding system for that language +environment. + +@kindex C-x RET t +@findex set-terminal-coding-system + The command @kbd{C-x @key{RET} t} (@code{set-terminal-coding-system}) +specifies the coding system for terminal output. If you specify a +character code for terminal output, all characters output to the +terminal are translated into that coding system. + + This feature is useful for certain character-only terminals built to +support specific languages or character sets---for example, European +terminals that support one of the ISO Latin character sets. + + By default, output to the terminal is not translated at all. + +@kindex C-x RET k +@findex set-keyboard-coding-system + The command @kbd{C-x @key{RET} k} (@code{set-keyboard-coding-system}) +specifies the coding system for keyboard input. Character-code +translation of keyboard input is useful for terminals with keys that +send non-ASCII graphic characters---for example, some terminals designed +for ISO Latin-1 or subsets of it. + + By default, keyboard input is not translated at all. + + There is a similarity between using a coding system translation for +keyboard input, and using an input method: both define sequences of +keyboard input that translate into single characters. However, input +methods are designed to be convenient for interactive use by humans, and +the sequences that are translated are typically sequences of ASCII +printing characters. Coding systems typically translate sequences of +non-graphic characters. + +@kindex C-x RET p +@findex set-buffer-process-coding-system + The command @kbd{C-x @key{RET} p} (@code{set-buffer-process-coding-system}) +specifies the coding system for input and output to a subprocess. This +command applies to the current buffer; normally, each subprocess has its +own buffer, and thus you can use this command to specify translation to +and from a particular subprocess by giving the command in the +corresponding buffer. + + By default, process input and output are not translated at all. + +@vindex file-name-coding-system + The variable @code{file-name-coding-system} specifies a coding system +to use for encoding file names. If you set the variable to a coding +system name (as a Lisp symbol or a string), XEmacs encodes file names +using that coding system for all file operations. This makes it +possible to use non-Latin-1 characters in file names---or, at least, +those non-Latin-1 characters which the specified coding system can +encode. By default, this variable is @code{nil}, which implies that you +cannot use non-Latin-1 characters in file names.
--- a/man/xemacs/windows.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/xemacs/windows.texi Mon Aug 13 10:03:52 2007 +0200 @@ -1,5 +1,5 @@ -@node Windows, Major Modes, Buffers, Top +@node Windows, Mule, Buffers, Top @chapter Multiple Windows @cindex windows
--- a/man/xemacs/xemacs.texi Mon Aug 13 10:02:48 2007 +0200 +++ b/man/xemacs/xemacs.texi Mon Aug 13 10:03:52 2007 +0200 @@ -155,6 +155,7 @@ * Files:: All about handling files. * Buffers:: Multiple buffers; editing several files at once. * Windows:: Viewing two pieces of text at once. +* Mule:: Using world scripts. Advanced Features * Major Modes:: Text mode vs. Lisp mode vs. C mode ... @@ -1060,6 +1061,7 @@ @include files.texi @include buffers.texi @include windows.texi +@include mule.texi @include major.texi @include indent.texi @include text.texi
--- a/src/ChangeLog Mon Aug 13 10:02:48 2007 +0200 +++ b/src/ChangeLog Mon Aug 13 10:03:52 2007 +0200 @@ -1,11 +1,388 @@ +1997-10-30 SL Baur <steve@altair.xemacs.org> + + * config.h.in: Remove HAVE_GIF, HAVE_JPEG, HAVE_PNG, HAVE_TIFF and + replace with HAVE_IMAGEMAGICK. + +1997-10-30 Kyle Jones <kyle_jones@wonderworks.com> + + * process.c (Fprocess_send_string): Protect against + SIGPIPE when flushing outstream. + +1997-10-30 SL Baur <steve@altair.xemacs.org> + + * input-method-xfs.c: Xlocale.h must be included after config.h. + * input-method-motif.c: ditto. + * input-method-xlib.c: ditto. + +1997-10-28 Kyle Jones <kyle_jones@wonderworks.com> + + * Under LRECORD_VECTOR, moved vectors from being an basic + lrecord tpye to an lcrecord. + Added support for 31 bits Lisp integers. + Added support for maskless pointers to Lisp objects. + + * alloc.c + + (allocate_lisp_storage): Use XSETOBJ instead of + XSETCONS to avoid tripping the ERROR_CHECK_TYPECHECK + code with uninitialized data. XSETCONS used to work + until it became an lrecord type. + + Removed sweep_vectors_1, all_vectors and other vector + specific GC related objects in the LRECORD_VECTOR + case, as they are unneeded now that lrecord-based + vectors are lcrecords. + + Added `equal' methods for lrecord-based conses, vectors + and strings. I was mistaken before; they are needed. + + (pure_cons): moved XSETCONS call to after the + set_lheader_implementation call, to avoid tripping the + type checking code on an uninitialized implementation + pointer. + + (make_pure_vector): moved XSETVECTOR call to after the + set_lheader_implementation call, to avoid tripping the + type checking code on an uninitialized implementation + pointer. + + (Fpurecopy): return if given a null pointer. THis can + happen when initializing Qnil. + + (mark_object): return if passed a null pointer. I + think this can happen when marking through some kind of + objects that contain Lisp_Objects and null pointers. + + (marked_p): Ditto + + * buffer.c + + (mark_buffer): Don't mark conses in the indirect children + list is said list is in fact a null pointer. The + indirect children list gets reset to a null pointer + when a bfufer is killed. + + (complex_vars_of_buffer): initialize indirect_children + slow of Vbuffer_local_symbols and Vbuffer_defaults to + nil. + + * chartab.c + + (Fcheck_category_at): Don't use XREALINT to extract a + char from a Lisp_Object, use XCHAR instead. + + (Fchar_in_category): Ditto. + + * data.c + + (eq_with_ebola_notice): Use XCHAR_OR_INT instead of + XREALINT to extract data from a Lisp_Object that could + contain a charater or an integer. + + (make_int): use XSETINT in the USE_MINIMAL_TAGBITS + case. + + (make_char): use XSETINT in the USE_MINIMAL_TAGBITS + case. + + (Flsh): XUINT is gone; use XINT instead. + + * elhash.c + + (elisp_hvector_malloc): Use Qnull_pointer instead of + Qzero, as Qzero is no longer guaranteed to contain an + all-zero bit pattern. + + (make_lisp_hashtable): Ditto. + + (Fcopy_hashtable): Ditto. + + * emacsfns.h + + Conditionalize the declaration of make_char() on + whether a make_char macro exists or not. + + * fns.c + + (internal_equal): Conditionalize existence of cons, + string and vector comparison code on whether they are + lrecord-based. + + (internal_old_equal): Ditto. + + * lisp-disunion.h + + USE_MINIMAL_TAGBITS support. + + 31 bit Lisp integer support. + + Conditionalized existence of markbit related macros on + the existence of a markbit in a Lisp_Object. There are + no markbits in the USE_MINIMAL_TAGBITS implementation + of a Lisp_Object. + + Replaced XUINT with XPNTRVAL. + + Added declaration for Qnull_pointer. + + * lisp-union.h + + USE_MINIMAL_TAGBITS support. + + 31 bit Lisp integer support. + + Conditionalized existence of markbit related macros on + the existence of a markbit in a Lisp_Object. There are + no markbits in the USE_MINIMAL_TAGBITS implementation + of a Lisp_Object. + + Replaced XUINT with XPNTRVAL. + + Added a make_char macro, similar to the make_int + macro, for use with the GCC-specific XMAKE_LISP hack. + + * lisp.h + + USE_MINIMAL_TAGBITS support. + + 31 bit Lisp integer support. + + Added GCMARKBITS macro to specify how many markbits a + Lisp_Object contains. + + Support for lcrecord-based vectors. + + Added XCHAR_OR_INT for accessing data in an object + that might contain either a character or an integer. + + Made HACKEQ_UNSAFE use XCHAR_OR_INT instead of + XREALINT during its Ebola check. + + * print.c + + Made the printing code undestand the split Lisp integer type. + + * symbols.c + + Added declaration for Qnull_pointer. + +1997-10-27 Martin Buchholz <mrb@eng.sun.com> + + * src/m/ibmrs6000.h: + * src/s/aix3-2.h: C_SWITCH_SYSTEM ==> configure.in + * src/s/aix4-1.h: -li18n ==> configure.in + * src/s/aix4.h: Always include strings.h + * src/config.h.in: Add AIXV3 define, suggested by xmkmf. Remove + AIX_SMT_EXP. + * src/unexaix.c: Fix nested comments compiler warning + +1997-10-27 Kyle Jones <kyle_jones@wonderworks.com> + + * src/profile.c (sigprof_handler): Don't call XUNMARK on + fun, it isn't needed. + + * src/faces.c (face_property_matching_instance): Check + for charset == Qunbound, which it can be if the + character set is unspecified. + +1997-10-27 SL Baur <steve@altair.xemacs.org> + + * mule-wnnfns.c (vars_of_mule_wnn): Provide 'wnn feature. + + * mule-canna.c (vars_of_mule_canna): Provide 'CANNA feature. + +1997-10-27 Kazuyuki IENAGA <ienaga@jsys.co.jp> + + * device-x.c (x_init_device): To avoid crazy menubars due to + lack of suitable font loading. Disabled locale based app-defaults + loading when menubars=motif or menubars=lucid + xfs feature is not + used. Currently, the menubar resource has no effect for tty use. + +1997-10-25 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * README: Remove references to VMS. + + * vlimit.h: + * s/vms5-5.h: + * s/vms4-4.h: + * s/vms4-2.h: + * s/vms4-0.h: + * s/vms.h: Remove files since VMS isn't supported any more. + +1997-10-25 Kyle Jones <kyle_jones@wonderworks.com> + + * toolbar.h: Reduce MINIMUM_SHADOW_THICKNESS to 1. + +1997-10-24 Andreas Jaeger <aj@arthur.rhein-neckar.de> + + * database.c: Added support for Berkeley DB 2.x. + +1997-10-23 SL Baur <steve@altair.xemacs.org> + + * alloc.c: Disable purespace statistics unless --debug is in + effect. + + * console-stream.c (init_console_stream): At the price of a tiny + memory leak, reinitialize FILE fields of the console. + From Tonny Madsen <tma@nettest.dk> + + * emacs.c: New variable `inhibit_package_init'. + (vars_of_emacs): Use it. + (main_1): Initialize from command line. + + * Makefile.in.in (xemacs): Specify -vanilla when searching for + shadows. + + * emacs.c: Remove VMS ifdefs. + (standard_args): Added -no-packages, --no-packages. + Added -vanilla, --vanilla. + (Frun_emacs_from_temacs): Guard pure usage report with DEBUG_XEMACS + (Fdump_emacs): Ditto. + +1997-10-22 Hrvoje Niksic <hniksic@srce.hr> + + * fns.c (Ffeaturep): Use `Fcar' with `or'. + +1997-10-22 Kyle Jones <kyle_jones@wonderworks.com> + + * alloc.c: drop the Lisp_Type_Record case clause + that I added to the switch statement in a previous + patch. The string, vector and cons cases belong in + the `default' clause with the other lrecord types. + +1997-10-22 Kyle Jones <kyle_jones@wonderworks.com> + + * Added support for strings as lrecords. + + * lisp.h: #ifdef'd out Lisp_Type_String enum value + if LRECORD_STRING is defined. + + * alloc.c: Added allocation and garbage collection + code for lrecord-based strings. + + * print.c: move Lisp_String printing code to a + separate function so that it could be used as a + `print' method for lrecord-based strings. + +1997-10-20 Jan Vroonhof <vroonhof@math.ethz.ch> + + * extents.c: Renamed shot property to initial-redisplay-function + (extent_fragment_update): Changed the bookkeeping whether an event + has been spawned. The initial-redisplay-function property is no + longer set to nil. + + * extents.h: ditto + +1997-10-20 Kyle Jones <kyle_jones@wonderworks.com> + + * Added support for conses and vectors to be lrecords. + + * alloc.c: Modified allocation and GC code for + LRECORD_CONS and LRECORD_VECTOR support. Moved some + macros to lrecord.h. + + * bytecode.c: Warning comment about LRECORD_CONS. + + * elhash.c: Let internal_hash handle vector hashing + if LRECORD_VECTOR is defined, just as it does when + LRECORD_VECTOR is not defined. The code could have + been copied into an `hash' method function but I don't + see any point to it. Added lrecord style marking code + to finish_marking_weak_hashtables. Bracketed code + that groks the non-lrecord method of marking vectors + with #ifdefs. + + * fns.c: Let internal_equal and internal_old_equal + handle vector comparisons when LRECORD_VECTOR is + defined, just as it does when LRECORD_VECTOR is not + defined. The code could have been copied into an + `equal' method function but I don't see any point to + it. + + * lisp.h: Added typecheck macros for LRECORD_CONS + support. LRECORD_VECTOR macros were already present. + + * print.c: New functions print_cons and print_vector + for LRECORD_CONS and LRECORD_VECTOR support. + Some GC protection also added. + + * lrecord.h: Received some macros from alloc.c, so + that they could be used in lisp.h. + +1997-10-20 Hrvoje Niksic <hniksic@srce.hr> + + * fns.c (Ffeaturep): Handle `not' correctly. + + * lread.c (vars_of_lread): Use defsymbol for featurep. + +1997-10-15 Olivier Galibert <olivier.galibert@mines.u-nancy.fr> + + * s/irix5-0.h: Removed -G 0 from LD_SWITCH_SYSTEM. .sbss sections + are supported since unexelfsgi.c upgrade. + +1997-10-16 Kyle Jones <kyle_jones@wonderworks.com> + + * lstream.c (Lstream_close): Don't return early if the + closer method reports failure. Doing so caused GC and + memory corruption crashes. + +1997-10-14 Hrvoje Niksic <hniksic@srce.hr> + + * extents.c (Fset_extent_property): Allow `keymap' property to be + set to nil. + +1997-10-15 SL Baur <steve@altair.xemacs.org> + + * mule-coding.c (acceptable_control_char_p): Add C-_ for info. + (detect_coding_iso2022): Ditto. + From SENDA Shigeya <senda@ic.rdc.ricoh.co.jp> + +1997-10-09 MORIOKA Tomohiko <morioka@jaist.ac.jp> + + * mule-coding.c (make-coding-system, detect-coding-region): Modify + DOC-string because of renaming `automatic-conversion' -> + `undecided' to sync with Emacs 20.2. + + (make-coding-system, coding-system-type, detect-coding-region): + Rename `Qautomatic_conversion' -> `Qundecided'. + + * general.c (syms_of_general): Rename `automatic-conversion' -> + `undecided' to sync with Emacs 20.2. + + * emacsfns.h, event-Xt.c (x_to_emacs_keysym): Rename + `Qautomatic_conversion' -> `Qundecided'. + + * buffer.c (buffer-file-coding-system): Modify DOC-string because + of renaming `automatic-conversion' -> `undecided' to sync with + Emacs 20.2. + +1997-10-15 Olivier Galibert <olivier.galibert@mines.u-nancy.fr> + + * lisp.h (MANY): Bump SUBR_MAX_ARGS to 12 and add corresponding + DEFUN_n macros. + +1997-10-13 Stephen J. Turnbull <turnbull@sk.tsukuba.ac.jp> + + * console-tty.c: Include gpmevent.h + * gpmevent.c (connect_to_gpm): change to void + * gpmevent.h: Ditto. + +1997-10-13 Kyle Jones <kyle_jones@wonderworks.com> + + * lisp-disunion.h (XSETOBJ): cast Lisp type enum to + an EMACS_UINT quantity to avoid a compiler warning about + integer overflow when the most significat bit of the + type tag is shifted into the sign bit position of an + EMACS_INT. + 1997-10-12 SL Baur <steve@altair.xemacs.org> - * src/s/freebsd.h: Add X11 guard for building without X11. + * s/freebsd.h: Add X11 guard for building without X11. From Hrvoje Niksic <hniksic@srce.hr> 1997-10-12 Kyle Jones <kyle_jones@wonderworks.com> - * src/doprnt.c (emacs_doprnt_1): if forwarded field width + * doprnt.c (emacs_doprnt_1): if forwarded field width is negative, set minus_flag and make the field width positive. Makes (format "%*s" -10 "abc") work like (format "%-*s" 10 "abc"). @@ -14,7 +391,7 @@ * unexsol2.c (unexec): CONST isn't defined here. From Adrian Aichner <aichner@ecf.teradyne.com> - + 1997-10-11 SL Baur <steve@altair.xemacs.org> * realpath.c (realpath): CONST IS LOSING but removing it conflicts
--- a/src/Makefile.in.in Mon Aug 13 10:02:48 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 10:03:52 2007 +0200 @@ -300,7 +300,7 @@ @$(RM) $@ && touch SATISFIED -$(DUMPENV) ./temacs -batch -l loadup.el dump @if test -f $@; then if test -f SATISFIED; then \ - ./xemacs -q -batch -f list-load-path-shadows; fi; \ + ./xemacs -batch -vanilla -f list-load-path-shadows; fi; \ $(RM) SATISFIED; exit 0; fi; \ if test -f SATISFIED; then $(RM) SATISFIED; exit 1; fi; \ $(RECURSIVE_MAKE) $@;
--- a/src/README Mon Aug 13 10:02:48 2007 +0200 +++ b/src/README Mon Aug 13 10:03:52 2007 +0200 @@ -1,7 +1,6 @@ This directory contains the source files for the C component of XEmacs. Nothing in this directory is needed for using XEmacs once it is built -and installed, if the dumped Emacs (on Unix systems) or the XEmacs -executable and map files (on VMS systems) are copied elsewhere. +and installed, if the dumped Emacs is copied elsewhere. See the files ../README and then ../INSTALL for installation instructions. @@ -12,23 +11,6 @@ Emacs. Most of this should work transparently to the user; you should only need to run `../configure', and then type `make'. -See the file VMSBUILD in this directory for instructions on compiling, -linking and building Emacs on VMS. - -The files `*.com' and `temacs.opt' are used on VMS only. -The files `vlimit.h', `ioclt.h' and `param.h' are stubs to -allow compilation on VMS with the minimum amount of #ifdefs. - -`uaf.h' contains VMS uaf structure definitions. This is only needed if -you define READ_SYSUAF. This should only be done for single-user -systems where you are not overly concerned with security, since it -either requires that you install Emacs with SYSPRV or make SYSUAF.DAT -world readable. Otherwise, Emacs can determine information about the -current user, but no one else. - -`pwd.h' contains definitions for VMS to be able to correctly simulate -`getpwdnam' and `getpwduid'. - General changes for XEmacs: --------------------------- 1. Lisp objects.
--- a/src/alloc.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/alloc.c Mon Aug 13 10:03:52 2007 +0200 @@ -62,7 +62,10 @@ /* #define VERIFY_STRING_CHARS_INTEGRITY */ /* Define this to see where all that space is going... */ +/* But the length of the printout is obnoxious, so limit it to testers */ +#ifdef DEBUG_XEMACS #define PURESTAT +#endif /* Define this to use malloc/free with no freelist for all datatypes, the hope being that some debugging tools may help detect @@ -486,8 +489,8 @@ char *lim = ((char *) p) + size; Lisp_Object val = Qnil; - XSETCONS (val, lim); - if ((char *) XCONS (val) != lim) + XSETOBJ (val, Lisp_Type_Record, lim); + if ((char *) XPNTR (val) != lim) { xfree (p); memory_full (); @@ -496,16 +499,6 @@ } -#define MARKED_RECORD_HEADER_P(lheader) \ - (((lheader)->implementation->finalizer) == this_marks_a_marked_record) -#define UNMARKABLE_RECORD_HEADER_P(lheader) \ - (((lheader)->implementation->marker) == this_one_is_unmarkable) -#define MARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)++); } while (0) -#define UNMARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)--); } while (0) - - /* lrecords are chained together through their "next.v" field. * After doing the mark phase, the GC will walk this linked * list and free any record which hasn't been marked @@ -991,6 +984,44 @@ /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 +#ifdef LRECORD_CONS +static Lisp_Object mark_cons (Lisp_Object, void (*) (Lisp_Object)); +static int cons_equal(Lisp_Object, Lisp_Object, int); +extern void print_cons (Lisp_Object, Lisp_Object, int); +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, + mark_cons, print_cons, 0, + cons_equal, + /* + * No `hash' method needed. + * internal_hash knows how to + * handle conses. + */ + 0, + struct Lisp_Cons); +static Lisp_Object +mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + if (NILP (XCDR (obj))) + return XCAR (obj); + else + (markobj) (XCAR (obj)); + return XCDR (obj); +} + +static int +cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) +{ + while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1)) + { + ob1 = XCDR(ob1); + ob2 = XCDR(ob2); + if (! CONSP (ob1) || ! CONSP (ob2)) + return internal_equal (ob1, ob2, depth + 1); + } + return 0; +} +#endif /* LRECORD_CONS */ + DEFUN ("cons", Fcons, 2, 2, 0, /* Create a new cons, give it CAR and CDR as components, and return it. */ @@ -1001,9 +1032,12 @@ struct Lisp_Cons *c; ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c); +#ifdef LRECORD_CONS + set_lheader_implementation (&(c->lheader), lrecord_cons); +#endif XSETCONS (val, c); - XCAR (val) = car; - XCDR (val) = cdr; + c->car = car; + c->cdr = cdr; return val; } @@ -1017,6 +1051,9 @@ struct Lisp_Cons *c; NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c); +#ifdef LRECORD_CONS + set_lheader_implementation (&(c->lheader), lrecord_cons); +#endif XSETCONS (val, c); XCAR (val) = car; XCDR (val) = cdr; @@ -1136,6 +1173,77 @@ /* Vector allocation */ /**********************************************************************/ +#ifdef LRECORD_VECTOR +static Lisp_Object mark_vector (Lisp_Object, void (*) (Lisp_Object)); +static unsigned int size_vector (CONST void *); +static int vector_equal(Lisp_Object, Lisp_Object, int); +extern void print_vector (Lisp_Object, Lisp_Object, int); +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector, + mark_vector, print_vector, 0, + vector_equal, + /* + * No `hash' method needed for + * vectors. internal_hash + * knows how to handle vectors. + */ + 0, + size_vector, struct Lisp_Vector); +static Lisp_Object +mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + struct Lisp_Vector *ptr = XVECTOR (obj); + int len = vector_length (ptr); + int i; + + for (i = 0; i < len - 1; i++) + (markobj) (ptr->contents[i]); + return (len > 0) ? ptr->contents[len - 1] : Qnil; +} + +static unsigned int +size_vector (CONST void *lheader) +{ + struct Lisp_Vector *p = lheader; + /* + * -1 because struct Lisp_Vector includes 1 slot + */ + return sizeof (struct Lisp_Vector) + + ((p->size - 1) * sizeof (Lisp_Object)) ; +} + +static int +vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) +{ + int indice; + int len = XVECTOR_LENGTH (o1); + if (len != XVECTOR_LENGTH (o2)) + return 0; + for (indice = 0; indice < len; indice++) + { + if (!internal_equal (XVECTOR_DATA (o1) [indice], + XVECTOR_DATA (o2) [indice], + depth + 1)) + return 0; + } + return 1; +} + +/* #### should allocate `small' vectors from a frob-block */ +static struct Lisp_Vector * +make_vector_internal (EMACS_INT sizei) +{ + EMACS_INT sizem = (sizeof (struct Lisp_Vector) + /* -1 because struct Lisp_Vector includes 1 slot */ + + (sizei - 1) * sizeof (Lisp_Object) + ); + struct Lisp_Vector *p = alloc_lcrecord (sizem, lrecord_vector); + + p->size = sizei; + return p; +} + +#else /* ! LRECORD_VECTOR */ + static Lisp_Object all_vectors; /* #### should allocate `small' vectors from a frob-block */ @@ -1148,9 +1256,6 @@ + (sizei - 1 + 1) * sizeof (Lisp_Object) ); struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem); -#ifdef LRECORD_VECTOR - set_lheader_implementation (&(p->lheader), lrecord_vector); -#endif INCREMENT_CONS_COUNTER (sizem, "vector"); @@ -1160,6 +1265,8 @@ return p; } +#endif + Lisp_Object make_vector (EMACS_INT length, Lisp_Object init) { @@ -1794,6 +1901,46 @@ /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 +#ifdef LRECORD_STRING +static Lisp_Object mark_string (Lisp_Object, void (*) (Lisp_Object)); +static int string_equal (Lisp_Object, Lisp_Object, int); +extern void print_string (Lisp_Object, Lisp_Object, int); +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, + mark_string, print_string, + /* + * No `finalize', or `hash' methods. + * internal_hash already knows how + * to hash strings and finalization + * is done with the + * ADDITIONAL_FREE_string macro, + * which is the standard way to do + * finalization when using + * SWEEP_FIXED_TYPE_BLOCK(). + */ + 0, string_equal, 0, + struct Lisp_String); +static Lisp_Object +mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + struct Lisp_String *ptr = XSTRING (obj); + + if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist))) + flush_cached_extent_info (XCAR (ptr->plist)); + return ptr->plist; +} + +static int +string_equal (Lisp_Object o1, Lisp_Object o2, int depth) +{ + Bytecount len = XSTRING_LENGTH (o1); + if (len != XSTRING_LENGTH (o2)) + return 0; + if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)) + return 0; + return 1; +} +#endif /* LRECORD_STRING */ + /* String blocks contain this many useful bytes. */ #define STRING_CHARS_BLOCK_SIZE \ (8192 - MALLOC_OVERHEAD - ((2 * sizeof (struct string_chars_block *)) \ @@ -1905,6 +2052,9 @@ /* Allocate the string header */ ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s); +#ifdef LRECORD_STRING + set_lheader_implementation (&(s->lheader), lrecord_string); +#endif s_chars = allocate_string_chars_struct (s, fullsize); @@ -2357,6 +2507,9 @@ return make_string (data, length); s = (struct Lisp_String *) (PUREBEG + pureptr); +#ifdef LRECORD_STRING + set_lheader_implementation (&(s->lheader), lrecord_string); +#endif set_string_length (s, length); if (no_need_to_copy_data) { @@ -2404,16 +2557,21 @@ pure_cons (Lisp_Object car, Lisp_Object cdr) { Lisp_Object new; + struct Lisp_Cons *c; if (!check_purespace (sizeof (struct Lisp_Cons))) return Fcons (Fpurecopy (car), Fpurecopy (cdr)); - XSETCONS (new, PUREBEG + pureptr); + c = (struct Lisp_Cons *) (PUREBEG + pureptr); +#ifdef LRECORD_CONS + set_lheader_implementation (&(c->lheader), lrecord_cons); +#endif pureptr += sizeof (struct Lisp_Cons); bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons)); - XCAR (new) = Fpurecopy (car); - XCDR (new) = Fpurecopy (cdr); + c->car = Fpurecopy (car); + c->cdr = Fpurecopy (cdr); + XSETCONS (new, c); return new; } @@ -2482,6 +2640,7 @@ make_pure_vector (EMACS_INT len, Lisp_Object init) { Lisp_Object new; + struct Lisp_Vector *v; EMACS_INT size = (sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object)); @@ -2490,15 +2649,19 @@ if (!check_purespace (size)) return make_vector (len, init); - XSETVECTOR (new, PUREBEG + pureptr); + v = (struct Lisp_Vector *) (PUREBEG + pureptr); +#ifdef LRECORD_VECTOR + set_lheader_implementation (&(v->header.lheader), lrecord_vector); +#endif pureptr += size; bump_purestat (&purestat_vector_all, size); - XVECTOR_LENGTH (new) = len; + v->size = len; for (size = 0; size < len; size++) - XVECTOR_DATA (new)[size] = init; - + v->contents[size] = init; + + XSETVECTOR (new, v); return new; } @@ -2532,19 +2695,25 @@ return obj; if (!POINTER_TYPE_P (XTYPE (obj)) - || PURIFIED (XPNTR (obj))) + || PURIFIED (XPNTR (obj)) + /* happens when bootstrapping Qnil */ + || EQ (obj, Qnull_pointer)) return obj; switch (XTYPE (obj)) { +#ifndef LRECORD_CONS case Lisp_Type_Cons: return pure_cons (XCAR (obj), XCDR (obj)); - +#endif + +#ifndef LRECORD_STRING case Lisp_Type_String: return make_pure_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj), XSTRING (obj)->plist, 0); +#endif /* ! LRECORD_STRING */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: @@ -2573,6 +2742,29 @@ n->maxdepth = o->maxdepth; return new; } +#ifdef LRECORD_CONS + else if (CONSP (obj)) + return pure_cons (XCAR (obj), XCDR (obj)); +#endif /* LRECORD_CONS */ +#ifdef LRECORD_VECTOR + else if (VECTORP (obj)) + { + struct Lisp_Vector *o = XVECTOR (obj); + Lisp_Object new = make_pure_vector (vector_length (o), Qnil); + for (i = 0; i < vector_length (o); i++) + XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]); + return new; + } +#endif /* LRECORD_VECTOR */ +#ifdef LRECORD_STRING + else if (STRINGP (obj)) + { + return make_pure_string (XSTRING_DATA (obj), + XSTRING_LENGTH (obj), + XSTRING (obj)->plist, + 0); + } +#endif /* LRECORD_STRING */ #ifdef LISP_FLOAT_TYPE else if (FLOATP (obj)) return make_pure_float (float_data (XFLOAT (obj))); @@ -2776,12 +2968,15 @@ { tail_recurse: + if (EQ (obj, Qnull_pointer)) + return; if (!POINTER_TYPE_P (XGCTYPE (obj))) return; if (PURIFIED (XPNTR (obj))) return; switch (XGCTYPE (obj)) { +#ifndef LRECORD_CONS case Lisp_Type_Cons: { struct Lisp_Cons *ptr = XCONS (obj); @@ -2800,6 +2995,7 @@ } goto tail_recurse; } +#endif case Lisp_Type_Record: /* case Lisp_Symbol_Value_Magic: */ @@ -2825,6 +3021,7 @@ } break; +#ifndef LRECORD_STRING case Lisp_Type_String: { struct Lisp_String *ptr = XSTRING (obj); @@ -2840,6 +3037,7 @@ } } break; +#endif /* ! LRECORD_STRING */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: @@ -2873,15 +3071,13 @@ mark_object (sym->value); mark_object (sym->function); { - /* Open-code mark_string */ - /* symbol->name is a struct Lisp_String *, not a Lisp_Object */ - struct Lisp_String *pname = sym->name; - if (!PURIFIED (pname) - && !XMARKBIT (pname->plist)) - { - XMARK (pname->plist); - mark_object (pname->plist); - } + /* + * symbol->name is a struct Lisp_String *, not a + * Lisp_Object. Fix it up and pass to mark_object. + */ + Lisp_Object symname; + XSETSTRING(symname, sym->name); + mark_object(symname); } if (!symbol_next (sym)) { @@ -2936,6 +3132,27 @@ } #endif /* unused */ +static int +pure_string_sizeof(Lisp_Object obj) +{ + struct Lisp_String *ptr = XSTRING (obj); + int size = string_length (ptr); + + if (string_data (ptr) != + (unsigned char *) ptr + sizeof (struct Lisp_String)) + { + /* string-data not allocated contiguously. + Probably (better be!!) a pointer constant "C" data. */ + size = sizeof (struct Lisp_String); + } + else + { + size = sizeof (struct Lisp_String) + size + 1; + size = ALIGN_SIZE (size, sizeof (Lisp_Object)); + } + return size; +} + /* recurse arg isn't actually used */ static int pure_sizeof (Lisp_Object obj /*, int recurse */) @@ -2953,26 +3170,14 @@ switch (XTYPE (obj)) { + +#ifndef LRECORD_STRING case Lisp_Type_String: { - struct Lisp_String *ptr = XSTRING (obj); - int size = string_length (ptr); - - if (string_data (ptr) != - (unsigned char *) ptr + sizeof (struct Lisp_String)) - { - /* string-data not allocated contiguously. - Probably (better be!!) a pointer constant "C" data. */ - size = sizeof (struct Lisp_String); - } - else - { - size = sizeof (struct Lisp_String) + size + 1; - size = ALIGN_SIZE (size, sizeof (Lisp_Object)); - } - total += size; + total += pure_string_sizeof (obj); } break; +#endif /* ! LRECORD_STRING */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: @@ -2998,7 +3203,7 @@ #endif /* unused */ } break; -#endif /* !LRECORD_SYMBOL */ +#endif /* !LRECORD_VECTOR */ case Lisp_Type_Record: { @@ -3006,6 +3211,11 @@ CONST struct lrecord_implementation *implementation = lheader->implementation; +#ifdef LRECORD_STRING + if (STRINGP (obj)) + total += pure_string_sizeof (obj); + else +#endif if (implementation->size_in_bytes_method) total += ((implementation->size_in_bytes_method) (lheader)); else @@ -3030,6 +3240,7 @@ } break; +#ifndef LRECORD_CONS case Lisp_Type_Cons: { struct Lisp_Cons *ptr = XCONS (obj); @@ -3051,6 +3262,7 @@ #endif /* unused */ } break; +#endif /* Others can't be purified */ default: @@ -3065,8 +3277,10 @@ /* Find all structures not marked, and free them. */ +#ifndef LRECORD_VECTOR static int gc_count_num_vector_used, gc_count_vector_total_size; static int gc_count_vector_storage; +#endif static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size; static int gc_count_bit_vector_storage; static int gc_count_num_short_string_in_use; @@ -3213,6 +3427,8 @@ /* *total = total_size; */ } +#ifndef LRECORD_VECTOR + static void sweep_vectors_1 (Lisp_Object *prev, int *used, int *total, int *storage) @@ -3251,6 +3467,8 @@ *storage = total_storage; } +#endif /* ! LRECORD_VECTOR */ + static void sweep_bit_vectors_1 (Lisp_Object *prev, int *used, int *total, int *storage) @@ -3422,8 +3640,13 @@ static void sweep_conses (void) { -#define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car) -#define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0) +#ifndef LRECORD_CONS +# define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car) +# define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0) +#else /* LRECORD_CONS */ +# define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) +# define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) +#endif /* LRECORD_CONS */ #define ADDITIONAL_FREE_cons(ptr) SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons); @@ -3677,7 +3900,11 @@ abort (); /* Just skip it if it isn't marked. */ +#ifdef LRECORD_STRING + if (! MARKED_RECORD_HEADER_P (&(string->lheader))) +#else if (!XMARKBIT (string->plist)) +#endif { from_pos += fullsize; continue; @@ -3758,8 +3985,30 @@ int num_small_used = 0, num_small_bytes = 0, num_bytes = 0; int debug = debug_string_purity; -#define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist) -#define UNMARK_string(ptr) \ +#ifdef LRECORD_STRING + +# define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader)) +# define UNMARK_string(ptr) \ + do { struct Lisp_String *p = (ptr); \ + int size = string_length (p); \ + UNMARK_RECORD_HEADER (&(p->lheader)); \ + num_bytes += size; \ + if (!BIG_STRING_SIZE_P (size)) \ + { num_small_bytes += size; \ + num_small_used++; \ + } \ + if (debug) debug_string_purity_print (p); \ + } while (0) +# define ADDITIONAL_FREE_string(p) \ + do { int size = string_length (p); \ + if (BIG_STRING_SIZE_P (size)) \ + xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \ + } while (0) + +#else + +# define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist) +# define UNMARK_string(ptr) \ do { struct Lisp_String *p = (ptr); \ int size = string_length (p); \ XUNMARK (p->plist); \ @@ -3770,12 +4019,14 @@ } \ if (debug) debug_string_purity_print (p); \ } while (0) -#define ADDITIONAL_FREE_string(p) \ +# define ADDITIONAL_FREE_string(p) \ do { int size = string_length (p); \ if (BIG_STRING_SIZE_P (size)) \ xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \ } while (0) +#endif /* ! LRECORD_STRING */ + SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String); gc_count_num_short_string_in_use = num_small_used; @@ -3788,16 +4039,21 @@ static int marked_p (Lisp_Object obj) { + if (EQ (obj, Qnull_pointer)) return 1; if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; if (PURIFIED (XPNTR (obj))) return 1; switch (XGCTYPE (obj)) { +#ifndef LRECORD_CONS case Lisp_Type_Cons: return XMARKBIT (XCAR (obj)); +#endif case Lisp_Type_Record: return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj)); +#ifndef LRECORD_STRING case Lisp_Type_String: return XMARKBIT (XSTRING (obj)->plist); +#endif /* ! LRECORD_STRING */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: return XVECTOR_LENGTH (obj) < 0; @@ -3845,10 +4101,12 @@ /* Put all unmarked conses on free list */ sweep_conses (); +#ifndef LRECORD_VECTOR /* Free all unmarked vectors */ sweep_vectors_1 (&all_vectors, &gc_count_num_vector_used, &gc_count_vector_total_size, &gc_count_vector_storage); +#endif /* Free all unmarked bit vectors */ sweep_bit_vectors_1 (&all_bit_vectors, @@ -4232,6 +4490,9 @@ Lisp_Object pl = Qnil; Lisp_Object ret[6]; int i; +#ifdef LRECORD_VECTOR + int gc_count_vector_total_size; +#endif if (purify_flag && pure_lossage) { @@ -4249,6 +4510,12 @@ char buf [255]; CONST char *name = lrecord_implementations_table[i]->name; int len = strlen (name); +#ifdef LRECORD_VECTOR + /* save this for the FSFmacs-compatible part of the summary */ + if (i == *lrecord_vector[0].lrecord_type_index) + gc_count_vector_total_size = + lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed; +#endif sprintf (buf, "%s-storage", name); pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); /* Okay, simple pluralization check for `symbol-value-varalias' */ @@ -4307,10 +4574,12 @@ pl = gc_plist_hack ("compiled-functions-used", gc_count_num_compiled_function_in_use, pl); +#ifndef LRECORD_VECTOR pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl); pl = gc_plist_hack ("vectors-total-length", gc_count_vector_total_size, pl); pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl); +#endif pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl); pl = gc_plist_hack ("bit-vectors-total-length", @@ -4545,7 +4814,9 @@ pureptr = 0; pure_lossage = 0; breathing_space = 0; +#ifndef LRECORD_VECTOR XSETINT (all_vectors, 0); /* Qzero may not be set yet. */ +#endif XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */ XSETINT (Vgc_message, 0); all_lcrecords = 0;
--- a/src/buffer.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/buffer.c Mon Aug 13 10:03:52 2007 +0200 @@ -252,7 +252,8 @@ /* Don't mark normally through the children slot. (Actually, in this case, it doesn't matter.) */ - mark_conses_in_list (buf->indirect_children); + if (! EQ (buf->indirect_children, Qnull_pointer)) + mark_conses_in_list (buf->indirect_children); if (buf->base_buffer) { @@ -2219,6 +2220,9 @@ defs->auto_save_failure_time = -1; defs->invisibility_spec = Qt; + defs->indirect_children = Qnil; + syms->indirect_children = Qnil; + { /* 0 means var is always local. Default used only at creation. * -1 means var is always local. Default used only at reset and @@ -2508,8 +2512,8 @@ used for the encoding. Automatically buffer-local when set in any fashion. This is normally set automatically when a file is loaded in based on the determined coding system of the file (assuming that -`buffer-file-coding-system-for-read' is set to `automatic-conversion', -which calls for automatic determination of the file's coding system). +`buffer-file-coding-system-for-read' is set to `undecided', which +calls for automatic determination of the file's coding system). Normally the modeline indicates the current file coding system using its mnemonic abbreviation. @@ -2542,8 +2546,7 @@ particular operation, you should bind the variable `coding-system-for-read' rather than changing the other two variables just mentioned, which are intended to be used for -global environment specification. -*/ ); +global environment specification. */ ); #endif /* MULE */ DEFVAR_BUFFER_LOCAL ("auto-fill-function", auto_fill_function /*
--- a/src/bytecode.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/bytecode.c Mon Aug 13 10:03:52 2007 +0200 @@ -1058,6 +1058,7 @@ #if 0 /* probably this code is OK, but nth_entry is commented out above --ben */ + /* #### will not work if cons type is an lrecord. */ if (XTYPE (TOP) == Lisp_Type_Cons) { /* Exchange args and then do nth. */
--- a/src/chartab.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/chartab.c Mon Aug 13 10:03:52 2007 +0200 @@ -1621,7 +1621,7 @@ CHECK_INT (pos); CHECK_CATEGORY_DESIGNATOR (designator); - des = XREALINT (designator); + des = XCHAR (designator); ctbl = check_category_table (category_table, Vstandard_category_table); ch = BUF_FETCH_CHAR (buf, XINT (pos)); return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil; @@ -1639,7 +1639,7 @@ unsigned int des; CHECK_CATEGORY_DESIGNATOR (designator); - des = XREALINT (designator); + des = XCHAR (designator); CHECK_CHAR (chr); ch = XCHAR (chr); ctbl = check_category_table (category_table, Vstandard_category_table);
--- a/src/config.h.in Mon Aug 13 10:02:48 2007 +0200 +++ b/src/config.h.in Mon Aug 13 10:03:52 2007 +0200 @@ -64,6 +64,8 @@ #undef EMACS_VERSION #undef XEMACS_CODENAME +/* Make all functions available on AIX. See AC_AIX. */ +#undef _ALL_SOURCE /* Used to identify the XEmacs version in stack traces. */ #undef STACK_TRACE_EYE_CATCHER @@ -100,6 +102,7 @@ /* The following will be defined if xmkmf thinks they are necessary */ #undef SVR4 #undef SYSV +#undef AIXV3 #undef _POSIX_SOURCE #undef _BSD_SOURCE #undef _GNU_SOURCE @@ -204,6 +207,9 @@ /* Can `gettimeofday' accept two arguments? */ #undef GETTIMEOFDAY_ONE_ARGUMENT +/* Is the timezone variable already declared in system headers? */ +#undef HAVE_TIMEZONE_DECL + #undef HAVE_MMAP #undef HAVE_STRCOLL #undef HAVE_GETPGRP @@ -279,8 +285,6 @@ #undef NLIST_STRUCT -#undef AIX_SMT_EXP - /* Compile in support for SOCKS? */ #undef HAVE_SOCKS @@ -294,17 +298,8 @@ This enables graphical display of X-face headers in mail/news messages */ #undef HAVE_XFACE -/* Compile in support for GIF (Graphics Interchange Format) images? */ -#undef HAVE_GIF - -/* Compile in support for displaying JPEG images via the `jpeg' library? */ -#undef HAVE_JPEG - -/* Compile in support for displaying PNG images via the `png' library? */ -#undef HAVE_PNG - -/* Compile in support for displaying TIFF images via the `tiff' library? */ -#undef HAVE_TIFF +/* Compile in support for ImageMagick (all image formats) */ +#undef HAVE_IMAGEMAGICK /* Do you have the Xmu library? This should always be the case except on losing HP-UX systems. */ @@ -406,7 +401,7 @@ Requires libDtSvc, which typically must be present at runtime. */ #undef HAVE_CDE -/* Compile in support for OffiX Drag and Drop? Requires libdnd. */ +/* Compile in support for OffiX Drag and Drop? */ #undef HAVE_OFFIX_DND /* Compile in support for proper session-management. */
--- a/src/console-stream.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/console-stream.c Mon Aug 13 10:03:52 2007 +0200 @@ -344,6 +344,10 @@ Vterminal_frame = Fmake_frame (Qnil, Vterminal_device); minibuf_window = XFRAME (Vterminal_frame)->minibuffer_window; } - else if (noninteractive) - event_stream_select_console (XCONSOLE (Vterminal_console)); + else { + /* Re-initialize the FILE fields of the console. */ + stream_init_console (XCONSOLE (Vterminal_console), Qnil); + if (noninteractive) + event_stream_select_console (XCONSOLE (Vterminal_console)); + } }
--- a/src/console-tty.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/console-tty.c Mon Aug 13 10:03:52 2007 +0200 @@ -38,6 +38,9 @@ #ifdef MULE #include "mule-coding.h" #endif +#ifdef HAVE_GPM +#include "gpmevent.h" +#endif DEFINE_CONSOLE_TYPE (tty);
--- a/src/data.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/data.c Mon Aug 13 10:03:52 2007 +0200 @@ -87,7 +87,7 @@ { if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) && (debug_issue_ebola_notices >= 2 - || XREALINT (obj1) == XREALINT (obj2))) + || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))) { stderr_out("Comparison between integer and character is constant nil ("); Fprinc (obj1, Qexternal_debugging_output); @@ -166,8 +166,12 @@ make_int (EMACS_INT num) { Lisp_Object val; +#ifdef USE_MINIMAL_TAGBITS + XSETINT(val, num); +#else /* Don't use XSETINT here -- it's defined in terms of make_int (). */ XSETOBJ (val, Lisp_Type_Int, num); +#endif return val; } #endif /* ! defined (make_int) */ @@ -191,13 +195,19 @@ /* characters do not need to sign extend so there's no need for special futzing like with ints. */ +#ifndef make_char Lisp_Object make_char (Emchar num) { Lisp_Object val; +#ifdef USE_MINIMAL_TAGBITS + XSETCHAR (val, num); +#else XSETOBJ (val, Lisp_Type_Char, num); +#endif return val; } +#endif /* ! make_char */ /* Data type predicates */ @@ -1641,7 +1651,8 @@ { int C_count = XINT (count); - EMACS_UINT C_value = (EMACS_UINT) XUINT (value); + /* EMACS_UINT C_value = (EMACS_UINT) XUINT (value);*/ + EMACS_UINT C_value = (EMACS_UINT) XINT (value); XSETINT (val, C_count > 0 ? C_value << C_count : C_value >> -C_count); } return val;
--- a/src/database.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/database.c Mon Aug 13 10:03:52 2007 +0200 @@ -22,6 +22,7 @@ /* Written by Bill Perry */ /* Substantially rewritten by Martin Buchholz */ +/* db 2.x support added by Andreas Jaeger */ #include <config.h> #include "lisp.h" @@ -37,6 +38,8 @@ /* Work around Berkeley DB's use of int types which are defined slightly differently in the not quite yet standard <inttypes.h>. See db.h for details of why we're resorting to this... */ +/* glibc 2.1 doesn't have this problem with DB 2.x */ +#if !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) #ifdef HAVE_INTTYPES_H #define __BIT_TYPES_DEFINED__ #include <inttypes.h> @@ -47,7 +50,11 @@ typedef uint64_t u_int64_t; #endif /* WE_DONT_NEED_QUADS */ #endif /* HAVE_INTTYPES_H */ +#endif /* !(defined __GLIBC__ && __GLIBC_MINOR__ >= 1) */ #include DB_H_PATH /* Berkeley db's header file */ +#ifndef DB_VERSION_MAJOR +# define DB_VERSION_MAJOR 1 +#endif /* DB_VERSION_MAJOR */ Lisp_Object Qberkeley_db; Lisp_Object Qhash; Lisp_Object Qbtree; @@ -61,7 +68,7 @@ Lisp_Object Qdatabasep; -typedef enum { DB_DBM, DB_BERKELEY, DB_UNKNOWN } XEMACS_DB_TYPE; +typedef enum { DB_DBM, DB_BERKELEY, DB_IS_UNKNOWN } XEMACS_DB_TYPE; struct database; typedef struct database database; @@ -138,7 +145,7 @@ dbase->access_ = 0; dbase->mode = 0; dbase->dberrno = 0; - dbase->type = DB_UNKNOWN; + dbase->type = DB_IS_UNKNOWN; #ifdef MULE dbase->coding_system = Fget_coding_system (Qbinary); #endif @@ -400,15 +407,30 @@ DBT keydatum, valdatum; int status = 0; +#if DB_VERSION_MAJOR == 2 + /* Always initialize keydatum, valdatum. */ + memset(&keydatum, 0, sizeof(keydatum)); + memset(&valdatum, 0, sizeof(valdatum)); +#endif /* DV_VERSION_MAJOR = 2 */ + keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); +#if DB_VERSION_MAJOR == 1 status = db->db_handle->get (db->db_handle, &keydatum, &valdatum, 0); +#else + status = db->db_handle->get (db->db_handle, NULL, &keydatum, &valdatum, 0); +#endif /* DB_VERSION_MAJOR */ if (!status) return make_string ((Bufbyte *) valdatum.data, valdatum.size); +#if DB_VERSION_MAJOR == 1 db->dberrno = (status == 1) ? -1 : errno; +#else + db->dberrno = (status < 0) ? -1 : errno; +#endif /* DB_VERSION_MAJOR */ + return Qnil; } @@ -421,13 +443,26 @@ DBT keydatum, valdatum; int status = 0; +#if DB_VERSION_MAJOR == 2 + /* Always initalize keydatum, valdatum. */ + memset(&keydatum, 0, sizeof(keydatum)); + memset(&valdatum, 0, sizeof(valdatum)); +#endif /* DV_VERSION_MAJOR = 2 */ + keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); valdatum.data = XSTRING_DATA (val); valdatum.size = XSTRING_LENGTH (val); +#if DB_VERSION_MAJOR == 1 status = db->db_handle->put (db->db_handle, &keydatum, &valdatum, - NILP (replace) ? R_NOOVERWRITE : 0); + NILP (replace) ? R_NOOVERWRITE : 0); db->dberrno = (status == 1) ? -1 : errno; +#else + status = db->db_handle->put (db->db_handle, NULL, &keydatum, &valdatum, + NILP (replace) ? DB_NOOVERWRITE : 0); + db->dberrno = (status < 0) ? -1 : errno; +#endif/* DV_VERSION_MAJOR = 2 */ + return status; } @@ -437,14 +472,29 @@ DBT keydatum; int status; +#if DB_VERSION_MAJOR == 2 + /* Always initialize keydatum. */ + memset(&keydatum, 0, sizeof(keydatum)); +#endif /* DV_VERSION_MAJOR = 2 */ + keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); +#if DB_VERSION_MAJOR == 1 status = db->db_handle->del (db->db_handle, &keydatum, 0); +#else + status = db->db_handle->del (db->db_handle, NULL, &keydatum, 0); +#endif /* DB_VERSION_MAJOR */ + if (!status) return 0; +#if DB_VERSION_MAJOR == 1 db->dberrno = (status == 1) ? -1 : errno; +#else + db->dberrno = (status < 0) ? -1 : errno; +#endif /* DB_VERSION_MAJOR */ + return 1; } @@ -456,6 +506,7 @@ DB *dbp = db->db_handle; int status; +#if DB_VERSION_MAJOR == 1 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); status == 0; status = dbp->seq (dbp, &keydatum, &valdatum, R_NEXT)) @@ -465,6 +516,24 @@ val = make_string ((Bufbyte *) valdatum.data, valdatum.size); call2 (func, key, val); } +#else + DBC *dbcp; + /* Initialize the key/data pair so the flags aren't set. */ + memset(&keydatum, 0, sizeof(keydatum)); + memset(&valdatum, 0, sizeof(valdatum)); + + status = dbp->cursor (dbp, NULL, &dbcp); + for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); + status == 0; + status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_NEXT)) + { + /* ### Needs mule-izing */ + key = make_string ((Bufbyte *) keydatum.data, keydatum.size); + val = make_string ((Bufbyte *) valdatum.data, valdatum.size); + call2 (func, key, val); + } + dbcp->c_close (dbcp); +#endif /* DB_VERSION_MAJOR */ } static void @@ -472,8 +541,13 @@ { if (db->db_handle) { +#if DB_VERSION_MAJOR == 1 db->db_handle->sync (db->db_handle, 0); db->db_handle->close (db->db_handle); +#else + db->db_handle->sync (db->db_handle, 0); + db->db_handle->close (db->db_handle, 0); +#endif /* DB_VERSION_MAJOR */ db->db_handle = NULL; } } @@ -577,7 +651,8 @@ { DBTYPE real_subtype; DB *db; - + int status; + if (EQ (subtype, Qhash) || NILP (subtype)) real_subtype = DB_HASH; else if (EQ (subtype, Qbtree)) @@ -587,10 +662,35 @@ else signal_simple_error ("Unsupported subtype", subtype); +#if DB_VERSION_MAJOR == 1 db = dbopen (filename, accessmask, modemask, real_subtype, NULL); if (!db) return Qnil; +#else + /* Berkeley DB Version 2 has only the accessmask DB_CREATE and DB_RDONLY, + other flags shouldn't be set */ + if (NILP (access_)) + { + accessmask = DB_CREATE; + } + else + { + char *acc; + CHECK_STRING (access_); + acc = (char *) XSTRING_DATA (access_); + accessmask = 0; + + if (strchr (acc, '+')) + accessmask |= DB_CREATE; + if (strchr (acc, 'r') && !strchr (acc, 'w')) + accessmask |= DB_RDONLY; + } + status = db_open (filename, real_subtype, accessmask, modemask, NULL , NULL, &db); + if (status) + return Qnil; +#endif /* DB_VERSION_MAJOR */ + dbase = new_database (); dbase->db_handle = db; dbase->type = DB_BERKELEY;
--- a/src/device-x.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/device-x.c Mon Aug 13 10:03:52 2007 +0200 @@ -262,6 +262,7 @@ Vdefault_x_device = device; #ifdef MULE +#if defined(LWLIB_MENUBARS_MOTIF) || defined(USE_XFONTSET) { /* Read in locale-specific resources from data-directory/app-defaults/$LANG/emacs-application-class. @@ -280,6 +281,7 @@ XrmCombineFileDatabase (path, &db, False); } } +#endif /* LWLIB_MENUBARS_MOTIF or USE_XFONTSET */ #endif /* MULE */ if (NILP (DEVICE_NAME (d)))
--- a/src/elhash.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/elhash.c Mon Aug 13 10:03:52 2007 +0200 @@ -99,6 +99,7 @@ c_table->harray = (hentry *) XVECTOR_DATA (ht->harray); c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry)); c_table->zero_entry = LISP_TO_VOID (ht->zero_entry); +#ifndef LRECORD_VECTOR if (len < 0) { /* #### if alloc.c mark_object() changes, this must change too. */ @@ -109,6 +110,7 @@ assert (gc_in_progress); len = -1 - len; } +#endif c_table->size = len/LISP_OBJECTS_PER_HENTRY; c_table->fullness = ht->fullness; c_table->hash_function = ht->hash_function; @@ -154,7 +156,7 @@ struct hashtable *ht = XHASHTABLE (table); assert (bytes > XVECTOR_LENGTH (ht->harray) * sizeof (Lisp_Object)); - new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qzero); + new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qnull_pointer); return (void *) XVECTOR_DATA (new_vector); } @@ -252,7 +254,7 @@ table->harray = make_vector ((compute_harray_size (size) * LISP_OBJECTS_PER_HENTRY), - Qzero); + Qnull_pointer); switch (test) { case HASHTABLE_EQ: @@ -341,7 +343,7 @@ new_ht->zero_entry = Qunbound; new_ht->hash_function = old_ht->hash_function; new_ht->test_function = old_ht->test_function; - new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qzero); + new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qnull_pointer); ht_copy_to_c (new_ht, &new_htbl); copy_hash (&new_htbl, &old_htbl); ht_copy_from_c (&new_htbl, new_ht); @@ -716,11 +718,19 @@ */ struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray); int len = vector_length (ptr); +#ifdef LRECORD_VECTOR + if (! MARKED_RECORD_P(XHASHTABLE(rest)->harray)) + { + MARK_RECORD_HEADER(&(ptr->header.lheader)); + did_mark = 1; + } +#else if (len >= 0) { ptr->size = -1 - len; did_mark = 1; } +#endif /* else it's already marked (remember, this function is iterated until marking stops) */ } @@ -830,7 +840,6 @@ } else if (STRINGP (obj)) return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); -#ifndef LRECORD_VECTOR else if (VECTORP (obj)) { struct Lisp_Vector *v = XVECTOR (obj); @@ -838,7 +847,6 @@ internal_array_hash (v->contents, vector_length (v), depth + 1)); } -#endif /* !LRECORD_VECTOR */ else if (LRECORDP (obj)) { CONST struct lrecord_implementation
--- a/src/emacs.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/emacs.c Mon Aug 13 10:03:52 2007 +0200 @@ -52,10 +52,6 @@ #include TT_C_H_PATH #endif -#ifdef VMS -#include <ssdef.h> -#endif - #ifdef APOLLO #ifndef APOLLO_SR10 #include <default_acl.h> @@ -158,6 +154,9 @@ int noninteractive1; +/* Nonzero means don't perform package searches at startup */ +int inhibit_package_init; + /* Save argv and argc. */ char **initial_argv; int initial_argc; @@ -210,12 +209,8 @@ } # endif } -#ifdef VMS - LIB$STOP (SS$_ABORT); -#else /* Signal the same code; this time it will really be fatal. */ kill (getpid (), fatal_error_code); -#endif /* not VMS */ SIGRETURN; } @@ -519,24 +514,6 @@ } #endif /* HAVE_SHM */ -#ifdef VMS - /* If -map specified, map the data file in */ - if (argc > 2 && ! strcmp (argv[1], "-map")) - { - skip_args = 2; - mapin_data (argv[2]); - } - -#ifdef LINK_CRTL_SHARE -#ifdef SHAREABLE_LIB_BUG - /* Bletcherous shared libraries! */ - if (!stdin) stdin = fdopen (0, "r"); - if (!stdout) stdout = fdopen (1, "w"); - if (!stderr) stderr = fdopen (2, "w"); - if (!environ) environ = envp; -#endif /* SHAREABLE_LIB_BUG */ -#endif /* LINK_CRTL_SHARE */ -#endif /* VMS */ #if (defined (MSDOS) && defined (EMX)) || defined (WIN32) || defined (_SCO_DS) environ = envp; #endif @@ -635,6 +612,17 @@ if (argmatch (argv, argc, "-batch", "--batch", 5, NULL, &skip_args)) noninteractive = 1; + /* Partially handle -no-packages and -vanilla. Packages are searched */ + /* prior to the rest of the command line being parsed in startup.el */ + if (argmatch (argv, argc, "-no-packages", "--no-packages", + 6, NULL, &skip_args) || + argmatch (argv, argc, "-vanilla", "--vanilla", + 7, NULL, &skip_args)) + { + inhibit_package_init = 1; + skip_args--; + } + /* Partially handle the -version and -help switches: they imply -batch, but are not removed from the list. */ if (argmatch (argv, argc, "-help", "--help", 3, NULL, &skip_args) || @@ -1397,16 +1385,8 @@ init_ntproc(); #endif -#ifdef VMS - init_vms_input (); /* init_redisplay calls get_tty_device_size, - that needs this */ -#endif /* VMS */ init_redisplay (); /* Determine terminal type. init_sys_modes uses results */ -#ifdef VMS - init_vmsproc (); - init_vmsfns (); -#endif /* VMS */ init_event_stream (); /* Set up so we can get user input. */ init_macros (); /* set up so we can run macros. */ init_editfns (); /* Determine the name of the user we're running as */ @@ -1498,9 +1478,6 @@ { /* Handled by main_1 above: */ { "-nl", "--no-shared-memory", 100, 0 }, -#ifdef VMS - { "-map", "--map-data", 100, 0 }, -#endif { "-t", "--terminal", 95, 1 }, { "-nw", "--no-windows", 90, 0 }, { "-batch", "--batch", 85, 0 }, @@ -1519,7 +1496,9 @@ { "-q", "--no-init-file", 50, 0 }, { "-unmapped", 0, 50, 0 }, { "-no-init-file", 0, 50, 0 }, + { "-vanilla", "--vanilla", 50, 0 }, { "-no-site-file", "--no-site-file", 40, 0 }, + { "-no-packages", "--no-packages", 35, 0 }, { "-u", "--user", 30, 1 }, { "-user", 0, 30, 1 }, { "-debug-init", "--debug-init", 20, 0 }, @@ -1772,7 +1751,11 @@ unbind_to (0, Qnil); /* this closes loadup.el */ purify_flag = 0; run_temacs_argc = nargs + 1; +#ifdef DEBUG_XEMACS report_pure_usage (1, 0); +#else + report_pure_usage (0, 0); +#endif LONGJMP (run_temacs_catch, 1); return Qnil; /* not reached; warning suppression */ } @@ -1877,13 +1860,7 @@ shut_down_emacs (0, ((STRINGP (arg)) ? arg : Qnil)); - exit ((INTP (arg)) ? XINT (arg) -#ifdef VMS - : 1 -#else - : 0 -#endif - ); + exit ((INTP (arg)) ? XINT (arg) : 0); /* NOTREACHED */ return Qnil; /* I'm sick of the compiler warning */ } @@ -1992,9 +1969,6 @@ #endif #endif /* TOOLTALK */ -#ifdef VMS - kill_vms_processes (); -#endif } @@ -2083,7 +2057,11 @@ opurify = purify_flag; purify_flag = 0; +#ifdef DEBUG_XEMACS report_pure_usage (1, 1); +#else + report_pure_usage (0, 1); +#endif fflush (stderr); fflush (stdout); @@ -2091,9 +2069,6 @@ disksave_object_finalization (); release_breathing_space (); -#ifdef VMS - mapout_data (XSTRING_DATA (intoname)); -#else /* Tell malloc where start of impure now is */ /* Also arrange for warnings when nearly out of space. */ #ifndef SYSTEM_MALLOC @@ -2134,7 +2109,6 @@ 0, 0); } #endif /* not MSDOS and EMX */ -#endif /* not VMS */ purify_flag = opurify; @@ -2379,6 +2353,10 @@ Non-nil means XEmacs is running without interactive terminal. */ ); + DEFVAR_BOOL ("inhibit-package-init", &inhibit_package_init /* +Set to non-nil when the package-path should not be searched at startup. +*/ ); + DEFVAR_INT ("emacs-priority", &emacs_priority /* Priority for XEmacs to run at. This value is effective only if set before XEmacs is dumped,
--- a/src/emacsfns.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/emacsfns.h Mon Aug 13 10:03:52 2007 +0200 @@ -329,7 +329,9 @@ #ifndef make_int Lisp_Object make_int (EMACS_INT); #endif +#ifndef make_char Lisp_Object make_char (Emchar num); +#endif DECLARE_DOESNT_RETURN (pure_write_error (void)); DECLARE_DOESNT_RETURN (args_out_of_range (Lisp_Object, Lisp_Object)); DECLARE_DOESNT_RETURN (args_out_of_range_3 (Lisp_Object, Lisp_Object, @@ -1172,7 +1174,7 @@ extern Lisp_Object Qassoc; extern Lisp_Object Qat; extern Lisp_Object Qautodetect; -extern Lisp_Object Qautomatic_conversion; +extern Lisp_Object Qundecided; extern Lisp_Object Qbad_variable; extern Lisp_Object Qbefore; extern Lisp_Object Qbinary;
--- a/src/event-Xt.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/event-Xt.c Mon Aug 13 10:03:52 2007 +0200 @@ -846,7 +846,7 @@ /* ### Use Fget_coding_system (Vcomposed_input_coding_system) */ instream = make_decoding_input_stream (XLSTREAM (fb_instream), - Fget_coding_system (Qautomatic_conversion)); + Fget_coding_system (Qundecided)); istr = XLSTREAM (instream);
--- a/src/events.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/events.c Mon Aug 13 10:03:52 2007 +0200 @@ -1920,13 +1920,13 @@ } } -#ifdef HAVE_OFFIX_DND -DEFUN ("event-dnd-data", Fevent_dnd_data, 1, 1, 0, /* +DEFUN ("event-drag-and-drop-data", Fevent_drag_and_drop_data, 1, 1, 0, /* Return the Dnd data list of EVENT. -EVENT should be a dnd_drop (later also dnd_drag) event. +EVENT should be a dnd_drop event. */ (event)) { +#ifdef HAVE_OFFIX_DND again: CHECK_LIVE_EVENT (event); switch (XEVENT (event)->event_type) @@ -1937,8 +1937,10 @@ event = wrong_type_argument (Qdnd_drop_event_p, event); goto again; } +#else /* !HAVE_OFFIX_DND */ + return Qnil; +#endif /* HAVE_OFFIX_DND */ } -#endif /* HAVE_OFFIX_DND */ DEFUN ("event-properties", Fevent_properties, 1, 1, 0, /* Return a list of all of the properties of EVENT. @@ -2000,7 +2002,7 @@ props = Fcons (Qx, Fcons (Fevent_x_pixel (event), props)); props = Fcons (Qmodifiers, Fcons (Fevent_modifiers (event), props)); props = Fcons (Qbutton, Fcons (Fevent_button (event), props)); - props = Fcons (Qdnd_data, Fcons (Fevent_dnd_data (event), props)); + props = Fcons (Qdnd_data, Fcons (Fevent_drag_and_drop_data (event), props)); break; #endif @@ -2070,9 +2072,7 @@ DEFSUBR (Fevent_process); DEFSUBR (Fevent_function); DEFSUBR (Fevent_object); -#ifdef HAVE_OFFIX_DND - DEFSUBR (Fevent_dnd_data); -#endif + DEFSUBR (Fevent_drag_and_drop_data); defsymbol (&Qeventp, "eventp"); defsymbol (&Qevent_live_p, "event-live-p");
--- a/src/extents.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/extents.c Mon Aug 13 10:03:52 2007 +0200 @@ -446,7 +446,7 @@ Lisp_Object Qdetachable; Lisp_Object Qpriority; Lisp_Object Qmouse_face; -Lisp_Object Qone_shot_function; +Lisp_Object Qinitial_redisplay_function; Lisp_Object Qglyph_layout; /* This exists only for backwards compatibility. */ Lisp_Object Qbegin_glyph_layout, Qend_glyph_layout; @@ -933,7 +933,7 @@ ((markobj) (data->children)); ((markobj) (data->read_only)); ((markobj) (data->mouse_face)); - ((markobj) (data->one_shot_function)); + ((markobj) (data->initial_redisplay_function)); return data->parent; } @@ -1647,7 +1647,7 @@ !NILP (extent_end_glyph (anc)) || !NILP (extent_mouse_face (anc)) || !NILP (extent_invisible (anc)) || - !NILP (extent_one_shot_function (anc)) || + !NILP (extent_initial_redisplay_function (anc)) || invisibility_change) extent_changed_for_redisplay (extent, descendants_too, invisibility_change); @@ -2885,21 +2885,20 @@ Dynarr_add (ef->extents, &dummy_lhe_extent); } /* since we are looping anyway, we might as well do this here */ - if (!NILP(extent_one_shot_function (e))) + if ((!NILP(extent_initial_redisplay_function (e))) && + !extent_in_red_event_p(e)) { - Lisp_Object function = extent_one_shot_function (e); + Lisp_Object function = extent_initial_redisplay_function (e); Lisp_Object obj; - /* printf("One shot function called!\n "); */ + /* printf("initial redisplay function called!\n "); */ /* print_extent_2(e); printf("\n"); */ - /* Do NOT use the set function here because that sets the - redisplay flag. - FIXME: One should probably inhibit the displaying of + /* FIXME: One should probably inhibit the displaying of this extent to reduce flicker */ - set_extent_one_shot_function (e,Qnil); /* one shot */ + extent_in_red_event_p(e) = 1; /* call the function */ XSETEXTENT(obj,e); @@ -4772,19 +4771,24 @@ } /* Do we need a lisp-level function ? */ -DEFUN ("set-extent-one-shot-function", Fset_extent_one_shot_function, +DEFUN ("set-extent-initial-redisplay-function", Fset_extent_initial_redisplay_function, 2,2,0,/* -Set one-shot-function of EXTENT to the function -FUNCTION. This function will be called with EXTENT as its only -argument shortly after (part of) the extent has been under -consideration for display. The property is then cleared. +Note: This feature is experimental! + +Set initial-redisplay-function of EXTENT to the function +FUNCTION. + +The first time the EXTENT is (re)displayed, an eval event will be +dispatched calling FUNCTION with EXTENT as its only argument. */ (extent, function)) { EXTENT e = decode_extent(extent, DE_MUST_BE_ATTACHED); e = extent_ancestor (e); /* Is this needed? Macro also does chasing!*/ - set_extent_one_shot_function(e,function); + set_extent_initial_redisplay_function(e,function); + extent_in_red_event_p(e) = 0; /* If the function changed we can spawn + new events */ extent_changed_for_redisplay(e,1,0); /* Do we need to mark children too ?*/ return function; @@ -5090,9 +5094,12 @@ read-only Text within this extent will be unmodifiable. - one-shot-function function to be called the first time (part of) the extent + initial-redisplay-function (EXPERIMENTAL) + function to be called the first time (part of) the extent is redisplayed. It will be called with the extent as its - first argument. + first argument. + Note: The function will not be called immediately + during redisplay, an eval event will be dispatched. detachable Whether the extent gets detached (as with `detach-extent') when all the text within the @@ -5225,8 +5232,8 @@ Fset_extent_priority (extent, value); else if (EQ (property, Qface)) Fset_extent_face (extent, value); - else if (EQ (property, Qone_shot_function)) - Fset_extent_one_shot_function (extent, value); + else if (EQ (property, Qinitial_redisplay_function)) + Fset_extent_initial_redisplay_function (extent, value); else if (EQ (property, Qmouse_face)) Fset_extent_mouse_face (extent, value); /* Obsolete: */ @@ -5264,7 +5271,7 @@ else { if (EQ (property, Qkeymap)) - while (NILP (Fkeymapp (value))) + while (!NILP (value) && NILP (Fkeymapp (value))) value = wrong_type_argument (Qkeymapp, value); external_plist_put (extent_plist_addr (e), property, value, 0, ERROR_ME); @@ -5331,8 +5338,8 @@ return extent_invisible (e); else if (EQ (property, Qface)) return Fextent_face (extent); - else if (EQ (property, Qone_shot_function)) - return extent_one_shot_function (e); + else if (EQ (property, Qinitial_redisplay_function)) + return extent_initial_redisplay_function (e); else if (EQ (property, Qmouse_face)) return Fextent_mouse_face (extent); /* Obsolete: */ @@ -5410,8 +5417,8 @@ result = Fcons (Qpriority, Fcons (make_int (extent_priority (anc)), result)); - if (!NILP (extent_one_shot_function (anc))) - result = Fcons (Qone_shot_function, Fcons (extent_one_shot_function (anc), result)); + if (!NILP (extent_initial_redisplay_function (anc))) + result = Fcons (Qinitial_redisplay_function, Fcons (extent_initial_redisplay_function (anc), result)); if (!NILP (extent_invisible (anc))) result = Fcons (Qinvisible, Fcons (extent_invisible (anc), result)); @@ -6626,7 +6633,7 @@ defsymbol (&Qdetachable, "detachable"); defsymbol (&Qpriority, "priority"); defsymbol (&Qmouse_face, "mouse-face"); - defsymbol (&Qone_shot_function,"one-shot-function"); + defsymbol (&Qinitial_redisplay_function,"initial-redisplay-function"); defsymbol (&Qglyph_layout, "glyph-layout"); /* backwards compatibility */ @@ -6680,7 +6687,7 @@ DEFSUBR (Fmap_extent_children); DEFSUBR (Fextent_at); - DEFSUBR (Fset_extent_one_shot_function); + DEFSUBR (Fset_extent_initial_redisplay_function); DEFSUBR (Fextent_face); DEFSUBR (Fset_extent_face); DEFSUBR (Fextent_mouse_face); @@ -6755,7 +6762,7 @@ extent_auxiliary_defaults.invisible = Qnil; extent_auxiliary_defaults.read_only = Qnil; extent_auxiliary_defaults.mouse_face = Qnil; - extent_auxiliary_defaults.one_shot_function = Qnil; + extent_auxiliary_defaults.initial_redisplay_function = Qnil; } void
--- a/src/extents.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/extents.h Mon Aug 13 10:03:52 2007 +0200 @@ -79,7 +79,9 @@ /* Not used any more */ unsigned int detachable : 1; /* 13 extent detaches if text deleted */ unsigned int internal : 1; /* 14 used by map-extents etc. */ - unsigned int unused15 : 1; /* 15 unused */ + unsigned int in_red_event : 1; /* 15 An event has been spawned for + initial redisplay. Not exported to + the lisp level */ unsigned int unused16 : 1; /* 16 unused */ /* --- Adding more flags will cause the extent struct grow by another word. It's not clear that this would make a difference, however, @@ -132,7 +134,7 @@ Lisp_Object invisible; Lisp_Object read_only; Lisp_Object mouse_face; - Lisp_Object one_shot_function; + Lisp_Object initial_redisplay_function; #ifdef ENERGIZE Energize_Extent_Data *energize_data; #endif @@ -255,7 +257,7 @@ #define extent_invisible(e) extent_aux_field (e, invisible) #define extent_read_only(e) extent_aux_field (e, read_only) #define extent_mouse_face(e) extent_aux_field (e, mouse_face) -#define extent_one_shot_function(e) extent_aux_field (e, one_shot_function) +#define extent_initial_redisplay_function(e) extent_aux_field (e, initial_redisplay_function) #ifdef ENERGIZE #define extent_energize_data(e) extent_aux_field (e, energize_data) #endif @@ -272,9 +274,9 @@ set_extent_aux_field (e, read_only, value) #define set_extent_mouse_face(e, value) \ set_extent_aux_field (e, mouse_face, value) -/* Use Fset_extent_one_shot_function unless you know what you are ding */ -#define set_extent_one_shot_function(e, value) \ - set_extent_aux_field (e, one_shot_function, value) +/* Use Fset_extent_initial_redisplay_function unless you know what you are ding */ +#define set_extent_initial_redisplay_function(e, value) \ + set_extent_aux_field (e, initial_redisplay_function, value) #ifdef ENERGIZE #define set_extent_energize_data(e, value) \ set_extent_aux_field (e, energize_data, value) @@ -290,6 +292,7 @@ #define extent_duplicable_p(e) extent_normal_field (e, duplicable) #define extent_detachable_p(e) extent_normal_field (e, detachable) #define extent_internal_p(e) extent_normal_field (e, internal) +#define extent_in_red_event_p(e) extent_normal_field (e, in_red_event) #define extent_no_chase_plist_addr(e) \ MAC_BEGIN \
--- a/src/faces.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/faces.c Mon Aug 13 10:03:52 2007 +0200 @@ -580,19 +580,20 @@ XFACE (face)->charsets_warned_about))) { #ifdef MULE - warn_when_safe - (Qfont, Qwarning, - "Unable to instantiate font for face %s, charset %s", - string_data (symbol_name - (XSYMBOL (XFACE (face)->name))), - string_data (symbol_name - (XSYMBOL (XCHARSET_NAME (charset))))); -#else - warn_when_safe (Qfont, Qwarning, - "Unable to instantiate font for face %s", - string_data (symbol_name - (XSYMBOL (XFACE (face)->name)))); + if (! UNBOUNDP (charset)) + warn_when_safe + (Qfont, Qwarning, + "Unable to instantiate font for face %s, charset %s", + string_data (symbol_name + (XSYMBOL (XFACE (face)->name))), + string_data (symbol_name + (XSYMBOL (XCHARSET_NAME (charset))))); + else #endif + warn_when_safe (Qfont, Qwarning, + "Unable to instantiate font for face %s", + string_data (symbol_name + (XSYMBOL (XFACE (face)->name)))); XFACE (face)->charsets_warned_about = Fcons (charset, XFACE (face)->charsets_warned_about); }
--- a/src/fns.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/fns.c Mon Aug 13 10:03:52 2007 +0200 @@ -2886,6 +2886,7 @@ /* Note that (equal 20 20.0) should be nil */ else if (XTYPE (o1) != XTYPE (o2)) return 0; +#ifndef LRECORD_CONS else if (CONSP (o1)) { if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1)) @@ -2894,7 +2895,7 @@ o2 = XCDR (o2); goto do_cdr; } - +#endif #ifndef LRECORD_VECTOR else if (VECTORP (o1)) { @@ -2912,7 +2913,8 @@ } return 1; } -#endif /* !LRECORD_VECTOR */ +#endif +#ifndef LRECORD_STRING else if (STRINGP (o1)) { Bytecount len = XSTRING_LENGTH (o1); @@ -2922,6 +2924,7 @@ return 0; return 1; } +#endif else if (LRECORDP (o1)) { CONST struct lrecord_implementation @@ -2956,6 +2959,7 @@ /* Note that (equal 20 20.0) should be nil */ else if (XTYPE (o1) != XTYPE (o2)) return 0; +#ifndef LRECORD_CONS else if (CONSP (o1)) { if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1)) @@ -2964,7 +2968,7 @@ o2 = XCDR (o2); goto do_cdr; } - +#endif #ifndef LRECORD_VECTOR else if (VECTORP (o1)) { @@ -2981,7 +2985,8 @@ } return 1; } -#endif /* !LRECORD_VECTOR */ +#endif +#ifndef LRECORD_STRING else if (STRINGP (o1)) { Bytecount len = XSTRING_LENGTH (o1); @@ -2991,6 +2996,7 @@ return 0; return 1; } +#endif else if (LRECORDP (o1)) { CONST struct lrecord_implementation @@ -3340,27 +3346,29 @@ Lisp_Object Vfeatures; -#ifndef FEATUREP_SYNTAX DEFUN ("featurep", Ffeaturep, 1, 1, 0, /* -Return t if FEATURE is present in this Emacs. +Return non-nil if feature FEXP is present in this Emacs. Use this to conditionalize execution of lisp code based on the -presence or absence of emacs or environment extensions. -Use `provide' to declare that a feature is available. -This function looks at the value of the variable `features'. -*/ - (feature)) -{ - CHECK_SYMBOL (feature); - return NILP (Fmemq (feature, Vfeatures)) ? Qnil : Qt; -} -#else -extern Lisp_Object Vemacs_major_version, Vemacs_minor_version; - -DEFUN ("featurep", Ffeaturep, 1, 1, 0, /* -Return non-nil if feature expression FEXP is true. + presence or absence of emacs or environment extensions. +FEXP can be a symbol, a number, or a list. +If a symbol, it will be looked up in the `features' variable, and + non-nil will be returned if it is found. +If FEXP is a number, the function will return non-nil if this Emacs + has an equal or greater version number than FEXP. +If FEXP is a list whose car is the symbol `and', it will return + non-nil if all the features in its cdr are non-nil. +If FEXP is a list whose car is the symbol `or', it will return non-nil + if any of the features in its cdr are non-nil. +If FEXP is a list whose car is the symbol `not', it will return + non-nil if the feature is not present. */ (fexp)) { +#ifndef FEATUREP_SYNTAX + CHECK_SYMBOL (fexp); + return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; +#else /* FEATUREP_SYNTAX */ + extern Lisp_Object Vemacs_major_version, Vemacs_minor_version; static double featurep_emacs_version; /* Brute force translation from Erik Naggum's lisp function. */ @@ -3387,32 +3395,32 @@ tem = XCAR(fexp); if (EQ(tem, Qnot)) { - Lisp_Object negate = XCDR(fexp); - - if (!NILP(XCDR(fexp))) - { - return Fsignal(Qinvalid_read_syntax, list1(XCDR(fexp))); - } + Lisp_Object negate; + + tem = XCDR (fexp); + negate = Fcar (tem); + if (!NILP (tem)) + return NILP (Ffeaturep (negate)) ? Qt : Qnil; else - { - return NILP(Ffeaturep(negate)) ? Qt : Qnil; - } + return Fsignal (Qinvalid_read_syntax, list1 (tem)); } else if (EQ(tem, Qand)) { tem = XCDR(fexp); - while (!NILP(tem) && !NILP(Ffeaturep(XCAR(tem)))) + /* Use Fcar/Fcdr for error-checking. */ + while (!NILP (tem) && !NILP (Ffeaturep (Fcar (tem)))) { - tem = XCDR(tem); + tem = Fcdr (tem); } return NILP(tem) ? Qt : Qnil; } else if (EQ(tem, Qor)) { - tem = XCDR(fexp); - while (!NILP(tem) && NILP(Ffeaturep(XCAR(tem)))) + tem = XCDR (fexp); + /* Use Fcar/Fcdr for error-checking. */ + while (!NILP (tem) && NILP (Ffeaturep (Fcar (tem)))) { - tem = XCDR(tem); + tem = Fcdr (tem); } return NILP(tem) ? Qnil : Qt; }
--- a/src/frame-x.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/frame-x.c Mon Aug 13 10:03:52 2007 +0200 @@ -1263,13 +1263,13 @@ x_event.xbutton.y_root = lisp_event->event.button.y; modifier = lisp_event->event.button.modifiers; - if (modifier && MOD_SHIFT) state |= ShiftMask; - if (modifier && MOD_CONTROL) state |= ControlMask; - if (modifier && MOD_META) state |= xd->MetaMask; - if (modifier && MOD_SUPER) state |= xd->SuperMask; - if (modifier && MOD_HYPER) state |= xd->HyperMask; - if (modifier && MOD_ALT) state |= xd->AltMask; - state |= (Button1Mask << (lisp_event->event.button.button-1)); + if (modifier & MOD_SHIFT) state |= ShiftMask; + if (modifier & MOD_CONTROL) state |= ControlMask; + if (modifier & MOD_META) state |= xd->MetaMask; + if (modifier & MOD_SUPER) state |= xd->SuperMask; + if (modifier & MOD_HYPER) state |= xd->HyperMask; + if (modifier & MOD_ALT) state |= xd->AltMask; + state |= Button1Mask << (lisp_event->event.button.button-1); x_event.xbutton.state = state; x_event.xbutton.button = lisp_event->event.button.button;
--- a/src/general.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/general.c Mon Aug 13 10:03:52 2007 +0200 @@ -38,7 +38,7 @@ Lisp_Object Qassoc; Lisp_Object Qat; Lisp_Object Qautodetect; -Lisp_Object Qautomatic_conversion; +Lisp_Object Qundecided; Lisp_Object Qbad_variable; Lisp_Object Qbefore; Lisp_Object Qbinary; @@ -173,7 +173,7 @@ defsymbol (&Qassoc, "assoc"); defsymbol (&Qat, "at"); defsymbol (&Qautodetect, "autodetect"); - defsymbol (&Qautomatic_conversion, "automatic-conversion"); + defsymbol (&Qundecided, "undecided"); defsymbol (&Qbad_variable, "bad-variable"); defsymbol (&Qbefore, "before"); defsymbol (&Qbinary, "binary");
--- a/src/glyphs-x.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/glyphs-x.c Mon Aug 13 10:03:52 2007 +0200 @@ -37,8 +37,7 @@ Pointer/icon overhaul, more restructuring by Ben Wing for 19.14 TODO: - TIFF Support - Loadable module support for images + ImageMagick support Convert images.el to C and stick it in here? */ @@ -57,16 +56,14 @@ #include "sysfile.h" -#ifdef HAVE_PNG -#ifdef __cplusplus -extern "C" { -#endif -#include <png.h> -#ifdef __cplusplus -} -#endif -#else -#include <setjmp.h> +#ifdef HAVE_IMAGEMAGICK +#define HAVE_X11_MAGICK_IMAGE_H +#endif /* HAVE_IMAGEMAGICK */ + +#ifdef HAVE_X11_MAGICK_IMAGE_H +#include <magick.h> +/* #include <image.h> */ +#include <assert.h> #endif #define LISP_DEVICE_TO_X_SCREEN(dev) \ @@ -89,24 +86,9 @@ Lisp_Object Qxface; #endif -#ifdef HAVE_JPEG -DEFINE_IMAGE_INSTANTIATOR_FORMAT (jpeg); -Lisp_Object Qjpeg; -#endif - -#ifdef HAVE_PNG -DEFINE_IMAGE_INSTANTIATOR_FORMAT (png); -Lisp_Object Qpng; -#endif - -#ifdef HAVE_TIFF -DEFINE_IMAGE_INSTANTIATOR_FORMAT (tiff); -Lisp_Object Qtiff; -#endif - -#ifdef HAVE_GIF -DEFINE_IMAGE_INSTANTIATOR_FORMAT (gif); -Lisp_Object Qgif; +#ifdef HAVE_IMAGEMAGICK +DEFINE_IMAGE_INSTANTIATOR_FORMAT (imagick); +Lisp_Object Qimagick; #endif DEFINE_IMAGE_INSTANTIATOR_FORMAT (cursor_font); @@ -960,7 +942,7 @@ break; case IMAGE_POINTER: - { + { XColor fg_color, bg_color; Pixmap source; @@ -999,7 +981,7 @@ abort (); } } - + static int xbm_possible_dest_types (void) { @@ -1023,7 +1005,7 @@ CONST char *gcc_may_you_rot_in_hell; if (!NILP (mask_data)) - { +{ GET_C_STRING_BINARY_DATA_ALLOCA (XCAR (XCDR (XCDR (mask_data))), gcc_may_you_rot_in_hell); mask = @@ -1032,7 +1014,7 @@ XINT (XCAR (XCDR (mask_data))), (CONST unsigned char *) gcc_may_you_rot_in_hell); - } +} init_image_instance_from_xbm_inline (ii, width, height, bits, instantiator, pointer_fg, pointer_bg, @@ -1043,8 +1025,8 @@ static void xbm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, Lisp_Object pointer_bg, - int dest_mask, Lisp_Object domain) + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) { Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); CONST char *gcc_go_home; @@ -1060,1285 +1042,6 @@ } -#define USE_TEMP_FILES_FOR_PNG_IMAGES 1 - -#ifdef HAVE_JPEG - -/********************************************************************** - * JPEG * - **********************************************************************/ - -#ifdef __cplusplus -extern "C" { -#endif -#include <jpeglib.h> -#include <jerror.h> -#ifdef __cplusplus -} -#endif - -/* The in-core jpeg code doesn't work, so I'm avoiding it for now. -sb */ -/* Late-breaking update, we're going to give it a try, I think it's */ -/* fixed now -sb */ -/*#define USE_TEMP_FILES_FOR_JPEG_IMAGES 1*/ -static void -jpeg_validate (Lisp_Object instantiator) -{ - file_or_data_must_be_present (instantiator); -} - -static Lisp_Object -jpeg_normalize (Lisp_Object inst, Lisp_Object console_type) -{ - return simple_image_type_normalize (inst, console_type, Qjpeg); -} - -static int -jpeg_possible_dest_types (void) -{ - return IMAGE_COLOR_PIXMAP_MASK; -} - -/* To survive the otherwise baffling complexity of making sure - everything gets cleaned up in the presence of an error, we - use an unwind_protect(). */ - -struct jpeg_unwind_data -{ - Display *dpy; - /* Stream that we need to close */ - FILE *instream; - /* Object that holds state info for JPEG decoding */ - struct jpeg_decompress_struct *cinfo_ptr; - /* Pixels to keep around while the image is active */ - unsigned long *pixels; - int npixels; - /* Client-side image structure */ - XImage *ximage; - /* Tempfile to remove */ - char tempfile[50]; - int tempfile_needs_to_be_removed; -}; - -static Lisp_Object -jpeg_instantiate_unwind (Lisp_Object unwind_obj) -{ - struct jpeg_unwind_data *data = - (struct jpeg_unwind_data *) get_opaque_ptr (unwind_obj); - - free_opaque_ptr (unwind_obj); - if (data->cinfo_ptr) - jpeg_destroy_decompress (data->cinfo_ptr); - - if (data->instream) - fclose (data->instream); - - if (data->tempfile_needs_to_be_removed) - unlink (data->tempfile); - - if (data->npixels > 0) - { - Screen *scr = DefaultScreenOfDisplay (data->dpy); - Colormap cmap = DefaultColormapOfScreen (scr); - XFreeColors (data->dpy, cmap, data->pixels, data->npixels, 0L); - xfree (data->pixels); - } - - if (data->ximage) - { - if (data->ximage->data) - { - xfree (data->ximage->data); - data->ximage->data = 0; - } - XDestroyImage (data->ximage); - } - - return Qnil; -} - -/* - * ERROR HANDLING: - * - * The JPEG library's standard error handler (jerror.c) is divided into - * several "methods" which you can override individually. This lets you - * adjust the behavior without duplicating a lot of code, which you might - * have to update with each future release. - * - * Our example here shows how to override the "error_exit" method so that - * control is returned to the library's caller when a fatal error occurs, - * rather than calling exit() as the standard error_exit method does. - * - * We use C's setjmp/longjmp facility to return control. This means that the - * routine which calls the JPEG library must first execute a setjmp() call to - * establish the return point. We want the replacement error_exit to do a - * longjmp(). But we need to make the setjmp buffer accessible to the - * error_exit routine. To do this, we make a private extension of the - * standard JPEG error handler object. (If we were using C++, we'd say we - * were making a subclass of the regular error handler.) - * - * Here's the extended error handler struct: - */ - -struct my_jpeg_error_mgr -{ - struct jpeg_error_mgr pub; /* "public" fields */ - jmp_buf setjmp_buffer; /* for return to caller */ -}; - -#if defined(JPEG_LIB_VERSION) && (JPEG_LIB_VERSION >= 61) -METHODDEF(void) -#else -METHODDEF void -#endif -our_init_source (j_decompress_ptr cinfo) { -} - -#if defined(JPEG_LIB_VERSION) && (JPEG_LIB_VERSION >= 61) -METHODDEF(boolean) -#else -METHODDEF boolean -#endif -our_fill_input_buffer (j_decompress_ptr cinfo) { - /* Insert a fake EOI marker */ - struct jpeg_source_mgr *src = (struct jpeg_source_mgr *) cinfo->src; - static JOCTET buffer[2]; - - buffer[0] = (JOCTET) 0xFF; - buffer[1] = (JOCTET) JPEG_EOI; - - src->next_input_byte = buffer; - src->bytes_in_buffer = 2; - return TRUE; -} - -#if defined(JPEG_LIB_VERSION) && (JPEG_LIB_VERSION >= 61) -METHODDEF(void) -#else -METHODDEF void -#endif -our_skip_input_data (j_decompress_ptr cinfo, long num_bytes) { - struct jpeg_source_mgr *src = NULL; - - src = (struct jpeg_source_mgr *) cinfo->src; - - if (!src) { - return; - } else if (num_bytes > src->bytes_in_buffer) { - ERREXIT(cinfo, JERR_INPUT_EOF); - /*NOTREACHED*/ - } - - src->bytes_in_buffer -= num_bytes; - src->next_input_byte += num_bytes; -} - -#if defined(JPEG_LIB_VERSION) && (JPEG_LIB_VERSION >= 61) -METHODDEF(void) -#else -METHODDEF void -#endif -our_term_source (j_decompress_ptr cinfo) { -} - -typedef struct { - struct jpeg_source_mgr pub; -} our_jpeg_source_mgr; - -static void -jpeg_memory_src (j_decompress_ptr cinfo, JOCTET *data, unsigned int len) -{ - struct jpeg_source_mgr *src = NULL; - - if (cinfo->src == NULL) { /* first time for this JPEG object? */ - cinfo->src = (struct jpeg_source_mgr *) - (*cinfo->mem->alloc_small) ((j_common_ptr) cinfo, JPOOL_PERMANENT, - sizeof(our_jpeg_source_mgr)); - src = (struct jpeg_source_mgr *) cinfo->src; - src->next_input_byte = data; - } - src = (struct jpeg_source_mgr *) cinfo->src; - src->init_source = our_init_source; - src->fill_input_buffer = our_fill_input_buffer; - src->skip_input_data = our_skip_input_data; - src->resync_to_restart = jpeg_resync_to_restart; /* use default method */ - src->term_source = our_term_source; - src->bytes_in_buffer = len; - src->next_input_byte = data; -} - -#if defined(JPEG_LIB_VERSION) && (JPEG_LIB_VERSION >= 61) -METHODDEF(void) -#else -METHODDEF void -#endif -my_jpeg_error_exit (j_common_ptr cinfo) -{ - /* cinfo->err really points to a my_error_mgr struct, so coerce pointer */ - struct my_jpeg_error_mgr *myerr = (struct my_jpeg_error_mgr *) cinfo->err; - - /* Return control to the setjmp point */ - longjmp (myerr->setjmp_buffer, 1); -} - -/* The code in this routine is based on example.c from the JPEG library - source code and from gif_instantiate() */ -static void -jpeg_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, Lisp_Object pointer_bg, - int dest_mask, Lisp_Object domain) -{ - struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); - Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); - Display *dpy; - Screen *scr; - /* It is OK for the unwind data to be local to this function, - because the unwind-protect is always executed when this - stack frame is still valid. */ - struct jpeg_unwind_data unwind; - int speccount = specpdl_depth (); - - /* This struct contains the JPEG decompression parameters and pointers to - * working space (which is allocated as needed by the JPEG library). - */ - struct jpeg_decompress_struct cinfo; - /* We use our private extension JPEG error handler. - * Note that this struct must live as long as the main JPEG parameter - * struct, to avoid dangling-pointer problems. - */ - struct my_jpeg_error_mgr jerr; - - if (!DEVICE_X_P (XDEVICE (device))) - signal_simple_error ("Not an X device", device); - - dpy = DEVICE_X_DISPLAY (XDEVICE (device)); - scr = DefaultScreenOfDisplay (dpy); - - /* Step -1: First record our unwind-protect, which will clean up after - any exit, normal or not */ - - memset (&unwind, 0, sizeof (unwind)); - unwind.dpy = dpy; - record_unwind_protect (jpeg_instantiate_unwind, make_opaque_ptr (&unwind)); - -#ifdef USE_TEMP_FILES_FOR_JPEG_IMAGES - /* Step 0: Write out to a temp file. - - The JPEG routines require you to read from a file unless - you provide your own special input handlers, which I don't - feel like doing. */ - { - Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - - assert (!NILP (data)); - - write_lisp_string_to_temp_file (data, unwind.tempfile); - unwind.tempfile_needs_to_be_removed = 1; - - /* VERY IMPORTANT: use "b" option to fopen() if you are on a machine that - * requires it in order to read binary files. - */ - - if ((unwind.instream = fopen (unwind.tempfile, "r")) == NULL) - report_file_error ("Opening JPEG temp file", - list1 (build_string (unwind.tempfile))); - } -#endif - - /* Step 1: allocate and initialize JPEG decompression object */ - - /* We set up the normal JPEG error routines, then override error_exit. */ - cinfo.err = jpeg_std_error (&jerr.pub); - jerr.pub.error_exit = my_jpeg_error_exit; - - /* Establish the setjmp return context for my_error_exit to use. */ - if (setjmp (jerr.setjmp_buffer)) - { - /* If we get here, the JPEG code has signaled an error. - * We need to clean up the JPEG object, close the input file, and return. - */ - - { - Lisp_Object errstring; - char buffer[JMSG_LENGTH_MAX]; - - /* Create the message */ - (*cinfo.err->format_message) ((j_common_ptr) &cinfo, buffer); - errstring = build_string (buffer); - - signal_simple_error_2 ("JPEG decoding error", - errstring, instantiator); - } - } - - /* Now we can initialize the JPEG decompression object. */ - jpeg_create_decompress (&cinfo); - unwind.cinfo_ptr = &cinfo; - - /* Step 2: specify data source (eg, a file) */ - -#ifdef USE_TEMP_FILES_FOR_JPEG_IMAGES - jpeg_stdio_src (&cinfo, unwind.instream); -#else - { - Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - Extbyte *bytes; - Extcount len; - - /* #### This is a definite problem under Mule due to the amount of - stack data it might allocate. Need to be able to convert and - write out to a file. */ - GET_STRING_BINARY_DATA_ALLOCA (data, bytes, len); - jpeg_memory_src (&cinfo, bytes, len); - } -#endif - - /* Step 3: read file parameters with jpeg_read_header() */ - - jpeg_read_header (&cinfo, TRUE); - /* We can ignore the return value from jpeg_read_header since - * (a) suspension is not possible with the stdio data source, and - * (b) we passed TRUE to reject a tables-only JPEG file as an error. - * See libjpeg.doc for more info. - */ - - /* Step 4: set parameters for decompression. */ - - /* We request that the JPEG file be automatically quantized into - 8-bit color in case it's not already (many JPEGs are stored in - 24-bit color). "Two-pass quantize" means that the colormap - is determined on-the-fly for this particular image rather than - quantizing to a supplied colormap. We can get away with this - because we then use allocate_nearest_color(). - - #### Note of course that this is not the most color-effective - way of doing things -- we could quantize an image that has - lots of very similar colors, and eat up the colormap with these - (useless to other images) colors. Unfortunately I don't think - there's any "general" way of maximizing the overall image - quality of lots of images, given that we don't know the - colors of the images until we come across each one. Best we - could do would be various sorts of heuristics, which I don't - feel like dealing with now. A better scheme would be the - way things are done under MS Windows, where the colormap is - dynamically adjusted for various applications; but that kind - of thing would have to be provided by X, which it isn't. */ - - cinfo.quantize_colors = TRUE; - cinfo.two_pass_quantize = TRUE; - cinfo.colormap = NULL; - - /* Step 5: Start decompressor */ - - jpeg_start_decompress (&cinfo); - /* We can ignore the return value since suspension is not possible - * with the stdio data source. - */ - - /* At this point we know the size of the image and the colormap. */ - - /* Step 5.33: Allocate the colors */ - { - int i; - - /* Just in case the image contains out-of-range pixels, we go - ahead and allocate space for all of them. */ - unwind.pixels = xnew_array (unsigned long, 256); - unwind.npixels = cinfo.actual_number_of_colors; - - for (i = 0; i < 256; i++) - unwind.pixels[i] = 0; /* Use a reasonable color for out of range. */ - - /* Allocate pixels for the various colors. */ - for (i = 0; i < unwind.npixels; i++) - { - XColor color; - int ri, gi, bi; - - ri = 0; - gi = cinfo.out_color_components > 1 ? 1 : 0; - bi = cinfo.out_color_components > 2 ? 2 : 0; - - /* Ok... apparently, an entry of cinfo.colormap can be NULL if - there are no bits of that color in the image. How incredibly - gross. Wouldn't it be nice to have exceptions!? */ - color.red = cinfo.colormap[ri] ? cinfo.colormap[ri][i] << 8 : 0; - color.green = cinfo.colormap[gi] ? cinfo.colormap[gi][i] << 8 : 0; - color.blue = cinfo.colormap[bi] ? cinfo.colormap[bi][i] << 8 : 0; - color.flags = DoRed | DoGreen | DoBlue; - - allocate_nearest_color (dpy, DefaultColormapOfScreen (scr), &color); - unwind.pixels[i] = color.pixel; - } - } - - /* Step 5.66: Create the image */ - { - int height = cinfo.output_height; - int width = cinfo.output_width; - int depth; - int bitmap_pad; - - depth = DefaultDepthOfScreen (scr); - - /* first get bitmap_pad (from XPM) */ - bitmap_pad = ((depth > 16) ? 32 : - (depth > 8) ? 16 : - 8); - - unwind.ximage = XCreateImage (dpy, DefaultVisualOfScreen (scr), - depth, ZPixmap, 0, 0, width, height, - bitmap_pad, 0); - - if (!unwind.ximage) - signal_simple_error ("Unable to create X image struct", instantiator); - - /* now that bytes_per_line must have been set properly alloc data */ - unwind.ximage->data = - (char *) xmalloc (unwind.ximage->bytes_per_line * height); - } - - /* Step 6: Read in the data and put into image */ - { - JSAMPARRAY row_buffer; /* Output row buffer */ - int row_stride; /* physical row width in output buffer */ - - /* We may need to do some setup of our own at this point before reading - * the data. After jpeg_start_decompress() we have the correct scaled - * output image dimensions available, as well as the output colormap - * if we asked for color quantization. - * In this example, we need to make an output work buffer of the right size. - */ - /* JSAMPLEs per row in output buffer. - Since we asked for quantized output, cinfo.output_components - will always be 1. */ - row_stride = cinfo.output_width * cinfo.output_components; - /* Make a one-row-high sample array that will go away when done - with image */ - row_buffer = ((*cinfo.mem->alloc_sarray) - ((j_common_ptr) &cinfo, JPOOL_IMAGE, row_stride, 1)); - - /* Here we use the library's state variable cinfo.output_scanline as the - * loop counter, so that we don't have to keep track ourselves. - */ - while (cinfo.output_scanline < cinfo.output_height) - { - int i; - int scanline = cinfo.output_scanline; - - /* jpeg_read_scanlines expects an array of pointers to scanlines. - * Here the array is only one element long, but you could ask for - * more than one scanline at a time if that's more convenient. - */ - (void) jpeg_read_scanlines (&cinfo, row_buffer, 1); - - for (i = 0; i < cinfo.output_width; i++) - XPutPixel (unwind.ximage, i, scanline, - /* Let's make sure we avoid getting bit like - what happened for GIF's. It's probably the - case that JSAMPLE's are unsigned chars as - opposed to chars, but you never know. - - (They could even be shorts if the library - was compiled with 12-bit samples -- #### - We should deal with this possibility) */ - unwind.pixels[(unsigned char) row_buffer[0][i]]); - } - } - - /* Step 6.5: Create the pixmap and set up the image instance */ - init_image_instance_from_x_image (ii, unwind.ximage, dest_mask, - unwind.pixels, unwind.npixels, - instantiator); - - /* Step 7: Finish decompression */ - - jpeg_finish_decompress (&cinfo); - /* We can ignore the return value since suspension is not possible - * with the stdio data source. - */ - - /* And we're done! - - Now that we've succeeded, we don't want the pixels - freed right now. They're kept around in the image instance - structure until it's destroyed. */ - unwind.npixels = 0; - - /* This will clean up everything else. */ - unbind_to (speccount, Qnil); -} - -#endif /* HAVE_JPEG */ - - -#ifdef HAVE_GIF - -/********************************************************************** - * GIF * - **********************************************************************/ - -#include "gif_lib.h" /* This is in our own source tree */ - -static void -gif_validate (Lisp_Object instantiator) -{ - file_or_data_must_be_present (instantiator); -} - -static Lisp_Object -gif_normalize (Lisp_Object inst, Lisp_Object console_type) -{ - return simple_image_type_normalize (inst, console_type, Qgif); -} - -static int -gif_possible_dest_types (void) -{ - return IMAGE_COLOR_PIXMAP_MASK; -} - -/* To survive the otherwise baffling complexity of making sure - everything gets cleaned up in the presence of an error, we - use an unwind_protect(). */ - -struct gif_unwind_data -{ - Display *dpy; - /* Object that holds the decoded data from a GIF file */ - GifFileType *giffile; - /* Pixels to keep around while the image is active */ - unsigned long *pixels; - int npixels; - /* Client-side image structure */ - XImage *ximage; - /* Tempfile to remove */ - char tempfile[50]; - int tempfile_needs_to_be_removed; -}; - -static Lisp_Object -gif_instantiate_unwind (Lisp_Object unwind_obj) -{ - struct gif_unwind_data *data = - (struct gif_unwind_data *) get_opaque_ptr (unwind_obj); - - free_opaque_ptr (unwind_obj); - if (data->giffile) - DGifCloseFile (data->giffile); - if (data->tempfile_needs_to_be_removed) - unlink (data->tempfile); - if (data->npixels > 0) - { - Screen *scr = DefaultScreenOfDisplay (data->dpy); - Colormap cmap = DefaultColormapOfScreen (scr); - XFreeColors (data->dpy, cmap, data->pixels, data->npixels, 0L); - xfree (data->pixels); - } - if (data->ximage) - { - if (data->ximage->data) - { - xfree (data->ximage->data); - data->ximage->data = 0; - } - XDestroyImage (data->ximage); - } - - return Qnil; -} - -#if 0 -/* We provide our own version of DGifSlurp() because the standardly - provided one doesn't handle interlaced GIFs. This is based on - code in gif2x11.c. */ - -/* Return value is GIF_ERROR, GIF_OK, or -1. - #### We are using "forbidden" knowledge that neither of these - constants is -1. */ - -static int -our_own_dgif_slurp_from_gif2x11_c (GifFileType *GifFile) -{ - int i, j, Row, Col, Width, Height; - int ExtCode, Count; - GifRecordType RecordType; - GifByteType *Extension; - SavedImage *sp = NULL; - static int InterlacedOffset[] = { 0, 4, 2, 1 }; - static int InterlacedJumps[] = { 8, 8, 4, 2 }; - - GifPixelType *ScreenBuffer = - (GifPixelType *) xmalloc (GifFile->SHeight * GifFile->SWidth * - sizeof (GifPixelType)); - GifFile->SavedImages = xnew (SavedImage); - - for (i = 0; i < GifFile->SHeight * GifFile->SWidth; i++) - ScreenBuffer[i] = GifFile->SBackGroundColor; - - /* Scan the content of the GIF file and load the image(s) in: */ - do - { - if (DGifGetRecordType (GifFile, &RecordType) == GIF_ERROR) - return GIF_ERROR; - - switch (RecordType) - { - case IMAGE_DESC_RECORD_TYPE: - if (DGifGetImageDesc (GifFile) == GIF_ERROR) - return GIF_ERROR; - - sp = &GifFile->SavedImages[GifFile->ImageCount-1]; - Row = GifFile->Image.Top; /* Image Position relative to Screen. */ - Col = GifFile->Image.Left; - Width = GifFile->Image.Width; - Height = GifFile->Image.Height; - if (GifFile->Image.Left + GifFile->Image.Width > GifFile->SWidth || - GifFile->Image.Top + GifFile->Image.Height > GifFile->SHeight) - return -1; - - sp->RasterBits = (GifPixelType*) xmalloc(Width * Height * - sizeof (GifPixelType)); - - if (GifFile->Image.Interlace) - { - /* Need to perform 4 passes on the images: */ - for (Count = i = 0; i < 4; i++) - for (j = Row + InterlacedOffset[i]; j < Row + Height; - j += InterlacedJumps[i]) - { - if (DGifGetLine (GifFile, &sp->RasterBits[j * Width + Col], - Width) == GIF_ERROR) - return GIF_ERROR; - } - } - else - { - for (i = 0; i < Height; i++) - { - if (DGifGetLine (GifFile, - &sp->RasterBits[(Row++) * Width + Col], - Width) == GIF_ERROR) - return GIF_ERROR; - } - } - - /* Only get 1 image from animated gifs. */ - /* #### if the rest of the file was bad, we still return - GIF_OK, since we don't even bother looking at it. Should - probably check for ImageCount == 1 above too, hmm. */ - goto done; - break; - - case EXTENSION_RECORD_TYPE: - /* Skip any extension blocks in file: */ - if (DGifGetExtension (GifFile, &ExtCode, &Extension) == GIF_ERROR) - return GIF_ERROR; - - while (Extension != NULL) - { - if (DGifGetExtensionNext (GifFile, &Extension) == GIF_ERROR) - return GIF_ERROR; - } - break; - - case TERMINATE_RECORD_TYPE: - break; - - default: /* Should be traps by DGifGetRecordType. */ - break; - } - } - while (RecordType != TERMINATE_RECORD_TYPE); - - done: - - return GIF_OK; -} -#endif - -static void -gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, Lisp_Object pointer_bg, - int dest_mask, Lisp_Object domain) -{ - struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); - Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); - Display *dpy; - Screen *scr; - /* It is OK for the unwind data to be local to this function, - because the unwind-protect is always executed when this - stack frame is still valid. */ - struct gif_unwind_data unwind; - int speccount = specpdl_depth (); - - if (!DEVICE_X_P (XDEVICE (device))) - signal_simple_error ("Not an X device", device); - - dpy = DEVICE_X_DISPLAY (XDEVICE (device)); - scr = DefaultScreenOfDisplay (dpy); - - memset (&unwind, 0, sizeof (unwind)); - unwind.dpy = dpy; - record_unwind_protect (gif_instantiate_unwind, make_opaque_ptr (&unwind)); - - /* 1. Now decode the data. */ - - /* #### The GIF routines currently require that you read from a file, - so write out to a temp file. We should change this. */ - { - Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - - assert (!NILP (data)); - - write_lisp_string_to_temp_file (data, unwind.tempfile); - unwind.tempfile_needs_to_be_removed = 1; - - /* Then slurp the image into memory, decoding along the way. - The result is the image in a simple one-byte-per-pixel - format (#### the GIF routines only support 8-bit GIFs, - it appears). */ - unwind.giffile = DGifOpenFileName (unwind.tempfile); - if (unwind.giffile == NULL) - { - gif_decode_error: - signal_simple_error ("Unable to decode GIF", - build_string (EmacsPrintGifError ())); - } -#if 0 - if (our_own_dgif_slurp_from_gif2x11_c(unwind.giffile) != GIF_OK) -#else - /* DGifSlurp() doesn't handle interlaced files. */ - /* Actually, it does, sort of. It just sets the Interlace flag - and stores RasterBits in interlaced order. We handle that below. */ - if (DGifSlurp (unwind.giffile) != GIF_OK) -#endif - goto gif_decode_error; - } - - /* 2. Now allocate the colors for the image. */ - { - int i; - ColorMapObject *cmap = unwind.giffile->SColorMap; - /* Just in case the image contains out-of-range pixels, we go - ahead and allocate space for all of them. */ - unwind.pixels = xnew_array (unsigned long, 256); - unwind.npixels = cmap->ColorCount; - - for (i = 0; i < 256; i++) - unwind.pixels[i] = 0; /* Use a reasonable color for out of range. */ - - /* Allocate pixels for the various colors. */ - for (i = 0; i < cmap->ColorCount; i++) - { - XColor color; - - color.red = cmap->Colors[i].Red << 8; - color.green = cmap->Colors[i].Green << 8; - color.blue = cmap->Colors[i].Blue << 8; - color.flags = DoRed | DoGreen | DoBlue; - - allocate_nearest_color (dpy, DefaultColormapOfScreen (scr), &color); - unwind.pixels[i] = color.pixel; - } - } - - /* 3. Now create the image */ - { - int height = unwind.giffile->SHeight; - int width = unwind.giffile->SWidth; - int depth; - int bitmap_pad; - int i, j, row, pass, interlace; - /* interlaced gifs have rows in this order: - 0, 8, 16, ..., 4, 12, 20, ..., 2, 6, 10, ..., 1, 3, 5, ... */ - static int InterlacedOffset[] = { 0, 4, 2, 1 }; - static int InterlacedJumps[] = { 8, 8, 4, 2 }; - - - depth = DefaultDepthOfScreen (scr); - - /* first get bitmap_pad (from XPM) */ - bitmap_pad = ((depth > 16) ? 32 : - (depth > 8) ? 16 : - 8); - - unwind.ximage = XCreateImage (dpy, DefaultVisualOfScreen (scr), - depth, ZPixmap, 0, 0, width, height, - bitmap_pad, 0); - - if (!unwind.ximage) - signal_simple_error ("Unable to create X image struct", instantiator); - - /* now that bytes_per_line must have been set properly alloc data */ - unwind.ximage->data = - (char *) xmalloc (unwind.ximage->bytes_per_line * height); - - /* write the data -- - #### XPutPixel() is a client-side-only function but could - still be slow. Another possibility is to just convert to - XPM format and use the Xpm routines, which optimize this - stuff; but it's doubtful that this will be faster in the - long run, what with all the XPM overhead. If this proves - to be a bottleneck here, maybe we should just copy the - optimization routines from XPM (they're in turn mostly - copied from the Xlib source code). */ - - /* Note: We just use the first image in the file and ignore the rest. - We check here that that image covers the full "screen" size. - I don't know whether that's always the case. - -dkindred@cs.cmu.edu */ - if (unwind.giffile->SavedImages[0].ImageDesc.Height != height - || unwind.giffile->SavedImages[0].ImageDesc.Width != width - || unwind.giffile->SavedImages[0].ImageDesc.Left != 0 - || unwind.giffile->SavedImages[0].ImageDesc.Top != 0) - signal_simple_error ("First image in GIF file is not full size", - instantiator); - - interlace = unwind.giffile->SavedImages[0].ImageDesc.Interlace; - pass = 0; - row = interlace ? InterlacedOffset[pass] : 0; - for (i = 0; i < height; i++) - { - if (interlace && row >= height) - row = InterlacedOffset[++pass]; - - for (j = 0; j < width; j++) - XPutPixel (unwind.ximage, j, row, - unwind.pixels[(unsigned char) - /* incorrect signed declaration - of RasterBits[] */ - (unwind.giffile->SavedImages[0]. - RasterBits[i * width + j])]); - - row += interlace ? InterlacedJumps[pass] : 1; - } - } - - /* 4. Now create the pixmap and set up the image instance */ - init_image_instance_from_x_image (ii, unwind.ximage, dest_mask, - unwind.pixels, unwind.npixels, - instantiator); - /* Now that we've succeeded, we don't want the pixels - freed right now. They're kept around in the image instance - structure until it's destroyed. */ - unwind.npixels = 0; - unbind_to (speccount, Qnil); -} - -#endif /* HAVE_GIF */ - - -#ifdef HAVE_PNG - -/********************************************************************** - * PNG * - **********************************************************************/ -static void -png_validate (Lisp_Object instantiator) -{ - file_or_data_must_be_present (instantiator); -} - -static Lisp_Object -png_normalize (Lisp_Object inst, Lisp_Object console_type) -{ - return simple_image_type_normalize (inst, console_type, Qpng); -} - -static int -png_possible_dest_types (void) -{ - return IMAGE_COLOR_PIXMAP_MASK; -} - -#if !defined (USE_TEMP_FILES_FOR_PNG_IMAGES) && (PNG_LIBPNG_VER >= 87) -struct png_memory_storage -{ - Extbyte *bytes; /* The data */ - Extcount len; /* How big is it? */ - int index; /* Where are we? */ -}; - -static void png_read_from_memory(png_structp png_ptr, png_bytep data, - png_uint_32 length) -{ - struct png_memory_storage *tbr = - (struct png_memory_storage *) png_get_io_ptr (png_ptr); - - if (length > (tbr->len - tbr->index)) - png_error (png_ptr, (png_const_charp) "Read Error"); - memcpy(data,tbr->bytes + tbr->index,length); - tbr->index = tbr->index + length; -} -#endif /* !USE_TEMP_FILES_FOR_PNG_IMAGESS || PNG_LIBPNG_VER >= 87 */ - -struct png_unwind_data -{ - Display *dpy; - FILE *instream; - png_struct *png_ptr; - png_info *info_ptr; - unsigned long *pixels; - int npixels; - XImage *ximage; - char tempfile[50]; - int tempfile_needs_to_be_removed; -}; - -static Lisp_Object -png_instantiate_unwind (Lisp_Object unwind_obj) -{ - struct png_unwind_data *data = - (struct png_unwind_data *) get_opaque_ptr (unwind_obj); - - free_opaque_ptr (unwind_obj); - if (data->png_ptr) - png_read_destroy (data->png_ptr, data->info_ptr, (png_info *) NULL); - if (data->instream) - fclose (data->instream); - if (data->tempfile_needs_to_be_removed) - unlink (data->tempfile); - if (data->npixels > 0) - { - Screen *scr = DefaultScreenOfDisplay (data->dpy); - Colormap cmap = DefaultColormapOfScreen (scr); - XFreeColors (data->dpy, cmap, data->pixels, data->npixels, 0L); - xfree (data->pixels); - } - - if (data->ximage) - { - if (data->ximage->data) - { - xfree (data->ximage->data); - data->ximage->data = 0; - } - XDestroyImage (data->ximage); - } - - return Qnil; -} - -/* This doesn't appear to be used. */ -#if 0 -#define get_png_val(p) _get_png_val (&(p), info_ptr.bit_depth) -png_uint_16 -_get_png_val (png_byte **pp, int bit_depth) -{ - png_uint_16 c = 0; - - if (bit_depth == 16) { - c = (*((*pp)++)) << 8; - } - c |= (*((*pp)++)); - - return c; -} -#endif - -static void -png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, Lisp_Object pointer_bg, - int dest_mask, Lisp_Object domain) -{ - struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); - Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); - Display *dpy; - Screen *scr; - struct png_unwind_data unwind; - int speccount = specpdl_depth (); - - /* PNG variables */ - png_struct *png_ptr; - png_info *info_ptr; - - if (!DEVICE_X_P (XDEVICE (device))) - signal_simple_error ("Not an X device", device); - - dpy = DEVICE_X_DISPLAY (XDEVICE (device)); - scr = DefaultScreenOfDisplay (dpy); - - png_ptr = xnew (png_struct); - info_ptr = xnew (png_info); - - memset (&unwind, 0, sizeof (unwind)); - unwind.png_ptr = png_ptr; - unwind.info_ptr = info_ptr; - unwind.dpy = dpy; - - record_unwind_protect (png_instantiate_unwind, make_opaque_ptr (&unwind)); - - /* This code is a mixture of stuff from Ben's GIF/JPEG stuff from - this file, example.c from the libpng 0.81 distribution, and the - pngtopnm sources. -WMP- - */ -#if defined (USE_TEMP_FILES_FOR_PNG_IMAGES) || (PNG_LIBPNG_VER < 87) - /* Write out to a temp file - we really should take the time to - write appropriate memory bound IO stuff, but I am just trying - to get the stupid thing working right now. - */ - { - Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - - assert (!NILP (data)); - - write_lisp_string_to_temp_file (data, unwind.tempfile); - unwind.tempfile_needs_to_be_removed = 1; - - if ((unwind.instream = fopen (unwind.tempfile, "rb")) == NULL) - report_file_error ("Opening PNG temp file", - list1 (build_string (unwind.tempfile))); - } -#else - /* Nothing */ -#endif - - /* Set the jmp_buf reurn context for png_error ... if this returns !0, then - we ran into a problem somewhere, and need to clean up after ourselves. */ - if (setjmp (png_ptr->jmpbuf)) - { - /* Am I doing enough here? I think so, since most things happen - in png_unwind */ - png_read_destroy (png_ptr, info_ptr, (png_info *) NULL); - signal_simple_error ("Error decoding PNG", instantiator); - } - - /* Initialize all PNG structures */ - png_info_init (info_ptr); - png_read_init (png_ptr); - - /* Initialize the IO layer and read in header information */ -#if defined (USE_TEMP_FILES_FOR_PNG_IMAGES) || (PNG_LIBPNG_VER < 87) - png_init_io (png_ptr, unwind.instream); -#else - { - Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - Extbyte *bytes; - Extcount len; - struct png_memory_storage tbr; /* Data to be read */ - - assert (!NILP (data)); - - /* #### This is a definite problem under Mule due to the amount of - stack data it might allocate. Need to be able to convert and - write out to a file. */ - GET_STRING_BINARY_DATA_ALLOCA (data, bytes, len); - tbr.bytes = bytes; - tbr.len = len; - tbr.index = 0; - png_set_read_fn(png_ptr,(void *) &tbr, png_read_from_memory); - } -#endif - - png_read_info (png_ptr, info_ptr); - - /* set up the transformations you want. Note that these are - all optional. Only call them if you want them */ - /* tell libpng to strip 16 bit depth files down to 8 bits */ - if (info_ptr->bit_depth == 16) - png_set_strip_16 (png_ptr); - if (info_ptr->bit_depth < 8) - png_set_packing (png_ptr); - /* ##### Perhaps some way to specify the screen gamma should be in here? */ - - { - int height = info_ptr->height; - int width = info_ptr->width; - int depth = info_ptr->bit_depth; - int linesize = max (info_ptr->bit_depth >> 3, 1) * width; - int bitmap_pad; - int y; - XColor color; - png_byte *png_pixels; - png_byte **row_pointers; - png_color static_color_cube[216]; - - /* Wow, allocate all the memory. Truly, exciting. */ - unwind.pixels = xnew_array (unsigned long, 256); - png_pixels = xnew_array (png_byte, linesize * height); - row_pointers = xnew_array (png_byte *, height); - - for (y = 0; y < 256; y++) - unwind.pixels[y] = 0; - for (y = 0; y < height; y++) - row_pointers[y] = png_pixels + (linesize * y); - - /* #### This is where we should handle transparency, but I am unsure of - how exactly to get that information right now, in a safe manner. */ -#if 0 - { - png_color_16 current_background; - - /* Some appropriate magic should go here to get the current - buffers (device?) background color and convert it to a - png_color_16 struct */ - if (info_ptr->valid & PNG_INFO_bKGD) - png_set_background (png_ptr, &(info_ptr->background), PNG_GAMMA_FILE, - 1, 1.0); - else - png_set_background (png_ptr, ¤t_background, PNG_GAMMA_SCREEN, - 0, 1.0); - } -#endif - - if ((info_ptr->color_type == PNG_COLOR_TYPE_RGB) || - (info_ptr->color_type == PNG_COLOR_TYPE_RGB_ALPHA)) - { - if (!(info_ptr->valid & PNG_INFO_PLTE)) - { - for (y = 0; y < 216; y++) - { - static_color_cube[y].red = (y % 6) * 255.0 / 5; - static_color_cube[y].green = ((y / 6) % 6) * 255.0 / 5; - static_color_cube[y].blue = (y / 36) * 255.0 / 5; - } - png_set_dither (png_ptr, static_color_cube, 216, 216, NULL, 1); - } - else - { - png_set_dither (png_ptr, info_ptr->palette, info_ptr->num_palette, - info_ptr->num_palette, info_ptr->hist, 1); - } - } - - png_read_image (png_ptr, row_pointers); - png_read_end (png_ptr, info_ptr); - - /* Ok, now we go and allocate all the colors */ - if (info_ptr->valid & PNG_INFO_PLTE) - { - unwind.npixels = info_ptr->num_palette; - for (y = 0; y < unwind.npixels; y++) - { - color.red = info_ptr->palette[y].red << 8; - color.green = info_ptr->palette[y].green << 8; - color.blue = info_ptr->palette[y].blue << 8; - color.flags = DoRed | DoGreen | DoBlue; - allocate_nearest_color (dpy, DefaultColormapOfScreen (scr), - &color); - unwind.pixels[y] = color.pixel; - } - } - else - { - unwind.npixels = 216; - for (y = 0; y < 216; y++) - { - color.red = static_color_cube[y].red << 8; - color.green = static_color_cube[y].green << 8; - color.blue = static_color_cube[y].blue << 8; - color.flags = DoRed|DoGreen|DoBlue; - allocate_nearest_color (dpy, DefaultColormapOfScreen (scr), - &color); - unwind.pixels[y] = color.pixel; - } - } - -#ifdef PNG_SHOW_COMMENTS - /* #### - * I turn this off by default now, because the !%^@#!% comments - * show up every time the image is instantiated, which can get - * really really annoying. There should be some way to pass this - * type of data down into the glyph code, where you can get to it - * from lisp anyway. - WMP - */ - { - int i; - - for (i = 0 ; i < info_ptr->num_text ; i++) - { - /* How paranoid do I have to be about no trailing NULLs, and - using (int)info_ptr->text[i].text_length, and strncpy and a temp - string somewhere? */ - - warn_when_safe (Qpng, Qinfo, "%s - %s", - info_ptr->text[i].key, - info_ptr->text[i].text); - } - } -#endif - - /* Now create the image */ - - depth = DefaultDepthOfScreen (scr); - - /* first get bitmap_pad (from XPM) */ - bitmap_pad = ((depth > 16) ? 32 : - (depth > 8) ? 16 : - 8); - - unwind.ximage = XCreateImage (dpy, DefaultVisualOfScreen (scr), - depth, ZPixmap, 0, 0, width, height, - bitmap_pad, 0); - - if (!unwind.ximage) - signal_simple_error ("Unable to create X image struct", - instantiator); - - /* now that bytes_per_line must have been set properly alloc data */ - unwind.ximage->data = (char *) xmalloc (unwind.ximage->bytes_per_line * - height); - - { - int i, j; - for (i = 0; i < height; i++) - for (j = 0; j < width; j++) - XPutPixel (unwind.ximage, j, i, - unwind.pixels[png_pixels[i * width + j]]); - } - - xfree (row_pointers); - xfree (png_pixels); - } - - init_image_instance_from_x_image (ii, unwind.ximage, dest_mask, - unwind.pixels, unwind.npixels, - instantiator); - - /* This will clean up everything else. */ - unwind.npixels = 0; - unbind_to (speccount, Qnil); -} - -#endif /* HAVE_PNG */ - - -#ifdef HAVE_TIFF - -/********************************************************************** - * TIFF * - **********************************************************************/ -static void -tiff_validate (Lisp_Object instantiator) -{ - file_or_data_must_be_present (instantiator); -} - -static Lisp_Object -tiff_normalize (Lisp_Object inst, Lisp_Object console_type) -{ - signal_simple_error ("No TIFF support yet", inst); - return Qnil; -} - -static int -tiff_possible_dest_types (void) -{ - return IMAGE_COLOR_PIXMAP_MASK; -} - -static void -tiff_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, Lisp_Object pointer_bg, - int dest_mask, Lisp_Object domain) -{ - abort (); -} - -#endif /* HAVE_TIFF */ - - #ifdef HAVE_XPM /********************************************************************** @@ -2968,6 +1671,162 @@ #endif /* HAVE_XPM */ +#ifdef HAVE_IMAGEMAGICK +/********************************************************************** + * ImageMagick * + **********************************************************************/ +static void +imagick_validate (Lisp_Object instantiator) +{ + file_or_data_must_be_present (instantiator); +} + +static Lisp_Object +imagick_normalize (Lisp_Object inst, Lisp_Object console_type) +{ + return simple_image_type_normalize (inst, console_type, Qimagick); +} + +static int +imagick_possible_dest_types (void) +{ + return IMAGE_COLOR_PIXMAP_MASK; +} + +struct imagick_unwind_data +{ + /* FIXME - what goes here...*/ + Display *dpy; + FILE *instream; + Image *image; + XImage *ximage; + unsigned long *pixels; + unsigned long npixels; + char tempfile[50]; + int tempfile_needs_to_be_removed; +}; + +static Lisp_Object +imagick_instantiate_unwind (Lisp_Object unwind_obj) +{ + struct imagick_unwind_data *data = + (struct imagick_unwind_data *) get_opaque_ptr (unwind_obj); + + free_opaque_ptr (unwind_obj); + if (data->instream) + fclose (data->instream); + if (data->tempfile_needs_to_be_removed) + unlink (data->tempfile); + + if (data->image) { + DestroyImage(data->image); + } + + if (data->ximage) + { + if (data->ximage->data) + { + xfree (data->ximage->data); + data->ximage->data = NULL; + } + XDestroyImage (data->ximage); + } + + return Qnil; +} + +static void XDitherImage(Image *image,XImage *ximage); + +static void +imagick_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, + int dest_mask, Lisp_Object domain) +{ + struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + Lisp_Object device = IMAGE_INSTANCE_DEVICE (ii); + Display *dpy; + Screen *scr; + Dimension depth; + struct imagick_unwind_data unwind; + int speccount = specpdl_depth (); + ImageInfo image_info; + + /* ImageMagick variables */ + + /* Basic error checking */ + if (!DEVICE_X_P (XDEVICE (device))) + signal_simple_error ("Not an X device", device); + + dpy = DEVICE_X_DISPLAY (XDEVICE (device)); + scr = DefaultScreenOfDisplay (dpy); + depth = DefaultDepthOfScreen (scr); + /* Set up the unwind */ + memset (&unwind, 0, sizeof (unwind)); + unwind.dpy = dpy; + record_unwind_protect(imagick_instantiate_unwind,make_opaque_ptr(&unwind)); + + /* Write out to a temp file - not sure if ImageMagick supports the + ** notion of an abstrat 'data source' right now. + */ + { + Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); + + assert (!NILP (data)); + + write_lisp_string_to_temp_file (data, unwind.tempfile); + unwind.tempfile_needs_to_be_removed = 1; + + if ((unwind.instream = fopen (unwind.tempfile, "rb")) == NULL) + report_file_error ("Opening ImageMagick temp file", + list1 (build_string (unwind.tempfile))); + } + + /* Initialize structures and read in the image */ + GetImageInfo(&image_info); + strcpy(image_info.filename,unwind.tempfile); + unwind.image = ReadImage(&image_info); + if (unwind.image == (Image *) NULL) { + signal_simple_error ("Unable to read image.",instantiator); + } + + unwind.ximage = XCreateImage(dpy, DefaultVisualOfScreen (scr), + depth, + (depth == 1) ? XYPixmap : ZPixmap, + 0, 0, + unwind.image->columns, + unwind.image->rows, + XBitmapPad(dpy), 0); + + if (!unwind.ximage) { + signal_simple_error("Unable to allocate XImage structure", + instantiator); + } + + unwind.ximage->data = (char *) xmalloc(unwind.ximage->bytes_per_line * + unwind.ximage->height * + unwind.ximage->depth); + + if (unwind.ximage->data == (char *)NULL) { + signal_simple_error("Unable to allocate pixel information", + instantiator); + } + + /* Need to pull the data from the 'Image' structure in + ** unwind.image and convert it to an 'XImage' in unwind.ximage + ** + ** FIXME IM FUCKED + ** + ** WMP 10/30/97 + */ + + init_image_instance_from_x_image (ii, unwind.ximage, dest_mask, + unwind.pixels, unwind.npixels, + instantiator); +} + +#endif /* HAVE_IMAGEMAGICK */ + + #ifdef HAVE_XFACE /********************************************************************** @@ -3872,52 +2731,16 @@ IIFORMAT_VALID_KEYWORD (font, Q_foreground, check_valid_string); IIFORMAT_VALID_KEYWORD (font, Q_background, check_valid_string); -#ifdef HAVE_JPEG - INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (jpeg, "jpeg"); - - IIFORMAT_HAS_METHOD (jpeg, validate); - IIFORMAT_HAS_METHOD (jpeg, normalize); - IIFORMAT_HAS_METHOD (jpeg, possible_dest_types); - IIFORMAT_HAS_METHOD (jpeg, instantiate); - - IIFORMAT_VALID_KEYWORD (jpeg, Q_data, check_valid_string); - IIFORMAT_VALID_KEYWORD (jpeg, Q_file, check_valid_string); -#endif - -#ifdef HAVE_GIF - INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (gif, "gif"); - - IIFORMAT_HAS_METHOD (gif, validate); - IIFORMAT_HAS_METHOD (gif, normalize); - IIFORMAT_HAS_METHOD (gif, possible_dest_types); - IIFORMAT_HAS_METHOD (gif, instantiate); - - IIFORMAT_VALID_KEYWORD (gif, Q_data, check_valid_string); - IIFORMAT_VALID_KEYWORD (gif, Q_file, check_valid_string); -#endif - -#ifdef HAVE_PNG - INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (png, "png"); - - IIFORMAT_HAS_METHOD (png, validate); - IIFORMAT_HAS_METHOD (png, normalize); - IIFORMAT_HAS_METHOD (png, possible_dest_types); - IIFORMAT_HAS_METHOD (png, instantiate); - - IIFORMAT_VALID_KEYWORD (png, Q_data, check_valid_string); - IIFORMAT_VALID_KEYWORD (png, Q_file, check_valid_string); -#endif - -#ifdef HAVE_TIFF - INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (tiff, "tiff"); - - IIFORMAT_HAS_METHOD (tiff, validate); - IIFORMAT_HAS_METHOD (tiff, normalize); - IIFORMAT_HAS_METHOD (tiff, possible_dest_types); - IIFORMAT_HAS_METHOD (tiff, instantiate); - - IIFORMAT_VALID_KEYWORD (tiff, Q_data, check_valid_string); - IIFORMAT_VALID_KEYWORD (tiff, Q_file, check_valid_string); +#ifdef HAVE_IMAGEMAGICK + INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (imagick, "imagick"); + + IIFORMAT_HAS_METHOD (imagick, validate); + IIFORMAT_HAS_METHOD (imagick, normalize); + IIFORMAT_HAS_METHOD (imagick, possible_dest_types); + IIFORMAT_HAS_METHOD (imagick, instantiate); + + IIFORMAT_VALID_KEYWORD (imagick, Q_data, check_valid_string); + IIFORMAT_VALID_KEYWORD (imagick, Q_file, check_valid_string); #endif #ifdef HAVE_XPM @@ -3963,22 +2786,6 @@ void vars_of_glyphs_x (void) { -#ifdef HAVE_JPEG - Fprovide (Qjpeg); -#endif - -#ifdef HAVE_GIF - Fprovide (Qgif); -#endif - -#ifdef HAVE_PNG - Fprovide (Qpng); -#endif - -#ifdef HAVE_TIFF - Fprovide (Qtiff); -#endif - #ifdef HAVE_XPM Fprovide (Qxpm); @@ -3996,6 +2803,10 @@ Vxpm_color_symbols = Qnil; /* initialized in x-faces.el */ #endif +#ifdef HAVE_IMAGEMAGICK + Fprovide (Qimagick); +#endif + #ifdef HAVE_XFACE Fprovide (Qxface); #endif
--- a/src/gpmevent.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/gpmevent.c Mon Aug 13 10:03:52 2007 +0200 @@ -83,7 +83,7 @@ return (1); } -int connect_to_gpm(struct console *con) +void connect_to_gpm(struct console *con) { /* Only do this if we are running after dumping and really interactive */ if (!noninteractive && initialized) {
--- a/src/gpmevent.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/gpmevent.h Mon Aug 13 10:03:52 2007 +0200 @@ -2,6 +2,6 @@ #define _HAVE_GPM int handle_gpm_read(struct Lisp_Event *event, struct console *con, int fd); -int connect_to_gpm(struct console *con); +void connect_to_gpm(struct console *con); #endif
--- a/src/input-method-motif.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/input-method-motif.c Mon Aug 13 10:03:52 2007 +0200 @@ -23,8 +23,8 @@ /* Written by Martin Buchholz. */ +#include <config.h> #include <X11/Xlocale.h> /* More portable than <locale.h> ? */ -#include <config.h> #include "lisp.h" #include "console-x.h" #include "device.h"
--- a/src/input-method-xfs.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/input-method-xfs.c Mon Aug 13 10:03:52 2007 +0200 @@ -25,8 +25,8 @@ the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ +#include <config.h> #include <X11/Xlocale.h> /* More portable than <locale.h> ? */ -#include <config.h> #include "lisp.h" #include "frame.h" #include "device.h"
--- a/src/input-method-xlib.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/input-method-xlib.c Mon Aug 13 10:03:52 2007 +0200 @@ -27,8 +27,8 @@ and X11 R6 release guide chapters on internationalized input, for further details */ +#include <config.h> #include <X11/Xlocale.h> /* More portable than <locale.h> ? */ -#include <config.h> #include "lisp.h" #include "frame.h" #include "device.h"
--- a/src/lisp-disunion.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/lisp-disunion.h Mon Aug 13 10:03:52 2007 +0200 @@ -19,59 +19,164 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: FSF 19.30. Split out from lisp.h. */ +/* This file has diverged greatly from FSF Emacs. Syncing is no + longer desired or possible */ -/* If union type is not wanted, define Lisp_Object as just a number - and define the macros below to extract fields by shifting */ +/* + * Format of a non-union-type Lisp Object + * + * For the USE_MINIMAL_TAGBITS implementation: + * + * 3 2 1 0 + * bit 10987654321098765432109876543210 + * -------------------------------- + * VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVTT + * + * For the non-USE_MINIMAL_TAGBITS implementation: + * + * 3 2 1 0 + * bit 10987654321098765432109876543210 + * -------------------------------- + * TTTMVVVVVVVVVVVVVVVVVVVVVVVVVVVV + * + * V = value bits + * T = type bits + * M = mark bits + * + * For integral Lisp types, i.e. integers and characters, the value + * bits are the Lisp object. + * + * The object is obtained by masking off the type and mark + * bits. In the USE_MINIMAL_TAGBITS implementation, bit 1 is + * used as a value bit by splitting the Lisp integer type into + * two subtypes, Lisp_Type_Int_Even and Lisp_Type_Int_Odd. By + * this trickery we get 31 bits for integers instead of 30. + * + * In the non-USE_MINIMAL_TAGBITS world, Lisp integers are 28 + * bits, or more properly (LONGBITS - GCTYPEBITS - 1) bits. + * + * For non-integral types, the value bits of Lisp_Object contain a + * pointer to structure containing the object. The pointer is + * obtained by masking off the type and mark bits. + * + * In the USE_MINIMAL_TAGBITS implementation, all + * pointer-based types are coalesced under a single type called + * Lisp_Type_Record. The type bits for this type are required + * by the implementation to be 00, just like the least + * significant bits of word-aligned struct pointers on 32-bit + * hardware. Because of this, Lisp_Object pointers don't have + * to be masked and are full-sized. + * + * In the non-USE_MINIMAL_TAGBITS implementation, the type and + * mark bits must be masked off and pointers are limited to 28 + * bits (really LONGBITS - GCTYPEBITS - 1 bits). + */ -#define Qzero 0 +#ifdef USE_MINIMAL_TAGBITS +# define Qzero Lisp_Type_Int_Even +# define VALMASK (((1L << (VALBITS)) - 1L) << (GCTYPEBITS)) +#else +# define Qzero Lisp_Type_Int +# define VALMASK ((1L << (VALBITS)) - 1L) +# define GCTYPEMASK ((1L << (GCTYPEBITS)) - 1L) +#endif typedef EMACS_INT Lisp_Object; -#define VALMASK ((1L << (VALBITS)) - 1L) -#define GCTYPEMASK ((1L << (GCTYPEBITS)) - 1L) - -/* comment from FSFmacs (perhaps not accurate here): +#define Qnull_pointer 0 - This is set in the car of a cons and in the plist slot of a symbol - to indicate it is marked. Likewise in the plist slot of an interval, - the chain slot of a marker, the type slot of a float, and the name - slot of a buffer. +/* + * There are no mark bits in the USE_MINIMAL_TAGBITS implementation. + * Integers and characters don't need to be marked. All other types + * are lrecord-based, which means they get marked by incrementing + * their ->implementation pointer. + */ +#if GCMARKBITS > 0 + /* + * XMARKBIT accesses the markbit. Markbits are used only in particular + * slots of particular structure types. Other markbits are always + * zero. Outside of garbage collection, all mark bits are always zero. + */ +# define MARKBIT (1UL << (VALBITS)) +# define XMARKBIT(a) ((a) & (MARKBIT)) + +# define XMARK(a) ((void) ((a) |= (MARKBIT))) +# define XUNMARK(a) ((void) ((a) &= (~(MARKBIT)))) +#endif - In strings, this bit in the size field indicates that the string - is a "large" one, one which was separately malloc'd - rather than being part of a string block. */ - -#define MARKBIT (1UL << (VALBITS)) +/* + * Extract the type bits from a Lisp_Object. If using USE_MINIMAL_TAGBITS, + * the least significant two bits are the type bits. Otherwise the + * most significant GCTYPEBITS bits are the type bits. + * + * In the non-USE_MINIMAL_TAGBITS case, one needs to override this + * if there must be high bits set in data space. Masking the bits + * (doing the result of the below & ((1 << (GCTYPEBITS)) - 1) would + * work on all machines, but would penalize machines which don't + * need it) + */ +#ifdef USE_MINIMAL_TAGBITS +# define XTYPE(a) ((enum Lisp_Type) (((EMACS_UINT)(a)) & ~(VALMASK))) +#else +# define XTYPE(a) ((enum Lisp_Type) (((EMACS_UINT)(a)) >> ((VALBITS) + 1))) +#endif - -/* These macros extract various sorts of values from a Lisp_Object. - For example, if tem is a Lisp_Object whose type is Lisp_Type_Cons, - XCONS (tem) is the struct Lisp_Cons * pointing to the memory for that cons. */ - -/* One needs to override this if there must be high bits set in data space - (doing the result of the below & ((1 << (GCTYPE + 1)) - 1) would work - on all machines, but would penalize machines which don't need it) */ -#define XTYPE(a) ((enum Lisp_Type) (((EMACS_UINT)(a)) >> ((VALBITS) + 1))) +/* + * This applies only to the non-USE_MINIMAL_TAGBITS Lisp_Object. + * + * In the past, during garbage collection, XGCTYPE needed to be used + * for extracting types so that the mark bit was ignored. XGCTYPE + * did and exatr & operation to remove the mark bit. But the mark + * bit has been since moved so that the type bits could be extracted + * with a single shift operation, making XGCTYPE no more expensive + * than XTYPE, so the two operations are now equivalent. + */ +#ifndef XGCTYPE +# define XGCTYPE(a) XTYPE(a) +#endif #define EQ(x,y) ((x) == (y)) -#define GC_EQ(x,y) (XGCTYPE (x) == XGCTYPE (y) && XPNTR (x) == XPNTR (y)) -/* Extract the value of a Lisp_Object as a signed integer. */ - -#ifndef XREALINT /* Some machines need to do this differently. */ -# define XREALINT(a) (((a) << (LONGBITS-VALBITS)) >> (LONGBITS-VALBITS)) +#ifdef USE_MINIMAL_TAGBITS +# define GC_EQ(x,y) EQ(x,y) +#else +# define GC_EQ(x,y) (XGCTYPE (x) == XGCTYPE (y) && XPNTR (x) == XPNTR (y)) #endif -/* Extract the value as an unsigned integer. This is a basis - for extracting it as a pointer to a structure in storage. */ +/* + * Extract the value of a Lisp_Object as a signed integer. + * + * The right shifts below are non-portable because >> is allowed to + * sign extend or not signed extend signed integers depending on the + * compiler implementors preference. But this right-shifting of + * signed ints has been here forever, so the apparently reality is + * that all compilers of any consequence do sign extension, which is + * what is needed here. + */ +#ifndef XREALINT /* Some machines need to do this differently. */ +# ifdef USE_MINIMAL_TAGBITS +# define XREALINT(a) ((a) >> (LONGBITS-VALBITS-1)) +# else +# define XREALINT(a) (((a) << (LONGBITS-VALBITS)) >> (LONGBITS-VALBITS)) +# endif +#endif -#define XUINT(a) ((a) & VALMASK) +/* + * Extract the pointer value bits of a pointer based type. + */ +#ifdef USE_MINIMAL_TAGBITS +# define XPNTRVAL(a) (a) /* This depends on Lisp_Type_Record == 0 */ +# define XCHARVAL(a) ((a) >> (LONGBITS-VALBITS)) +#else +# define XPNTRVAL(a) ((a) & VALMASK) +# define XCHARVAL(a) XPNTRVAL(a) +#endif #ifdef HAVE_SHM /* In this representation, data is found in two widely separated segments. */ extern int pure_size; # define XPNTR(a) \ - (XUINT (a) | (XUINT (a) > pure_size ? DATA_SEG_BITS : PURE_SEG_BITS)) + (XPNTRVAL (a) | (XPNTRVAL (a) > pure_size ? DATA_SEG_BITS : PURE_SEG_BITS)) # else /* not HAVE_SHM */ # ifdef DATA_SEG_BITS /* This case is used for the rt-pc. @@ -79,38 +184,30 @@ and did not adjust it in that case. But I don't think that zero should ever be found in a Lisp object whose data type says it points to something. */ -# define XPNTR(a) (XUINT (a) | DATA_SEG_BITS) +# define XPNTR(a) (XPNTRVAL (a) | DATA_SEG_BITS) # else -# define XPNTR(a) XUINT (a) +# define XPNTR(a) XPNTRVAL (a) # endif #endif /* not HAVE_SHM */ -#define XSETINT(a, b) XSETOBJ (a, Lisp_Type_Int, b) - -#define XSETCHAR(var, value) XSETOBJ (var, Lisp_Type_Char, value) - -/* XSETOBJ was formerly named XSET. The name change was made to catch - C code that attempts to use this macro. You should always use the - individual settor macros (XSETCONS, XSETBUFFER, etc.) instead. */ - -#define XSETOBJ(var, type_tag, value) \ - ((void) ((var) = (((EMACS_INT) (type_tag) << ((VALBITS) + 1)) \ - + ((EMACS_INT) (value) & VALMASK)))) +#ifdef USE_MINIMAL_TAGBITS -/* During garbage collection, XGCTYPE must be used for extracting types - so that the mark bit is ignored. XMARKBIT accesses the markbit. - Markbits are used only in particular slots of particular structure types. - Other markbits are always zero. - Outside of garbage collection, all mark bits are always zero. */ +/* XSETINT depends on Lisp_Type_Int_Even == 1 and Lisp_Type_Int_Odd == 3 */ +# define XSETINT(var, value) \ + ((void) ((var) = ((value) << (LONGBITS-VALBITS-1)) + 1)) +# define XSETCHAR(var, value) \ + ((void) ((var) = ((value) << (LONGBITS-VALBITS)) + Lisp_Type_Char)) +# define XSETOBJ(var, type_tag, value) \ + ((void) ((var) = ((EMACS_UINT) (value)))) -#ifndef XGCTYPE -# define XGCTYPE(a) XTYPE(a) -#endif +#else -# define XMARKBIT(a) ((a) & (MARKBIT)) - -# define XMARK(a) ((void) ((a) |= (MARKBIT))) -# define XUNMARK(a) ((void) ((a) &= (~(MARKBIT)))) +# define XSETINT(a, b) XSETOBJ (a, Lisp_Type_Int, b) +# define XSETCHAR(var, value) XSETOBJ (var, Lisp_Type_Char, value) +# define XSETOBJ(var, type_tag, value) \ + ((void) ((var) = (((EMACS_UINT) (type_tag) << ((VALBITS) + 1)) \ + + ((EMACS_INT) (value) & VALMASK)))) +#endif /* Use this for turning a (void *) into a Lisp_Object, as when the Lisp_Object is passed into a toolkit callback function */
--- a/src/lisp-union.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/lisp-union.h Mon Aug 13 10:03:52 2007 +0200 @@ -28,11 +28,11 @@ { #if (!!defined (WORDS_BIGENDIAN) != !!defined (LOWTAGS)) /* Big-endian lowtags, little-endian hightags */ - unsigned EMACS_INT type_mark: GCTYPEBITS + 1; + unsigned EMACS_INT type_mark: GCTYPEBITS + GCMARKBITS; signed EMACS_INT val: VALBITS; #else /* If WORDS_BIGENDIAN, or little-endian hightags */ signed EMACS_INT val: VALBITS; - unsigned EMACS_INT mark_type: GCTYPEBITS + 1; + unsigned EMACS_INT mark_type: GCTYPEBITS + GCMARKBITS; #endif /* BIG/LITTLE_ENDIAN vs HIGH/LOWTAGS */ } s; struct @@ -47,11 +47,26 @@ #endif /* __GNUC__ */ /* The markbit is not really part of the value of a Lisp_Object, and is always zero except during garbage collection. */ - unsigned EMACS_INT markbit: 1; +#if GCMARKBITS > 0 + unsigned EMACS_INT markbit: GCMARKBITS; +#endif #if (!!defined (WORDS_BIGENDIAN) != !!defined (LOWTAGS)) unsigned EMACS_INT val: VALBITS; #endif } gu; +#ifdef USE_MINIMAL_TAGBITS + struct + { +#if (!!defined (WORDS_BIGENDIAN) != !!defined (LOWTAGS)) + unsigned bit: GCTYPEBITS - 1; +#endif + signed EMACS_INT val: VALBITS + 1; +#if (!!defined (WORDS_BIGENDIAN) == !!defined (LOWTAGS)) + unsigned bit: GCTYPEBITS - 1; +#endif + } si; +#endif /* USE_MINIMAL_TAGBITS */ + EMACS_UINT ui; EMACS_INT i; /* GCC bites yet again. I fart in the general direction of the GCC authors. @@ -64,6 +79,7 @@ } Lisp_Object; +#ifndef USE_MINIMAL_TAGBITS #ifndef XMAKE_LISP #if (__GNUC__ > 1) /* Use GCC's struct initializers feature */ @@ -73,15 +89,17 @@ val: ((unsigned EMACS_INT) value) } }) #endif /* __GNUC__ */ #endif /* !XMAKE_LISP */ - +#endif /* ! USE_MINIMAL_TAGBITS */ #ifdef XMAKE_LISP #define Qzero (XMAKE_LISP (Lisp_Type_Int, 0)) #define make_int(a) (XMAKE_LISP (Lisp_Type_Int, (a))) +#define make_char(a) (XMAKE_LISP (Lisp_Type_Char, (a))) #else extern Lisp_Object Qzero; #endif +extern Lisp_Object Qnull_pointer; #define EQ(x,y) ((x).v == (y).v) #define GC_EQ(x,y) ((x).gu.val == (y).gu.val && (x).gu.type == (y).gu.type) @@ -96,15 +114,26 @@ /* Make sure we sign-extend; compilers have been known to fail to do so. */ #define XREALINT(a) (((a).i << ((LONGBITS) - (VALBITS))) >> ((LONGBITS) - (VALBITS))) #else -#define XREALINT(a) ((a).s.val) +#ifdef USE_MINIMAL_TAGBITS +# define XREALINT(a) ((a).si.val) +#else +# define XREALINT(a) ((a).s.val) +#endif #endif /* EXPLICIT_SIGN_EXTEND */ -#define XUINT(a) ((a).gu.val) +#ifdef USE_MINIMAL_TAGBITS +# define XPNTRVAL(a) ((a).ui) +# define XCHARVAL(a) ((a).gu.val) +#else +# define XPNTRVAL(a) ((a).gu.val) +# define XCHARVAL(a) XPNTRVAL(a) +#endif + #ifdef HAVE_SHM /* In this representation, data is found in two widely separated segments. */ extern int pure_size; # define XPNTR(a) \ - ((void *)(((a).gu.val) | ((a).gu.val > pure_size ? DATA_SEG_BITS : PURE_SEG_BITS))) + ((void *)(XPNTRVAL(a)) | (XPNTRVAL(a) > pure_size ? DATA_SEG_BITS : PURE_SEG_BITS))) #else /* not HAVE_SHM */ # ifdef DATA_SEG_BITS /* This case is used for the rt-pc and hp-pa. @@ -113,46 +142,66 @@ But I don't think that zero should ever be found in a Lisp object whose data type says it points to something. */ -# define XPNTR(a) ((void *)(((a).gu.val) | DATA_SEG_BITS)) +# define XPNTR(a) ((void *)((XPNTRVAL(a)) | DATA_SEG_BITS)) # else /* not DATA_SEG_BITS */ -# define XPNTR(a) ((void *) ((a).gu.val)) +# define XPNTR(a) ((void *) (XPNTRVAL(a))) # endif /* not DATA_SEG_BITS */ #endif /* not HAVE_SHM */ -#define XSETINT(a, b) ((void) ((a) = make_int (b))) -#define XSETCHAR(a, b) ((void) ((a) = make_char (b))) +#ifdef USE_MINIMAL_TAGBITS +# define XSETINT(a, b) \ + do { Lisp_Object *_xzx = &(a) ; \ + (*_xzx).si.val = (b) ; \ + (*_xzx).si.bit = 1; \ + } while (0) +# define XSETCHAR(a, b) \ + do { Lisp_Object *_xzx = &(a) ; \ + (*_xzx).gu.val = (b) ; \ + (*_xzx).gu.type = Lisp_Type_Char; \ + } while (0) +#else +# define XSETINT(a, b) ((void) ((a) = make_int (b))) +# define XSETCHAR(a, b) ((void) ((a) = make_char (b))) +#endif /* XSETOBJ was formerly named XSET. The name change was made to catch C code that attempts to use this macro. You should always use the individual settor macros (XSETCONS, XSETBUFFER, etc.) instead. */ -#ifdef XMAKE_LISP -#define XSETOBJ(a, type, b) ((void) ((a) = XMAKE_LISP (type, b))) +#ifdef USE_MINIMAL_TAGBITS +# define XSETOBJ(var, vartype, value) \ + ((void) ((var).ui = (EMACS_UINT)(value))) #else +# ifdef XMAKE_LISP +# define XSETOBJ(a, type, b) ((void) ((a) = XMAKE_LISP (type, b))) +# else /* This is haired up to avoid evaluating var twice... This is necessary only in the "union" version. The "int" version has never done double evaluation. */ /* XEmacs change: put the assignment to val first; otherwise you can trip up the error_check_*() stuff */ -#define XSETOBJ(var, vartype, value) \ +# define XSETOBJ(var, vartype, value) \ do { \ Lisp_Object *tmp_xset_var = &(var); \ (*tmp_xset_var).s.val = ((EMACS_INT) (value)); \ (*tmp_xset_var).gu.markbit = 0; \ (*tmp_xset_var).gu.type = (vartype); \ } while (0) -#endif /* undefined XMAKE_LISP */ +# endif /* ! XMAKE_LISP */ +#endif /* ! USE_MINIMAL_TAGBITS */ -/* During garbage collection, XGCTYPE must be used for extracting types - so that the mark bit is ignored. XMARKBIT access the markbit. - Markbits are used only in particular slots of particular structure types. - Other markbits are always zero. - Outside of garbage collection, all mark bits are always zero. */ - -#define XMARKBIT(a) ((a).gu.markbit) -#define XMARK(a) ((void) (XMARKBIT (a) = 1)) -#define XUNMARK(a) ((void) (XMARKBIT (a) = 0)) +#if GCMARKBITS > 0 +/* + * XMARKBIT access the markbit. Markbits are used only in particular + * slots of particular structure types. Other markbits are always + * zero. Outside of garbage collection, all mark bits are always + * zero. + */ +# define XMARKBIT(a) ((a).gu.markbit) +# define XMARK(a) ((void) (XMARKBIT (a) = 1)) +# define XUNMARK(a) ((void) (XMARKBIT (a) = 0)) +#endif /* Use this for turning a (void *) into a Lisp_Object, as when the Lisp_Object is passed into a toolkit callback function */
--- a/src/lisp.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/lisp.h Mon Aug 13 10:03:52 2007 +0200 @@ -630,38 +630,44 @@ /* Definition of Lisp_Object data type */ /************************************************************************/ -/* There's not any particular reason not to use lrecords for these; some - objects get slightly larger, but we get 3 bit tags instead of 4. - */ -/* #define LRECORD_SYMBOL */ - +#ifdef USE_MINIMAL_TAGBITS +# define LRECORD_CONS +# define LRECORD_VECTOR +# define LRECORD_SYMBOL +# define LRECORD_STRING +#endif /* Define the fundamental Lisp data structures */ /* This is the set of Lisp data types */ +#ifndef USE_MINIMAL_TAGBITS + enum Lisp_Type { /* Integer. XINT(obj) is the integer value. */ - Lisp_Type_Int, /* 0 DTP-FIXNUM */ + Lisp_Type_Int, /* XRECORD_LHEADER (object) points to a struct lrecord_header lheader->implementation determines the type (and GC behaviour) of the object. */ - Lisp_Type_Record, /* 1 DTP-OTHER-POINTER */ + Lisp_Type_Record, +#ifndef LRECORD_CONS /* Cons. XCONS (object) points to a struct Lisp_Cons. */ - Lisp_Type_Cons, /* 2 DTP-LIST */ + Lisp_Type_Cons, +#endif - /* LRECORD_STRING is NYI */ +#ifndef LRECORD_STRING /* String. XSTRING (object) points to a struct Lisp_String. The length of the string, and its contents, are stored therein. */ - Lisp_Type_String, /* 3 DTP-STRING */ + Lisp_Type_String, +#endif #ifndef LRECORD_VECTOR /* Vector of Lisp objects. XVECTOR(object) points to a struct Lisp_Vector. The length of the vector, and its contents, are stored therein. */ - Lisp_Type_Vector, /* 4 DTP-SIMPLE-ARRAY */ + Lisp_Type_Vector, #endif /* !LRECORD_VECTOR */ #ifndef LRECORD_SYMBOL @@ -669,11 +675,25 @@ Lisp_Type_Symbol, #endif /* !LRECORD_SYMBOL */ - Lisp_Type_Char /* 5 DTP-CHAR */ + Lisp_Type_Char }; -/* unsafe! */ -#define POINTER_TYPE_P(type) ((type) != Lisp_Type_Int && (type) != Lisp_Type_Char) +# define POINTER_TYPE_P(type) \ + ((type) != Lisp_Type_Int && (type) != Lisp_Type_Char) + +#else + +enum Lisp_Type +{ + Lisp_Type_Record, + Lisp_Type_Int_Even, + Lisp_Type_Char, + Lisp_Type_Int_Odd +}; + +#define POINTER_TYPE_P(type) ((type) == Lisp_Type_Record) + +#endif /* This should be the underlying type into which a Lisp_Object must fit. In a strict ANSI world, this must be `int', since ANSI says you can't @@ -697,11 +717,22 @@ /* These values are overridden by the m- file on some machines. */ #ifndef GCTYPEBITS -# define GCTYPEBITS 3L +# ifdef USE_MINIMAL_TAGBITS +# define GCTYPEBITS 2L +# else +# define GCTYPEBITS 3L +# endif +#endif + +/* Valid values for GCMARKBITS are 0 and 1. */ +#ifdef USE_MINIMAL_TAGBITS +# define GCMARKBITS 0L +#else +# define GCMARKBITS 1L #endif #ifndef VALBITS -# define VALBITS ((LONGBITS)-((GCTYPEBITS)+1L)) +# define VALBITS ((LONGBITS)-(GCTYPEBITS)-(GCMARKBITS)) #endif #ifdef NO_UNION_TYPE @@ -722,7 +753,7 @@ #define HACKEQ_UNSAFE(obj1, obj2) \ (EQ (obj1, obj2) || (!POINTER_TYPE_P (XGCTYPE (obj1)) \ && !POINTER_TYPE_P (XGCTYPE (obj2)) \ - && XREALINT (obj1) == XREALINT (obj2))) + && XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))) #ifdef DEBUG_XEMACS extern int debug_issue_ebola_notices; @@ -758,6 +789,9 @@ struct Lisp_Cons { +#ifdef LRECORD_CONS + struct lrecord_header lheader; +#endif Lisp_Object car, cdr; }; @@ -773,6 +807,21 @@ }; #endif +#ifdef LRECORD_CONS + +DECLARE_LRECORD (cons, struct Lisp_Cons); +#define XCONS(x) XRECORD (x, cons, struct Lisp_Cons) +#define XSETCONS(x, p) XSETRECORD (x, p, cons) +#define CONSP(x) RECORDP (x, cons) +#define GC_CONSP(x) GC_RECORDP (x, cons) +#define CHECK_CONS(x) CHECK_RECORD (x, cons) +#define CONCHECK_CONS(x) CONCHECK_RECORD (x, cons) + +#define CONS_MARKED_P(c) MARKED_RECORD_HEADER_P(&((c)->lheader)) +#define MARK_CONS(c) MARK_RECORD_HEADER (&((c)->lheader)) + +#else /* ! LRECORD_CONS */ + DECLARE_NONRECORD (cons, Lisp_Type_Cons, struct Lisp_Cons); #define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, struct Lisp_Cons) #define XSETCONS(c, p) XSETOBJ (c, Lisp_Type_Cons, p) @@ -786,6 +835,8 @@ #define CONS_MARKED_P(c) XMARKBIT (c->car) #define MARK_CONS(c) XMARK (c->car) +#endif /* ! LRECORD_CONS */ + #define NILP(x) EQ (x, Qnil) #define GC_NILP(x) GC_EQ (x, Qnil) #define CHECK_LIST(x) \ @@ -923,7 +974,7 @@ struct Lisp_Vector { #ifdef LRECORD_VECTOR - struct lrecord_header lheader; + struct lcrecord_header header; #endif long size; /* next is now chained through v->contents[size], terminated by Qzero. @@ -958,8 +1009,9 @@ #define XVECTOR_LENGTH(s) vector_length (XVECTOR (s)) #define vector_data(v) ((v)->contents) #define XVECTOR_DATA(s) vector_data (XVECTOR (s)) -#define vector_next(v) ((v)->contents[(v)->size]) - +#ifndef LRECORD_VECTOR +# define vector_next(v) ((v)->contents[(v)->size]) +#endif /*********** bit vector ***********/ @@ -1141,12 +1193,12 @@ XCHAR (Lisp_Object obj) { assert (CHARP (obj)); - return XREALINT (obj); + return XCHARVAL (obj); } #else -#define XCHAR(x) XREALINT (x) +#define XCHAR(x) XCHARVAL (x) #endif @@ -1230,8 +1282,15 @@ #endif /* not LISP_FLOAT_TYPE */ -#define INTP(x) (XTYPE (x) == Lisp_Type_Int) -#define GC_INTP(x) (XGCTYPE (x) == Lisp_Type_Int) +#ifdef USE_MINIMAL_TAGBITS +# define INTP(x) \ + (XTYPE (x) == Lisp_Type_Int_Even || XTYPE(x) == Lisp_Type_Int_Odd) +# define GC_INTP(x) \ + (XGCTYPE (x) == Lisp_Type_Int_Even || XGCTYPE(x) == Lisp_Type_Int_Odd) +#else +# define INTP(x) (XTYPE (x) == Lisp_Type_Int) +# define GC_INTP(x) (XGCTYPE (x) == Lisp_Type_Int) +#endif #define ZEROP(x) EQ (x, Qzero) #define GC_ZEROP(x) GC_EQ (x, Qzero) @@ -1252,8 +1311,39 @@ #endif -#define CHECK_INT(x) CHECK_NONRECORD (x, Lisp_Type_Int, Qintegerp) -#define CONCHECK_INT(x) CONCHECK_NONRECORD (x, Lisp_Type_Int, Qintegerp) +#ifdef ERROR_CHECK_TYPECHECK + +INLINE EMACS_INT XCHAR_OR_INT (Lisp_Object obj); +INLINE EMACS_INT +XCHAR_OR_INT (Lisp_Object obj) +{ + assert (INTP (obj) || CHARP (obj)); + return CHARP (obj) ? XCHAR (obj) : XINT (obj); +} + +#else + +#define XCHAR_OR_INT(obj) (CHARP ((obj)) ? XCHAR ((obj)) : XINT ((obj))) + +#endif + +#ifdef USE_MINIMAL_TAGBITS +/* + * can't use CHECK_NONRECORD and CONCHECK_NONRECORD here because in + * the USE_MINIMAL_TAGBITS implementation Lisp integers have two types. + */ +# define CHECK_INT(x) do { \ + if (! INTP (x)) \ + dead_wrong_type_argument (Qintegerp, x); \ + } while (0) +# define CONCHECK_INT(x) do { \ + if (! INTP (x)) \ + x = wrong_type_argument (Qintegerp, x); \ + } while (0) +#else +# define CHECK_INT(x) CHECK_NONRECORD (x, Lisp_Type_Int, Qintegerp) +# define CONCHECK_INT(x) CONCHECK_NONRECORD (x, Lisp_Type_Int, Qintegerp) +#endif #define NATNUMP(x) (INTP (x) && XINT (x) >= 0) #define GC_NATNUMP(x) (GC_INTP (x) && XINT (x) >= 0) @@ -1435,7 +1525,7 @@ comment and creates the DOC file form it. */ -#define SUBR_MAX_ARGS 8 +#define SUBR_MAX_ARGS 12 #define MANY -2 #define UNEVALLED -1 @@ -1455,14 +1545,18 @@ #define DEFUN_MANY(named_int, named_Lisp_Object) named_int, named_Lisp_Object #define DEFUN_UNEVALLED(args) Lisp_Object args #define DEFUN_0() void -#define DEFUN_1(a) Lisp_Object a -#define DEFUN_2(a,b) DEFUN_1(a), Lisp_Object b -#define DEFUN_3(a,b,c) DEFUN_2(a,b), Lisp_Object c -#define DEFUN_4(a,b,c,d) DEFUN_3(a,b,c), Lisp_Object d -#define DEFUN_5(a,b,c,d,e) DEFUN_4(a,b,c,d), Lisp_Object e -#define DEFUN_6(a,b,c,d,e,f) DEFUN_5(a,b,c,d,e), Lisp_Object f -#define DEFUN_7(a,b,c,d,e,f,g) DEFUN_6(a,b,c,d,e,f), Lisp_Object g -#define DEFUN_8(a,b,c,d,e,f,g,h) DEFUN_7(a,b,c,d,e,f,g), Lisp_Object h +#define DEFUN_1(a) Lisp_Object a +#define DEFUN_2(a,b) DEFUN_1(a), Lisp_Object b +#define DEFUN_3(a,b,c) DEFUN_2(a,b), Lisp_Object c +#define DEFUN_4(a,b,c,d) DEFUN_3(a,b,c), Lisp_Object d +#define DEFUN_5(a,b,c,d,e) DEFUN_4(a,b,c,d), Lisp_Object e +#define DEFUN_6(a,b,c,d,e,f) DEFUN_5(a,b,c,d,e), Lisp_Object f +#define DEFUN_7(a,b,c,d,e,f,g) DEFUN_6(a,b,c,d,e,f), Lisp_Object g +#define DEFUN_8(a,b,c,d,e,f,g,h) DEFUN_7(a,b,c,d,e,f,g), Lisp_Object h +#define DEFUN_9(a,b,c,d,e,f,g,h,i) DEFUN_8(a,b,c,d,e,f,g,h), Lisp_Object i +#define DEFUN_10(a,b,c,d,e,f,g,h,i,j) DEFUN_9(a,b,c,d,e,f,g,h,i), Lisp_Object j +#define DEFUN_11(a,b,c,d,e,f,g,h,i,j,k) DEFUN_10(a,b,c,d,e,f,g,h,i,j), Lisp_Object k +#define DEFUN_12(a,b,c,d,e,f,g,h,i,j,k,l) DEFUN_11(a,b,c,d,e,f,g,h,i,j,k), Lisp_Object l /* WARNING: If you add defines here for higher values of maxargs, make sure to also fix the clauses in primitive_funcall(),
--- a/src/lread.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/lread.c Mon Aug 13 10:03:52 2007 +0200 @@ -3158,8 +3158,7 @@ Ffset (Qload, intern ("load-internal")); #ifdef FEATUREP_SYNTAX - Qfeaturep = intern("featurep"); - staticpro(&Qfeaturep); + defsymbol (&Qfeaturep, "featurep"); Fprovide(intern("xemacs")); #ifdef INFODOCK Fprovide(intern("infodock"));
--- a/src/lrecord.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/lrecord.h Mon Aug 13 10:03:52 2007 +0200 @@ -184,6 +184,18 @@ XRECORD_LHEADER (obj)->implementation->finalizer == \ this_marks_a_marked_record) + +/* moved here from alloc.c so that lisp.h macros can use them. */ +#define MARKED_RECORD_HEADER_P(lheader) \ + (((lheader)->implementation->finalizer) == this_marks_a_marked_record) +#define UNMARKABLE_RECORD_HEADER_P(lheader) \ + (((lheader)->implementation->marker) == this_one_is_unmarkable) +#define MARK_RECORD_HEADER(lheader) \ + do { (((lheader)->implementation)++); } while (0) +#define UNMARK_RECORD_HEADER(lheader) \ + do { (((lheader)->implementation)--); } while (0) + + /* Declaring the following structures as const puts them in the text (read-only) segment, which makes debugging inconvenient because this segment is not mapped when processing a core-
--- a/src/lstream.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/lstream.c Mon Aug 13 10:03:52 2007 +0200 @@ -714,13 +714,37 @@ if (lstr->flags & LSTREAM_FL_IS_OPEN) { - /* don't return here on error, or file descriptor leak will result. */ rc = Lstream_pseudo_close (lstr); + /* + * We used to return immediately if the closer method reported + * failure, leaving the stream open. But this is no good, for + * the following reasons. + * + * 1. The finalizer method used in GC makes no provision for + * failure, so we must not return without freeing buffer + * memory. + * + * 2. The closer method may have already freed some memory + * used for I/O in this stream. E.g. encoding_closer frees + * ENCODING_STREAM_DATA(stream)->runoff. If a writer method + * tries to use this buffer later, it will write into memory + * that may have been allocated elsewhere. Sometime later + * you will see a sign that says "Welcome to Crash City." + * + * 3. The closer can report failure if a flush fails in the + * other stream in a MULE encoding/decoding stream pair. + * The other stream in the pair is closed, but returning + * early leaves the current stream open. If we try to + * flush the current stream later, we will crash when the + * flusher notices that the other end stream is closed. + * + * So, we no longer abort the close if the closer method + * reports some kind of failure. We still report the failure + * to the caller. + */ if (lstr->imp->closer) - { - if ((lstr->imp->closer) (lstr) < 0) - return -1; - } + if ((lstr->imp->closer) (lstr) < 0) + rc = -1; } lstr->flags &= ~LSTREAM_FL_IS_OPEN;
--- a/src/m/ibmrs6000.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/m/ibmrs6000.h Mon Aug 13 10:03:52 2007 +0200 @@ -137,7 +137,7 @@ #define ORDINARY_LINK - +#if 0 /* mrb */ #ifndef USG5_4 /* XEmacs change -- automatically add the correct path for smt.exp if it exists. */ @@ -162,3 +162,4 @@ #endif /* __GNUC__ == 2 && __GNUC_MINOR__ == 7 */ #endif /* USG5_4 */ +#endif /* mrb */
--- a/src/mule-canna.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/mule-canna.c Mon Aug 13 10:03:52 2007 +0200 @@ -1510,6 +1510,8 @@ DEFVAR_INT ("canna-key-control-down", &Vcanna_key_Cntrl_Down /* */ ); + + Fprovide(intern("CANNA")); } #ifdef CANNA_MULE
--- a/src/mule-coding.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/mule-coding.c Mon Aug 13 10:03:52 2007 +0200 @@ -572,7 +572,7 @@ TYPE describes the conversion method used and should be one of -nil or 'automatic-conversion +nil or 'undecided Automatic conversion. XEmacs attempts to detect the coding system used in the file. 'no-conversion @@ -742,7 +742,7 @@ int need_to_setup_eol_systems = 1; /* Convert type to constant */ - if (NILP (type) || EQ (type, Qautomatic_conversion)) + if (NILP (type) || EQ (type, Qundecided)) { ty = CODESYS_AUTODETECT; } else if (EQ (type, Qshift_jis)) { ty = CODESYS_SHIFT_JIS; } else if (EQ (type, Qiso2022)) { ty = CODESYS_ISO2022; } @@ -944,7 +944,7 @@ { switch (XCODING_SYSTEM_TYPE (Fget_coding_system (coding_system))) { - case CODESYS_AUTODETECT: return Qautomatic_conversion; + case CODESYS_AUTODETECT: return Qundecided; case CODESYS_SHIFT_JIS: return Qshift_jis; case CODESYS_ISO2022: return Qiso2022; case CODESYS_BIG5: return Qbig5; @@ -960,6 +960,31 @@ return Qnil; /* not reached */ } +Lisp_Object coding_system_charset (coding_system, gnum) +{ + Lisp_Object cs + = XCODING_SYSTEM_ISO2022_INITIAL_CHARSET (coding_system, gnum); + + if (CHARSETP(cs)){ + return XCHARSET_NAME(cs); + } + else { + return Qnil; + } +} + +DEFUN ("coding-system-charset", Fcoding_system_charset, 2, 2, 0, /* +Return initial charset of CODING-SYSTEM designated to GNUM. +GNUM allows 0 .. 3. +*/ + (coding_system, gnum)) +{ + coding_system = Fget_coding_system (coding_system); + CHECK_INT (gnum); + + return coding_system_charset(coding_system, XINT (gnum)); +} + DEFUN ("coding-system-property", Fcoding_system_property, 2, 2, 0, /* Return the PROP property of CODING-SYSTEM. */ @@ -1025,14 +1050,14 @@ return XCODING_SYSTEM_PRE_WRITE_CONVERSION (coding_system); else if (type == CODESYS_ISO2022) { -#define INITIAL_CHARSET(charset_num) \ - (XCHARSET_NAME (XCODING_SYSTEM_ISO2022_INITIAL_CHARSET \ - (coding_system, charset_num))) - - if (EQ (prop, Qcharset_g0)) return INITIAL_CHARSET (0); - else if (EQ (prop, Qcharset_g1)) return INITIAL_CHARSET (1); - else if (EQ (prop, Qcharset_g2)) return INITIAL_CHARSET (2); - else if (EQ (prop, Qcharset_g3)) return INITIAL_CHARSET (3); + if (EQ (prop, Qcharset_g0)) + return coding_system_charset (coding_system, 0); + else if (EQ (prop, Qcharset_g1)) + return coding_system_charset (coding_system, 1); + else if (EQ (prop, Qcharset_g2)) + return coding_system_charset (coding_system, 2); + else if (EQ (prop, Qcharset_g3)) + return coding_system_charset (coding_system, 3); #define FORCE_CHARSET(charset_num) \ (XCODING_SYSTEM_ISO2022_FORCE_CHARSET_ON_OUTPUT \ @@ -1259,6 +1284,7 @@ case 11: /* vertical tab */ case 12: /* form feed */ case 26: /* MS-DOS C-z junk */ + case 31: /* '^_' -- for info */ return 1; default: return 0; @@ -1469,11 +1495,10 @@ DEFUN ("detect-coding-region", Fdetect_coding_region, 2, 3, 0, /* Detect coding system of the text in the region between START and END. -Returned value is a list of possible coding systems ordered by -priority. If only ASCII characters are found, it returns -'automatic-conversion or one of its subsidiary coding systems -according to a detected end-of-line type. Optional arg BUFFER -defaults to the current buffer. +Returned a list of possible coding systems ordered by priority. +If only ASCII characters are found, it returns 'undecided or one of +its subsidiary coding systems according to a detected end-of-line +type. Optional arg BUFFER defaults to the current buffer. */ (start, end, buffer)) { @@ -1506,7 +1531,7 @@ } if (decst.mask == ~0) - val = subsidiary_coding_system (Fget_coding_system (Qautomatic_conversion), + val = subsidiary_coding_system (Fget_coding_system (Qundecided), decst.eol_type); else { @@ -3614,6 +3639,7 @@ case 11: /* vertical tab */ case 12: /* form feed */ case 26: /* MS-DOS C-z junk */ + case 31: /* '^_' -- for info */ goto label_continue_loop; default: @@ -4606,6 +4632,7 @@ DEFSUBR (Fcoding_system_type); DEFSUBR (Fcoding_system_doc_string); + DEFSUBR (Fcoding_system_charset); DEFSUBR (Fcoding_system_property); DEFSUBR (Fcoding_category_list);
--- a/src/mule-wnnfns.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/mule-wnnfns.c Mon Aug 13 10:03:52 2007 +0200 @@ -1896,6 +1896,8 @@ wnnfns_env_norm[i] = (struct wnn_env *) 0; wnnfns_env_rev[i] = (struct wnn_env *) 0; } + + Fprovide(intern("wnn")); } void
--- a/src/print.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/print.c Mon Aug 13 10:03:52 2007 +0200 @@ -854,6 +854,137 @@ write_c_string (end, printcharfun); } +void +print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + /* This function can GC */ + struct gcpro gcpro1, gcpro2; + + /* If print_readably is on, print (quote -foo-) as '-foo- + (Yeah, this should really be what print-pretty does, but we + don't have the rest of a pretty printer, and this actually + has non-negligible impact on size/speed of .elc files.) + */ + if (print_readably && + EQ (XCAR (obj), Qquote) && + CONSP (XCDR (obj)) && + NILP (XCDR (XCDR (obj)))) + { + obj = XCAR (XCDR (obj)); + GCPRO2 (obj, printcharfun); + write_char_internal ("'", printcharfun); + UNGCPRO; + print_internal (obj, printcharfun, escapeflag); + return; + } + + GCPRO2 (obj, printcharfun); + write_char_internal ("(", printcharfun); + { + int i = 0; + int max = 0; + + if (INTP (Vprint_length)) + max = XINT (Vprint_length); + while (CONSP (obj)) + { + if (i++) + write_char_internal (" ", printcharfun); + if (max && i > max) + { + write_c_string ("...", printcharfun); + break; + } + print_internal (Fcar (obj), printcharfun, + escapeflag); + obj = Fcdr (obj); + } + } + if (!NILP (obj) && !CONSP (obj)) + { + write_c_string (" . ", printcharfun); + print_internal (obj, printcharfun, escapeflag); + } + UNGCPRO; + write_char_internal (")", printcharfun); + return; +} + +void +print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + print_vector_internal ("[", "]", obj, printcharfun, escapeflag); +} + +void +print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + Bytecount size = XSTRING_LENGTH (obj); + struct gcpro gcpro1, gcpro2; + int max = size; + GCPRO2 (obj, printcharfun); + + if (INTP (Vprint_string_length) && + XINT (Vprint_string_length) < max) + max = XINT (Vprint_string_length); + if (max < 0) + max = 0; + + /* !!#### This handles MAX incorrectly for Mule. */ + if (!escapeflag) + { + /* This deals with GC-relocation */ + output_string (printcharfun, 0, obj, 0, max); + if (max < size) + write_c_string (" ...", printcharfun); + } + else + { + Bytecount i; + struct Lisp_String *s = XSTRING (obj); + Bytecount last = 0; + + write_char_internal ("\"", printcharfun); + for (i = 0; i < max; i++) + { + Bufbyte ch = string_byte (s, i); + if (ch == '\"' || ch == '\\' + || (ch == '\n' && print_escape_newlines)) + { + if (i > last) + { + output_string (printcharfun, 0, obj, last, + i - last); + } + if (ch == '\n') + { + write_c_string ("\\n", printcharfun); + } + else + { + write_char_internal ("\\", printcharfun); + /* This is correct for Mule because the + character is either \ or " */ + write_char_internal ((char *) (string_data (s) + i), + printcharfun); + } + last = i + 1; + } + } + if (max > last) + { + output_string (printcharfun, 0, obj, last, + max - last); + } + if (max < size) + write_c_string (" ...", printcharfun); + write_char_internal ("\"", printcharfun); + } + UNGCPRO; + return; +} + + static void default_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) @@ -928,7 +1059,12 @@ switch (XTYPE (obj)) { +#ifdef USE_MINIMAL_TAGBITS + case Lisp_Type_Int_Even: + case Lisp_Type_Int_Odd: +#else case Lisp_Type_Int: +#endif { sprintf (buf, "%ld", (long) XINT (obj)); write_c_string (buf, printcharfun); @@ -977,73 +1113,15 @@ break; } +#ifndef LRECORD_STRING case Lisp_Type_String: { - Bytecount size = XSTRING_LENGTH (obj); - struct gcpro gcpro1, gcpro2; - int max = size; - GCPRO2 (obj, printcharfun); - - if (INTP (Vprint_string_length) && - XINT (Vprint_string_length) < max) - max = XINT (Vprint_string_length); - if (max < 0) - max = 0; - - /* !!#### This handles MAX incorrectly for Mule. */ - if (!escapeflag) - { - /* This deals with GC-relocation */ - output_string (printcharfun, 0, obj, 0, max); - if (max < size) - write_c_string (" ...", printcharfun); - } - else - { - Bytecount i; - struct Lisp_String *s = XSTRING (obj); - Bytecount last = 0; - - write_char_internal ("\"", printcharfun); - for (i = 0; i < max; i++) - { - Bufbyte ch = string_byte (s, i); - if (ch == '\"' || ch == '\\' - || (ch == '\n' && print_escape_newlines)) - { - if (i > last) - { - output_string (printcharfun, 0, obj, last, - i - last); - } - if (ch == '\n') - { - write_c_string ("\\n", printcharfun); - } - else - { - write_char_internal ("\\", printcharfun); - /* This is correct for Mule because the - character is either \ or " */ - write_char_internal ((char *) (string_data (s) + i), - printcharfun); - } - last = i + 1; - } - } - if (max > last) - { - output_string (printcharfun, 0, obj, last, - max - last); - } - if (max < size) - write_c_string (" ...", printcharfun); - write_char_internal ("\"", printcharfun); - } - UNGCPRO; + print_string(obj, printcharfun, escapeflag); break; } +#endif /* ! LRECORD_STRING */ +#ifndef LRECORD_CONS case Lisp_Type_Cons: { struct gcpro gcpro1, gcpro2; @@ -1052,68 +1130,29 @@ if (INTP (Vprint_level) && print_depth > XINT (Vprint_level)) { + GCPRO2 (obj, printcharfun); write_c_string ("...", printcharfun); - break; - } - - /* If print_readably is on, print (quote -foo-) as '-foo- - (Yeah, this should really be what print-pretty does, but we - don't have the rest of a pretty printer, and this actually - has non-negligible impact on size/speed of .elc files.) - */ - if (print_readably && - EQ (XCAR (obj), Qquote) && - CONSP (XCDR (obj)) && - NILP (XCDR (XCDR (obj)))) - { - obj = XCAR (XCDR (obj)); - GCPRO2 (obj, printcharfun); - write_char_internal ("'", printcharfun); UNGCPRO; - print_internal (obj, printcharfun, escapeflag); break; } - GCPRO2 (obj, printcharfun); - write_char_internal ("(", printcharfun); - { - int i = 0; - int max = 0; - - if (INTP (Vprint_length)) - max = XINT (Vprint_length); - while (CONSP (obj)) - { - if (i++) - write_char_internal (" ", printcharfun); - if (max && i > max) - { - write_c_string ("...", printcharfun); - break; - } - print_internal (Fcar (obj), printcharfun, - escapeflag); - obj = Fcdr (obj); - } - } - if (!NILP (obj) && !CONSP (obj)) - { - write_c_string (" . ", printcharfun); - print_internal (obj, printcharfun, escapeflag); - } - UNGCPRO; - write_char_internal (")", printcharfun); + print_cons (obj, printcharfun, escapeflag); break; } +#endif /* ! LRECORD_CONS */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: { + struct gcpro gcpro1, gcpro2; + /* If deeper than spec'd depth, print placeholder. */ if (INTP (Vprint_level) && print_depth > XINT (Vprint_level)) { + GCPRO2 (obj, printcharfun); write_c_string ("...", printcharfun); + UNGCPRO; break; } @@ -1136,6 +1175,21 @@ struct lrecord_header *lheader = XRECORD_LHEADER (obj); struct gcpro gcpro1, gcpro2; +#if defined(LRECORD_CONS) || defined(LRECORD_VECTOR) + if (CONSP (obj) || VECTORP(obj)) + { + /* If deeper than spec'd depth, print placeholder. */ + if (INTP (Vprint_level) + && print_depth > XINT (Vprint_level)) + { + GCPRO2 (obj, printcharfun); + write_c_string ("...", printcharfun); + UNGCPRO; + break; + } + } +#endif + GCPRO2 (obj, printcharfun); if (lheader->implementation->printer) ((lheader->implementation->printer) @@ -1346,7 +1400,6 @@ } UNGCPRO; } - int alternate_do_pointer; char alternate_do_string[5000];
--- a/src/process.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/process.c Mon Aug 13 10:03:52 2007 +0200 @@ -1923,7 +1923,9 @@ XSTRING_DATA (p->name)); #endif } + old_sigpipe = (SIGTYPE (*) (int)) signal (SIGPIPE, send_process_trap); Lstream_flush (XLSTREAM (p->outstream)); + signal (SIGPIPE, old_sigpipe); UNGCPRO; Lstream_delete (XLSTREAM (lstream)); }
--- a/src/profile.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/profile.c Mon Aug 13 10:03:52 2007 +0200 @@ -92,8 +92,6 @@ { fun = *backtrace_list->function; - /* #### dmoore - why do we need to unmark it, we aren't in GC. */ - XUNMARK (fun); if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun)) fun = QSunknown; }
--- a/src/s/aix3-2.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/s/aix3-2.h Mon Aug 13 10:03:52 2007 +0200 @@ -16,7 +16,9 @@ additional optimization. --nils@exp-math.uni-essen.de */ /* XEmacs change: maxmem=-1 means unlimited. Suggested by dkeller@VNET.IBM.COM */ +#if 0 /* mrb */ #define C_SWITCH_SYSTEM "-ma -qmaxmem=-1" +#endif /* mrb */ #else /* Otherwise, XEmacs is just too big ... */ #define C_SWITCH_SYSTEM "-mminimal-toc"
--- a/src/s/aix4-1.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/s/aix4-1.h Mon Aug 13 10:03:52 2007 +0200 @@ -4,9 +4,11 @@ #include "aix4.h" +#if 0 /* mrb */ /* olson@mcs.anl.gov says -li18n is needed by -lXm. */ #undef LIB_MOTIF #define LIB_MOTIF "-lXm -li18n" +#endif /* mrb */ #ifdef __GNUC__ #undef _NO_PROTO
--- a/src/s/aix4.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/s/aix4.h Mon Aug 13 10:03:52 2007 +0200 @@ -1,8 +1,12 @@ -/* Synched up with: FSF 19.31. */ - #define AIX4 #include "aix3-2-5.h" /* AIX 4 does not have HFT any more. */ #undef AIXHFT + +/* Get bzero, strcasecmp, and friends, for warning suppression. + These functions shouldn't actually be used, but don't try to fix it. */ +#ifndef NOT_C_CODE +#include <strings.h> +#endif
--- a/src/s/irix5-0.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/s/irix5-0.h Mon Aug 13 10:03:52 2007 +0200 @@ -77,13 +77,6 @@ /* Tell process_send_signal to use VSUSP instead of VSWTCH. */ #define PREFER_VSUSP -/* Because unexelfsgi.c cannot handle a ".sbss" section yet, we must - tell the linker to avoid making one. SGI's cc does this by - default, but GCC (at least 2.5.8 and 2.6.0) doesn't. */ -#ifdef __GNUC__ -#define LD_SWITCH_SYSTEM "-G 0" -#endif - /* define MAIL_USE_FLOCK if the mailer uses flock to interlock access to /usr/spool/mail/$USER. The alternative is that a lock file named
--- a/src/s/vms.h Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,217 +0,0 @@ -/* system description header for VMS - Copyright (C) 1986 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs 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. - -GNU Emacs 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: FSF 19.31. */ - -/* - * Define symbols to identify the version of Unix this is. - * Define all the symbols that apply correctly. - */ - -#ifndef VMS /* Decus cpp doesn't define this but VAX C does */ -#define VMS -#endif /* VMS */ -/* Note that this file is used indirectly via vms4-0.h, or some other - such file. These other files define a symbol VMS4_0, VMS4_2, etc. */ - -/* SYSTEM_TYPE should indicate the kind of system you are using. - It sets the Lisp variable system-type. */ - -#define SYSTEM_TYPE "vax-vms" - -/* Letter to use in finding device name of first pty, - if system supports pty's. 'a' means it is /dev/ptya0 */ - -#define FIRST_PTY_LETTER 'a' - -/* - * Define HAVE_PTYS if the system supports pty devices. - */ - -/* #define HAVE_PTYS */ - -/* - * Define NONSYSTEM_DIR_LIBRARY to make Emacs emulate - * The 4.2 opendir, etc., library functions. - * (This is autoconfed, but configure probably doesn't - * work on this system.) - */ - -#define NONSYSTEM_DIR_LIBRARY - -/* If your system uses COFF (Common Object File Format) then define the - preprocessor symbol "COFF". */ - -/* #define COFF */ - -/* define MAIL_USE_FLOCK if the mailer uses flock - to interlock access to /usr/spool/mail/$USER. - The alternative is that a lock file named - /usr/spool/mail/$USER.lock. */ - -/* #define MAIL_USE_FLOCK */ - -/* Define the maximum record length for print strings, if needed. */ - -#define MAX_PRINT_CHARS 300 - - -/* Here, on a separate page, add any special hacks needed - to make Emacs work on this system. For example, - you might define certain system call names that don't - exist on your system, or that do different things on - your system and must be used only through an encapsulation - (Which you should place, by convention, in sysdep.c). */ - -/* Do you have the sharable library bug? If you link with a sharable - library that contains psects with the NOSHR attribute and also refer to - those psects in your program, the linker give you a private version of - the psect which is not related to the version used by the sharable - library. The end result is that your references to variables in that - psect have absolutely nothing to do with library references to what is - supposed to be the same variable. If you intend to link with the standard - C library (NOT the sharable one) you don't need to define this. (This - is NOT fixed in V4.4...) */ - -#define SHARABLE_LIB_BUG - -/* Partially due to the above mentioned bug and also so that we don't need - to require that people have a sharable C library, the default for Emacs - is to link with the non-shared library. If you want to link with the - shared library, define this and remake xmakefile and fileio.c. This allows - us to ship a guaranteed executable image. */ - -#define LINK_CRTL_SHARE - -/* Define this if you want to read the file SYS$SYSTEM:SYSUAF.DAT for user - information. If you do use this, you must either make SYSUAF.DAT world - readable or install Emacs with SYSPRV. */ - -/* #define READ_SYSUAF */ - -/* On VMS these have a different name */ - -#define unlink delete - -#ifndef _GNUC_ -extern double mth$dmod(double, double); -#define drem mth$dmod -#endif - -/* Some time routines are missing in the VAX C RTL, or needs some - extra bit of code */ -#define tzset sys_tzset -#define localtime sys_localtime -#define gmtime sys_gmtime - -/* On later versions of VMS these exist in the C run time library, but - we are using our own implementations. Hide their names to avoid - linker errors */ -#define rename sys_rename -#define execvp sys_execvp -#define system sys_system - -#ifndef GNU_MALLOC -/* Hide these names so that we don't get linker errors */ -#define malloc sys_malloc -#define free sys_free -#define realloc sys_realloc -#define calloc sys_calloc - -/* Don't use the standard brk and sbrk */ -#define sbrk sys_sbrk -#define brk sys_brk -#endif - -/* On VMS we want to avoid reading and writing very large amounts of - data at once, so we redefine read and write here. */ - -#define ENCAPSULATE_READ -#define ENCAPSULATE_WRITE - -/* sys_creat just calls the real creat with additional args of - "rfm=var", "rat=cr" to get "normal" VMS files... */ -#define ENCAPSULATE_CREAT - -/* fwrite forces an RMS PUT on every call. This is abysmally slow, so - we emulate fwrite with fputc, which forces buffering and is much - faster! */ -#define ENCAPSULATE_FWRITE - -/* getuid only returns the member number, which is not unique on most VMS - systems. We emulate it with (getgid()<<16 | getuid()). */ -#define getuid sys_getuid - -/* If user asks for TERM, check first for EMACS_TERM. */ -#define getenv sys_getenv - -/* Standard C abort is less useful than it should be. */ -#define abort sys_abort - -/* Case conflicts with C library fread. */ -#define Fread F_read - -/* Case conflicts with C library srandom. */ -#define Srandom S_random - -/* variable length too long... maybe */ -#if 0 -#define do_line_insertion_deletion_costs do_line_insertion_deletion_cost -#endif - -/* Cause initialization of vmsfns.c to be run. */ -#define SYMS_SYSTEM syms_of_vmsfns () - -/* VAXCRTL access doesn't deal with SYSPRV very well (among other oddities...) - Here, we use $CHKPRO to really determine access. */ -#define ENCAPSULATE_ACCESS - -#define PAGESIZE 512 - -#define _longjmp longjmp -#define _setjmp setjmp - -globalref char sdata[]; -#define DATA_START (((int) sdata + 511) & ~511) -#define TEXT_START 512 - -/* Baud-rate values from tty status are not standard. */ - -#define BAUD_CONVERT \ -{ 0, 50, 75, 110, 134, 150, 300, 600, 1200, 1800, \ - 2000, 2400, 3600, 4800, 7200, 9600, 19200 } - -#define SYSTEM_PURESIZE_EXTRA 50000 - -/* Stdio FILE type has extra indirect on VMS, so must alter this macro. */ - -#define PENDING_OUTPUT_COUNT(FILE) ((*(FILE))->_ptr - (*(FILE))->_base) - -#define NULL_DEVICE "NLA0:" - -#define TERMCAP_NAME "emacs_library:[etc]termcap.dat" - -#define EXEC_SUFFIXES ".exe:.com" - -/* Case conflict with Xlib XFree () */ -#define xfree emacs_xfree - -/* What separator do we use in paths? */ -#define SEPCHAR ','
--- a/src/s/vms4-0.h Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -/* Synched up with: FSF 19.31. */ - -#include "vms.h" -#define VMS4_0
--- a/src/s/vms4-2.h Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -/* Synched up with: FSF 19.31. */ - -#include "vms.h" -#define VMS4_2 -
--- a/src/s/vms4-4.h Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -/* Synched up with: FSF 19.31. */ - -#include "vms.h" -#define VMS4_4 -
--- a/src/s/vms5-5.h Mon Aug 13 10:02:48 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -/* Synched up with: FSF 19.31. */ - -#include "vms.h" -#define VMS5_5 -#define VMS4_4 - -/* The bug that SHARABLE_LIB_BUG fixes is gone in version 5.5 of VMS. - And defining it causes lossage because sys_errlist has a different - number of elements. */ -#undef SHARABLE_LIB_BUG
--- a/src/symbols.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/symbols.c Mon Aug 13 10:03:52 2007 +0200 @@ -3103,6 +3103,9 @@ #ifndef Qzero Lisp_Object Qzero; #endif +#ifndef Qnull_pointer +Lisp_Object Qnull_pointer; +#endif /* some losing systems can't have static vars at function scope... */ static struct symbol_value_magic guts_of_unbound_marker = @@ -3122,6 +3125,10 @@ Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ #endif +#ifndef Qnull_pointer + Qnull_pointer.ui = 0; +#endif + Vobarray = make_vector (OBARRAY_SIZE, Qzero); initial_obarray = Vobarray; staticpro (&initial_obarray);
--- a/src/systime.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/systime.h Mon Aug 13 10:03:52 2007 +0200 @@ -50,8 +50,8 @@ #endif #endif -/* SVr4 doesn't actually declare this in its #include files. */ -#ifdef USG5_4 +/* SVr4 and some friends don't actually declare this in its #include files. */ +#ifndef HAVE_TIMEZONE_DECL extern long timezone; #endif
--- a/src/toolbar.h Mon Aug 13 10:02:48 2007 +0200 +++ b/src/toolbar.h Mon Aug 13 10:03:52 2007 +0200 @@ -111,7 +111,7 @@ #define DEFAULT_TOOLBAR_HEIGHT 37 #define DEFAULT_TOOLBAR_WIDTH 40 #define DEFAULT_TOOLBAR_BLANK_SIZE 8 -#define MINIMUM_SHADOW_THICKNESS 2 +#define MINIMUM_SHADOW_THICKNESS 1 extern Lisp_Object Vtoolbar_size[4]; void update_frame_toolbars (struct frame *f);
--- a/src/unexaix.c Mon Aug 13 10:02:48 2007 +0200 +++ b/src/unexaix.c Mon Aug 13 10:03:52 2007 +0200 @@ -308,7 +308,7 @@ ) { close (new); - /* unlink (new_name); /* Failed, unlink new a.out */ + /* unlink (new_name); */ /* Failed, unlink new a.out */ return -1; }